From 4e757e8d260f8857f77d9276bd7ec7b146745595 Mon Sep 17 00:00:00 2001 From: "Kartik K. Agaram" Date: Fri, 2 Jan 2015 11:34:24 -0800 Subject: 481 - oh of course: 'int-canon.memory*' --- chessboard-rawterm.mu | 10 +-- mu.arc | 202 +++++++++++++++++++++++++------------------------- 2 files changed, 106 insertions(+), 106 deletions(-) diff --git a/chessboard-rawterm.mu b/chessboard-rawterm.mu index bf87b829..5493104a 100644 --- a/chessboard-rawterm.mu +++ b/chessboard-rawterm.mu @@ -5,11 +5,11 @@ N:literal P:literal _:literal _:literal _:literal _:literal p:literal n:literal B:literal P:literal _:literal _:literal _:literal _:literal p:literal b:literal Q:literal P:literal _:literal _:literal _:literal _:literal p:literal q:literal - ) -;? K:literal P:literal _:literal _:literal _:literal _:literal p:literal k:literal -;? B:literal P:literal _:literal _:literal _:literal _:literal p:literal b:literal -;? N:literal P:literal _:literal _:literal _:literal _:literal p:literal n:literal -;? R:literal P:literal _:literal _:literal _:literal _:literal p:literal r:literal) +;? ) + K:literal P:literal _:literal _:literal _:literal _:literal p:literal k:literal + B:literal P:literal _:literal _:literal _:literal _:literal p:literal b:literal + N:literal P:literal _:literal _:literal _:literal _:literal p:literal n:literal + R:literal P:literal _:literal _:literal _:literal _:literal p:literal r:literal) ; assert(length(initial-position) == 64) ;? (print-primitive (("list-length\n" literal))) (len:integer <- list-length initial-position:list-address) diff --git a/mu.arc b/mu.arc index c033815c..74922b84 100644 --- a/mu.arc +++ b/mu.arc @@ -1,6 +1,35 @@ +;; profiler (http://arclanguage.org/item?id=11556) +(mac proc (name params . body) + `(def ,name ,params ,@body nil)) + +(= times* (table)) + +(mac deftimed(name args . body) + `(do + (def ,(sym (string name "_core")) ,args + ,@body) + (def ,name ,args + (let t0 (msec) + (ret ans ,(cons (sym (string name "_core")) args) + (update-time ,(string name) t0)))))) + +(proc update-time(name t0) ; call directly in recursive functions + (or= times*.name (list 0 0)) + (with ((a b) times*.name + timing (- (msec) t0)) + (= times*.name + (list + (+ a timing) + (+ b 1))))) + +(def print-times() + (prn "gc " (current-gc-milliseconds)) + (each (name time) (tablist times*) + (prn name " " time))) + ;; what happens when our virtual machine starts up (= initialization-fns* (queue)) -(def reset () +(deftimed reset () (each f (as cons initialization-fns*) (f))) @@ -21,36 +50,37 @@ (= curr-trace-file* nil) (= traces* (queue))) -(def new-trace (filename) +(deftimed new-trace (filename) (prn "== @filename") ;? ) (= 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*)) + nil) +;? (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*)) (redef tr args ; why am I still returning to prn when debugging? Will this help? (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) @@ -58,7 +88,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) @@ -76,7 +106,7 @@ ; things that a future assembler will need separate memory for: ; code; types; args channel ; at compile time: mapping names to locations -(def clear () +(deftimed clear () (= type* (table)) ; name -> type info (= memory* (table)) ; address -> value (= function* (table)) ; name -> [instructions] @@ -173,7 +203,7 @@ (defextend empty (x) (isa x 'routine) (no rep.x!call-stack)) -(def stack (routine) +(deftimed stack (routine) ((rep routine) 'call-stack)) (mac push-stack (routine op) @@ -183,11 +213,11 @@ (mac pop-stack (routine) `(pop ((rep ,routine) 'call-stack))) -(def top (routine) +(deftimed top (routine) stack.routine.0) -(def body (routine (o idx 0)) - (function* stack.routine.idx!fn-name)) +(deftimed body (routine) + (function* stack.routine.0!fn-name)) (mac pc (routine (o idx 0)) ; assignable `((((rep ,routine) 'call-stack) ,idx) 'pc)) @@ -205,10 +235,10 @@ (mac results (routine) ; assignable `((((rep ,routine) 'call-stack) 0) 'results)) -(def waiting-for-exact-cycle? (routine) +(deftimed waiting-for-exact-cycle? (routine) (is 'literal rep.routine!sleep.1)) -(def ready-to-wake-up (routine) +(deftimed ready-to-wake-up (routine) (assert no.routine*) (if (is 'literal rep.routine!sleep.1) (> curr-cycle* rep.routine!sleep.0) @@ -261,7 +291,7 @@ ; wake up any necessary sleeping routines (which might be waiting for a ; particular time or for a particular memory location to change) ; detect deadlock: kill all sleeping routines when none can be woken -(def update-scheduler-state () +(deftimed update-scheduler-state () ;? (trace "schedule" curr-cycle*) (when routine* (if @@ -295,7 +325,7 @@ ;? (tr 114) ) -(def detect-deadlock () +(deftimed detect-deadlock () (when (and (empty running-routines*) (~empty sleeping-routines*) (~some 'literal (map (fn(_) rep._!sleep.1) @@ -305,7 +335,7 @@ (= rep.routine!error "deadlock detected") (push routine completed-routines*)))) -(def die (msg) +(deftimed die (msg) (tr "die: " msg) (= rep.routine*!error msg) (= rep.routine*!stack-trace rep.routine*!call-stack) @@ -322,7 +352,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 @@ -330,29 +360,29 @@ (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) (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)) @@ -361,7 +391,7 @@ (= Viewport nil) ; 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")) @@ -373,7 +403,7 @@ (die "No results returned: @(tostring:prn (body.routine* pc.routine*))")) (++ pc.routine*)) (++ curr-cycle*) - (trace "run" "-- " int-canon.memory*) +;? (trace "run" "-- " int-canon.memory*) (trace "run" curr-cycle* " " top.routine*!fn-name " " pc.routine* ": " (body.routine* pc.routine*)) ;? (trace "run" routine*) (when (atom (body.routine* pc.routine*)) ; label @@ -653,7 +683,7 @@ (++ pc.routine*))) (return time-slice))) -(def prepare-reply (args) +(deftimed prepare-reply (args) (= results.routine* (accum yield (each a args @@ -665,7 +695,7 @@ ; indirect addressing - 'deref' ; relative addressing - if routine* has 'default-scope' -(def m (loc) ; read memory, respecting metadata +(deftimed m (loc) ; read memory, respecting metadata (point return (when (literal? loc) (return v.loc)) @@ -682,7 +712,7 @@ (annotate 'record (map memory* (addrs addr n))))))) -(def setm (loc val) ; set memory, respecting metadata +(deftimed setm (loc val) ; set memory, respecting metadata (point return (when (is v.loc 'default-scope) (assert (is 1 sizeof.loc) "can't store compounds in default-scope @loc") @@ -714,22 +744,22 @@ (trace "setm" loc ": setting " dest " to " 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) @@ -741,7 +771,7 @@ ;? (tr "3: @(tostring write.operand)") ))) -(def array-len (operand) +(deftimed array-len (operand) (trace "array-len" operand) (zap canonize operand) (if typeinfo.operand!array @@ -749,7 +779,7 @@ :else (err "can't take len of non-array @operand"))) -(def sizeof (x) +(deftimed sizeof (x) (trace "sizeof" x) (assert acons.x) (zap canonize x) @@ -769,7 +799,7 @@ ;? (tr "sizeof: @x is a primitive") (return typeinfo.x!size))) -(def absolutize (operand) +(deftimed absolutize (operand) (if (no routine*) operand (is '_ v.operand) @@ -789,7 +819,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) @@ -801,17 +831,17 @@ (lookup-space operand (memory* (+ base 1)) ; location 0 points to parent space (- space 1)))) -(def space (operand) +(deftimed space (operand) (or (alref 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 @@ -819,18 +849,18 @@ ; memory allocation -(def new-scalar (type) +(deftimed new-scalar (type) ;? (tr "new scalar: @type") (ret result rep.routine*!alloc (++ rep.routine*!alloc (sizeof `((_ ,type)))))) -(def new-array (type size) +(deftimed new-array (type size) ;? (tr "new array: @type @size") (ret result rep.routine*!alloc (++ rep.routine*!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 rep.routine*!alloc (= (memory* rep.routine*!alloc) len.literal-string) @@ -841,7 +871,7 @@ ;; 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 @@ -912,7 +942,7 @@ (yield instr))) (++ pc)))))))) -(def close-offset (pc locs nblocks) +(deftimed close-offset (pc locs nblocks) (or= nblocks 1) ;? (tr nblocks) (point return @@ -931,13 +961,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 @@ -962,7 +992,7 @@ ;; convert symbolic names to raw memory locations -(def add-closure-generator (instrs name) +(deftimed add-closure-generator (instrs name) ;? (prn "== @name") (each instr instrs (when acons.instr @@ -985,7 +1015,7 @@ ) (replace-names-with-location instrs name)) -(def assign-names-to-location (instrs name) +(deftimed assign-names-to-location (instrs name) (ret location (table) (with (isa-field (table) idx 1) ; 0 always reserved for parent scope @@ -1034,7 +1064,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) @@ -1045,7 +1075,7 @@ instrs) ; 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)) @@ -1058,7 +1088,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 @@ -1073,7 +1103,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 @@ -1081,7 +1111,7 @@ ;; literate tangling system for reordering code -(def convert-quotes (instrs) +(deftimed convert-quotes (instrs) (let deferred (queue) (each instr instrs (when (acons instr) @@ -1143,7 +1173,7 @@ ;; loading code into the virtual machine -(def add-code (forms) +(deftimed add-code (forms) (each (op . rest) forms (case op ; function [ ] @@ -1201,7 +1231,7 @@ (push fragment after*.label)) ))) -(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))) @@ -1214,7 +1244,7 @@ ; we could clear location* at this point, but maybe we'll find a use for it ) -(def tokenize-arg (arg) +(deftimed tokenize-arg (arg) ;? (tr "tokenize-arg " arg) (if (in arg '<- '_) arg @@ -1225,7 +1255,7 @@ :else arg)) -(def tokenize-args (instrs) +(deftimed tokenize-args (instrs) ;? (tr "tokenize-args " instrs) ;? (prn2 "@(tostring prn.instrs) => " (accum yield @@ -1242,15 +1272,15 @@ (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))) ;; test helpers -(def memory-contains (addr value) +(deftimed memory-contains (addr value) ;? (prn "Looking for @value starting at @addr") (loop (addr addr idx 0) @@ -1263,7 +1293,7 @@ :else (recur (+ addr 1) (+ idx 1))))) -(def memory-contains-array (addr value) +(deftimed memory-contains-array (addr value) ;? (prn "Looking for @value starting at @addr, size @memory*.addr vs @len.value") (and (>= memory*.addr len.value) (loop (addr (+ addr 1) @@ -1286,7 +1316,7 @@ (mac init-fn (name . body) `(= (system-function* ',name) ',body)) -(def load-system-functions () +(deftimed load-system-functions () (each (name f) system-function* (= (function* name) (system-function* name)))) @@ -1740,8 +1770,6 @@ (freeze system-function*) ) ; section 100 for system software -(load "profiler.arc") - ;; load all provided files and start at 'main' (reset) ;? (new-trace "main") @@ -1754,34 +1782,6 @@ ;? (set dump-trace*) ;? (freeze function*) ;? (prn function*!factorial) -;? (profile run) -;? (profile run-for-time-slice) -;? (profile make-routine) -;? (profile empty) -;? (profile stack) -;? (profile top) -;? (profile body) -;? (profile parse-instr) -;? (profile metadata) -;? (profile ty) -;? (profile literal?) -;? (profile typeinfo) -;? (profile m) -;? (profile setm) -;? (profile addr) -;? (profile addrs) -;? (profile canonize) -;? (profile array-len) -;? (profile sizeof) -;? (profile absolutize) -;? (profile lookup-space) -;? (profile deref) -;? (profile drop-one) -;? (profile new-scalar) -;? (profile new-array) -;? (profile new-string) -;? (profile convert-braces) -;? (profile convert-names) (run 'main) ;? (if ($.current-charterm) ($.close-charterm)) ;? (prn "\nmemory: " int-canon.memory*) @@ -1789,4 +1789,4 @@ (aif rep.routine!error (prn "error - " it))) ) ;? (reset) -(profiles) +(print-times) -- cgit 1.4.1-2-gfad0