@effekt-lang/effekt 0.53.0 → 0.55.0

package/libraries/chez/cps/effekt.ss

@@ -0,0 +1,169 @@
+; Value = Any
+; Generation = Int
+
+; Ref = Store * Value * Generation 
+(define-record-type ref (fields store (mutable value) (mutable generation)))
+
+; Node = box MEM | box Diff
+
+; MEM
+; Means the correct values are in MEMory
+(define-record-type mem (fields))
+
+; Diff = Ref * Value * Generation * Node
+; Notes the DIFFerences between root and the current state in MEMory
+(define-record-type diff (fields ref value generation root))
+
+; Store = Node * Generation
+(define-record-type store (fields (mutable root) (mutable generation)))
+
+; Snapshot = Store * Node * Generation
+(define-record-type snap (fields store root generation))
+
+; -> Store
+(define (create-store) (make-store (box (make-mem)) 0))
+
+; Store -> Snapshot
+(define (snapshot store)
+    (let* ([sGen (store-generation store)]
+           [snap (make-snap store (store-root store) sGen)])
+        (store-generation-set! store (+ sGen 1))
+        snap))
+
+; Node, [box Diff] -> [box Diff]
+(define (collectDiffs n acc)
+    (let ([unboxedN (unbox n)])
+        (cond
+            [(mem? unboxedN) acc]
+            [else (collectDiffs (diff-root unboxedN) (cons n acc))])))
+
+; Node, [Diff] -> void
+(define (applyDiffs n diffs)
+    (cond
+        [(null? diffs) (set-box! n (make-mem))]
+        [else
+            (let* ([currentDiff (car diffs)]
+                   [realDiff (unbox currentDiff)]
+                   [r (diff-ref realDiff)]
+                   [oldValue (ref-value r)])
+                (ref-value-set! r (diff-value realDiff))
+                (set-box! n (make-diff r oldValue (ref-generation r) currentDiff))
+                (applyDiffs currentDiff (cdr diffs)))]))
+
+; Node, Node -> void
+(define (reroot newRoot oldRoot)
+    (applyDiffs oldRoot (collectDiffs newRoot '())))
+
+; Store, Snapshot -> void
+(define (restore snap)
+    (let* ([snapRoot (snap-root snap)]
+           [store (snap-store snap)]
+           [storeRoot (store-root store)])
+        (reroot snapRoot storeRoot)
+        (store-root-set! store snapRoot)))
+
+; Cont a = a, MetaCont -> #
+; Prompt = Int
+
+; MetaCont = Cont * Prompt * Store | Snapshot * MetaCont?
+; Holds a "copy" of k, as well as its prompt and store
+(define-record-type meta-cont 
+    (fields (mutable cont) prompt (mutable store) (mutable rest)))
+
+; Value, MetaCont -> Ref
+(define (var init ks)
+    (let ([store (meta-cont-store ks)])
+        (make-ref store init (store-generation store))))
+
+; Ref -> Value
+(define (get ref) (ref-value ref))
+
+; Ref, Value -> void
+(define (put ref value)
+    (let* ([rGen (ref-generation ref)]
+           [store (ref-store ref)]
+           [sGen (store-generation store)])
+        (if (= rGen sGen)
+            (ref-value-set! ref value)
+            (let ([oldVal (ref-value ref)]
+                  [newRoot (box (make-mem))]
+                  [oldRoot (store-root store)])
+                (ref-value-set! ref value)
+                (ref-generation-set! ref sGen)
+                (set-box! oldRoot (make-diff ref oldVal rGen newRoot))
+                (store-root-set! store newRoot)))))
+
+; MetaCont -> MetaCont
+(define (create-region ks) ks)
+
+; Value, MetaCont -> Ref
+(define allocate var)
+
+; Ref | MetaCont -> void
+(define (deallocate _) (void))
+
+(define _prompt 1)
+(define (new-prompt)
+    (let ([prompt _prompt])
+         (set! _prompt (+ prompt 1))
+         prompt))
+
+(define (top-level-k x _) x)
+(define top-level-ks (make-meta-cont top-level-k 0 (create-store) '()))
+
+; a, MetaCont -> #
+(define (return x ks)
+    (let* ([new-ks (meta-cont-rest ks)]
+           [k (meta-cont-cont new-ks)])
+    (k x new-ks)))
+
+; Program a b = a, Cont b, MetaCont -> #
+
+; Program Prompt b, MetaCont, Cont b -> #
+(define (reset prog ks k)
+    (let ([prompt (new-prompt)])
+         (meta-cont-cont-set! ks k)
+         (prog prompt (make-meta-cont return prompt (create-store) ks) return)))
+
+; MetaCont, Prompt -> MetaCont * MetaCont
+(define (split-stack ks p)
+    (define (worker above below)
+        (let ([new-below (meta-cont-rest below)]
+              [snap (snapshot (meta-cont-store below))])
+             (meta-cont-store-set! below snap)
+             (meta-cont-rest-set! below above)
+             (if (= (meta-cont-prompt below) p)
+                 (values below new-below)
+                 (worker below new-below))))
+    (worker '() ks))
+
+; Prompt, Program MetaCont b, MetaCont, Cont b -> #
+(define (shift p prog ks k)
+    (meta-cont-cont-set! ks k)
+    (let-values ([(c underC) (split-stack ks p)])
+                (prog c underC (meta-cont-cont underC))))
+
+; MetaCont, MetaCont -> MetaCont
+(define (rewind cont ks)
+    (if (null? cont)
+        ks
+        (let* ([snap (meta-cont-store cont)]
+               [next (meta-cont-rest cont)]
+               [newKs (make-meta-cont (meta-cont-cont cont)
+                                      (meta-cont-prompt cont)
+                                      (snap-store snap)
+                                      ks)])
+            (restore snap)
+            (rewind next newKs))))
+
+; Block b = Cont b, MetaCont -> #
+
+; MetaCont, Block, MetaCont, Cont -> #
+(define (resume cont block ks k)
+    (meta-cont-cont-set! ks k)
+    (let ([rewinded (rewind cont ks)])
+         (block rewinded (meta-cont-cont rewinded))))
+
+; Block b -> b
+(define (run-top-level p)
+    (p top-level-ks top-level-k))

package/libraries/common/effekt.effekt

@@ -22,7 +22,7 @@ namespace chez {
 
   // CPS implementation
   // ------------------
-  extern include chezLift "../chez/lift/effekt.ss"
+  extern include chezCPS "../chez/cps/effekt.ss"
 
   // Monadic implementation
   // ----------------------

package/libraries/common/io/channel.effekt

@@ -0,0 +1,51 @@
+module io/channel
+
+import io
+import io/signal
+
+record Node[A, B](this: Signal[A, B], rest: Ref[Option[Node[A, B]]])
+
+type Sender[A, B] = Ref[Node[A, B]]
+type Receiver[A, B] = Ref[Node[A, B]]
+
+/// Creates a new rendezvous channel and returns the receiving and the sending end.
+/// Every send must be matched by exactly one receive upon which two values are exchanged.
+def channel[A, B](): (Sender[A, B], Receiver[A, B]) = {
+  val node = Node(signal(), ref(None()))
+  (ref(node), ref(node))
+}
+
+/// Sends a value to a channel and blocks until a receiver arrives.
+def send[A, B](sender: Sender[A, B], value: A): B = {
+  val Node(this, rest) = sender.get()
+  rest.get() match {
+    case None() =>
+      val node = Node(signal(), ref(None()))
+      rest.set(Some(node))
+      sender.set(node)
+    case Some(node) =>
+      sender.set(node)
+  }
+  // TODO avoid yield
+  yield()
+  this.unsafeFire(value)
+}
+
+/// Receives a value from a channel and blocks until a sender arrives.
+def receive[A, B](receiver: Receiver[A, B], value: B): A = {
+  val Node(this, rest) = receiver.get()
+  rest.get() match {
+    case None() =>
+      val node = Node(signal(), ref(None()))
+      rest.set(Some(node))
+      receiver.set(node)
+    case Some(node) =>
+      receiver.set(node)
+  }
+  // TODO avoid yield
+  yield()
+  this.unsafeWait(value)
+}
+
+// TODO streaming
+

package/libraries/common/io/promise.effekt

@@ -0,0 +1,53 @@
+module io/promise
+
+import io
+import io/signal
+
+// Promises
+// --------
+
+type State[T] {
+  Pending(signals: List[Signal[T, Unit]])
+  Resolved(value: T)
+}
+
+type Promise[T] = Ref[State[T]]
+
+namespace promise {
+  /// Creates a pending promise that must be resolved exactly once
+  /// and can be awaited multiple times.
+  def make[T](): Promise[T] =
+    ref(Pending(Nil()))
+}
+
+/// Spawns a task and immediately returns a promise that upon completion
+/// of the task will resolve to its result.
+def promise[T](task: () => T at {io, async, global}): Promise[T] = {
+  val p = promise::make[T]();
+  spawn(box { p.resolve(task()) });
+  return p
+}
+
+/// Awaits and blocks until the given promise is resolved.
+def await[T](promise: Promise[T]): T =
+  promise.get match {
+    case Resolved(value) =>
+      return value
+    case Pending(signals) =>
+      val signal = signal()
+      promise.set(Pending(Cons(signal, signals)))
+      // TODO perhaps yield to avoid stack overflow
+      signal.unsafeWait(())
+  }
+
+/// Resolves the given promise, unblocking all awaiting tasks.
+def resolve[T](promise: Promise[T], value: T): Unit =
+  promise.get match {
+    case Resolved(value) =>
+      panic("ERROR: Promise already resolved")
+    case Pending(signals) =>
+      promise.set(Resolved(value))
+      // TODO perhaps yield to avoid stack overflow
+      signals.reverse.foreach { signal => unsafeFire(signal, value) }
+  }
+

package/libraries/common/io/signal.effekt

@@ -0,0 +1,55 @@
+module io/signal
+
+// Signals
+// -------
+
+/// Must be fired exactly once with an A receiving a B,
+/// and must be waited for exactly once with a B receiving an A.
+extern type Signal[A, B]
+
+extern def signal[A, B]() at global: Signal[A, B] =
+  js "signal$make()"
+  llvm """
+    %signal = call %Pos @c_signal_make()
+    ret %Pos %signal
+  """
+
+extern def unsafeFire[A, B](signal: Signal[A, B], value: A) at async: B =
+  js "$effekt.capture(callback => signal$notify(${signal}, ${value}, callback))"
+  llvm """
+    call void @c_signal_notify(%Pos ${signal}, %Pos ${value}, %Stack %stack)
+    ret void
+  """
+
+extern def unsafeWait[A, B](signal: Signal[A, B], value: B) at async: A =
+  js "$effekt.capture(callback => signal$notify(${signal}, ${value}, callback))"
+  llvm """
+    call void @c_signal_notify(%Pos ${signal}, %Pos ${value}, %Stack %stack)
+    ret void
+  """
+
+extern llvm """
+  declare %Pos @c_signal_make()
+  declare void @c_signal_notify(%Pos, %Pos, %Stack)
+"""
+
+extern js """
+  function signal$make() {
+    return { state: 0, value: null, stack: null };
+  }
+  function signal$notify(signal, value, stack) {
+    if (signal.state === 0) {
+      signal.state = 1;
+      signal.value = value;
+      signal.stack  = stack;
+    } else {
+      const otherValue = signal.value;
+      const otherStack = signal.stack;
+      signal.value = null;
+      signal.stack = null;
+
+      otherStack(value);
+      stack(otherValue);
+    }
+  }
+"""

package/libraries/common/io/time.effekt

@@ -4,7 +4,7 @@ extern llvm """
   declare void @c_timer_start(%Int, %Stack)
 """
 
-extern def wait(millis: Int) at async: Unit =
+extern def sleep(millis: Int) at async: Unit =
   js "$effekt.capture(k => setTimeout(() => k($effekt.unit), ${millis}))"
   llvm """
     call void @c_timer_start(%Int ${millis}, %Stack %stack)

package/libraries/common/io.effekt

@@ -1,18 +1,14 @@
 module io
 
-import ref
-import queue
 
 // Event Loop
 // ----------
 
-type Task[T] = () => T at {io, async, global}
-
 extern llvm """
   declare void @c_yield(%Stack)
 """
 
-extern def spawn(task: Task[Unit]) at async: Unit =
+extern def spawn[T](task: () => T at {io, async, global}) at async: Unit =
   js "$effekt.capture(k => { setTimeout(() => k($effekt.unit), 0); return $effekt.run(${task}) })"
   llvm """
     call void @c_yield(%Stack %stack)
@@ -34,55 +30,3 @@ extern def abort() at async: Nothing =
     ret void
   """
 
-
-// Promises
-// --------
-
-extern type Promise[T]
-  // = js "{resolve: ƒ, promise: Promise}"
-  // = llvm "{tag: 0, obj: Promise*}"
-
-def promise[T](task: Task[T]): Promise[T] = {
-  val p = promise::make[T]();
-  spawn(box { p.resolve(task()) });
-  return p
-}
-
-extern llvm """
-  declare %Pos @c_promise_make()
-  declare void @c_promise_resolve(%Pos, %Pos)
-  declare void @c_promise_await(%Pos, %Neg)
-"""
-
-extern def await[T](promise: Promise[T]) at async: T =
-  js "$effekt.capture(k => ${promise}.promise.then(k))"
-  llvm """
-    call void @c_promise_await(%Pos ${promise}, %Stack %stack)
-    ret void
-  """
-
-extern def resolve[T](promise: Promise[T], value: T) at async: Unit =
-  js "$effekt.capture(k => { ${promise}.resolve(${value}); return k($effekt.unit) })"
-  llvm """
-    call void @c_promise_resolve(%Pos ${promise}, %Pos ${value}, %Stack %stack)
-    ret void
-  """
-
-namespace promise {
-  extern js """
-    function promise$make() {
-      let resolve;
-      const promise = new Promise((res, rej) => {
-        resolve = res;
-      });
-      return { resolve: resolve, promise: promise };
-    }
-  """
-
-  extern def make[T]() at io: Promise[T] =
-    js "promise$make()"
-    llvm """
-      %promise = call %Pos @c_promise_make()
-      ret %Pos %promise
-    """
-}

package/libraries/common/list.effekt

@@ -944,6 +944,22 @@ def each[A](list: List[A]): Unit / emit[A] =
       each(tail)
   }
 
+/// Push iterator that emits all the tails (suffixes) of the given `list`.
+///
+/// Examples:
+/// ```effekt
+/// > list::collect[List[Int]] { [1, 2, 3].tails }
+/// [[1, 2, 3], [2, 3], [3], []]
+///
+/// > list::collect[List[Int]] { [].tails }
+/// [[]]
+/// ```
+def tails[A](list: List[A]): Unit / emit[List[A]] =
+  list match {
+    case Nil()            => do emit(Nil())
+    case Cons(head, tail) => do emit(list); tails(tail)
+  }
+
 def feed[T, R](list: List[T]) { reader: () => R / read[T] }: R = {
   var l = list
   try {

package/libraries/common/process.effekt

@@ -1,4 +1,5 @@
 module process
+import array
 
 extern def exit(errorCode: Int) at io: Nothing =
   js   "(function() { process.exit(${errorCode}) })()"
@@ -7,3 +8,101 @@ extern def exit(errorCode: Int) at io: Nothing =
     ret %Pos zeroinitializer
   """
   chez "(exit ${errorCode})"
+
+// Subprocesses
+// ------------
+
+extern jsNode """
+const { spawn } = require('node:child_process');
+"""
+extern llvm """
+  declare %Pos @c_spawn_options_default()
+  declare %Pos @c_spawn_options_on_stdout(%Pos, %Pos)
+  declare %Pos @c_spawn_options_on_stderr(%Pos, %Pos)
+  declare %Pos @c_spawn_options_pipe_stdin(%Pos, %Pos)
+  declare %Pos @c_write_stream(%Pos, %Pos)
+  declare %Pos @c_close_stream(%Pos)
+  declare %Pos @c_spawn(%Pos, %Pos, %Pos)
+"""
+
+extern type SpawnOptions
+extern def default() at {}: SpawnOptions =
+  jsNode """{ stdio: [0,1,2], onSpawn: (p) => {} }"""
+  llvm """
+    %opts = call %Pos @c_spawn_options_default()
+    ret %Pos %opts
+  """
+extern def onStdout(opts: SpawnOptions, callback: String => Unit at {io, global}) at {}: SpawnOptions =
+  jsNode """(function() {
+    let old = ${opts};
+    old.stdio[1] = 'pipe';
+    let oldSpawn = old.onSpawn;
+    old.onSpawn = function(p) {
+      oldSpawn(p);
+      p.stdout.on('data', (chunk) => {
+        $effekt.runToplevel((ks, k) => (${callback})(chunk, ks, k));
+      });
+    };
+    return old; })()"""
+  llvm """
+    %opts = call %Pos @c_spawn_options_on_stdout(%Pos ${opts}, %Pos ${callback})
+    ret %Pos %opts
+  """
+extern def onStderr(opts: SpawnOptions, callback: String => Unit at {io, global}) at {}: SpawnOptions =
+  jsNode """(function() {
+    let old = ${opts};
+    old.stdio[2] = 'pipe';
+    let oldSpawn = old.onSpawn;
+    old.onSpawn = function(p) {
+      oldSpawn(p);
+      p.stderr.on('data', (chunk) => {
+        $effekt.runToplevel((ks, k) => (${callback})(chunk, ks, k));
+      });
+    };
+    return old; })()"""
+  llvm """
+    %opts = call %Pos @c_spawn_options_on_stderr(%Pos ${opts}, %Pos ${callback})
+    ret %Pos %opts
+  """
+extern type WritableStream
+extern def withStdin(opts: SpawnOptions, callback: WritableStream => Unit at {io, global}) at {}: SpawnOptions =
+  jsNode """(function () {
+    let old = ${opts};
+    old.stdio[0] = 'pipe'
+    let oldSpawn = old.onSpawn;
+    old.onSpawn = function(p) {
+      oldSpawn(p);
+      p.on('spawn', () => {
+        $effekt.runToplevel((ks, k) => (${callback})(p.stdin, ks, k));
+      });
+    };
+    return old;
+  })()"""
+  llvm """
+    %opts = call %Pos @c_spawn_options_pipe_stdin(%Pos ${opts}, %Pos ${callback})
+    ret %Pos %opts
+  """
+extern def write(to: WritableStream, s: String) at io: Unit =
+  jsNode """${to}.write(${s})"""
+  llvm """
+    call void @c_write_stream(%Pos ${to}, %Pos ${s})
+    ret %Pos zeroinitializer
+  """
+extern def close(to: WritableStream) at io: Unit =
+  jsNode """${to}.end()"""
+  llvm """
+    call void @c_close_stream(%Pos ${to})
+    ret %Pos zeroinitializer
+  """
+
+extern def spawn(cmd: String, args: Array[String], options: SpawnOptions) at async: Int  =
+  jsNode """$effekt.capture(k => {
+    let p = spawn(${cmd}, ${args}, ${options});
+    ${options}.onSpawn(p);
+    p.on('close', (exitcode, sig) => { k(exitcode) });
+    return p;
+    })"""
+  llvm """
+    call void @c_spawn(%Pos ${cmd}, %Pos ${args}, %Pos ${options}, %Stack %stack)
+    ret void
+  """