diff options
| -rw-r--r-- | mu.arc | 148 | ||||
| -rw-r--r-- | trace.arc.t | 2 |
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 |