760

This speeds up the final test but not all together.

2 files changed, 77 insertions, 73 deletions

diff --git a/mu.arc b/mu.arc
index 7f4ed6fa..0c5556ba 100644
--- a/mu.arc
+++ b/mu.arc
@@ -32,7 +32,7 @@
 
 ;; what happens when our virtual machine starts up
 (= initialization-fns* (queue))
-(def reset ()
+(deftimed reset ()
   (each f (as cons initialization-fns*)
     (f)))
 
@@ -53,7 +53,7 @@
   (= curr-trace-file* nil)
   (= traces* (queue)))
 
-(def new-trace (filename)
+(deftimed new-trace (filename)
   (prn "== @filename")
 ;?   )
   (= curr-trace-file* filename))
@@ -76,17 +76,17 @@
   (do1 nil
        (apply trace "-" args)))
 
-(def tr2 (msg arg)
+(deftimed tr2 (msg arg)
   (tr msg arg)
   arg)
 
-(def check-trace-contents (msg expected-contents)
+(deftimed check-trace-contents (msg expected-contents)
   (unless (trace-contents-match expected-contents)
     (prn "F - " msg)
     (prn "  trace contents")
     (print-trace-contents-mismatch expected-contents)))
 
-(def trace-contents-match (expected-contents)
+(deftimed trace-contents-match (expected-contents)
   (each (label msg) (as cons traces*)
     (when (and expected-contents
                (is label expected-contents.0.0)
@@ -94,7 +94,7 @@
       (pop expected-contents)))
   (no expected-contents))
 
-(def print-trace-contents-mismatch (expected-contents)
+(deftimed print-trace-contents-mismatch (expected-contents)
   (each (label msg) (as cons traces*)
     (whenlet (expected-label expected-msg)  expected-contents.0
       (if (and (is label expected-label)
@@ -107,7 +107,7 @@
   (each (expected-label expected-msg)  expected-contents
     (prn "  ! " expected-label ": " expected-msg)))
 
-(def check-trace-doesnt-contain (msg (label unexpected-contents))
+(deftimed check-trace-doesnt-contain (msg (label unexpected-contents))
   (when (some (fn ((l s))
                 (and (is l label)  (posmatch unexpected-contents msg)))
               (as cons traces*))
@@ -248,24 +248,28 @@
 (defextend empty (x)  (isa x 'routine)
   (no rep.x!call-stack))
 
-(def stack (routine)
+(deftimed stack (routine)
   ((rep routine) 'call-stack))
 
-(def push-stack (routine op)
+(deftimed push-stack (routine op)
   (push (obj fn-name op  pc 0  caller-arg-idx 0  t0 (msec))
         rep.routine!call-stack))
 
-(def pop-stack (routine)
-  (update-time top.routine!fn-name (msec))
+(deftimed pop-stack (routine)
+;?   (update-time label.routine (msec)) ;? 1
   (pop rep.routine!call-stack))
 
 (def top (routine)
   stack.routine.0)
 
-(def label (routine)
-  (string:intersperse "/" (map [_ 'fn-name] stack.routine)))
+(deftimed label (routine)
+  (whenlet stack stack.routine
+    (or= stack.0!label
+         (label2 stack))))
+(deftimed label2 (stack)
+         (string:intersperse "/" (map [_ 'fn-name] stack)));))
 
-(def body (routine)
+(deftimed body (routine)
   (function* stack.routine.0!fn-name))
 
 (mac pc (routine (o idx 0))  ; assignable
@@ -286,10 +290,10 @@
 (mac reply-args (routine)  ; assignable
   `((((rep ,routine) 'call-stack) 0) 'reply-args))
 
-(def waiting-for-exact-cycle? (routine)
+(deftimed waiting-for-exact-cycle? (routine)
   (is 'until rep.routine!sleep.0))
 
-(def ready-to-wake-up (routine)
+(deftimed ready-to-wake-up (routine)
   (assert no.routine*)
   (case rep.routine!sleep.0
     until
@@ -416,7 +420,7 @@
   (detect-deadlock)
   )
 
-(def detect-deadlock ()
+(deftimed detect-deadlock ()
   (when (and (empty running-routines*)
              (~empty sleeping-routines*)
              (~some 'literal (map (fn(_) rep._!sleep.1)
@@ -426,7 +430,7 @@
       (= rep.routine!error "deadlock detected")
       (push routine completed-routines*))))
 
-(def die (msg)
+(deftimed die (msg)
   (tr "die: " msg)
   (= rep.routine*!error msg)
   (iflet abort-continuation (abort-routine*)
@@ -441,7 +445,7 @@
 
 ; routines consist of instrs
 ; instrs consist of oargs, op and args
-(def parse-instr (instr)
+(deftimed parse-instr (instr)
 ;?   (prn instr)
   (iflet delim (pos '<- instr)
     (list (cut instr 0 delim)  ; oargs
@@ -449,31 +453,31 @@
           (cut instr (+ delim 2)))  ; args
     (list nil (v car.instr) cdr.instr)))
 
-(def metadata (operand)
+(deftimed metadata (operand)
   cdr.operand)
 
-(def ty (operand)
+(deftimed ty (operand)
   (cdr operand.0))
 
-(def literal? (operand)
+(deftimed literal? (operand)
   (unless (acons ty.operand)
     (err "no type in operand @operand"))
   (in ty.operand.0 'literal 'offset 'fn))
 
-(def typeinfo (operand)
+(deftimed typeinfo (operand)
   (or (type* ty.operand.0)
       (err "unknown type @(tostring prn.operand)")))
 
 ; operand accessors
-(def nondummy (operand)  ; precondition for helpers below
+(deftimed nondummy (operand)  ; precondition for helpers below
   (~is '_ operand))
 
 ; just for convenience, 'new' instruction sometimes takes a raw string and
 ; allocates just enough space to store it
-(def not-raw-string (operand)
+(deftimed not-raw-string (operand)
   (~isa operand 'string))
 
-(def address? (operand)
+(deftimed address? (operand)
   (or (is ty.operand.0 'location)
       typeinfo.operand!address))
 
@@ -488,7 +492,7 @@
 ($:define (reset) (tput 'sgr0))
 
 ; run instructions from 'routine*' for 'time-slice'
-(def run-for-time-slice (time-slice)
+(deftimed run-for-time-slice (time-slice)
   (point return
     (for ninstrs 0 (< ninstrs time-slice) (++ ninstrs)
       (if (empty body.routine*) (err "@stack.routine*.0!fn-name not defined"))
@@ -954,7 +958,7 @@
         (++ pc.routine*)))
     (return time-slice)))
 
-(def prepare-reply (args)
+(deftimed prepare-reply (args)
   (= results.routine*
      (accum yield
        (each a args
@@ -986,7 +990,7 @@
                         (map memory* (addrs addr n)))))
       (trace "mem" loc " => " result))))
 
-(def setm (loc val)  ; set memory, respecting metadata
+(deftimed setm (loc val)  ; set memory, respecting metadata
 ;?   (tr 111)
   (point return
 ;?   (tr 112)
@@ -1021,22 +1025,22 @@
                 (trace "mem" loc ": " dest " <= " repr.src)
                 (= memory*.dest src))))))))
 
-(def typeof (operand)
+(deftimed typeof (operand)
   (let loc absolutize.operand
     (while (pos '(deref) metadata.loc)
       (zap deref loc))
     ty.loc.0))
 
-(def addr (operand)
+(deftimed addr (operand)
   (v canonize.operand))
 
-(def addrs (n sz)
+(deftimed addrs (n sz)
   (accum yield
     (repeat sz
       (yield n)
       (++ n))))
 
-(def canonize (operand)
+(deftimed canonize (operand)
 ;?   (tr "0: @operand")
   (ret operand
 ;?     (prn "1: " operand)
@@ -1076,7 +1080,7 @@
 ;?   (tr "sizeof: @x is a primitive")
   (return typeinfo.x!size)))
 
-(def absolutize (operand)
+(deftimed absolutize (operand)
   (if (no routine*)
         operand
       (in v.operand '_ 'default-space)
@@ -1108,11 +1112,11 @@
     (lookup-space operand (memory* (+ base 1))  ; location 0 points to next space
                   (- space 1))))
 
-(def space (operand)
+(deftimed space (operand)
   (or (alref metadata.operand 'space)
       0))
 
-(def deref (operand)
+(deftimed deref (operand)
   (assert (pos '(deref) metadata.operand))
   (assert address?.operand)
   (cons `(,(memory* v.operand) ,@typeinfo.operand!elem)
@@ -1126,7 +1130,7 @@
 
 ; memory allocation
 
-(def alloc (sz)
+(deftimed alloc (sz)
   (when (> sz (- rep.routine*!alloc-max rep.routine*!alloc))
     (let curr-alloc Memory-allocated-until
       (= rep.routine*!alloc curr-alloc)
@@ -1135,16 +1139,16 @@
   (ret result rep.routine*!alloc
     (++ rep.routine*!alloc sz)))
 
-(def new-scalar (type)
+(deftimed new-scalar (type)
 ;?   (tr "new scalar: @type")
   (alloc (sizeof `((_ ,type)))))
 
-(def new-array (type size)
+(deftimed new-array (type size)
 ;?   (tr "new array: @type @size")
   (ret result (alloc (+ 1 (* (sizeof `((_ ,@type*.type!elem))) size)))
     (= memory*.result size)))
 
-(def new-string (literal-string)
+(deftimed new-string (literal-string)
 ;?   (tr "new string: @literal-string")
   (ret result (alloc (+ 1 len.literal-string))
     (= memory*.result len.literal-string)
@@ -1152,14 +1156,14 @@
 ;?       (prn index " " repr.c) ;? 1
       (= (memory* (+ result 1 index)) c))))
 
-(def to-arc-string (string-address)
+(deftimed to-arc-string (string-address)
   (let len (memory* string-address)
     (string:map memory* (range (+ string-address 1)
                                (+ string-address len)))))
 
 ;; desugar structured assembly based on blocks
 
-(def convert-braces (instrs)
+(deftimed convert-braces (instrs)
 ;?   (prn "convert-braces " instrs)
   (let locs ()  ; list of information on each brace: (open/close pc)
     (let pc 0
@@ -1223,7 +1227,7 @@
                   (yield-unchanged)))
             (++ pc))))))))
 
-(def close-offset (pc locs nblocks)
+(deftimed close-offset (pc locs nblocks)
   (or= nblocks 1)
 ;?   (tr nblocks)
   (point return
@@ -1242,13 +1246,13 @@
 ;?         (tr "close now " loc)
         (return (- loc pc 1))))))))
 
-(def open-offset (pc stack nblocks)
+(deftimed open-offset (pc stack nblocks)
   (or= nblocks 1)
   (- (stack (- nblocks 1)) 1 pc))
 
 ;; convert jump targets to offsets
 
-(def convert-labels (instrs)
+(deftimed convert-labels (instrs)
 ;?   (tr "convert-labels " instrs)
   (let labels (table)
     (let pc 0
@@ -1273,7 +1277,7 @@
 
 ;; convert symbolic names to raw memory locations
 
-(def add-next-space-generator (instrs name)
+(deftimed add-next-space-generator (instrs name)
 ;?   (prn "== @name")
   (each instr instrs
     (when acons.instr
@@ -1296,7 +1300,7 @@
 ;?   (tr "save names for function @name: @(tostring:pr location*.name)") ;? 1
   (replace-names-with-location instrs name))
 
-(def assign-names-to-location (instrs name)
+(deftimed assign-names-to-location (instrs name)
   (trace "cn0" "convert-names in @name")
 ;?   (prn name ": " location*) ;? 1
   (point return
@@ -1366,7 +1370,7 @@
                 ; todo: can't allocate arrays on the stack
                 (++ idx (sizeof `((_ ,@ty.arg))))))))))))))
 
-(def replace-names-with-location (instrs name)
+(deftimed replace-names-with-location (instrs name)
   (each instr instrs
     (when (acons instr)
       (let (oargs op args)  (parse-instr instr)
@@ -1379,7 +1383,7 @@
   instrs)
 
 (= allow-raw-addresses* nil)
-(def check-default-space (instrs name)
+(deftimed check-default-space (instrs name)
   (unless allow-raw-addresses*
     (let oarg-names (accum yield
                       (each (oargs _ _) (map parse-instr (keep acons  ; non-label
@@ -1391,7 +1395,7 @@
         (prn "function @name has no default-space")))))
 
 ; assign an index to an arg
-(def maybe-add (arg location idx)
+(deftimed maybe-add (arg location idx)
   (trace "maybe-add" arg)
   (when (and nondummy.arg
 ;?              (prn arg " " (assoc 'space arg))
@@ -1404,7 +1408,7 @@
     (= (location v.arg) idx)))
 
 ; convert the arg to corresponding index
-(def convert-name (arg default-name)
+(deftimed convert-name (arg default-name)
 ;?   (prn "111 @arg @default-name")
   (when (and nondummy.arg not-raw-string.arg
              (~is ty.arg.0 'literal))  ; can't use 'literal?' because we want to rename offsets
@@ -1419,7 +1423,7 @@
 ;?       (prn 115)
       )))
 
-(def space-to-name (arg default-name)
+(deftimed space-to-name (arg default-name)
   (ret name default-name
     (when (~is space.arg 'global)
       (repeat space.arg
@@ -1427,7 +1431,7 @@
 
 ;; literate tangling system for reordering code
 
-(def convert-quotes (instrs)
+(deftimed convert-quotes (instrs)
   (let deferred (queue)
     (each instr instrs
       (when (acons instr)
@@ -1489,7 +1493,7 @@
 
 ;; loading code into the virtual machine
 
-(def add-code (forms)
+(deftimed add-code (forms)
   (each (op . rest)  forms
     (case op
       ; function <name> [ <instructions> ]
@@ -1567,7 +1571,7 @@
         (prn "unrecognized top-level " (cons op rest))
       )))
 
-(def freeze (function-table)
+(deftimed freeze (function-table)
   (each (name body)  canon.function-table
 ;?     (prn "freeze " name)
     (= function-table.name (convert-labels:convert-braces:tokenize-args:insert-code body name)))
@@ -1591,13 +1595,13 @@
   ; we could clear location* at this point, but maybe we'll find a use for it
   )
 
-(def freeze-another (fn-name)
+(deftimed freeze-another (fn-name)
   (= function*.fn-name (convert-labels:convert-braces:tokenize-args:insert-code function*.fn-name fn-name))
   (check-default-space function*.fn-name fn-name)
   (add-next-space-generator function*.fn-name fn-name)
   (convert-names function*.fn-name fn-name))
 
-(def tokenize-arg (arg)
+(deftimed tokenize-arg (arg)
 ;?   (tr "tokenize-arg " arg)
   (if (in arg '<- '_)
         arg
@@ -1608,7 +1612,7 @@
       :else
         arg))
 
-(def tokenize-args (instrs)
+(deftimed tokenize-args (instrs)
 ;?   (tr "tokenize-args " instrs)
 ;?   (prn2 "@(tostring prn.instrs) => "
   (accum yield
@@ -1625,21 +1629,21 @@
   (pr msg)
   (apply prn args))
 
-(def canon (table)
+(deftimed canon (table)
   (sort (compare < [tostring (prn:car _)]) (as cons table)))
 
-(def int-canon (table)
+(deftimed int-canon (table)
   (sort (compare < car) (as cons table)))
 
-(def routine-canon (routine-table)
+(deftimed routine-canon (routine-table)
   (sort (compare < label:car) (as cons routine-table)))
 
-(def repr (val)
+(deftimed repr (val)
   (tostring write.val))
 
 ;; test helpers
 
-(def memory-contains (addr value)
+(deftimed memory-contains (addr value)
 ;?   (prn "Looking for @value starting at @addr")
   (loop (addr addr
          idx  0)
@@ -1652,7 +1656,7 @@
         :else
           (recur (+ addr 1) (+ idx 1)))))
 
-(def memory-contains-array (addr value)
+(deftimed memory-contains-array (addr value)
   (and (>= memory*.addr len.value)
        (loop (addr (+ addr 1)  ; skip count
               idx  0)
@@ -1664,7 +1668,7 @@
                (recur (+ addr 1) (+ idx 1))))))
 
 ; like memory-contains-array but shows diffs
-(def memory-contains-array-verbose (addr value)
+(deftimed memory-contains-array-verbose (addr value)
   (prn "Mismatch when looking at @addr, size @memory*.addr vs @len.value")
   (and (>= memory*.addr len.value)
        (loop (addr (+ addr 1)  ; skip count
@@ -1680,7 +1684,7 @@
                (recur (+ addr 1) (+ idx 1))))))
 
 ; like memory-contains-array but shows diffs in 2D
-(def screen-contains (addr width value)
+(deftimed screen-contains (addr width value)
   (or (memory-contains-array addr value)
       (do ;(memory-contains-array-verbose addr value)
           (prn "Mismatch detected. Screen contents:")
@@ -1709,11 +1713,11 @@
      (freeze-another ',name)
      (run-more ',name)))
 
-(def routine-that-ran (f)
+(deftimed routine-that-ran (f)
   (find [some [is f _!fn-name] stack._]
         completed-routines*))
 
-(def routine-running (f)
+(deftimed routine-running (f)
   (or
     (find [some [is f _!fn-name] stack._]
           completed-routines*)
@@ -1725,19 +1729,19 @@
          (some [is f _!fn-name] stack.routine*)
          routine*)))
 
-(def ran-to-completion (f)
+(deftimed ran-to-completion (f)
   ; if a routine calling f ran to completion there'll be no sign of it in any
   ; completed call-stacks.
   (~routine-that-ran f))
 
-(def restart (routine)
+(deftimed restart (routine)
   (while (in top.routine!fn-name 'read 'write)
     (pop-stack routine))
   (wipe rep.routine!sleep)
   (wipe rep.routine!error)
   (enq routine running-routines*))
 
-(def dump (msg routine)
+(deftimed dump (msg routine)
   (prn "= @msg " rep.routine!sleep)
   (prn:rem [in car._ 'sleep 'call-stack] (as cons rep.routine))
   (each frame rep.routine!call-stack
@@ -1756,7 +1760,7 @@
   (let real-name (v tokenize-arg.name)
     `(= (system-function* ',real-name) ',body)))
 
-(def load-system-functions ()
+(deftimed load-system-functions ()
   (each (name f) system-function*
     (= (function* name)
        (system-function* name))))
diff --git a/trace.arc.t b/trace.arc.t
index a26093a3..30601c78 100644
--- a/trace.arc.t
+++ b/trace.arc.t
@@ -538,4 +538,4 @@ schedule:  done with routine")
   (prn "F - process-key: navigation moves between top-level lines only"))
 
 (reset)
-;? (print-times) ;? 1
+;? (print-times) ;? 2