;; 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 "new-trace " 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*))
(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)))
;; virtual machine state
; things that a future assembler will need separate memory for:
; code; types; args channel
(def clear ()
(= type* (table))
(= memory* (table))
(= function* (table))
)
(enq clear initialization-fns*)
(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
string-address (obj size 1 address t elem 'string)
character (obj size 1) ; int32 like a Go rune
character-address (obj size 1 address t elem 'character)
; isolating function calls
scope (obj array t elem 'location) ; by convention index 0 points to outer scope
scope-address (obj size 1 address t elem 'scope)
; arrays consist of an integer length followed by the right number of elems
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 series of elems, corresponding to a list of 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-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))
channel-address (obj size 1 address t elem 'channel)
; 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)
)))
;; managing concurrent routines
; routine = runtime state for a serial thread of execution
(def make-routine (fn-name . args)
(annotate 'routine (obj alloc 1000 call-stack (list
(obj fn-name fn-name pc 0 args args caller-arg-idx 0)))))
(defextend empty (x) (isa x 'routine)
(no rep.x!call-stack))
(def stack (routine)
((rep routine) 'call-stack))
(mac push-stack (routine op)
`(push (obj fn-name ,op pc 0 caller-arg-idx 0)
((rep ,routine) 'call-stack)))
(mac pop-stack (routine)
`(pop ((rep ,routine) 'call-stack)))
(def top (routine)
stack.routine.0)
(def body (routine (o idx 0))
(function* stack.routine.idx!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 results (routine) ; assignable
`((((rep ,routine) 'call-stack) 0) 'results))
(def waiting-for-exact-cycle? (routine)
(is 'literal rep.routine!sleep.1))
(def ready-to-wake-up (routine)
(assert no.routine*)
(if (is 'literal rep.routine!sleep.1)
(> curr-cycle* rep.routine!sleep.0)
(~is rep.routine!sleep.1 (memory* rep.routine!sleep.0))))
(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 tests
)
; 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-functions)
(= traces* (queue))
(each it fn-names
(enq make-routine.it running-routines*))
(while (~empty running-routines*)
(= routine* deq.running-routines*)
(trace "schedule" top.routine*!fn-name)
(routine-mark
(run-for-time-slice scheduling-interval*))
(update-scheduler-state)
;? (tr "after run iter " running-routines*)
;? (tr "after run iter " empty.running-routines*)
))
; 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 (either by time or on a location)
; detect deadlock: kill all sleeping routines when none can be woken
(def update-scheduler-state ()
;? (trace "schedule" curr-cycle*)
(when routine*
(if
rep.routine*!sleep
(do (trace "schedule" "pushing " top.routine*!fn-name " to sleep queue")
(set sleeping-routines*.routine*))
(~empty routine*)
(do (trace "schedule" "scheduling " top.routine*!fn-name " for further processing")
(enq routine* running-routines*))
:else
(do (trace "schedule" "done with routine")
(push routine* completed-routines*)))
(= routine* nil))
;? (tr 111)
(each (routine _) canon.sleeping-routines*
(when (ready-to-wake-up routine)
(trace "schedule" "waking up " top.routine!fn-name)
(wipe sleeping-routines*.routine) ; do this before modifying routine
(wipe rep.routine!sleep)
(++ pc.routine)
(enq routine running-routines*)))
;? (tr 112)
(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 0] exact-sleeping-routines))
(= curr-cycle* (+ 1 next-wakeup-cycle))
(trace "schedule" "skipping to cycle " curr-cycle*)
(update-scheduler-state))))
;? (tr 113)
(detect-deadlock)
;? (tr 114)
)
(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)
(= rep.routine*!stack-trace rep.routine*!call-stack)
(wipe rep.routine*!call-stack)
(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)
(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 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))
($:require "charterm/main.rkt")
; 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"))
(while (>= pc.routine* (len body.routine*))
(pop-stack routine*)
(if empty.routine* (return ninstrs))
(++ pc.routine*))
(++ curr-cycle*)
(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
(when (aand scheduler-switch-table*
(alref it (body.routine* pc.routine*)))
(++ pc.routine*)
(trace "run" "context-switch forced " abort-routine*)
((abort-routine*)))
(++ pc.routine*)
(continue))
(let (oarg op arg) (parse-instr (body.routine* pc.routine*))
(let results
(case op
; arithmetic
add
(do (trace "add" (m arg.0) " " (m arg.1))
(+ (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
(is (m arg.0) (m arg.1))
not-equal
(do (trace "neq" (m arg.0) " " (m arg.1))
(~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)))
(trace "jump" "jumping to " pc.routine*)
(continue))
jump-if
(let flag (m arg.0)
(trace "jump" "checking that " flag " is t")
(when (is t flag)
(= pc.routine* (+ 1 pc.routine* (v arg.1)))
(trace "jump" "jumping to " pc.routine*)
(continue)))
jump-unless ; convenient helper
(let flag (m arg.0)
(trace "jump" "checking that " flag " is not t")
(unless (is t flag)
(= pc.routine* (+ 1 pc.routine* (v arg.1)))
(trace "jump" "jumping to " pc.routine*)
(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 sizeof (firstn idx typeinfo.operand!elems)))
,typeinfo.operand!elems.idx)
(global))))
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 sizeof (firstn idx typeinfo.operand!elems))))
index
(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"))
(m `((,(+ v.operand
1 ; for array size
(* idx sizeof.elemtype))
,elemtype)
(global))))
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 typeinfo.base!address)
array-len.base
-1))
; tagged-values require one primitive
save-type
(annotate 'record `(,((ty arg.0) 0) ,(m arg.0)))
; multiprocessing
run
(run (v arg.0))
fork
(let routine (apply make-routine (v car.arg) (map m cdr.arg))
;? (tr "before: " rep.routine*!alloc)
(= rep.routine!alloc rep.routine*!alloc)
(++ rep.routine*!alloc 1000)
;? (tr "after: " rep.routine*!alloc " " rep.routine!alloc)
(enq routine running-routines*))
; todo: errors should stall a process and let its parent
; inspect it
assert
(assert (m arg.0))
sleep
(let operand arg.0
;? (tr "sleep " operand)
; store sleep as either (<cycle number> literal) or (<location> <current value>)
(if (is ty.operand.0 'literal)
(let delay v.operand
(trace "run" "sleeping until " (+ curr-cycle* delay))
(= rep.routine*!sleep `(,(+ curr-cycle* delay) literal)))
(do
;? (tr "blocking on " operand " -> " (addr operand))
(= rep.routine*!sleep `(,addr.operand ,m.operand))))
((abort-routine*)))
; text interaction
clear-screen
(do1 nil ($.charterm-clear-screen))
clear-line
(do1 nil ($.charterm-clear-line))
cursor
(do1 nil ($.charterm-cursor (m arg.0) (m arg.1)))
print-primitive
(do1 nil ((if ($.current-charterm) $.charterm-display pr) (m arg.0)))
read-key
(and ($.charterm-byte-ready?) ($.charterm-read-key))
bold-mode
(do1 nil ($.charterm-bold))
non-bold-mode
(do1 nil ($.charterm-normal))
console-on
(do1 nil (if (no ($.current-charterm)) ($.open-charterm)))
console-off
(do1 nil (if ($.current-charterm) ($.close-charterm)))
; user-defined functions
next-input
(let idx caller-arg-idx.routine*
(++ caller-arg-idx.routine*)
(trace "arg" arg " " idx " " 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" arg " " idx " " caller-args.routine*)
(if (len> caller-args.routine* idx)
(list caller-args.routine*.idx t)
(list nil nil))))
prepare-reply
(prepare-reply arg)
reply
(do (when arg
(prepare-reply arg))
(let results results.routine*
(pop-stack routine*)
(if empty.routine* (return ninstrs))
(let (caller-oargs _ _) (parse-instr (body.routine* pc.routine*))
(trace "reply" arg " " caller-oargs)
(each (dest val) (zip caller-oargs results)
(when nondummy.dest
(trace "reply" val " => " dest)
(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
(let callee-args (accum yield
(each a arg
(yield (m a))))
(push-stack routine* op)
(= caller-args.routine* callee-args))
(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" val " => " dest)
(setm dest val)))
(when oarg ; must be a list
(trace "run" 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))))))
; helpers for memory access respecting
; immediate addressing - 'literal' and 'offset'
; direct addressing - default
; indirect addressing - 'deref'
; relative addressing - if routine* has 'default-scope'
(def m (loc) ; read memory, respecting metadata
(point return
(if (in ty.loc.0 'literal 'offset)
(return v.loc))
(when (is v.loc 'default-scope)
(return rep.routine*!call-stack.0!default-scope))
(trace "m" loc)
(assert (isa v.loc 'int) "addresses must be numeric (problem in convert-names?) @loc")
(with (n sizeof.loc
addr addr.loc)
;? (trace "m" "reading " n " locations starting at " addr)
(if (is 1 n)
memory*.addr
:else
(annotate 'record
(map memory* (addrs addr n)))))))
(def 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")
(= rep.routine*!call-stack.0!default-scope val)
(return))
(assert (isa v.loc 'int) "can't store to non-numeric address (problem in convert-names?)")
(trace "setm" loc " <= " val)
(with (n (if (isa val 'record) (len rep.val) 1)
addr addr.loc)
(trace "setm" "size of " loc " is " n)
(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 "setm" loc ": setting " addr " to " val)
(= memory*.addr val))
(do (if ((type* typeof.loc) 'array)
; size check for arrays
(when (~is n
(+ 1 ; array length
(* rep.val.0 (sizeof ((type* typeof.loc) 'elem)))))
(die "writing invalid array @(tostring prn.val)"))
; size check for non-arrays
(when (~is sizeof.loc n)
(die "writing to incorrect size @(tostring prn.val) => @loc")))
(let addrs (addrs addr n)
(each (dest src) (zip addrs rep.val)
(trace "setm" loc ": setting " dest " to " 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)
;? (prn 211 " " operand)
(let loc absolutize.operand
;? (prn 212 " " loc)
(while (pos '(deref) metadata.loc)
;? (prn 213 " " loc)
(zap deref loc))
;? (prn 214 " " loc)
v.loc))
(def addrs (n sz)
(accum yield
(repeat sz
(yield n)
(++ n))))
(def canonize (operand)
(ret operand
(zap absolutize operand)
(while (pos '(deref) metadata.operand)
(zap deref 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)
(point return
(when (acons x)
(zap canonize x)
;? (tr "sizeof 1 @x")
(when typeinfo.x!array
;? (tr "sizeof 2")
(return (+ 1 (* array-len.x (sizeof typeinfo.x!elem))))))
;? (tr "sizeof 3")
(let type (if (and acons.x (pos '(deref) metadata.x))
typeinfo.x!elem ; deref pointer
acons.x
ty.x.0
:else ; naked type
x)
(assert type*.type "sizeof: no such type @type")
(if (~or type*.type!and-record type*.type!array)
type*.type!size
type*.type!and-record
(sum idfn
(accum yield
(each elem type*.type!elems
(yield sizeof.elem))))
:else
(err "sizeof can't handle @type (arrays require a specific variable)")))))
(def absolutize (operand)
(if (no routine*)
operand
(pos '(global) metadata.operand)
operand
:else
(iflet base rep.routine*!call-stack.0!default-scope
;? (do (prn 313 " " operand " " base)
(if (< v.operand memory*.base)
`((,(+ v.operand base) ,@(cdr operand.0))
,@metadata.operand
(global))
(die "no room for var @operand in routine of size @memory*.base"))
;? )
operand)))
(def deref (operand)
(assert (pos '(deref) metadata.operand))
(assert typeinfo.operand!address)
(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 x)))))
; memory allocation
(def new-scalar (type)
;? (tr "new scalar: @type")
(ret result rep.routine*!alloc
(++ rep.routine*!alloc sizeof.type)))
(def 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)
;? (tr "new string: @literal-string")
(ret result rep.routine*!alloc
(= (memory* rep.routine*!alloc) len.literal-string)
(++ rep.routine*!alloc)
(each c literal-string
(= (memory* rep.routine*!alloc) c)
(++ rep.routine*!alloc))))
;; 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))
(let (oarg op arg) (parse-instr instr)
(trace "c{1" pc " " op " " oarg)
(case op
break
(do
(assert (is oarg nil) "break: can't take oarg in @instr")
(yield `(((jump)) ((,(close-offset pc locs (and arg (v arg.0))) offset)))))
break-if
(do
(assert (is oarg nil) "break-if: can't take oarg in @instr")
(yield `(((jump-if)) ,arg.0 ((,(close-offset pc locs (and cdr.arg (v arg.1))) offset)))))
break-unless
(do
(assert (is oarg nil) "break-unless: can't take oarg in @instr")
(yield `(((jump-unless)) ,arg.0 ((,(close-offset pc locs (and cdr.arg (v arg.1))) offset)))))
loop
(do
(assert (is oarg nil) "loop: can't take oarg in @instr")
(yield `(((jump)) ((,(open-offset pc stack (and arg (v arg.0))) offset)))))
loop-if
(do
(trace "cvt0" "loop-if: " instr " => " (- stack.0 1))
(assert (is oarg nil) "loop-if: can't take oarg in @instr")
(yield `(((jump-if)) ,arg.0 ((,(open-offset pc stack (and cdr.arg (v arg.1))) offset)))))
loop-unless
(do
(trace "cvt0" "loop-if: " instr " => " (- stack.0 1))
(assert (is oarg nil) "loop-unless: can't take oarg in @instr")
(yield `(((jump-unless)) ,arg.0 ((,(open-offset pc stack (and cdr.arg (v arg.1))) offset)))))
;else
(yield instr)))
(++ 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 convert-names (instrs)
;? (tr "convert-names " instrs)
(with (location (table)
isa-field (table))
(let idx 1
(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 "1")
; rename args
(if (in op 'get 'get-address)
(with (basetype (typeinfo args.0)
field (v args.1))
(assert basetype "no such type @args.0")
(trace "cn0" "field-access " field)
; todo: need to rename args.0 as well?
(when (pos '(deref) (metadata args.0))
(trace "cn0" "field-access deref")
(assert basetype!address "@args.0 requests deref, but it's not an address")
(= basetype (type* basetype!elem)))
(when (isa field 'sym)
(assert (or (~location field) isa-field.field) "field @args.1 is also a variable")
(when (~location field)
(trace "cn0" "new field; computing location")
(assert basetype!fields "no field names available for @instr")
(iflet idx (pos field basetype!fields)
(do (set isa-field.field)
(trace "cn0" "field location @idx")
(= location.field idx))
(assert nil "couldn't find field in @instr")))))
(each arg args
(when (and nondummy.arg not-raw-string.arg)
(assert (~isa-field v.arg) "arg @arg is also a field name")
(when (maybe-add arg location idx)
(err "use before set: @arg")))))
;? (tr "2")
; rename oargs
(each arg oargs
(trace "cn0" "checking " 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 arg " arg ": " idx)
; todo: can't allocate arrays on the stack
(++ idx (sizeof ty.arg.0)))))))))
(trace "cn1" "update names " canon.location " " canon.isa-field)
(each instr instrs
(when (acons instr)
(let (oargs op args) (parse-instr instr)
(each arg args
(when (and nondummy.arg not-raw-string.arg (location v.arg))
(zap location v.arg)))
(each arg oargs
(when (and nondummy.arg not-raw-string.arg (location v.arg))
(zap location v.arg))))))
instrs))
(def maybe-add (arg location idx)
(trace "maybe-add" arg)
(when (and nondummy.arg
(~in ty.arg.0 'literal 'offset 'fn)
(~location v.arg)
(isa v.arg 'sym)
(~in v.arg 'nil 'default-scope)
(~assoc 'global metadata.arg))
(= (location v.arg) idx)))
;; 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 <name> [ <instructions> ]
; don't apply our lightweight tools just yet
function!
(let (name (_make-br-fn body)) rest
(assert (is 'make-br-fn _make-br-fn))
(= function*.name body))
function
(let (name (_make-br-fn body)) rest
(assert (is 'make-br-fn _make-br-fn))
(= function*.name (join body function*.name)))
; before <label> [ <instructions> ]
;
; multiple before directives => code in order
before
(let (label (_make-br-fn fragment)) rest
(assert (is 'make-br-fn _make-br-fn))
(or= before*.label (queue))
(enq fragment before*.label))
; after <label> [ <instructions> ]
;
; multiple after directives => code in *reverse* order
; (if initialization order in a function is A B, corresponding
; finalization order should be B A)
after
(let (label (_make-br-fn fragment)) rest
(assert (is 'make-br-fn _make-br-fn))
(push fragment after*.label))
)))
(def freeze-functions ()
;? (prn "freeze")
(each (name body) canon.function*
;? (tr name)
;? (prn keys.before* " -- " keys.after*)
;? (= function*.name (convert-names:convert-labels:convert-braces:prn:insert-code body)))
(= function*.name (convert-names:convert-labels:convert-braces:tokenize-args:insert-code body name))))
(def tokenize-arg (arg)
;? (tr "tokenize-arg " arg)
(if (in arg '<- '_)
arg
(isa arg 'sym)
(map [map [fromstring _ (read)] _]
(map [tokens _ #\:]
(tokens string.arg #\/)))
:else
arg))
(def tokenize-args (instrs)
;? (tr "tokenize-args " instrs)
;? (prn2 "@(tostring prn.instrs) => "
(accum yield
(each instr instrs
(if atom.instr
(yield instr)
(is 'begin instr.0)
(yield `{begin ,@(tokenize-args cdr.instr)})
:else
(yield (map tokenize-arg instr))))))
;? )
(def prn2 (msg . args)
(pr msg)
(apply prn args))
(def canon (table)
(sort (compare < [tostring (prn:car _)]) (as cons table)))
(def int-canon (table)
(sort (compare < car) (as cons table)))
;; test helpers
(def memory-contains (addr value)
;? (prn "Looking for @value starting at @addr")
(loop (addr addr
idx 0)
;? (prn "@idx vs @addr")
(if (>= idx len.value)
t
(~is memory*.addr value.idx)
(do1 nil
(prn "@addr should contain @value.idx but contains @memory*.addr"))
:else
(recur (+ addr 1) (+ idx 1)))))
(def 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)
idx 0)
;? (prn "comparing @memory*.addr and @value.idx")
(if (>= idx len.value)
t
(~is memory*.addr value.idx)
(do1 nil
(prn "@addr should contain @value.idx but contains @memory*.addr"))
:else
(recur (+ addr 1) (+ idx 1))))))
;; system software
; create once, load before every test
(reset)
(= system-function* (table))
(mac init-fn (name . body)
`(= (system-function* ',name)
(convert-names:convert-labels:convert-braces:tokenize-args:insert-code ',body ',name)))
(on-init
(each (name f) system-function*
(= (function* name)
(system-function* name))))
(section 100
(init-fn maybe-coerce
(default-scope:scope-address <- new scope:literal 30:literal)
(x:tagged-value-address <- new tagged-value:literal)
(x:tagged-value-address/deref <- next-input)
(p:type <- next-input)
(xtype:type <- get x:tagged-value-address/deref 0:offset)
(match?:boolean <- equal xtype:type p:type)
{ begin
(break-if match?:boolean)
(reply 0:literal nil:literal)
}
(xvalue:location <- get x:tagged-value-address/deref 1:offset)
(reply xvalue:location match?:boolean))
(init-fn new-tagged-value
(default-scope:scope-address <- new scope:literal 30:literal)
; assert sizeof:arg.0 == 1
(xtype:type <- next-input)
(xtypesize:integer <- sizeof xtype:type)
(xcheck:boolean <- equal xtypesize:integer 1:literal)
(assert xcheck:boolean)
; todo: check that arg 0 matches the type? or is that for the future typechecker?
(result:tagged-value-address <- new tagged-value:literal)
; result->type = arg 0
(resulttype:location <- get-address result:tagged-value-address/deref type:offset)
(resulttype:location/deref <- copy xtype:type)
; result->payload = arg 1
(locaddr:location <- get-address result:tagged-value-address/deref payload:offset)
(locaddr:location/deref <- next-input)
(reply result:tagged-value-address))
(init-fn list-next ; list-address -> list-address
(default-scope:scope-address <- new scope:literal 30:literal)
(base:list-address <- next-input)
(result:list-address <- get base:list-address/deref cdr:offset)
(reply result:list-address))
(init-fn list-value-address ; list-address -> tagged-value-address
(default-scope:scope-address <- new scope:literal 30:literal)
(base:list-address <- next-input)
(result:tagged-value-address <- get-address base:list-address/deref car:offset)
(reply result:tagged-value-address))
(init-fn new-list
(default-scope:scope-address <- new scope:literal 30:literal)
; new-list = curr = new list
(new-list-result:list-address <- new list:literal)
(curr:list-address <- copy new-list-result:list-address)
{ begin
; while read curr-value
(curr-value:integer exists?:boolean <- next-input)
(break-unless exists?:boolean)
; curr.cdr = new list
(next:list-address-address <- get-address curr:list-address/deref cdr:offset)
(next:list-address-address/deref <- new list:literal)
; curr = curr.cdr
(curr:list-address <- list-next curr:list-address)
; curr.car = type:curr-value
(dest:tagged-value-address <- list-value-address curr:list-address)
(dest:tagged-value-address/deref <- save-type curr-value:integer)
(loop)
}
; return new-list.cdr
(new-list-result:list-address <- list-next new-list-result:list-address) ; memory leak
(reply new-list-result:list-address))
(init-fn new-channel
(default-scope:scope-address <- new scope:literal 30:literal)
; result = new channel
(result:channel-address <- new channel:literal)
; result.first-full = 0
(full:integer-address <- get-address result:channel-address/deref first-full:offset)
(full:integer-address/deref <- copy 0:literal)
; result.first-free = 0
(free:integer-address <- get-address result:channel-address/deref first-free:offset)
(free:integer-address/deref <- copy 0:literal)
; result.circular-buffer = new tagged-value[arg+1]
(capacity:integer <- next-input)
(capacity:integer <- add capacity:integer 1:literal) ; unused slot for full? below
(channel-buffer-address:tagged-value-array-address-address <- get-address result:channel-address/deref circular-buffer:offset)
(channel-buffer-address:tagged-value-array-address-address/deref <- new tagged-value-array:literal capacity:integer)
(reply result:channel-address))
(init-fn capacity
(default-scope:scope-address <- new scope:literal 30:literal)
(chan:channel <- next-input)
(q:tagged-value-array-address <- get chan:channel circular-buffer:offset)
(qlen:integer <- length q:tagged-value-array-address/deref)
(reply qlen:integer))
(init-fn write
(default-scope:scope-address <- new scope:literal 30:literal)
(chan:channel-address <- next-input)
(val:tagged-value <- next-input)
{ begin
; block if chan is full
(full:boolean <- full? chan:channel-address/deref)
(break-unless full:boolean)
(full-address:integer-address <- get-address chan:channel-address/deref first-full:offset)
(sleep full-address:integer-address/deref)
}
; store val
(q:tagged-value-array-address <- get chan:channel-address/deref circular-buffer:offset)
(free:integer-address <- get-address chan:channel-address/deref first-free:offset)
(dest:tagged-value-address <- index-address q:tagged-value-array-address/deref free:integer-address/deref)
(dest:tagged-value-address/deref <- copy val:tagged-value)
; increment free
(free:integer-address/deref <- add free:integer-address/deref 1:literal)
{ begin
; wrap free around to 0 if necessary
(qlen:integer <- length q:tagged-value-array-address/deref)
(remaining?:boolean <- less-than free:integer-address/deref qlen:integer)
(break-if remaining?:boolean)
(free:integer-address/deref <- copy 0:literal)
}
reply:chan:channel-address/deref)
(init-fn read
(default-scope:scope-address <- new scope:literal 30:literal)
(chan:channel-address <- next-input)
{ begin
; block if chan is empty
(empty:boolean <- empty? chan:channel-address/deref)
(break-unless empty:boolean)
(free-address:integer-address <- get-address chan:channel-address/deref first-free:offset)
(sleep free-address:integer-address/deref)
}
; read result
(full:integer-address <- get-address chan:channel-address/deref first-full:offset)
(q:tagged-value-array-address <- get chan:channel-address/deref circular-buffer:offset)
(result:tagged-value <- index q:tagged-value-array-address/deref full:integer-address/deref)
; increment full
(full:integer-address/deref <- add full:integer-address/deref 1:literal)
{ begin
; wrap full around to 0 if necessary
(qlen:integer <- length q:tagged-value-array-address/deref)
(remaining?:boolean <- less-than full:integer-address/deref qlen:integer)
(break-if remaining?:boolean)
(full:integer-address/deref <- copy 0:literal)
}
(reply result:tagged-value chan:channel-address/deref))
; An empty channel has first-empty and first-full both at the same value.
(init-fn empty?
(default-scope:scope-address <- new scope:literal 30:literal)
; return arg.first-full == arg.first-free
(chan:channel <- next-input)
(full:integer <- get chan:channel first-full:offset)
(free:integer <- get chan:channel first-free:offset)
(result:boolean <- equal full:integer free:integer)
(reply result:boolean))
; A full channel has first-empty just before first-full, wasting one slot.
; (Other alternatives: https://en.wikipedia.org/wiki/Circular_buffer#Full_.2F_Empty_Buffer_Distinction)
(init-fn full?
(default-scope:scope-address <- new scope:literal 30:literal)
(chan:channel <- next-input)
; curr = chan.first-free + 1
(curr:integer <- get chan:channel first-free:offset)
(curr:integer <- add curr:integer 1:literal)
{ begin
; if (curr == chan.capacity) curr = 0
(qlen:integer <- capacity chan:channel)
(remaining?:boolean <- less-than curr:integer qlen:integer)
(break-if remaining?:boolean)
(curr:integer <- copy 0:literal)
}
; return chan.first-full == curr
(full:integer <- get chan:channel first-full:offset)
(result:boolean <- equal full:integer curr:integer)
(reply result:boolean))
(init-fn strcat
(default-scope:scope-address <- new scope:literal 30:literal)
; result = new string[a.length + b.length]
(a:string-address <- next-input)
(a-len:integer <- length a:string-address/deref)
(b:string-address <- next-input)
(b-len:integer <- length b:string-address/deref)
(result-len:integer <- add a-len:integer b-len:integer)
(result:string-address <- new string:literal result-len:integer)
; copy a into result
(result-idx:integer <- copy 0:literal)
(i:integer <- copy 0:literal)
{ begin
; while (i < a.length)
(a-done?:boolean <- less-than i:integer a-len:integer)
(break-unless a-done?:boolean)
; result[result-idx] = a[i]
(out:byte-address <- index-address result:string-address/deref result-idx:integer)
(in:byte <- index a:string-address/deref i:integer)
(out:byte-address/deref <- copy in:byte)
; ++i
(i:integer <- add i:integer 1:literal)
; ++result-idx
(result-idx:integer <- add result-idx:integer 1:literal)
(loop)
}
; copy b into result
(i:integer <- copy 0:literal)
{ begin
; while (i < b.length)
(b-done?:boolean <- less-than i:integer b-len:integer)
(break-unless b-done?:boolean)
; result[result-idx] = a[i]
(out:byte-address <- index-address result:string-address/deref result-idx:integer)
(in:byte <- index b:string-address/deref i:integer)
(out:byte-address/deref <- copy in:byte)
; ++i
(i:integer <- add i:integer 1:literal)
; ++result-idx
(result-idx:integer <- add result-idx:integer 1:literal)
(loop)
}
(reply result:string-address))
; replace underscores in first with remaining args
(init-fn interpolate ; string-address template, string-address a..
(default-scope:scope-address <- new scope:literal 60:literal)
(template:string-address <- next-input)
; compute result-len, space to allocate for result
(tem-len:integer <- length template:string-address/deref)
(result-len:integer <- copy tem-len:integer)
{ begin
; while arg received
(a:string-address arg-received?:boolean <- next-input)
(break-unless arg-received?:boolean)
;? (print-primitive ("arg now: " literal))
;? (print-primitive a:string-address)
;? (print-primitive "@":literal)
;? print-primitive:a:string-address/deref ; todo: test (m on scoped array)
;? (print-primitive "\n":literal)
;? ;? (assert nil:literal)
; result-len = result-len + arg.length - 1 (for the 'underscore' being replaced)
(a-len:integer <- length a:string-address/deref)
(result-len:integer <- add result-len:integer a-len:integer)
(result-len:integer <- subtract result-len:integer 1:literal)
;? (print-primitive ("result-len now: " literal))
;? (print-primitive result-len:integer)
;? (print-primitive "\n":literal)
(loop)
}
; rewind to start of non-template args
(_ <- input 0:literal)
; result = new string[result-len]
(result:string-address <- new string:literal result-len:integer)
; repeatedly copy sections of template and 'holes' into result
(result-idx:integer <- copy 0:literal)
(i:integer <- copy 0:literal)
{ begin
; while arg received
(a:string-address arg-received?:boolean <- next-input)
(break-unless arg-received?:boolean)
; copy template into result until '_'
{ begin
; while (i < template.length)
(tem-done?:boolean <- less-than i:integer tem-len:integer)
(break-unless tem-done?:boolean 2:blocks)
; while template[i] != '_'
(in:byte <- index template:string-address/deref i:integer)
(underscore?:boolean <- equal in:byte ((#\_ literal)))
(break-if underscore?:boolean)
; result[result-idx] = template[i]
(out:byte-address <- index-address result:string-address/deref result-idx:integer)
(out:byte-address/deref <- copy in:byte)
; ++i
(i:integer <- add i:integer 1:literal)
; ++result-idx
(result-idx:integer <- add result-idx:integer 1:literal)
(loop)
}
;? (print-primitive ("i now: " literal))
;? (print-primitive i:integer)
;? (print-primitive "\n":literal)
; copy 'a' into result
(j:integer <- copy 0:literal)
{ begin
; while (j < a.length)
(arg-done?:boolean <- less-than j:integer a-len:integer)
(break-unless arg-done?:boolean)
; result[result-idx] = a[j]
(in:byte <- index a:string-address/deref j:integer)
;? (print-primitive ("copying: " literal))
;? (print-primitive in:byte)
;? (print-primitive (" at: " literal))
;? (print-primitive result-idx:integer)
;? (print-primitive "\n":literal)
(out:byte-address <- index-address result:string-address/deref result-idx:integer)
(out:byte-address/deref <- copy in:byte)
; ++j
(j:integer <- add j:integer 1:literal)
; ++result-idx
(result-idx:integer <- add result-idx:integer 1:literal)
(loop)
}
; skip '_' in template
(i:integer <- add i:integer 1:literal)
;? (print-primitive ("i now: " literal))
;? (print-primitive i:integer)
;? (print-primitive "\n":literal)
(loop) ; interpolate next arg
}
; done with holes; copy rest of template directly into result
{ begin
; while (i < template.length)
(tem-done?:boolean <- less-than i:integer tem-len:integer)
(break-unless tem-done?:boolean)
; result[result-idx] = template[i]
(in:byte <- index template:string-address/deref i:integer)
;? (print-primitive ("copying: " literal))
;? (print-primitive in:byte)
;? (print-primitive (" at: " literal))
;? (print-primitive result-idx:integer)
;? (print-primitive "\n":literal)
(out:byte-address <- index-address result:string-address/deref result-idx:integer)
(out:byte-address/deref <- copy in:byte)
; ++i
(i:integer <- add i:integer 1:literal)
; ++result-idx
(result-idx:integer <- add result-idx:integer 1:literal)
(loop)
}
(reply result:string-address))
) ; section 100 for system software
;; load all provided files and start at 'main'
(reset)
(awhen (pos "--" argv)
(map add-code:readfile (cut argv (+ it 1)))
;? (= dump-trace* (obj whitelist '("run" "schedule" "add")))
;? (freeze-functions)
;? (prn function*!factorial)
(run 'main)
(if ($.current-charterm) ($.close-charterm))
(prn "\nmemory: " memory*)
;? (prn completed-routines*)
)