From 2a4088119cf41175457414dfa59bd4064b8f0562 Mon Sep 17 00:00:00 2001 From: Kartik Agaram Date: Wed, 1 Jan 2020 17:04:37 -0800 Subject: 5852 --- archive/0.vm.arc/mu.arc | 3259 +++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 3259 insertions(+) create mode 100644 archive/0.vm.arc/mu.arc (limited to 'archive/0.vm.arc/mu.arc') diff --git a/archive/0.vm.arc/mu.arc b/archive/0.vm.arc/mu.arc new file mode 100644 index 00000000..2aebd3d5 --- /dev/null +++ b/archive/0.vm.arc/mu.arc @@ -0,0 +1,3259 @@ +(ero "initializing mu.. (takes ~5s)") +;; profiler (http://arclanguage.org/item?id=11556) +; Keeping this right on top as a reminder to profile before guessing at why my +; program is slow. +(mac proc (name params . body) + `(def ,name ,params ,@body nil)) + +(mac filter-log (msg f x) + `(ret x@ ,x + (prn ,msg (,f x@)))) + +(= 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 (current-process-milliseconds)) + (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 () + (each f (as cons initialization-fns*) + (f))) + +(mac on-init body + `(enq (fn () ,@body) + initialization-fns*)) + +;; persisting and checking traces for each test +(= traces* (queue)) +(= trace-dir* ".traces/") +(ensure-dir trace-dir*) +(= curr-trace-file* nil) +(on-init + (awhen curr-trace-file* + (tofile (+ trace-dir* it) + (each (label trace) (as cons traces*) + (pr label ": " trace)))) + (= curr-trace-file* nil) + (= traces* (queue))) + +(def 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*) + (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) + (prn "F - " msg) + (prn " trace contents") + (print-trace-contents-mismatch expected-contents))) + +(def trace-contents-match (expected-contents) + (each (label msg) (as cons traces*) + (when (and expected-contents + (is label expected-contents.0.0) + (posmatch expected-contents.0.1 msg)) + (pop expected-contents))) + (no 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) + (posmatch expected-msg msg)) + (do (pr " * ") + (pop expected-contents)) + (pr " ")) + (pr label ": " msg))) + (prn " couldn't find") + (each (expected-label expected-msg) expected-contents + (prn " ! " expected-label ": " expected-msg))) + +(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*)) + (prn "F - " msg) + (prn " trace contents") + (each (l msg) (as cons traces*) + (if (and (is l label) + (posmatch unexpected-contents msg)) + (pr " X ") + (pr " ")) + (pr label ": " msg)))) + +;; virtual machine state + +; things that a future assembler will need separate memory for: +; code; types; args channel +; at compile time: mapping names to locations +(on-init + (= type* (table)) ; name -> type info + (= memory* (table)) ; address -> value (make this a vector?) + (= function* (table)) ; name -> [instructions] + ; transforming mu programs + (= location* (table)) ; function -> {name -> index into default-space} + (= next-space-generator* (table)) ; function -> name of function generating next space + ; each function's next space will usually always come from a single function + (= next-routine-id* 0) + (= continuation* (table)) + ) + +(on-init + (= type* (obj + ; Each type must be scalar or array, sum or product or primitive + type (obj size 1) ; implicitly scalar and primitive + type-address (obj size 1 address t elem '(type)) + type-array (obj array t elem '(type)) + type-array-address (obj size 1 address t elem '(type-array)) + location (obj size 1 address t elem '(location)) ; assume it points to an atom + integer (obj size 1) + boolean (obj size 1) + boolean-address (obj size 1 address t elem '(boolean)) + byte (obj size 1) + byte-address (obj size 1 address t elem '(byte)) + string (obj array t elem '(byte)) ; inspired by Go + ; an address contains the location of a specific type + string-address (obj size 1 address t elem '(string)) + string-address-address (obj size 1 address t elem '(string-address)) + string-address-array (obj array t elem '(string-address)) + string-address-array-address (obj size 1 address t elem '(string-address-array)) + string-address-array-address-address (obj size 1 address t elem '(string-address-array-address)) + ; 'character' will be of larger size when mu supports unicode + ; we're currently undisciplined about mixing 'byte' and 'character' + ; realistic test of indiscipline in general + character (obj size 1) ; int32 like a Go rune + character-address (obj size 1 address t elem '(character)) + ; a buffer makes it easy to append to a string/array + ; todo: make this generic + ; data isn't a 'real' array: its length is stored outside it, + ; so for example, 'print-string' won't work on it. + buffer (obj size 2 and-record t elems '((integer) (string-address)) fields '(length data)) + buffer-address (obj size 1 address t elem '(buffer)) + ; a stream makes it easy to read from a string/array + stream (obj size 2 and-record t elems '((integer) (string-address)) fields '(pointer data)) + stream-address (obj size 1 address t elem '(stream)) + ; isolating function calls + space (obj array t elem '(location)) ; by convention index 0 points to outer space + space-address (obj size 1 address t elem '(space)) + ; arrays consist of an integer length followed by that many + ; elements, all of the same type + integer-array (obj array t elem '(integer)) + integer-array-address (obj size 1 address t elem '(integer-array)) + integer-array-address-address (obj size 1 address t elem '(integer-array-address)) + integer-address (obj size 1 address t elem '(integer)) ; pointer to int + integer-address-address (obj size 1 address t elem '(integer-address)) + ; and-records consist of a multiple fields of different types + integer-boolean-pair (obj size 2 and-record t elems '((integer) (boolean)) fields '(int bool)) + integer-boolean-pair-address (obj size 1 address t elem '(integer-boolean-pair)) + integer-boolean-pair-array (obj array t elem '(integer-boolean-pair)) + integer-boolean-pair-array-address (obj size 1 address t elem '(integer-boolean-pair-array)) + integer-integer-pair (obj size 2 and-record t elems '((integer) (integer))) + integer-integer-pair-address (obj size 1 address t elem '(integer-integer-pair)) + integer-point-pair (obj size 2 and-record t elems '((integer) (integer-integer-pair))) + integer-point-pair-address (obj size 1 address t elem '(integer-point-pair)) + integer-point-pair-address-address (obj size 1 address t elem '(integer-point-pair-address)) + ; tagged-values are the foundation of dynamic types + tagged-value (obj size 2 and-record t elems '((type) (location)) fields '(type payload)) + tagged-value-address (obj size 1 address t elem '(tagged-value)) + tagged-value-array (obj array t elem '(tagged-value)) + tagged-value-array-address (obj size 1 address t elem '(tagged-value-array)) + tagged-value-array-address-address (obj size 1 address t elem '(tagged-value-array-address)) + ; heterogeneous lists + list (obj size 2 and-record t elems '((tagged-value) (list-address)) fields '(car cdr)) + list-address (obj size 1 address t elem '(list)) + list-address-address (obj size 1 address t elem '(list-address)) + ; parallel routines use channels to synchronize + channel (obj size 3 and-record t elems '((integer) (integer) (tagged-value-array-address)) fields '(first-full first-free circular-buffer)) + ; be careful of accidental copies to channels + channel-address (obj size 1 address t elem '(channel)) + ; opaque pointer to a call stack + ; todo: save properly in allocated memory + continuation (obj size 1) + ; editor + line (obj array t elem '(character)) + line-address (obj size 1 address t elem '(line)) + line-address-address (obj size 1 address t elem '(line-address)) + screen (obj array t elem '(line-address)) + screen-address (obj size 1 address t elem '(screen)) + ; fake screen + terminal (obj size 5 and-record t elems '((integer) (integer) (integer) (integer) (string-address)) fields '(num-rows num-cols cursor-row cursor-col data)) + terminal-address (obj size 1 address t elem '(terminal)) + ; fake keyboard + keyboard (obj size 2 and-record t elems '((integer) (string-address)) fields '(index data)) + keyboard-address (obj size 1 address t elem '(keyboard)) + ))) + +;; managing concurrent routines + +(on-init +;? (prn "-- resetting memory allocation") + (= Memory-allocated-until 1000) + (= Allocation-chunk 100000)) + +; routine = runtime state for a serial thread of execution +(def make-routine (fn-name . args) + (let curr-alloc Memory-allocated-until +;? (prn "-- allocating routine: @curr-alloc") + (++ Memory-allocated-until Allocation-chunk) + (annotate 'routine (obj alloc curr-alloc alloc-max Memory-allocated-until + call-stack + (list (obj fn-name fn-name pc 0 args args caller-arg-idx 0)))) + ; other fields we use in routine: + ; sleep: conditions + ; limit: number of cycles this routine can use + ; running-since: start of the clock for counting cycles this routine has used + + ; todo: do memory management in mu + )) + +(defextend empty (x) (isa x 'routine) + (no rep.x!call-stack)) + +(def stack (routine) + ((rep routine) 'call-stack)) + +(def 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 label.routine (msec)) ;? 1 + (pop rep.routine!call-stack)) + +(def top (routine) + stack.routine.0) + +(def label (routine) + (whenlet stack stack.routine + (or= stack.0!label + (label2 stack)))) +(def label2 (stack) + (string:intersperse "/" (map [_ 'fn-name] stack)));)) + +(def body (routine) + (function* stack.routine.0!fn-name)) + +(mac pc (routine (o idx 0)) ; assignable + `((((rep ,routine) 'call-stack) ,idx) 'pc)) + +(mac caller-arg-idx (routine (o idx 0)) ; assignable + `((((rep ,routine) 'call-stack) ,idx) 'caller-arg-idx)) + +(mac caller-args (routine) ; assignable + `((((rep ,routine) 'call-stack) 0) 'args)) +(mac caller-operands (routine) ; assignable + `((((rep ,routine) 'call-stack) 0) 'caller-operands)) +(mac caller-results (routine) ; assignable + `((((rep ,routine) 'call-stack) 0) 'caller-results)) + +(mac results (routine) ; assignable + `((((rep ,routine) 'call-stack) 0) 'results)) +(mac reply-args (routine) ; assignable + `((((rep ,routine) 'call-stack) 0) 'reply-args)) + +(def waiting-for-exact-cycle? (routine) + (is 'until rep.routine!sleep.0)) + +(def ready-to-wake-up (routine) + (assert no.routine*) + (case rep.routine!sleep.0 + until + (> curr-cycle* rep.routine!sleep.1) + until-location-changes + (~is rep.routine!sleep.2 (memory* rep.routine!sleep.1)) + until-routine-done + (find [and _ (is rep._!id rep.routine!sleep.1)] + completed-routines*) + )) + +(on-init + (= running-routines* (queue)) ; simple round-robin scheduler + ; set of sleeping routines; don't modify routines while they're in this table + (= sleeping-routines* (table)) + (= completed-routines* nil) ; audit trail + (= routine* nil) + (= abort-routine* (parameter nil)) + (= curr-cycle* 0) + (= scheduling-interval* 500) + (= scheduler-switch-table* nil) ; hook into scheduler for debugging + ) + +; like arc's 'point' but you can also call ((abort-routine*)) in nested calls +(mac routine-mark body + (w/uniq (g p) + `(ccc (fn (,g) + (parameterize abort-routine* (fn ((o ,p)) (,g ,p)) + ,@body))))) + +(def run fn-names + (freeze function*) +;? (prn function*!main) ;? 1 + (load-system-functions) + (apply run-more fn-names)) + +; assume we've already frozen; throw on a few more routines and continue scheduling +(def run-more fn-names + (each it fn-names + (enq make-routine.it running-routines*)) + (while (~empty running-routines*) + (= routine* deq.running-routines*) + (when rep.routine*!limit + ; start the clock if it wasn't already running + (or= rep.routine*!running-since curr-cycle*)) + (trace "schedule" label.routine*) + (routine-mark + (run-for-time-slice scheduling-interval*)) + (update-scheduler-state))) + +; prepare next iteration of round-robin scheduler +; +; state before: routine* running-routines* sleeping-routines* +; state after: running-routines* (with next routine to run at head) sleeping-routines* +; +; responsibilities: +; add routine* to either running-routines* or sleeping-routines* or completed-routines* +; wake up any necessary sleeping routines (which might be waiting for a +; 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 () + (when routine* +;? (prn "update scheduler state: " routine*) + (if + rep.routine*!sleep + (do (trace "schedule" "pushing " label.routine* " to sleep queue") + ; keep the clock ticking at rep.routine*!running-since + (set sleeping-routines*.routine*)) + rep.routine*!error + (do (trace "schedule" "done with dead routine " label.routine*) +;? (tr rep.routine*) + (push routine* completed-routines*)) + empty.routine* + (do (trace "schedule" "done with routine " label.routine*) + (push routine* completed-routines*)) + (no rep.routine*!limit) + (do (trace "schedule" "scheduling " label.routine* " for further processing") + (enq routine* running-routines*)) + (> rep.routine*!limit 0) + (do (trace "schedule" "scheduling " label.routine* " for further processing (limit)") + ; stop the clock and debit the time on it from the routine + (-- rep.routine*!limit (- curr-cycle* rep.routine*!running-since)) + (wipe rep.routine*!running-since) + (if (<= rep.routine*!limit 0) + (do (trace "schedule" "routine ran out of time") + (push routine* completed-routines*)) + (enq routine* running-routines*))) + :else + (err "illegal scheduler state")) + (= routine* nil)) + (each (routine _) routine-canon.sleeping-routines* + (when (aand rep.routine!limit (<= it (- curr-cycle* rep.routine!running-since))) + (trace "schedule" "routine timed out") + (wipe sleeping-routines*.routine) + (push routine completed-routines*) +;? (tr completed-routines*) + )) + (each (routine _) routine-canon.sleeping-routines* + (when (ready-to-wake-up routine) + (trace "schedule" "waking up " label.routine) + (wipe sleeping-routines*.routine) ; do this before modifying routine + (wipe rep.routine!sleep) + (++ pc.routine) + (enq routine running-routines*))) + ; optimization for simulated time + (when (empty running-routines*) + (whenlet exact-sleeping-routines (keep waiting-for-exact-cycle? keys.sleeping-routines*) + (let next-wakeup-cycle (apply min (map [rep._!sleep 1] exact-sleeping-routines)) + (= curr-cycle* (+ 1 next-wakeup-cycle))) + (trace "schedule" "skipping to cycle " curr-cycle*) + (update-scheduler-state))) + (when (and (or (~empty running-routines*) + (~empty sleeping-routines*)) + (all [rep._ 'helper] (as cons running-routines*)) + (all [rep._ 'helper] keys.sleeping-routines*)) + (trace "schedule" "just helpers left; stopping everything") + (until (empty running-routines*) + (push (deq running-routines*) completed-routines*)) + (each (routine _) sleeping-routines* +;? (prn " " label.routine) ;? 0 + (wipe sleeping-routines*.routine) + (push routine completed-routines*))) + (detect-deadlock) + ) + +(def detect-deadlock () + (when (and (empty running-routines*) + (~empty sleeping-routines*) + (~some 'literal (map (fn(_) rep._!sleep.1) + keys.sleeping-routines*))) + (each (routine _) sleeping-routines* + (wipe sleeping-routines*.routine) + (= rep.routine!error "deadlock detected") + (push routine completed-routines*)))) + +(def die (msg) + (tr "die: " msg) + (= rep.routine*!error msg) + (iflet abort-continuation (abort-routine*) + (abort-continuation))) + +;; running a single routine + +; value of an arg or oarg, stripping away all metadata +; wish I could have this flag an error when arg is incorrectly formed +(mac v (operand) ; for value + `((,operand 0) 0)) + +; routines consist of instrs +; instrs consist of oargs, op and args +(def 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*?")) + (list (cut instr 0 delim) ; oargs + (v (instr (+ delim 1))) ; op + (cut instr (+ delim 2)))) ; args + (list nil (v car.instr) cdr.instr))) + +(def metadata (operand) + cdr.operand) + +(def ty (operand) + (cdr operand.0)) + +(def literal? (operand) + (unless (acons ty.operand) + (err "no type in operand @operand")) + (in ty.operand.0 'literal 'offset 'fn)) + +(def typeinfo (operand) + (or (type* ty.operand.0) + (err "unknown type @(tostring prn.operand)"))) + +; operand accessors +(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 +(def not-raw-string (operand) + (~isa operand 'string)) + +(def address? (operand) + (or (is ty.operand.0 'location) + typeinfo.operand!address)) + +($:require "charterm/main.rkt") +($:require graphics/graphics) +;? ($:require "terminal-color/terminal-color/main.rkt") ;? 1 +(= Viewport nil) +; http://rosettacode.org/wiki/Terminal_control/Coloured_text#Racket +($:define (tput . xs) (system (apply ~a 'tput " " (add-between xs " "))) (void)) +($:define (foreground color) (tput 'setaf color)) +($:define (background color) (tput 'setab color)) +($:define (reset) (tput 'sgr0)) + +(= new-string-foo* nil) +(= last-print* 0) + +; run instructions from 'routine*' for '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")) + ; falling out of end of function = implicit reply + (while (>= pc.routine* (len body.routine*)) + (pop-stack routine*) + (if empty.routine* (return ninstrs)) + (when (pos '<- (body.routine* pc.routine*)) + (die "No results returned: @(tostring:pr (body.routine* pc.routine*))")) + (++ pc.routine*)) + (++ curr-cycle*) + (when (no ($.current-charterm)) + (let curr (seconds) + (when (~is curr last-print*) + (prn curr " " curr-cycle* " " len.running-routines*) + (= last-print* curr)))) +;? (trace "run" "-- " int-canon.memory*) ;? 1 +;? (trace "run" curr-cycle*) + (trace "run" label.routine* " " pc.routine* ": " (body.routine* pc.routine*)) +;? (trace "run" routine*) + (when (atom (body.routine* pc.routine*)) ; label +;? (tr "label") ;? 1 + (when (aand scheduler-switch-table* + (alref it (body.routine* pc.routine*))) + (++ pc.routine*) + (trace "run" label.routine* " " pc.routine* ": " "context-switch forced " abort-routine*) + ((abort-routine*))) + (++ pc.routine*) + (continue)) + (let (oarg op arg) (parse-instr (body.routine* pc.routine*)) +;? (tr op) ;? 1 + (let results + (case op + ; arithmetic + add + (+ (m arg.0) (m arg.1)) + subtract + (- (m arg.0) (m arg.1)) + multiply + (* (m arg.0) (m arg.1)) + divide + (/ (real (m arg.0)) (m arg.1)) + divide-with-remainder + (list (trunc:/ (m arg.0) (m arg.1)) + (mod (m arg.0) (m arg.1))) + + ; boolean + and + (and (m arg.0) (m arg.1)) + or + (or (m arg.0) (m arg.1)) + not + (not (m arg.0)) + + ; comparison + equal +;? (do (prn (m arg.0) " vs " (m arg.1)) + (is (m arg.0) (m arg.1)) +;? ) + not-equal + (~is (m arg.0) (m arg.1)) + less-than + (< (m arg.0) (m arg.1)) + greater-than + (> (m arg.0) (m arg.1)) + lesser-or-equal + (<= (m arg.0) (m arg.1)) + greater-or-equal + (>= (m arg.0) (m arg.1)) + + ; control flow + jump + (do (= pc.routine* (+ 1 pc.routine* (v arg.0))) + (continue)) + jump-if + (when (m arg.0) + (= pc.routine* (+ 1 pc.routine* (v arg.1))) + (continue)) + jump-unless ; convenient helper + (unless (m arg.0) + (= pc.routine* (+ 1 pc.routine* (v arg.1))) + (continue)) + + ; data management: scalars, arrays, and-records (structs) + copy + (m arg.0) + get + (with (operand (canonize arg.0) + idx (v arg.1)) + (assert (iso '(offset) (ty arg.1)) "record index @arg.1 must have type 'offset'") + (assert (< -1 idx (len typeinfo.operand!elems)) "@idx is out of bounds of record @operand") + (m `((,(apply + v.operand + (map (fn(x) (sizeof `((_ ,@x)))) + (firstn idx typeinfo.operand!elems))) + ,@typeinfo.operand!elems.idx) + (raw)))) + get-address + (with (operand (canonize arg.0) + idx (v arg.1)) + (assert (iso '(offset) (ty arg.1)) "record index @arg.1 must have type 'offset'") + (assert (< -1 idx (len typeinfo.operand!elems)) "@idx is out of bounds of record @operand") + (apply + v.operand + (map (fn(x) (sizeof `((_ ,@x)))) + (firstn idx typeinfo.operand!elems)))) + index + (withs (operand (canonize arg.0) + elemtype typeinfo.operand!elem + idx (m arg.1)) +;? (write arg.0) +;? (pr " => ") +;? (write operand) +;? (prn) + (unless (< -1 idx array-len.operand) + (die "@idx is out of bounds of array @operand")) + (m `((,(+ v.operand + 1 ; for array size + (* idx (sizeof `((_ ,@elemtype))))) + ,@elemtype) + (raw)))) + index-address + (withs (operand (canonize arg.0) + elemtype typeinfo.operand!elem + idx (m arg.1)) + (unless (< -1 idx array-len.operand) + (die "@idx is out of bounds of array @operand")) + (+ v.operand + 1 ; for array size + (* idx (sizeof `((_ ,@elemtype)))))) + new + (if (isa arg.0 'string) + ; special-case: allocate space for a literal string + (new-string arg.0) + (let type (v arg.0) + (assert (iso '(literal) (ty arg.0)) "new: second arg @arg.0 must be literal") + (if (no type*.type) (err "no such type @type")) + ; todo: initialize memory. currently racket does it for us + (if type*.type!array + (new-array type (m arg.1)) + (new-scalar type)))) + sizeof + (sizeof `((_ ,(m arg.0)))) + length + (let base arg.0 + (if (or typeinfo.base!array address?.base) + array-len.base + -1)) + + ; tagged-values require one primitive + save-type + (annotate 'record `(,((ty arg.0) 0) ,(m arg.0))) + + ; code points for characters + character-to-integer + ($.char->integer (m arg.0)) + integer-to-character + ($.integer->char (m arg.0)) + + ; multiprocessing + fork + ; args: fn globals-table args ... + (let routine (apply make-routine (m arg.0) (map m (nthcdr 3 arg))) + (= rep.routine!id ++.next-routine-id*) + (= rep.routine!globals (when (len> arg 1) (m arg.1))) + (= rep.routine!limit (when (len> arg 2) (m arg.2))) + (enq routine running-routines*) + rep.routine!id) + fork-helper + ; args: fn globals-table args ... + (let routine (apply make-routine (m arg.0) (map m (nthcdr 3 arg))) + (= rep.routine!id ++.next-routine-id*) + (set rep.routine!helper) + (= rep.routine!globals (when (len> arg 1) (m arg.1))) + (= rep.routine!limit (when (len> arg 2) (m arg.2))) + (enq routine running-routines*) + rep.routine!id) + sleep + (do + (case (v arg.0) + for-some-cycles + (let wakeup-time (+ curr-cycle* (v arg.1)) + (trace "run" label.routine* " " pc.routine* ": " "sleeping until " wakeup-time) + (= rep.routine*!sleep `(until ,wakeup-time))) + until-location-changes + (= rep.routine*!sleep `(until-location-changes ,(addr arg.1) ,(m arg.1))) + until-routine-done + (= rep.routine*!sleep `(until-routine-done ,(m arg.1))) + ; else + (die "badly formed 'sleep' call @(tostring:prn (body.routine* pc.routine*))") + ) + ((abort-routine*))) + assert + (unless (m arg.0) + (die (v arg.1))) ; other routines will be able to look at the error status + assert-false + (when (m arg.0) + (die (v arg.1))) + + ; cursor-based (text mode) interaction + cursor-mode + ;(do1 nil (system "/bin/stty -F /dev/tty raw")) + (do1 nil (if (no ($.current-charterm)) ($.open-charterm))) + retro-mode + ;(do1 nil (system "/bin/stty -F /dev/tty sane")) + (do1 nil (if ($.current-charterm) ($.close-charterm))) + clear-host-screen + (do1 nil (pr "\e[m\e[2J\e[;H")) + clear-line-on-host + (do1 nil (pr "\e[2K")) + cursor-on-host + (do1 nil (pr (+ "\e[" (m arg.0) ";" (m arg.1) "H"))) + cursor-on-host-to-next-line + (do1 nil (pr "\r\n")) + cursor-up-on-host + (do1 nil (pr (+ "\e[" (aif (len> arg 0) (or m arg.0) 1) "A"))) + cursor-down-on-host + (do1 nil (pr (+ "\e[" (aif (len> arg 0) (or m arg.0) 1) "B"))) + cursor-right-on-host + (do1 nil (pr (+ "\e[" (aif (len> arg 0) (or m arg.0) 1) "C"))) + cursor-left-on-host + (do1 nil (pr (+ "\e[" (aif (len> arg 0) (or m arg.0) 1) "D"))) + print-character-to-host + (do1 nil + (assert (in (type:m arg.0) 'char 'sym) (rep (m arg.0))) +;? (write (m arg.0)) (pr " => ") (prn (type (m arg.0))) + (if (no ($.current-charterm)) + (pr (m arg.0)) + (caselet x (m arg.0) + ; todo: test these exceptions + #\newline + (pr "\r\n") + #\backspace + ; backspace doesn't clear after moving the cursor + (pr "\b \b") + ctrl-c + (do ($.close-charterm) + (die "interrupted")) + ;else + (if (and (len> arg 2) + (m arg.2)) + (do + ($.foreground (m arg.1)) + ($.background (m arg.2)) + (pr x) + ($.reset)) + (and (len> arg 1) + (m arg.1)) + (do + ($.foreground (m arg.1)) + (pr x) + ($.reset)) + :else + (pr x)))) + ) + read-key-from-host + (if ($.current-charterm) + (and ($.charterm-byte-ready?) + (ret result ($.charterm-read-key) + (case result + ; charterm exceptions + return + (= result #\newline) + backspace + (= result #\backspace) + ))) + ($.graphics-open?) + ($.ready-key-press Viewport)) + + ; graphics + window-on + (do1 nil + ($.open-graphics) + (= Viewport ($.open-viewport (m arg.0) ; name + (m arg.1) (m arg.2)))) ; width height + window-off + (do1 nil + ($.close-viewport Viewport) ; why doesn't this close the window? works in naked racket. not racket vs arc. + ($.close-graphics) + (= Viewport nil)) + mouse-position + (aif ($.ready-mouse-click Viewport) + (let posn ($.mouse-click-posn it) + (list (annotate 'record (list ($.posn-x posn) ($.posn-y posn))) t)) + (list nil nil)) + wait-for-mouse + (let posn ($.mouse-click-posn ($.get-mouse-click Viewport)) + (list (annotate 'record (list ($.posn-x posn) ($.posn-y posn))) t)) + ; clear-screen in cursor mode above + rectangle + (do1 nil + (($.draw-solid-rectangle Viewport) + ($.make-posn (m arg.0) (m arg.1)) ; origin + (m arg.2) (m arg.3) ; width height + (m arg.4))) ; color + point + (do1 nil + (($.draw-pixel Viewport) ($.make-posn (m arg.0) (m arg.1)) + (m arg.2))) ; color + + image + (do1 nil + (($.draw-pixmap Viewport) (m arg.0) ; filename + ($.make-posn (m arg.1) (m arg.2)))) + color-at + (let pixel (($.get-color-pixel Viewport) ($.make-posn (m arg.0) (m arg.1))) + (prn ($.rgb-red pixel) " " ($.rgb-blue pixel) " " ($.rgb-green pixel)) + ($:rgb-red pixel)) + + ; debugging aides + $dump-memory + (do1 nil + (prn:repr int-canon.memory*)) + $dump-trace + (tofile arg.0 + (each (label trace) (as cons traces*) + (pr label ": " trace))) + $start-tracing + (do1 nil + (set dump-trace*)) + $stop-tracing + (do1 nil + (wipe dump-trace*)) + $dump-routine + (do1 nil + ($.close-charterm) + (prn routine*) + ($.open-charterm) + ) + $dump-channel + (do1 nil + ($.close-charterm) + (withs (x (m arg.0) + y (memory* (+ x 2))) + (prn label.routine* " -- " x " -- " (list (memory* x) + (memory* (+ x 1)) + (memory* (+ x 2))) + " -- " (list (memory* y) + (memory* (+ y 1)) + (repr:memory* (+ y 2)) + (memory* (+ y 3)) + (repr:memory* (+ y 4))))) + ($.open-charterm) + ) + $quit + (quit) + $wait-for-key-from-host + (when ($.current-charterm) + (ret result ($.charterm-read-key) + (case result + ; charterm exceptions + return + (= result #\newline) + backspace + (= result #\backspace) + ))) + $print + (do1 nil +;? (write (m arg.0)) (pr " => ") (prn (type (m arg.0))) + (if (no ($.current-charterm)) + (pr (m arg.0)) + (unless disable-debug-prints-in-console-mode* + (caselet x (m arg.0) + #\newline + (pr "\r\n") + #\backspace + ; backspace doesn't clear after moving the cursor + (pr "\b \b") + ctrl-c + (do ($.close-charterm) + (die "interrupted")) + ;else + (pr x))) + )) + $write + (do1 nil + (write (m arg.0))) + $eval + (new-string:repr:eval:read:to-arc-string (m arg.0)) +;? (let x (to-arc-string (m arg.0)) ;? 1 +;? (prn x) ;? 1 +;? (new-string:repr:eval x)) ;? 1 + + $clear-trace + (do1 nil (wipe interactive-traces*)) + $save-trace + (let x (filter-log "CCC: " len + (string + (filter-log "BBB: " len + (map [string:intersperse ": " _] + (filter-log "AAA: " len + (as cons (interactive-traces* (m arg.0))))) + ))) +;? (let x (string:map [string:intersperse ": " _] +;? (apply join +;? (map [as cons _] rev.interactive-traces*))) + (prn "computed trace; now saving to memory\n") +;? (write x)(write #\newline) ;? 1 +;? (prn x) ;? 1 + (set new-string-foo*) + (do1 (new-string x) + (wipe new-string-foo*))) + + ; first-class continuations + current-continuation + (w/uniq continuation-name + (trace "continuation" "saving @(repr rep.routine*!call-stack) to @continuation-name") + (= continuation*.continuation-name (copy rep.routine*!call-stack)) + continuation-name) + continue-from + (let continuation-name (m arg.0) + (trace "continuation" "restoring @continuation-name") + (trace "continuation" continuation*.continuation-name) + (= rep.routine*!call-stack continuation*.continuation-name) + (trace "continuation" "call stack is now @(repr rep.routine*!call-stack)") +;? (++ pc.routine*) ;? 1 + (continue)) +;? ((abort-routine*))) ;? 1 + + ; user-defined functions + next-input + (let idx caller-arg-idx.routine* + (++ caller-arg-idx.routine*) + (trace "arg" repr.arg " " idx " " (repr caller-args.routine*)) + (if (len> caller-args.routine* idx) + (list caller-args.routine*.idx t) + (list nil nil))) + input + (do (assert (iso '(literal) (ty arg.0))) + (= caller-arg-idx.routine* (v arg.0)) + (let idx caller-arg-idx.routine* + (++ caller-arg-idx.routine*) + (trace "arg" repr.arg " " idx " " (repr caller-args.routine*)) + (if (len> caller-args.routine* idx) + (list caller-args.routine*.idx t) + (list nil nil)))) + rewind-inputs + (do1 nil + (= caller-arg-idx.routine* 0)) + ; type and otype won't always easily compile. be careful. + type + (ty (caller-operands.routine* (v arg.0))) + otype + (ty (caller-results.routine* (v arg.0))) + prepare-reply + (prepare-reply arg) + reply + (do (when arg + (prepare-reply arg)) + (with (results results.routine* + reply-args reply-args.routine*) + (pop-stack routine*) + (if empty.routine* (return ninstrs)) + (let (call-oargs _ call-args) (parse-instr (body.routine* pc.routine*)) +;? (trace "reply" repr.arg " " repr.call-oargs) ;? 1 + (each (dest reply-arg val) (zip call-oargs reply-args results) + (trace "run" label.routine* " " pc.routine* ": " repr.val " => " dest) + (when nondummy.dest + (whenlet argidx (alref metadata.reply-arg 'same-as-arg) + (unless (is v.dest (v call-args.argidx)) + (die "'same-as-arg' output arg in @repr.reply-args can't bind to @repr.call-oargs"))) + (setm dest val)))) + (++ pc.routine*) + (while (>= pc.routine* (len body.routine*)) + (pop-stack routine*) + (when empty.routine* (return ninstrs)) + (++ pc.routine*)) + (continue))) + ; else try to call as a user-defined function + (do (if function*.op + (with (callee-args (accum yield + (each a arg + (yield (m a)))) + callee-operands (accum yield + (each a arg + (yield a))) + callee-results (accum yield + (each a oarg + (yield a)))) + (push-stack routine* op) + (= caller-args.routine* callee-args) + (= caller-operands.routine* callee-operands) + (= caller-results.routine* callee-results)) + (err "no such op @op")) + (continue)) + ) + ; opcode generated some 'results' + ; copy to output args + (if (acons results) + (each (dest val) (zip oarg results) + (unless (is dest '_) + (trace "run" label.routine* " " pc.routine* ": " repr.val " => " dest) + (setm dest val))) + (when oarg ; must be a list + (trace "run" label.routine* " " pc.routine* ": " repr.results " => " oarg.0) + (setm oarg.0 results))) + ) + (++ pc.routine*))) + (return time-slice))) + +(def prepare-reply (args) + (= results.routine* + (accum yield + (each a args + (yield (m a))))) + (= reply-args.routine* args)) + +; helpers for memory access respecting +; immediate addressing - 'literal' and 'offset' +; direct addressing - default +; indirect addressing - 'deref' +; relative addressing - if routine* has 'default-space' + +(def m (loc) ; read memory, respecting metadata + (point return + (when (literal? loc) + (return v.loc)) + (when (is v.loc 'default-space) + (return rep.routine*!call-stack.0!default-space)) +;? (trace "mem" loc) ;? 1 + (assert (isa v.loc 'int) "addresses must be numeric (problem in convert-names?): @repr.loc") + (ret result + (with (n sizeof.loc + addr addr.loc) +;? (trace "mem" "reading " n " locations starting at " addr) ;? 1 + (if (is 1 n) + memory*.addr + :else + (annotate 'record + (map memory* (addrs addr n))))) + (trace "mem" loc " => " result)))) + +(def setm (loc val) ; set memory, respecting metadata +;? (tr 111) + (point return +;? (tr 112) + (when (is v.loc 'default-space) + (assert (is 1 sizeof.loc) "can't store compounds in default-space @loc") + (= rep.routine*!call-stack.0!default-space val) + (return)) +;? (tr 120) + (assert (isa v.loc 'int) "can't store to non-numeric address (problem in convert-names?)") +;? (trace "mem" loc " <= " repr.val) ;? 1 + (with (n (if (isa val 'record) (len rep.val) 1) + addr addr.loc + typ typeof.loc) +;? (trace "mem" "size of " loc " is " n) ;? 1 + (assert n "setm: can't compute type of @loc") + (assert addr "setm: null pointer @loc") + (if (is 1 n) + (do (assert (~isa val 'record) "setm: record of size 1 @(tostring prn.val)") + (trace "mem" loc ": " addr " <= " repr.val) + (= memory*.addr val)) + (do (if type*.typ!array + ; size check for arrays + (when (~is n + (+ 1 ; array length + (* rep.val.0 (sizeof `((_ ,@type*.typ!elem)))))) + (die "writing invalid array @(tostring prn.val)")) + ; size check for non-arrays + (when (~is sizeof.loc n) + (die "writing to incorrect size @(tostring pr.val) => @loc"))) + (let addrs (addrs addr n) + (each (dest src) (zip addrs rep.val) + (trace "mem" loc ": " dest " <= " repr.src) + (= memory*.dest src)))))))) + +(def typeof (operand) + (let loc absolutize.operand + (while (pos '(deref) metadata.loc) + (zap deref loc)) + ty.loc.0)) + +(def addr (operand) + (v canonize.operand)) + +(def addrs (n sz) + (accum yield + (repeat sz + (yield n) + (++ n)))) + +(def canonize (operand) +;? (tr "0: @operand") + (ret operand +;? (prn "1: " operand) +;? (tr "1: " operand) ; todo: why does this die? + (zap absolutize operand) +;? (tr "2: @repr.operand") + (while (pos '(deref) metadata.operand) + (zap deref operand) +;? (tr "3: @repr.operand") + ))) + +(def array-len (operand) + (trace "array-len" operand) + (zap canonize operand) + (if typeinfo.operand!array + (m `((,v.operand integer) ,@metadata.operand)) + :else + (err "can't take len of non-array @operand"))) + +(def sizeof (x) +;? (trace "sizeof" x) ;? 1 + (assert acons.x) + (zap canonize x) + (point return +;? (tr "sizeof: checking @x for array") + (when typeinfo.x!array +;? (tr "sizeof: @x is an array") + (assert (~is '_ v.x) "sizeof: arrays require a specific variable") + (return (+ 1 (* array-len.x (sizeof `((_ ,@typeinfo.x!elem))))))) +;? (tr "sizeof: not an array") + (when typeinfo.x!and-record +;? (tr "sizeof: @x is an and-record") + (return (sum idfn + (accum yield + (each elem typeinfo.x!elems + (yield (sizeof `((_ ,@elem))))))))) +;? (tr "sizeof: @x is a primitive") + (return typeinfo.x!size))) + +(def absolutize (operand) + (if (no routine*) + operand + (in v.operand '_ 'default-space) + operand + (pos '(raw) metadata.operand) + operand + (is 'global space.operand) + (aif rep.routine*!globals + `((,(+ it 1 v.operand) ,@(cdr operand.0)) + ,@(rem [caris _ 'space] metadata.operand) + (raw)) + (die "routine has no globals: @operand")) + :else + (iflet base rep.routine*!call-stack.0!default-space + (space-base (rem [caris _ 'space] operand) + base + space.operand) + operand))) + +(def space-base (operand base space) +;? (prn operand " " base) ;? 1 + (if (is 0 space) + ; base case + (if (< v.operand memory*.base) + `((,(+ base 1 v.operand) ,@(cdr operand.0)) + ,@metadata.operand + (raw)) + (die "no room for var @operand in routine of size @memory*.base")) + ; recursive case + (space-base operand (memory* (+ base 1)) ; location 0 points to next space + (- space 1)))) + +(def space (operand) + (or (alref metadata.operand 'space) + 0)) + +(def 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) + (when acons.x ; proper lists only + (if (testify.f car.x) + cdr.x + (cons car.x (drop-one f cdr.x))))) + +; memory allocation + +(def alloc (sz) + (when (> sz (- rep.routine*!alloc-max rep.routine*!alloc)) + (let curr-alloc Memory-allocated-until + (= rep.routine*!alloc curr-alloc) + (++ Memory-allocated-until Allocation-chunk) + (= rep.routine*!alloc-max Memory-allocated-until))) + (ret result rep.routine*!alloc + (++ rep.routine*!alloc sz))) + +(def new-scalar (type) +;? (tr "new scalar: @type") + (alloc (sizeof `((_ ,type))))) + +(def 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) +;? (tr "new string: @literal-string") + (ret result (alloc (+ 1 len.literal-string)) + (= memory*.result len.literal-string) + (on c literal-string + (when (and new-string-foo* (is 0 (mod index 100))) + (prn index " " repr.c)) + (= (memory* (+ result 1 index)) c)))) + +(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 + +(def convert-braces (instrs) +;? (prn "convert-braces " instrs) + (let locs () ; list of information on each brace: (open/close pc) + (let pc 0 + (loop (instrs instrs) + (each instr instrs +;? (tr instr) + (if (or atom.instr (~is 'begin instr.0)) ; label or regular instruction + (do + (trace "c{0" pc " " instr " -- " locs) + (++ pc)) + ; hack: racket replaces braces with parens, so we need the + ; keyword 'begin' to delimit blocks. + ; ultimately there'll be no nesting and braces will just be + ; in an instr by themselves. + :else ; brace + (do + (push `(open ,pc) locs) + (recur cdr.instr) + (push `(close ,pc) locs)))))) + (zap rev locs) +;? (tr "-") + (with (pc 0 + stack ()) ; elems are pcs + (accum yield + (loop (instrs instrs) + (each instr instrs +;? (tr "- " instr) + (point continue + (when (atom instr) ; label + (yield instr) + (++ pc) + (continue)) + (when (is car.instr 'begin) + (push pc stack) + (recur cdr.instr) + (pop stack) + (continue)) + (with ((oarg op arg) (parse-instr instr) + yield-new-instr (fn (new-instr) + (trace "c{1" "@pc X " instr " => " new-instr) + (yield new-instr)) + yield-unchanged (fn () + (trace "c{1" "@pc ✓ " instr) + (yield instr))) + (when (in op 'break 'break-if 'break-unless 'loop 'loop-if 'loop-unless) + (assert (is oarg nil) "@op: can't take oarg in @instr")) + (case op + break + (yield-new-instr `(((jump)) ((,(close-offset pc locs (and arg (v arg.0))) offset)))) + break-if + (yield-new-instr `(((jump-if)) ,arg.0 ((,(close-offset pc locs (and cdr.arg (v arg.1))) offset)))) + break-unless + (yield-new-instr `(((jump-unless)) ,arg.0 ((,(close-offset pc locs (and cdr.arg (v arg.1))) offset)))) + loop + (yield-new-instr `(((jump)) ((,(open-offset pc stack (and arg (v arg.0))) offset)))) + loop-if + (yield-new-instr `(((jump-if)) ,arg.0 ((,(open-offset pc stack (and cdr.arg (v arg.1))) offset)))) + loop-unless + (yield-new-instr `(((jump-unless)) ,arg.0 ((,(open-offset pc stack (and cdr.arg (v arg.1))) offset)))) + ;else + (yield-unchanged))) + (++ pc)))))))) + +(def close-offset (pc locs nblocks) + (or= nblocks 1) +;? (tr nblocks) + (point return +;? (tr "close " pc " " locs) + (let stacksize 0 + (each (state loc) locs + (point continue +;? (tr stacksize "/" done " " state " " loc) + (when (<= loc pc) + (continue)) +;? (tr "process " stacksize loc) + (if (is 'open state) (++ stacksize) (-- stacksize)) + ; last time +;? (tr "process2 " stacksize loc) + (when (is stacksize (* -1 nblocks)) +;? (tr "close now " loc) + (return (- loc pc 1)))))))) + +(def open-offset (pc stack nblocks) + (or= nblocks 1) + (- (stack (- nblocks 1)) 1 pc)) + +;; convert jump targets to offsets + +(def convert-labels (instrs) +;? (tr "convert-labels " instrs) + (let labels (table) + (let pc 0 + (each instr instrs + (when (~acons instr) +;? (tr "label " pc) + (= labels.instr pc)) + (++ pc))) + (let pc 0 + (each instr instrs + (when (and acons.instr + (acons car.instr) + (in (v car.instr) 'jump 'jump-if 'jump-unless)) + (each arg cdr.instr +;? (tr "trying " arg " " ty.arg ": " v.arg " => " (labels v.arg)) + (when (and (is ty.arg.0 'offset) + (isa v.arg 'sym) + (labels v.arg)) + (= v.arg (- (labels v.arg) pc 1))))) + (++ pc)))) + instrs) + +;; convert symbolic names to raw memory locations + +(def add-next-space-generator (instrs name) +;? (prn "== @name") + (each instr instrs + (when acons.instr + (let (oargs op args) (parse-instr instr) + (each oarg oargs + (when (and (nondummy oarg) + (is v.oarg 0) + (iso ty.oarg '(space-address))) + (assert (or (no next-space-generator*.name) + (is next-space-generator*.name (alref oarg 'names))) + "function can have only one next-space-generator environment") + (tr "next-space-generator of @name is @(alref oarg 'names)") + (= next-space-generator*.name (alref oarg 'names)))))))) + +; just a helper for testing; in practice we unbundle assign-names-to-location +; and replace-names-with-location. +(def convert-names (instrs (o name)) +;? (tr "convert-names " instrs) + (= location*.name (assign-names-to-location instrs name)) +;? (tr "save names for function @name: @(tostring:pr location*.name)") ;? 1 + (replace-names-with-location instrs name)) + +(def assign-names-to-location (instrs name (o init-locations)) + (trace "cn0" "convert-names in @name") +;? (prn name ": " location*) ;? 1 + (point return + (ret location (or init-locations (table)) + ; if default-space in first instruction has a name, begin with its bindings + (when (acons instrs.0) ; not a label + (let first-oarg-of-first-instr instrs.0.0 ; hack: assumes the standard default-space boilerplate + (when (and (nondummy first-oarg-of-first-instr) + (is 'default-space (v first-oarg-of-first-instr)) + (assoc 'names metadata.first-oarg-of-first-instr)) + (let old-names (location*:alref metadata.first-oarg-of-first-instr 'names) + (unless old-names +;? (prn "@name requires bindings for @(alref metadata.first-oarg-of-first-instr 'names) which aren't computed yet. Waiting.") ;? 1 + (return nil)) + (= location copy.old-names))))) ; assumption: we've already converted names for 'it' +;? (unless empty.location (prn location)) ;? 2 + (with (isa-field (table) + idx (+ 1 ; 0 always reserved for next space + (or (apply max vals.location) ; skip past bindings already shared from elsewhere + 0)) + already-location (copy location) + ) + (each instr instrs + (point continue + (when atom.instr + (continue)) + (trace "cn0" instr " " canon.location " " canon.isa-field) + (let (oargs op args) (parse-instr instr) +;? (tr "about to rename args: @op") + (when (in op 'get 'get-address) + ; special case: map field offset by looking up type table + (with (basetype (typeof args.0) + field (v args.1)) +;? (tr 111 " " args.0 " " basetype) + (assert type*.basetype!and-record "get on non-record @args.0") +;? (tr 112) + (trace "cn0" "field-access @field in @args.0 of type @basetype") + (when (isa field 'sym) + (unless (already-location field) + (assert (or (~location field) isa-field.field) "field @args.1 is also a variable")) + (when (~location field) + (trace "cn0" "new field; computing location") +;? (tr "aa " type*.basetype) + (assert type*.basetype!fields "no field names available for @instr") +;? (tr "bb") + (iflet idx (pos field type*.basetype!fields) + (do (set isa-field.field) + (trace "cn0" "field location @idx") + (= location.field idx)) + (assert nil "couldn't find field in @instr")))))) + ; map args to location indices + (each arg args + (trace "cn0" "checking arg " arg) + (when (and nondummy.arg not-raw-string.arg (~literal? arg)) + (assert (~isa-field v.arg) "arg @arg is also a field name") + (when (maybe-add arg location idx) + ; todo: test this + (err "use before set: @arg")))) +;? (tr "about to rename oargs") + ; map oargs to location indices + (each arg oargs + (trace "cn0" "checking oarg " arg) + (when (and nondummy.arg not-raw-string.arg) + (assert (~isa-field v.arg) "oarg @arg is also a field name") + (when (maybe-add arg location idx) + (trace "cn0" "location for oarg " arg ": " idx) + ; todo: can't allocate arrays on the stack + (++ idx (sizeof `((_ ,@ty.arg)))))))))))))) + +(def replace-names-with-location (instrs name) + (each instr instrs + (when (acons instr) + (let (oargs op args) (parse-instr instr) + (each arg args + (convert-name arg name)) + (each arg oargs + (convert-name arg name))))) + (each instr instrs + (trace "cn1" instr)) + instrs) + +(= allow-raw-addresses* nil) +(def check-default-space (instrs name) + (unless allow-raw-addresses* + (let oarg-names (accum yield + (each (oargs _ _) (map parse-instr (keep acons ; non-label + instrs)) + (each oarg oargs + (when nondummy.oarg + (yield v.oarg))))) + (when (~pos 'default-space oarg-names) + (prn "function @name has no default-space"))))) + +; assign an index to an arg +(def maybe-add (arg location idx) + (trace "maybe-add" arg) + (when (and nondummy.arg +;? (prn arg " " (assoc 'space arg)) + (~assoc 'space arg) + (~literal? arg) + (~location v.arg) + (isa v.arg 'sym) + (~in v.arg 'nil 'default-space) + (~pos '(raw) metadata.arg)) + (= (location v.arg) idx))) + +; convert the arg to corresponding index +(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 +;? (prn "112 @arg") + (let name (space-to-name arg default-name) +;? (prn "113 @arg @name @keys.location* @(tostring:pr location*.name)") +;? (when (is arg '((y integer) (space 1))) +;? (prn "@arg => @name")) + (when (aand location*.name (it v.arg)) +;? (prn 114) + (zap location*.name v.arg)) +;? (prn 115) + ))) + +(def space-to-name (arg default-name) + (ret name default-name + (when (~is space.arg 'global) + (repeat space.arg + (zap next-space-generator* name))))) + +(proc check-numeric-address (instrs name) + (unless allow-raw-addresses* + (on instr instrs + (when acons.instr ; not a label + (let (oargs op args) (parse-instr instr) + (each arg oargs + (when (and acons.arg ; not dummy _ or raw string + (isa v.arg 'int) + (~is v.arg 0) + (~pos '(raw) metadata.arg) + (~literal? arg)) + (prn "using a raw integer address @repr.arg in @name (instruction #@index)"))) + (each arg args + (when (and acons.arg ; not dummy _ or raw string + (isa v.arg 'int) + (~is v.arg 0) + (~pos '(raw) metadata.arg) + (~literal? arg)) + (prn "using a raw integer address @repr.arg in @name (instruction #@index)")))))))) + +;; literate tangling system for reordering code + +(def convert-quotes (instrs) + (let deferred (queue) + (each instr instrs + (when (acons instr) + (case instr.0 + defer + (let (q qinstrs) instr.1 + (assert (is 'make-br-fn q) "defer: first arg must be [quoted]") + (each qinstr qinstrs + (enq qinstr deferred)))))) + (accum yield + (each instr instrs + (if atom.instr ; label + (yield instr) + (is instr.0 'defer) + nil ; skip + (is instr.0 'reply) + (do + (when cdr.instr ; return values + (= instr.0 'prepare-reply) + (yield instr)) + (each instr (as cons deferred) + (yield instr)) + (yield '(reply))) + :else + (yield instr))) + (each instr (as cons deferred) + (yield instr))))) + +(on-init + (= before* (table)) ; label -> queue of fragments + (= after* (table))) ; label -> list of fragments + +; see add-code below for adding to before* and after* + +(def insert-code (instrs (o name)) +;? (tr "insert-code " instrs) + (loop (instrs instrs) + (accum yield + (each instr instrs + (if (and (acons instr) (~is 'begin car.instr)) + ; simple instruction + (yield instr) + (and (acons instr) (is 'begin car.instr)) + ; block + (yield `{begin ,@(recur cdr.instr)}) + (atom instr) + ; label + (do +;? (prn "tangling " instr) + (each fragment (as cons (or (and name (before* (sym:string name '/ instr))) + before*.instr)) + (each instr fragment + (yield instr))) + (yield instr) + (each fragment (or (and name (after* (sym:string name '/ instr))) + after*.instr) + (each instr fragment + (yield instr))))))))) + +;; loading code into the virtual machine + +(def add-code (forms) + (each (op . rest) forms + (case op + ; function [ ] + ; don't apply our lightweight tools just yet + function! + (let (name (_make-br-fn body)) rest + (assert (is 'make-br-fn _make-br-fn)) + (= name (v tokenize-arg.name)) + (= function*.name body)) + function + (let (name (_make-br-fn body)) rest + (assert (is 'make-br-fn _make-br-fn)) + (= name (v tokenize-arg.name)) + (when function*.name + (prn "adding new clause to @name")) + (= function*.name (join body function*.name))) + + ; and-record [ ] + and-record + (let (name (_make-br-fn fields)) rest + (assert (is 'make-br-fn _make-br-fn)) + (= name (v tokenize-arg.name)) + (let fields (map tokenize-arg fields) + (= type*.name (obj size len.fields + and-record t + ; dump all metadata for now except field name and type + elems (map cdar fields) + fields (map caar fields))))) + + ; primitive + primitive + (let (name) rest + (= name (v tokenize-arg.name)) + (= type*.name (obj size 1))) + + ; address + address + (let (name types) rest + (= name (v tokenize-arg.name)) + (= type*.name (obj size 1 + address t + elem types))) + + ; array + array + (let (name types) rest + (= name (v tokenize-arg.name)) + (= type*.name (obj array t + elem types))) + + ; before