@effekt-lang/effekt 0.53.0 → 0.54.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/stream.effekt

@@ -44,7 +44,7 @@ def fix[T] { one: T => Unit / emit[T] } { stream: => Unit / emit[T] }: Unit =
   try {
     stream()
   } with emit[T] { value =>
-    fix[T] {one} { one(value) }
+    fix {one} { one(value) }
     resume(())
   }
 

package/libraries/js/mutable/map.effekt

@@ -5,7 +5,7 @@ import array
 // A mutable map, backed by a JavaScript Map.
 extern type Map[K, V]
 
-extern def emptyMap[K, V]() at {}: Map[K, V] =
+extern def emptyMap[K, V]() at io: Map[K, V] =
   js "new Map()"
 
 def get[K, V](m: Map[K, V], key: K): Option[V] =
@@ -28,4 +28,4 @@ extern def values[K, V](map: Map[K, V]) at {}: Array[V] =
   js "Array.from(${map}.values())"
 
 extern def keys[K, V](map: Map[K, V]) at {}: Array[K] =
-  js "Array.from(${map}.keys())"
+  js "Array.from(${map}.keys())"

package/libraries/llvm/io.c

@@ -572,154 +572,59 @@ void c_yield(Stack stack) {
     c_timer_start(0, stack);
 }
 
-
-// Promises
+// Signals
 // --------
 
-typedef enum { UNRESOLVED, RESOLVED } promise_state_t;
-
-typedef struct Listeners {
-    Stack head;
-    struct Listeners* tail;
-} Listeners;
+typedef enum { INITIAL, NOTIFIED } signal_state_t;
 
 typedef struct {
     uint64_t rc;
     void* eraser;
-    promise_state_t state;
-    // state of {
-    //   case UNRESOLVED => Possibly empty (head is NULL) list of listeners
-    //   case RESOLVED   => Pos (the result)
-    // }
-    union {
-        struct Pos value;
-        Listeners listeners;
-    } payload;
-} Promise;
-
-void c_promise_erase_listeners(void *envPtr) {
-    // envPtr points to a Promise _after_ the eraser, so let's adjust it to point to the promise.
-    Promise *promise = (Promise*) (envPtr - offsetof(Promise, state));
-    promise_state_t state = promise->state;
-
-    Stack head;
-    Listeners* tail;
-    Listeners* current;
-
-    switch (state) {
-        case UNRESOLVED:
-            head = promise->payload.listeners.head;
-            tail = promise->payload.listeners.tail;
-            if (head != NULL) {
-                // Erase head
-                eraseStack(head);
-                // Erase tail
-                current = tail;
-                while (current != NULL) {
-                    head = current->head;
-                    tail = current->tail;
-                    free(current);
-                    eraseStack(head);
-                    current = tail;
-                };
-            };
-            break;
-        case RESOLVED:
-            erasePositive(promise->payload.value);
-            break;
-    }
-}
+    signal_state_t state;
+    struct Pos value;
+    Stack stack;
+} Signal;
 
-void c_promise_resume_listeners(Listeners* listeners, struct Pos value) {
-    if (listeners != NULL) {
-        Stack head = listeners->head;
-        Listeners* tail = listeners->tail;
-        free(listeners);
-        c_promise_resume_listeners(tail, value);
-        sharePositive(value);
-        resume_Pos(head, value);
-    }
+void c_signal_erase(void *envPtr) {
+    // envPtr points to a Signal _after_ the eraser, so let's adjust it to point to the beginning.
+    Signal *signal = (Signal*) (envPtr - offsetof(Signal, state));
+    erasePositive(signal->value);
+    if (signal->stack != NULL) { eraseStack(signal->stack); }
 }
 
-void c_promise_resolve(struct Pos promise, struct Pos value, Stack stack) {
-    Promise* p = (Promise*)promise.obj;
-
-    Stack head;
-    Listeners* tail;
+struct Pos c_signal_make() {
+    Signal* f = (Signal*)malloc(sizeof(Signal));
 
-    switch (p->state) {
-        case UNRESOLVED:
-            head = p->payload.listeners.head;
-            tail = p->payload.listeners.tail;
+    f->rc = 0;
+    f->eraser = c_signal_erase;
+    f->state = INITIAL;
+    f->value = (struct Pos) { .tag = 0, .obj = NULL, };
+    f->stack = NULL;
 
-            p->state = RESOLVED;
-            p->payload.value = value;
-            resume_Pos(stack, Unit);
-
-            if (head != NULL) {
-                // Execute tail
-                c_promise_resume_listeners(tail, value);
-                // Execute head
-                sharePositive(value);
-                resume_Pos(head, value);
-            };
-            break;
-        case RESOLVED:
-            erasePositive(promise);
-            erasePositive(value);
-            eraseStack(stack);
-            fprintf(stderr, "ERROR: Promise already resolved\n");
-            exit(1);
-            break;
-    }
-    // TODO stack overflow?
-    // We need to erase the promise now, since we consume it.
-    erasePositive(promise);
+    return (struct Pos) { .tag = 0, .obj = f, };
 }
 
-void c_promise_await(struct Pos promise, Stack stack) {
-    Promise* p = (Promise*)promise.obj;
-
-    Stack head;
-    Listeners* tail;
-    Listeners* node;
-    struct Pos value;
-
-    switch (p->state) {
-        case UNRESOLVED:
-            head = p->payload.listeners.head;
-            tail = p->payload.listeners.tail;
-            if (head != NULL) {
-                node = (Listeners*)malloc(sizeof(Listeners));
-                node->head = head;
-                node->tail = tail;
-                p->payload.listeners.head = stack;
-                p->payload.listeners.tail = node;
-            } else {
-                p->payload.listeners.head = stack;
-            };
+void c_signal_notify(struct Pos signal, struct Pos value, Stack stack) {
+    Signal* f = (Signal*)signal.obj;
+    switch (f->state) {
+        case INITIAL: {
+            f->state = NOTIFIED;
+            f->value = value;
+            f->stack = stack;
+            erasePositive(signal);
             break;
-        case RESOLVED:
-            value = p->payload.value;
-            sharePositive(value);
-            resume_Pos(stack, value);
+        }
+        case NOTIFIED: {
+            struct Pos other_value = f->value;
+            f->value = (struct Pos) { .tag = 0, .obj = NULL, };
+            Stack other_stack = f->stack;
+            f->stack = NULL;
+            erasePositive(signal);
+            resume_Pos(other_stack, value);
+            resume_Pos(stack, other_value);
             break;
-    };
-    // TODO hmm, stack overflow?
-    erasePositive(promise);
-}
-
-struct Pos c_promise_make() {
-    Promise* promise = (Promise*)malloc(sizeof(Promise));
-
-    promise->rc = 0;
-    promise->eraser = c_promise_erase_listeners;
-    promise->state = UNRESOLVED;
-    promise->payload.listeners.head = NULL;
-    promise->payload.listeners.tail = NULL;
-
-    return (struct Pos) { .tag = 0, .obj = promise, };
+        }
+    }
 }
 
-
 #endif