From f42a8ddc38ec6438c70f7ad5a2b3db3e29280f8e Mon Sep 17 00:00:00 2001
From: "Kartik K. Agaram" <vc@akkartik.com>
Date: Mon, 16 Feb 2015 14:28:23 -0800
Subject: 761 - now 30% faster than 758

4:26 compared to 6:20 on my laptop.
---
 mu.arc | 144 ++++++++++++++++++++++++++++++++---------------------------------
 1 file changed, 72 insertions(+), 72 deletions(-)

diff --git a/mu.arc b/mu.arc
index 0c5556ba..04d6ec5f 100644
--- a/mu.arc
+++ b/mu.arc
@@ -6,7 +6,7 @@
 
 (= times* (table))
 
-(mac deftimed(name args . body)
+(mac deftimed (name args . body)
   `(do
      (def ,(sym (string name "_core")) ,args
         ,@body)
@@ -32,7 +32,7 @@
 
 ;; what happens when our virtual machine starts up
 (= initialization-fns* (queue))
-(deftimed reset ()
+(def reset ()
   (each f (as cons initialization-fns*)
     (f)))
 
@@ -53,7 +53,7 @@
   (= curr-trace-file* nil)
   (= traces* (queue)))
 
-(deftimed new-trace (filename)
+(def new-trace (filename)
   (prn "== @filename")
 ;?   )
   (= curr-trace-file* filename))
@@ -76,17 +76,17 @@
   (do1 nil
        (apply trace "-" args)))
 
-(deftimed tr2 (msg arg)
+(def tr2 (msg arg)
   (tr msg arg)
   arg)
 
-(deftimed check-trace-contents (msg expected-contents)
+(def check-trace-contents (msg expected-contents)
   (unless (trace-contents-match expected-contents)
     (prn "F - " msg)
     (prn "  trace contents")
     (print-trace-contents-mismatch expected-contents)))
 
-(deftimed trace-contents-match (expected-contents)
+(def 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))
 
-(deftimed print-trace-contents-mismatch (expected-contents)
+(def 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)))
 
-(deftimed check-trace-doesnt-contain (msg (label unexpected-contents))
+(def 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,28 +248,28 @@
 (defextend empty (x)  (isa x 'routine)
   (no rep.x!call-stack))
 
-(deftimed stack (routine)
+(def stack (routine)
   ((rep routine) 'call-stack))
 
-(deftimed push-stack (routine op)
+(def push-stack (routine op)
   (push (obj fn-name op  pc 0  caller-arg-idx 0  t0 (msec))
         rep.routine!call-stack))
 
-(deftimed pop-stack (routine)
+(def pop-stack (routine)
 ;?   (update-time label.routine (msec)) ;? 1
   (pop rep.routine!call-stack))
 
 (def top (routine)
   stack.routine.0)
 
-(deftimed label (routine)
+(def label (routine)
   (whenlet stack stack.routine
     (or= stack.0!label
          (label2 stack))))
-(deftimed label2 (stack)
+(def label2 (stack)
          (string:intersperse "/" (map [_ 'fn-name] stack)));))
 
-(deftimed body (routine)
+(def body (routine)
   (function* stack.routine.0!fn-name))
 
 (mac pc (routine (o idx 0))  ; assignable
@@ -290,10 +290,10 @@
 (mac reply-args (routine)  ; assignable
   `((((rep ,routine) 'call-stack) 0) 'reply-args))
 
-(deftimed waiting-for-exact-cycle? (routine)
+(def waiting-for-exact-cycle? (routine)
   (is 'until rep.routine!sleep.0))
 
-(deftimed ready-to-wake-up (routine)
+(def ready-to-wake-up (routine)
   (assert no.routine*)
   (case rep.routine!sleep.0
     until
@@ -420,7 +420,7 @@
   (detect-deadlock)
   )
 
-(deftimed detect-deadlock ()
+(def detect-deadlock ()
   (when (and (empty running-routines*)
              (~empty sleeping-routines*)
              (~some 'literal (map (fn(_) rep._!sleep.1)
@@ -430,7 +430,7 @@
       (= rep.routine!error "deadlock detected")
       (push routine completed-routines*))))
 
-(deftimed die (msg)
+(def die (msg)
   (tr "die: " msg)
   (= rep.routine*!error msg)
   (iflet abort-continuation (abort-routine*)
@@ -445,7 +445,7 @@
 
 ; routines consist of instrs
 ; instrs consist of oargs, op and args
-(deftimed parse-instr (instr)
+(def parse-instr (instr)
 ;?   (prn instr)
   (iflet delim (pos '<- instr)
     (list (cut instr 0 delim)  ; oargs
@@ -453,31 +453,31 @@
           (cut instr (+ delim 2)))  ; args
     (list nil (v car.instr) cdr.instr)))
 
-(deftimed metadata (operand)
+(def metadata (operand)
   cdr.operand)
 
-(deftimed ty (operand)
+(def ty (operand)
   (cdr operand.0))
 
-(deftimed literal? (operand)
+(def literal? (operand)
   (unless (acons ty.operand)
     (err "no type in operand @operand"))
   (in ty.operand.0 'literal 'offset 'fn))
 
-(deftimed typeinfo (operand)
+(def typeinfo (operand)
   (or (type* ty.operand.0)
       (err "unknown type @(tostring prn.operand)")))
 
 ; operand accessors
-(deftimed nondummy (operand)  ; precondition for helpers below
+(def 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
-(deftimed not-raw-string (operand)
+(def not-raw-string (operand)
   (~isa operand 'string))
 
-(deftimed address? (operand)
+(def address? (operand)
   (or (is ty.operand.0 'location)
       typeinfo.operand!address))
 
@@ -492,7 +492,7 @@
 ($:define (reset) (tput 'sgr0))
 
 ; run instructions from 'routine*' for 'time-slice'
-(deftimed run-for-time-slice (time-slice)
+(def 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"))
@@ -958,7 +958,7 @@
         (++ pc.routine*)))
     (return time-slice)))
 
-(deftimed prepare-reply (args)
+(def prepare-reply (args)
   (= results.routine*
      (accum yield
        (each a args
@@ -990,7 +990,7 @@
                         (map memory* (addrs addr n)))))
       (trace "mem" loc " => " result))))
 
-(deftimed setm (loc val)  ; set memory, respecting metadata
+(def setm (loc val)  ; set memory, respecting metadata
 ;?   (tr 111)
   (point return
 ;?   (tr 112)
@@ -1025,22 +1025,22 @@
                 (trace "mem" loc ": " dest " <= " repr.src)
                 (= memory*.dest src))))))))
 
-(deftimed typeof (operand)
+(def typeof (operand)
   (let loc absolutize.operand
     (while (pos '(deref) metadata.loc)
       (zap deref loc))
     ty.loc.0))
 
-(deftimed addr (operand)
+(def addr (operand)
   (v canonize.operand))
 
-(deftimed addrs (n sz)
+(def addrs (n sz)
   (accum yield
     (repeat sz
       (yield n)
       (++ n))))
 
-(deftimed canonize (operand)
+(def canonize (operand)
 ;?   (tr "0: @operand")
   (ret operand
 ;?     (prn "1: " operand)
@@ -1080,7 +1080,7 @@
 ;?   (tr "sizeof: @x is a primitive")
   (return typeinfo.x!size)))
 
-(deftimed absolutize (operand)
+(def absolutize (operand)
   (if (no routine*)
         operand
       (in v.operand '_ 'default-space)
@@ -1112,11 +1112,11 @@
     (lookup-space operand (memory* (+ base 1))  ; location 0 points to next space
                   (- space 1))))
 
-(deftimed space (operand)
+(def space (operand)
   (or (alref metadata.operand 'space)
       0))
 
-(deftimed deref (operand)
+(def deref (operand)
   (assert (pos '(deref) metadata.operand))
   (assert address?.operand)
   (cons `(,(memory* v.operand) ,@typeinfo.operand!elem)
@@ -1130,7 +1130,7 @@
 
 ; memory allocation
 
-(deftimed alloc (sz)
+(def alloc (sz)
   (when (> sz (- rep.routine*!alloc-max rep.routine*!alloc))
     (let curr-alloc Memory-allocated-until
       (= rep.routine*!alloc curr-alloc)
@@ -1139,16 +1139,16 @@
   (ret result rep.routine*!alloc
     (++ rep.routine*!alloc sz)))
 
-(deftimed new-scalar (type)
+(def new-scalar (type)
 ;?   (tr "new scalar: @type")
   (alloc (sizeof `((_ ,type)))))
 
-(deftimed new-array (type size)
+(def new-array (type size)
 ;?   (tr "new array: @type @size")
   (ret result (alloc (+ 1 (* (sizeof `((_ ,@type*.type!elem))) size)))
     (= memory*.result size)))
 
-(deftimed new-string (literal-string)
+(def new-string (literal-string)
 ;?   (tr "new string: @literal-string")
   (ret result (alloc (+ 1 len.literal-string))
     (= memory*.result len.literal-string)
@@ -1156,14 +1156,14 @@
 ;?       (prn index " " repr.c) ;? 1
       (= (memory* (+ result 1 index)) c))))
 
-(deftimed to-arc-string (string-address)
+(def 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
 
-(deftimed convert-braces (instrs)
+(def convert-braces (instrs)
 ;?   (prn "convert-braces " instrs)
   (let locs ()  ; list of information on each brace: (open/close pc)
     (let pc 0
@@ -1227,7 +1227,7 @@
                   (yield-unchanged)))
             (++ pc))))))))
 
-(deftimed close-offset (pc locs nblocks)
+(def close-offset (pc locs nblocks)
   (or= nblocks 1)
 ;?   (tr nblocks)
   (point return
@@ -1246,13 +1246,13 @@
 ;?         (tr "close now " loc)
         (return (- loc pc 1))))))))
 
-(deftimed open-offset (pc stack nblocks)
+(def open-offset (pc stack nblocks)
   (or= nblocks 1)
   (- (stack (- nblocks 1)) 1 pc))
 
 ;; convert jump targets to offsets
 
-(deftimed convert-labels (instrs)
+(def convert-labels (instrs)
 ;?   (tr "convert-labels " instrs)
   (let labels (table)
     (let pc 0
@@ -1277,7 +1277,7 @@
 
 ;; convert symbolic names to raw memory locations
 
-(deftimed add-next-space-generator (instrs name)
+(def add-next-space-generator (instrs name)
 ;?   (prn "== @name")
   (each instr instrs
     (when acons.instr
@@ -1300,7 +1300,7 @@
 ;?   (tr "save names for function @name: @(tostring:pr location*.name)") ;? 1
   (replace-names-with-location instrs name))
 
-(deftimed assign-names-to-location (instrs name)
+(def assign-names-to-location (instrs name)
   (trace "cn0" "convert-names in @name")
 ;?   (prn name ": " location*) ;? 1
   (point return
@@ -1370,7 +1370,7 @@
                 ; todo: can't allocate arrays on the stack
                 (++ idx (sizeof `((_ ,@ty.arg))))))))))))))
 
-(deftimed replace-names-with-location (instrs name)
+(def replace-names-with-location (instrs name)
   (each instr instrs
     (when (acons instr)
       (let (oargs op args)  (parse-instr instr)
@@ -1383,7 +1383,7 @@
   instrs)
 
 (= allow-raw-addresses* nil)
-(deftimed check-default-space (instrs name)
+(def check-default-space (instrs name)
   (unless allow-raw-addresses*
     (let oarg-names (accum yield
                       (each (oargs _ _) (map parse-instr (keep acons  ; non-label
@@ -1395,7 +1395,7 @@
         (prn "function @name has no default-space")))))
 
 ; assign an index to an arg
-(deftimed maybe-add (arg location idx)
+(def maybe-add (arg location idx)
   (trace "maybe-add" arg)
   (when (and nondummy.arg
 ;?              (prn arg " " (assoc 'space arg))
@@ -1408,7 +1408,7 @@
     (= (location v.arg) idx)))
 
 ; convert the arg to corresponding index
-(deftimed convert-name (arg default-name)
+(def 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
@@ -1423,7 +1423,7 @@
 ;?       (prn 115)
       )))
 
-(deftimed space-to-name (arg default-name)
+(def space-to-name (arg default-name)
   (ret name default-name
     (when (~is space.arg 'global)
       (repeat space.arg
@@ -1431,7 +1431,7 @@
 
 ;; literate tangling system for reordering code
 
-(deftimed convert-quotes (instrs)
+(def convert-quotes (instrs)
   (let deferred (queue)
     (each instr instrs
       (when (acons instr)
@@ -1493,7 +1493,7 @@
 
 ;; loading code into the virtual machine
 
-(deftimed add-code (forms)
+(def add-code (forms)
   (each (op . rest)  forms
     (case op
       ; function <name> [ <instructions> ]
@@ -1571,7 +1571,7 @@
         (prn "unrecognized top-level " (cons op rest))
       )))
 
-(deftimed freeze (function-table)
+(def 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)))
@@ -1595,13 +1595,13 @@
   ; we could clear location* at this point, but maybe we'll find a use for it
   )
 
-(deftimed freeze-another (fn-name)
+(def 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))
 
-(deftimed tokenize-arg (arg)
+(def tokenize-arg (arg)
 ;?   (tr "tokenize-arg " arg)
   (if (in arg '<- '_)
         arg
@@ -1612,7 +1612,7 @@
       :else
         arg))
 
-(deftimed tokenize-args (instrs)
+(def tokenize-args (instrs)
 ;?   (tr "tokenize-args " instrs)
 ;?   (prn2 "@(tostring prn.instrs) => "
   (accum yield
@@ -1629,21 +1629,21 @@
   (pr msg)
   (apply prn args))
 
-(deftimed canon (table)
+(def canon (table)
   (sort (compare < [tostring (prn:car _)]) (as cons table)))
 
-(deftimed int-canon (table)
+(def int-canon (table)
   (sort (compare < car) (as cons table)))
 
-(deftimed routine-canon (routine-table)
+(def routine-canon (routine-table)
   (sort (compare < label:car) (as cons routine-table)))
 
-(deftimed repr (val)
+(def repr (val)
   (tostring write.val))
 
 ;; test helpers
 
-(deftimed memory-contains (addr value)
+(def memory-contains (addr value)
 ;?   (prn "Looking for @value starting at @addr")
   (loop (addr addr
          idx  0)
@@ -1656,7 +1656,7 @@
         :else
           (recur (+ addr 1) (+ idx 1)))))
 
-(deftimed memory-contains-array (addr value)
+(def memory-contains-array (addr value)
   (and (>= memory*.addr len.value)
        (loop (addr (+ addr 1)  ; skip count
               idx  0)
@@ -1668,7 +1668,7 @@
                (recur (+ addr 1) (+ idx 1))))))
 
 ; like memory-contains-array but shows diffs
-(deftimed memory-contains-array-verbose (addr value)
+(def 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
@@ -1684,7 +1684,7 @@
                (recur (+ addr 1) (+ idx 1))))))
 
 ; like memory-contains-array but shows diffs in 2D
-(deftimed screen-contains (addr width value)
+(def screen-contains (addr width value)
   (or (memory-contains-array addr value)
       (do ;(memory-contains-array-verbose addr value)
           (prn "Mismatch detected. Screen contents:")
@@ -1713,11 +1713,11 @@
      (freeze-another ',name)
      (run-more ',name)))
 
-(deftimed routine-that-ran (f)
+(def routine-that-ran (f)
   (find [some [is f _!fn-name] stack._]
         completed-routines*))
 
-(deftimed routine-running (f)
+(def routine-running (f)
   (or
     (find [some [is f _!fn-name] stack._]
           completed-routines*)
@@ -1729,19 +1729,19 @@
          (some [is f _!fn-name] stack.routine*)
          routine*)))
 
-(deftimed ran-to-completion (f)
+(def 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))
 
-(deftimed restart (routine)
+(def 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*))
 
-(deftimed dump (msg routine)
+(def 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
@@ -1760,7 +1760,7 @@
   (let real-name (v tokenize-arg.name)
     `(= (system-function* ',real-name) ',body)))
 
-(deftimed load-system-functions ()
+(def load-system-functions ()
   (each (name f) system-function*
     (= (function* name)
        (system-function* name))))
-- 
cgit 1.4.1-2-gfad0