diff options
Diffstat (limited to 'mu.arc')
| -rw-r--r-- | mu.arc | 185 |
1 files changed, 94 insertions, 91 deletions
diff --git a/mu.arc b/mu.arc index 9676112a..cbe34425 100644 --- a/mu.arc +++ b/mu.arc @@ -59,26 +59,29 @@ (= curr-trace-file* filename)) (= dump-trace* nil) -(def trace (label . args) - (when (or (is dump-trace* t) - (and dump-trace* (is label "-")) - (and dump-trace* (pos label dump-trace*!whitelist)) - (and dump-trace* (no dump-trace*!whitelist) (~pos label dump-trace*!blacklist))) - (apply prn label ": " args)) - (enq (list label (apply tostring:prn args)) - traces*) - (car args)) - -(on-init - (wipe dump-trace*)) - -(redef tr args ; why am I still returning to prn when debugging? Will this help? - (do1 nil - (apply trace "-" args))) - -(def tr2 (msg arg) - (tr msg arg) - arg) +(mac trace (label . args) + ) +(mac tr args) +;? (def trace (label . args) +;? (when (or (is dump-trace* t) +;? (and dump-trace* (is label "-")) +;? (and dump-trace* (pos label dump-trace*!whitelist)) +;? (and dump-trace* (no dump-trace*!whitelist) (~pos label dump-trace*!blacklist))) +;? (apply prn label ": " args)) +;? (enq (list label (apply tostring:prn args)) +;? traces*) +;? (car args)) +;? +;? (on-init +;? (wipe dump-trace*)) +;? +;? (redef tr args ; why am I still returning to prn when debugging? Will this help? +;? (do1 nil +;? (apply trace "-" args))) +;? +;? (def tr2 (msg arg) +;? (tr msg arg) +;? arg) (def check-trace-contents (msg expected-contents) (unless (trace-contents-match expected-contents) @@ -248,28 +251,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) +(deftimed pop-stack (routine) ;? (update-time label.routine (msec)) ;? 1 (pop rep.routine!call-stack)) -(def top (routine) +(deftimed top (routine) stack.routine.0) -(def label (routine) +(deftimed label (routine) (whenlet stack stack.routine (or= stack.0!label (label2 stack)))) -(def 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 @@ -290,10 +293,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 @@ -355,7 +358,7 @@ ; particular time or for a particular memory location to change) ; detect termination: all non-helper routines completed ; detect deadlock: kill all sleeping routines when none can be woken -(def update-scheduler-state () +(deftimed update-scheduler-state () (when routine* ;? (prn "update scheduler state: " routine*) (if @@ -420,7 +423,7 @@ (detect-deadlock) ) -(def detect-deadlock () +(deftimed detect-deadlock () (when (and (empty running-routines*) (~empty sleeping-routines*) (~some 'literal (map (fn(_) rep._!sleep.1) @@ -430,7 +433,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*) @@ -445,7 +448,7 @@ ; routines consist of instrs ; instrs consist of oargs, op and args -(def parse-instr (instr) +(deftimed parse-instr (instr) (iflet delim (pos '<- instr) (do (when (atom (instr (+ delim 1))) (err "operator not tokenized in @instr; maybe you need to freeze functions*?")) @@ -454,31 +457,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)) @@ -493,7 +496,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")) @@ -973,7 +976,7 @@ (++ pc.routine*))) (return time-slice))) -(def prepare-reply (args) +(deftimed prepare-reply (args) (= results.routine* (accum yield (each a args @@ -986,7 +989,7 @@ ; indirect addressing - 'deref' ; relative addressing - if routine* has 'default-space' -(def m (loc) ; read memory, respecting metadata +(deftimed m (loc) ; read memory, respecting metadata (point return (when (literal? loc) (return v.loc)) @@ -1005,7 +1008,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) @@ -1040,22 +1043,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) @@ -1067,7 +1070,7 @@ ;? (tr "3: @repr.operand") ))) -(def array-len (operand) +(deftimed array-len (operand) (trace "array-len" operand) (zap canonize operand) (if typeinfo.operand!array @@ -1075,7 +1078,7 @@ :else (err "can't take len of non-array @operand"))) -(def sizeof (x) +(deftimed sizeof (x) ;? (trace "sizeof" x) ;? 1 (assert acons.x) (zap canonize x) @@ -1095,7 +1098,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) @@ -1115,7 +1118,7 @@ space.operand) operand))) -(def lookup-space (operand base space) +(deftimed lookup-space (operand base space) (if (is 0 space) ; base case (if (< v.operand memory*.base) @@ -1127,17 +1130,17 @@ (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) (drop-one '(deref) metadata.operand))) -(def drop-one (f x) +(deftimed drop-one (f x) (when acons.x ; proper lists only (if (testify.f car.x) cdr.x @@ -1145,7 +1148,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) @@ -1154,16 +1157,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) @@ -1171,14 +1174,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 @@ -1242,7 +1245,7 @@ (yield-unchanged))) (++ pc)))))))) -(def close-offset (pc locs nblocks) +(deftimed close-offset (pc locs nblocks) (or= nblocks 1) ;? (tr nblocks) (point return @@ -1261,13 +1264,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 @@ -1292,7 +1295,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 @@ -1385,7 +1388,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) @@ -1398,7 +1401,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 @@ -1410,7 +1413,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)) @@ -1423,7 +1426,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 @@ -1438,7 +1441,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 @@ -1446,7 +1449,7 @@ ;; literate tangling system for reordering code -(def convert-quotes (instrs) +(deftimed convert-quotes (instrs) (let deferred (queue) (each instr instrs (when (acons instr) @@ -1508,7 +1511,7 @@ ;; loading code into the virtual machine -(def add-code (forms) +(deftimed add-code (forms) (each (op . rest) forms (case op ; function <name> [ <instructions> ] @@ -1586,7 +1589,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))) @@ -1610,14 +1613,14 @@ ; 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) (= location*.fn-name (assign-names-to-location function*.fn-name fn-name location*.fn-name)) (replace-names-with-location function*.fn-name fn-name)) -(def tokenize-arg (arg) +(deftimed tokenize-arg (arg) ;? (tr "tokenize-arg " arg) (if (in arg '<- '_) arg @@ -1628,7 +1631,7 @@ :else arg)) -(def tokenize-args (instrs) +(deftimed tokenize-args (instrs) ;? (tr "tokenize-args " instrs) ;? (prn2 "@(tostring prn.instrs) => " (accum yield @@ -1645,21 +1648,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) @@ -1672,7 +1675,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) @@ -1684,7 +1687,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 @@ -1700,7 +1703,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:") @@ -1729,11 +1732,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*) @@ -1745,19 +1748,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 @@ -1776,7 +1779,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)))) @@ -3073,7 +3076,7 @@ ) ; repl -(def run-interactive (stmt) +(deftimed run-interactive (stmt) ; careful to avoid re-processing functions and adding noise to traces (= function*!interactive (convert-labels:convert-braces:tokenize-args (list stmt))) (add-next-space-generator function*!interactive 'interactive) |