81 - reify machine state into a 'context' variable

Beginning of concurrency primitives.

3 files changed, 143 insertions, 84 deletions

diff --git a/mu.arc b/mu.arc
index 2b53f1ed..b728c51a 100644
--- a/mu.arc
+++ b/mu.arc
@@ -9,10 +9,6 @@
   `(enq (fn () (= (function* ',name) ',body))
         initialization-fns*))
 
-(mac on-init body
-  `(enq (fn () (run ',body))
-        initialization-fns*))
-
 (def clear ()
   (= types* (obj
               ; must be scalar or array, sum or product or primitive
@@ -75,7 +71,7 @@
       (++ n))))
 
 (def m (loc)  ; read memory, respecting metadata
-;?   (prn "m " loc sz.loc)
+;?   (prn "m " loc " " sz.loc)
   (if (is 1 sz.loc)
     (memory* (addr loc))
     (annotate 'record
@@ -100,22 +96,50 @@
           offset  (+ 1 (* idx sz.elem)))
     (m `(,(+ v.operand offset) ,elem))))
 
-(def run (instrs (o fn-args) (o fn-oargs))
-  (ret result nil
-    (with (ninstrs 0  fn-arg-idx 0)
-;?     (prn instrs)
-    (for pc 0 (< pc len.instrs) (do ++.ninstrs ++.pc)
-;?       (if (> ninstrs 10) (break))
-      (let instr instrs.pc
-;?         (prn memory*)
-;?         (prn pc ": " instr)
-        (let delim (or (pos '<- instr) -1)
-          (with (oarg  (if (>= delim 0)
-                         (cut instr 0 delim))
-                 op  (instr (+ delim 1))
-                 arg  (cut instr (+ delim 2)))
-;?             (prn op " " oarg)
-            (let tmp
+; context is a table containing the 'stack' of functions that haven't yet
+; returned
+; ({fn-name pc fn-arg-idx}*)
+
+(mac body (context)  ; assignable
+  `(function* ((,context 0) 'fn-name)))
+
+(mac pc (context)  ; assignable
+  `((,context 0) 'pc))
+
+(mac caller-arg-idx (context)  ; assignable
+  `((,context 0) 'caller-arg-idx))
+
+(= scheduling-interval* 500)
+
+(def parse-instr (instr)
+  (iflet delim (pos '<- instr)
+    (list (cut instr 0 delim)  ; oargs
+          (instr (+ delim 1))  ; op
+          (cut instr (+ delim 2)))  ; args
+    (list nil instr.0 cdr.instr)))
+
+(def caller-args (context)  ; not assignable
+  (let (_ _ args)  (parse-instr ((body cdr.context) (pc cdr.context)))
+    args))
+
+(def caller-oargs (context)  ; not assignable
+  (let (oargs _ _)  (parse-instr ((body cdr.context) (pc cdr.context)))
+    oargs))
+
+(def run (fn-name)
+;?   (prn "AAA")
+  (let context (list (obj fn-name fn-name  pc 0  caller-arg-idx 0))
+;?     (prn "BBB")
+    (for ninstrs 0 (< ninstrs scheduling-interval*) (++ ninstrs)
+;?       (prn "CCC " pc.context " " context " " (len body.context))
+      (if (>= pc.context (len body.context))
+        (pop context))
+      (if (no context) (break))
+;?       (prn "--- " context.0!fn-name " " pc.context ": " (body.context pc.context))
+;?       (prn "  " memory*)
+      (let (oarg op arg)  (parse-instr (body.context pc.context))
+;?         (prn op " " arg " -> " oarg)
+        (let tmp
               (case op
                 literal
                   arg.0
@@ -151,21 +175,23 @@
                 arg
                   (let idx (if arg
                              arg.0
-                             (do1 fn-arg-idx
-                                ++.fn-arg-idx))
-                    (m fn-args.idx))
+                             (do1 caller-arg-idx.context
+                                (++ caller-arg-idx.context)))
+;?                     (prn idx)
+;?                     (prn caller-args.context)
+                    (m caller-args.context.idx))
                 type
-                  (ty (fn-args arg.0))
+                  (ty (caller-args.context arg.0))
                 otype
-                  (ty (fn-oargs arg.0))
+                  (ty (caller-oargs.context arg.0))
                 jmp
-                  (do (= pc (+ pc (v arg.0)))
-;?                       (prn "jumping to " pc)
+                  (do (= pc.context (+ 1 pc.context (v arg.0)))
+;?                       (prn "jumping to " pc.context)
                       (continue))
                 jif
                   (when (is t (m arg.0))
-                    (= pc (+ pc (v arg.1)))
-;?                     (prn "jumping to " pc)
+                    (= pc.context (+ 1 pc.context (v arg.1)))
+;?                     (prn "jumping to " pc.context)
                     (continue))
                 copy
                   (m arg.0)
@@ -188,34 +214,33 @@
                 aref
                   (array-ref arg.0 (v arg.1))
                 reply
-                  (do (= result arg)
-                      (break))
+                  (do (pop context)
+                      (if no.context (break))
+                      (let (caller-oargs _ _)  (parse-instr (body.context pc.context))
+                        (each (dest src)  (zip caller-oargs arg)
+                          (setm dest  (m src))))
+                      (++ pc.context)
+                      (continue))
                 new
                   (let type (v arg.0)
                     (if types*.type!array
                       (new-array type (v arg.1))
                       (new-scalar type)))
                 ; else user-defined function
-                  (let-or new-body function*.op (prn "no definition for " op)
-;?                     (prn "== " memory*)
-                    (let results (run new-body arg oarg)
-;?                       (prn "=> " oarg " " results)
-                      (each o oarg
-;?                         (prn o)
-                        (setm o (m pop.results))))
-                    (continue))
+                  (do (push (obj fn-name op  pc 0  caller-arg-idx 0) context)
+                      (continue))
                 )
               ; opcode generated some value, stored in 'tmp'
-;?               (prn tmp " " oarg)
+;?               (prn "store: " tmp " " oarg)
               (if (acons tmp)
                 (for i 0 (< i (min len.tmp len.oarg)) ++.i
                   (setm oarg.i tmp.i))
                 (when oarg  ; must be a list
 ;?                   (prn oarg.0)
                   (setm oarg.0 tmp)))
-              )))))
-;?     (prn "return " result)
-    )))
+              )
+        (++ pc.context))))
+  nil)
 
 (enq (fn () (= Memory-in-use-until 1000))
      initialization-fns*)
@@ -322,5 +347,5 @@
 (reset)
 (awhen cdr.argv
   (map add-fns:readfile it)
-  (run function*!main)
+  (run 'main)
   (prn memory*))
diff --git a/mu.arc.t b/mu.arc.t
index 3695b4c8..0b89873f 100644
--- a/mu.arc.t
+++ b/mu.arc.t
@@ -4,7 +4,7 @@
 (add-fns
   '((test1
       ((1 integer) <- literal 1))))
-(run function*!test1)
+(run 'test1)
 ;? (prn memory*)
 (if (~iso memory* (obj 1 1))
   (prn "F - 'literal' writes a literal value (its lone 'arg' after the instruction name) to a location in memory (an address) specified by its lone 'oarg' or output arg before the arrow"))
@@ -15,7 +15,7 @@
       ((1 integer) <- literal 1)
       ((2 integer) <- literal 3)
       ((3 integer) <- add (1 integer) (2 integer)))))
-(run function*!test1)
+(run 'test1)
 (if (~iso memory* (obj 1 1  2 3  3 4))
   (prn "F - 'add' operates on two addresses"))
 
@@ -27,7 +27,7 @@
       ((1 integer) <- literal 1)
       ((2 integer) <- literal 3)
       (test1))))
-(run function*!main)
+(run 'main)
 ;? (prn memory*)
 (if (~iso memory* (obj 1 1  2 3  3 4))
   (prn "F - calling a user-defined function runs its instructions"))
@@ -42,7 +42,7 @@
       ((1 integer) <- literal 1)
       ((2 integer) <- literal 3)
       (test1))))
-(run function*!main)
+(run 'main)
 ;? (prn memory*)
 (if (~iso memory* (obj 1 1  2 3  3 4))
   (prn "F - 'reply' stops executing the current function"))
@@ -61,7 +61,7 @@
       ((2 integer) <- literal 3)
       (test1 (1 integer) (2 integer))
     )))
-(run function*!main)
+(run 'main)
 ;? (prn memory*)
 (if (~iso memory* (obj 1 1  2 3  3 4
                        ; add-fn's temporaries
@@ -82,7 +82,7 @@
       ((2 integer) <- literal 3)
       (test1 (1 integer) (2 integer))
     )))
-(run function*!main)
+(run 'main)
 ;? (prn memory*)
 (if (~iso memory* (obj 1 1  2 3  3 4
                        ; add-fn's temporaries
@@ -105,7 +105,7 @@
       ((1 integer) <- literal 1)
       ((2 integer) <- literal 3)
       ((3 integer) <- test1 (1 integer) (2 integer)))))
-(run function*!main)
+(run 'main)
 ;? (prn memory*)
 (if (~iso memory* (obj 1 1  2 3  3 4
                        ; add-fn's temporaries
@@ -124,7 +124,7 @@
       ((1 integer) <- literal 1)
       ((2 integer) <- literal 3)
       ((3 integer) (7 integer) <- test1 (1 integer) (2 integer)))))
-(run function*!main)
+(run 'main)
 ;? (prn memory*)
 (if (~iso memory* (obj 1 1  2 3  3 4    7 3
                          ; add-fn's temporaries
@@ -137,7 +137,7 @@
       ((1 integer) <- literal 1)
       ((2 integer) <- literal 3)
       ((3 integer) <- sub (1 integer) (2 integer)))))
-(run function*!main)
+(run 'main)
 ;? (prn memory*)
 (if (~iso memory* (obj 1 1  2 3  3 -2))
   (prn "F - 'sub' subtracts the value at one address from the value at another"))
@@ -148,7 +148,7 @@
       ((1 integer) <- literal 2)
       ((2 integer) <- literal 3)
       ((3 integer) <- mul (1 integer) (2 integer)))))
-(run function*!main)
+(run 'main)
 ;? (prn memory*)
 (if (~iso memory* (obj 1 2  2 3  3 6))
   (prn "F - 'mul' multiplies like 'add' adds"))
@@ -159,7 +159,7 @@
       ((1 integer) <- literal 8)
       ((2 integer) <- literal 3)
       ((3 integer) <- div (1 integer) (2 integer)))))
-(run function*!main)
+(run 'main)
 ;? (prn memory*)
 (if (~iso memory* (obj 1 8  2 3  3 (/ real.8 3)))
   (prn "F - 'div' divides like 'add' adds"))
@@ -170,7 +170,7 @@
       ((1 integer) <- literal 8)
       ((2 integer) <- literal 3)
       ((3 integer) (4 integer) <- idiv (1 integer) (2 integer)))))
-(run function*!main)
+(run 'main)
 ;? (prn memory*)
 (if (~iso memory* (obj 1 8  2 3  3 2  4 2))
   (prn "F - 'idiv' performs integer division, returning quotient and remainder"))
@@ -181,7 +181,7 @@
       ((1 boolean) <- literal t)
       ((2 boolean) <- literal nil)
       ((3 boolean) <- and (1 boolean) (2 boolean)))))
-(run function*!main)
+(run 'main)
 ;? (prn memory*)
 (if (~iso memory* (obj 1 t  2 nil  3 nil))
   (prn "F - logical 'and' for booleans"))
@@ -192,7 +192,7 @@
       ((1 boolean) <- literal 4)
       ((2 boolean) <- literal 3)
       ((3 boolean) <- lt (1 boolean) (2 boolean)))))
-(run function*!main)
+(run 'main)
 ;? (prn memory*)
 (if (~iso memory* (obj 1 4  2 3  3 nil))
   (prn "F - 'lt' is the less-than inequality operator"))
@@ -203,7 +203,7 @@
       ((1 boolean) <- literal 4)
       ((2 boolean) <- literal 3)
       ((3 boolean) <- le (1 boolean) (2 boolean)))))
-(run function*!main)
+(run 'main)
 ;? (prn memory*)
 (if (~iso memory* (obj 1 4  2 3  3 nil))
   (prn "F - 'le' is the <= inequality operator"))
@@ -214,7 +214,7 @@
       ((1 boolean) <- literal 4)
       ((2 boolean) <- literal 4)
       ((3 boolean) <- le (1 boolean) (2 boolean)))))
-(run function*!main)
+(run 'main)
 ;? (prn memory*)
 (if (~iso memory* (obj 1 4  2 4  3 t))
   (prn "F - 'le' returns true for equal operands"))
@@ -225,7 +225,7 @@
       ((1 boolean) <- literal 4)
       ((2 boolean) <- literal 5)
       ((3 boolean) <- le (1 boolean) (2 boolean)))))
-(run function*!main)
+(run 'main)
 ;? (prn memory*)
 (if (~iso memory* (obj 1 4  2 5  3 t))
   (prn "F - le is the <= inequality operator - 2"))
@@ -237,7 +237,7 @@
       (jmp (1 offset))
       ((2 integer) <- literal 3)
       (reply))))
-(run function*!main)
+(run 'main)
 ;? (prn memory*)
 (if (~iso memory* (obj 1 8))
   (prn "F - 'jmp' skips some instructions"))
@@ -250,7 +250,7 @@
       ((2 integer) <- literal 3)
       (reply)
       ((3 integer) <- literal 34))))
-(run function*!main)
+(run 'main)
 ;? (prn memory*)
 (if (~iso memory* (obj 1 8))
   (prn "F - 'jmp' doesn't skip too many instructions"))
@@ -265,7 +265,7 @@
       ((2 integer) <- literal 3)
       (reply)
       ((3 integer) <- literal 34))))
-(run function*!main)
+(run 'main)
 ;? (prn memory*)
 (if (~iso memory* (obj 1 1  2 1  3 t))
   (prn "F - 'jif' is a conditional 'jmp'"))
@@ -280,7 +280,7 @@
       ((4 integer) <- literal 3)
       (reply)
       ((3 integer) <- literal 34))))
-(run function*!main)
+(run 'main)
 ;? (prn memory*)
 (if (~iso memory* (obj 1 1  2 2  3 nil  4 3))
   (prn "F - if 'jif's first arg is false, it doesn't skip any instructions"))
@@ -296,7 +296,7 @@
       ((4 integer) <- literal 3)
       (reply)
       ((3 integer) <- literal 34))))
-(run function*!main)
+(run 'main)
 ;? (prn memory*)
 (if (~iso memory* (obj 1 2  2 4  3 nil  4 3))
   (prn "F - 'jif' can take a negative offset to make backward jumps"))
@@ -306,7 +306,7 @@
   '((main
       ((1 integer) <- literal 34)
       ((2 integer) <- copy (1 integer)))))
-(run function*!main)
+(run 'main)
 ;? (prn memory*)
 (if (~iso memory* (obj 1 34  2 34))
   (prn "F - 'copy' performs direct addressing"))
@@ -317,7 +317,7 @@
       ((1 integer-address) <- literal 2)
       ((2 integer) <- literal 34)
       ((3 integer) <- copy (1 integer-address deref)))))
-(run function*!main)
+(run 'main)
 ;? (prn memory*)
 (if (~iso memory* (obj 1 2  2 34  3 34))
   (prn "F - 'copy' performs indirect addressing"))
@@ -329,7 +329,7 @@
       ((2 integer) <- literal 34)
       ((3 integer) <- literal 2)
       ((1 integer-address deref) <- add (2 integer) (3 integer)))))
-(run function*!main)
+(run 'main)
 ;? (prn memory*)
 (if (~iso memory* (obj 1 2  2 36  3 2))
   (prn "F - instructions can perform indirect addressing on output arg"))
@@ -341,7 +341,7 @@
       ((2 boolean) <- literal nil)
       ((3 boolean) <- get (1 integer-boolean-pair) (1 offset))
       ((4 integer) <- get (1 integer-boolean-pair) (0 offset)))))
-(run function*!main)
+(run 'main)
 ;? (prn memory*)
 (if (~iso memory* (obj 1 34  2 nil  3 nil  4 34))
   (prn "F - 'get' accesses fields of records"))
@@ -353,7 +353,7 @@
       ((2 integer) <- literal 35)
       ((3 integer) <- literal 36)
       ((4 integer-integer-pair) <- get (1 integer-point-pair) (1 offset)))))
-(run function*!main)
+(run 'main)
 ;? (prn memory*)
 (if (~iso memory* (obj 1 34  2 35  3 36  4 35  5 36))
   (prn "F - 'get' accesses fields spanning multiple locations"))
@@ -367,7 +367,7 @@
       ((4 integer) <- literal 24)
       ((5 boolean) <- literal t)
       ((6 integer) <- get (1 integer-boolean-pair-array) (0 offset)))))
-(run function*!main)
+(run 'main)
 ;? (prn memory*)
 (if (~iso memory* (obj 1 2  2 23 3 nil  4 24 5 t  6 2))
   (prn "F - 'get' accesses length of array"))
@@ -381,7 +381,7 @@
       ((4 integer) <- literal 24)
       ((5 boolean) <- literal t)
       ((6 integer-boolean-pair) <- aref (1 integer-boolean-pair-array) (1 offset)))))
-(run function*!main)
+(run 'main)
 ;? (prn memory*)
 (if (~iso memory* (obj 1 2  2 23 3 nil  4 24 5 t  6 24 7 t))
   (prn "F - 'aref' accesses indices of arrays"))
@@ -395,7 +395,7 @@
       ((2 boolean) <- literal nil)
       ((4 boolean) <- literal t)
       ((3 integer-boolean-pair) <- copy (1 integer-boolean-pair)))))
-(run function*!main)
+(run 'main)
 ;? (prn memory*)
 (if (~iso memory* (obj 1 34  2 nil  3 34  4 nil))
   (prn "F - ops can operate on records spanning multiple locations"))
@@ -415,12 +415,15 @@
       ((1 integer) <- literal 1)
       ((2 integer) <- literal 3)
       ((3 integer) <- test1 (1 integer) (2 integer)))))
-(run function*!main)
+(run 'main)
 ;? (prn memory*)
 (if (~iso memory* (obj 1 1  2 3                     3 4
                          ; add-fn's temporaries
                          4 'integer  5 'integer  6 nil  7 1  8 3  9 4))
   (prn "F - an example function that checks that its args are integers"))
+;? (quit)
+
+; todo - test that reply increments pc for caller frame after popping current frame
 
 (reset)
 (add-fns
@@ -444,13 +447,14 @@
       ((1 boolean) <- literal t)
       ((2 boolean) <- literal t)
       ((3 boolean) <- add-fn (1 boolean) (2 boolean)))))
-(run function*!main)
+(run 'main)
 ;? (prn memory*)
 (if (~iso memory* (obj ; first call to add-fn
                        1 t  2 t                     3 t
                          ; add-fn's temporaries
                          4 'boolean  5 'boolean  6 nil  7 t  8 t  9 t))
   (prn "F - an example function that can do different things (dispatch) based on the type of its args or oargs"))
+;? (quit)
 
 (reset)
 (add-fns
@@ -477,7 +481,7 @@
       ((10 integer) <- literal 3)
       ((11 integer) <- literal 4)
       ((12 integer) <- add-fn (10 integer) (11 integer)))))
-(run function*!main)
+(run 'main)
 ;? (prn memory*)
 (if (~iso memory* (obj ; first call to add-fn
                        1 t  2 t                     3 t
@@ -571,7 +575,7 @@
                                      ((4 integer) <- literal 34)
                                      }
                                      (reply))))))
-(run function*!main)
+(run 'main)
 ;? (prn memory*)
 (if (~iso memory* (obj 1 4  2 4  3 nil  4 34))
   (prn "F - continue correctly loops"))
@@ -588,7 +592,7 @@
                                      ((4 integer) <- literal 34)
                                      }
                                      (reply))))))
-(run function*!main)
+(run 'main)
 ;? (prn memory*)
 (if (~iso memory* (obj 1 4  2 4  3 nil  4 34))
   (prn "F - continue might never trigger"))
@@ -598,7 +602,7 @@
   (add-fns
     '((main
         ((1 integer-address) <- new (integer type)))))
-  (run function*!main)
+  (run 'main)
   ;? (prn memory*)
   (if (~iso memory*.1 before)
     (prn "F - 'new' returns current high-water mark"))
@@ -610,7 +614,7 @@
   (add-fns
     '((main
         ((1 type-array-address) <- new (type-array type) (5 literal)))))
-  (run function*!main)
+  (run 'main)
   ;? (prn memory*)
   (if (~iso memory*.1 before)
     (prn "F - 'new' returns current high-water mark"))
diff --git a/sys.arc b/sys.arc
index 7364bfa9..b5f9c436 100644
--- a/sys.arc
+++ b/sys.arc
@@ -7,8 +7,38 @@
               ((2 integer) <- literal 2))))
      initialization-fns*)
 
-; todo: copy types* info into simulated machine
-; todo: sizeof
+(enq (fn ()
+       (build-type-table)
+     initialization-fns*)
+
+(= Free 3)
+(= Type-array Free)
+(def build-type-table ()
+  (allocate-type-array)
+  (build-types)
+  (fill-in-type-array))
+
+(def allocate-type-array ()
+  (= memory*.Free len.types*)
+  (++ Free)
+  (++ Free len.types*))
+
+(def build-types ()
+  (each type types*  ; todo
+    (
+
+(def sizeof (typeinfo)
+  (if (~or typeinfo!record typeinfo!array)
+        typeinfo!size
+      typeinfo!record
+        (sum idfn
+          (accum yield
+            (each elem typeinfo!elems
+              (yield (sizeof type*.elem)))))
+      typeinfo!array
+        (* (sizeof (type* typeinfo!elem))
+           (
+
 
 ;; 'new' - simple slab allocator. Intended only to carve out isolated memory
 ;; for different threads/routines as they request.