erlang: link/unlink/monitor/demonitor + refs (+17 tests)

lib/erlang/runtime.sx

@@ -117,6 +117,24 @@
   er-pid-equal?
   (fn (a b) (and (er-pid? a) (er-pid? b) (= (er-pid-id a) (er-pid-id b)))))
 
+;; ── refs ─────────────────────────────────────────────────────────
+(define er-mk-ref (fn (id) {:id id :tag "ref"}))
+(define er-ref? (fn (v) (er-is-tagged? v "ref")))
+(define
+  er-ref-equal?
+  (fn (a b) (and (er-ref? a) (er-ref? b) (= (get a :id) (get b :id)))))
+
+(define
+  er-ref-new!
+  (fn
+    ()
+    (let
+      ((s (er-sched)))
+      (let
+        ((n (get s :next-ref)))
+        (dict-set! s :next-ref (+ n 1))
+        (er-mk-ref n)))))
+
 ;; ── scheduler state ──────────────────────────────────────────────
 (define er-scheduler (list nil))
 
@@ -128,6 +146,7 @@
       er-scheduler
       0
       {:next-pid 0
+        :next-ref 0
         :current nil
         :processes {}
         :runnable (er-q-new)})))
@@ -190,6 +209,7 @@
             :mailbox (er-q-new)
             :state "runnable"
             :monitors (list)
+            :monitored-by (list)
             :continuation nil
             :receive-pats nil
             :trap-exit false
@@ -296,9 +316,165 @@
       (= (len vs) 1) (raise (er-mk-exit-marker (nth vs 0)))
       (= (len vs) 2)
       (error
-        "Erlang: exit/2 (signal another process) deferred to Phase 4 (links)")
+        "Erlang: exit/2 (signal another process) deferred to next Phase 4 step (signal propagation)")
       :else (error "Erlang: exit: wrong arity"))))
 
+;; ── links / monitors / refs ─────────────────────────────────────
+(define
+  er-bif-is-reference
+  (fn (vs) (er-bool (er-ref? (er-bif-arg1 vs "is_reference")))))
+
+(define
+  er-bif-make-ref
+  (fn
+    (vs)
+    (if
+      (not (= (len vs) 0))
+      (error "Erlang: make_ref/0: arity")
+      (er-ref-new!))))
+
+;; Add `target` to `pid`'s :links list if not already there.
+(define
+  er-link-add-one!
+  (fn
+    (pid target)
+    (let
+      ((links (er-proc-field pid :links)))
+      (when
+        (not (er-link-has? links target))
+        (append! links target)))))
+
+(define
+  er-link-has?
+  (fn
+    (links target)
+    (cond
+      (= (len links) 0) false
+      (er-pid-equal? (nth links 0) target) true
+      :else (er-link-has? (er-slice-list links 1) target))))
+
+(define
+  er-link-remove-one!
+  (fn
+    (pid target)
+    (let
+      ((old (er-proc-field pid :links)) (out (list)))
+      (for-each
+        (fn
+          (i)
+          (let
+            ((p (nth old i)))
+            (when (not (er-pid-equal? p target)) (append! out p))))
+        (range 0 (len old)))
+      (er-proc-set! pid :links out))))
+
+(define
+  er-bif-link
+  (fn
+    (vs)
+    (let
+      ((target (er-bif-arg1 vs "link")) (me (er-sched-current-pid)))
+      (cond
+        (not (er-pid? target)) (error "Erlang: link: not a pid")
+        (er-pid-equal? target me) (er-mk-atom "true")
+        (not (er-proc-exists? target))
+        (raise (er-mk-exit-marker (er-mk-atom "noproc")))
+        :else (do
+          (er-link-add-one! me target)
+          (er-link-add-one! target me)
+          (er-mk-atom "true"))))))
+
+(define
+  er-bif-unlink
+  (fn
+    (vs)
+    (let
+      ((target (er-bif-arg1 vs "unlink")) (me (er-sched-current-pid)))
+      (cond
+        (not (er-pid? target)) (error "Erlang: unlink: not a pid")
+        :else (do
+          (er-link-remove-one! me target)
+          (when
+            (er-proc-exists? target)
+            (er-link-remove-one! target me))
+          (er-mk-atom "true"))))))
+
+(define
+  er-bif-monitor
+  (fn
+    (vs)
+    (if
+      (not (= (len vs) 2))
+      (error "Erlang: monitor/2: arity")
+      (let
+        ((kind (nth vs 0))
+          (target (nth vs 1))
+          (me (er-sched-current-pid)))
+        (cond
+          (not (and (er-atom? kind) (= (get kind :name) "process")))
+          (error "Erlang: monitor: only 'process' supported")
+          (not (er-pid? target)) (error "Erlang: monitor: not a pid")
+          :else (let
+            ((ref (er-ref-new!)))
+            (append!
+              (er-proc-field me :monitors)
+              {:ref ref :pid target})
+            (when
+              (er-proc-exists? target)
+              (append!
+                (er-proc-field target :monitored-by)
+                {:from me :ref ref}))
+            ref))))))
+
+(define
+  er-bif-demonitor
+  (fn
+    (vs)
+    (let
+      ((ref (er-bif-arg1 vs "demonitor")) (me (er-sched-current-pid)))
+      (if
+        (not (er-ref? ref))
+        (error "Erlang: demonitor: not a reference")
+        (do
+          (er-demonitor-purge! me ref)
+          (er-mk-atom "true"))))))
+
+(define
+  er-demonitor-purge!
+  (fn
+    (me ref)
+    (let
+      ((old (er-proc-field me :monitors)) (out (list)) (target-ref (list nil)))
+      (for-each
+        (fn
+          (i)
+          (let
+            ((m (nth old i)))
+            (if
+              (er-ref-equal? (get m :ref) ref)
+              (set-nth! target-ref 0 (get m :pid))
+              (append! out m))))
+        (range 0 (len old)))
+      (er-proc-set! me :monitors out)
+      (when
+        (and
+          (not (= (nth target-ref 0) nil))
+          (er-proc-exists? (nth target-ref 0)))
+        (let
+          ((target (nth target-ref 0))
+            (oldby (er-proc-field (nth target-ref 0) :monitored-by))
+            (out2 (list)))
+          (for-each
+            (fn
+              (i)
+              (let
+                ((m (nth oldby i)))
+                (when
+                  (not (er-ref-equal? (get m :ref) ref))
+                  (append! out2 m))))
+            (range 0 (len oldby)))
+          (er-proc-set! target :monitored-by out2))))))
+
 ;; ── scheduler loop ──────────────────────────────────────────────
 ;; Each scheduler step wraps the process body in `guard`. `receive`
 ;; with no match captures a `call/cc` continuation onto the proc