2014-10-10 22:09:16 +00:00
|
|
|
;; what happens when our virtual machine starts up
|
2014-08-19 17:31:58 +00:00
|
|
|
(= initialization-fns* (queue))
|
|
|
|
(def reset ()
|
|
|
|
(each f (as cons initialization-fns*)
|
|
|
|
(f)))
|
|
|
|
|
2014-08-29 02:53:41 +00:00
|
|
|
(mac on-init body
|
|
|
|
`(enq (fn () ,@body)
|
|
|
|
initialization-fns*))
|
|
|
|
|
2014-10-10 22:04:14 +00:00
|
|
|
(mac init-fn (name . body)
|
2014-10-11 17:09:41 +00:00
|
|
|
`(enq (fn () (= (function* ',name) (convert-braces ',body)))
|
2014-10-10 22:04:14 +00:00
|
|
|
initialization-fns*))
|
|
|
|
|
|
|
|
; things that a future assembler will need separate memory for:
|
|
|
|
; code; types; args channel
|
|
|
|
(def clear ()
|
|
|
|
(= types* (table))
|
|
|
|
(= memory* (table))
|
|
|
|
(= function* (table)))
|
|
|
|
(enq clear initialization-fns*)
|
|
|
|
|
2014-10-28 18:32:00 +00:00
|
|
|
(on-init
|
|
|
|
(= types* (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)
|
|
|
|
byte (obj size 1)
|
|
|
|
;? string (obj array t elem 'byte) ; inspired by Go
|
|
|
|
character (obj size 1) ; int32 like a Go rune
|
|
|
|
character-address (obj size 1 address t elem 'character)
|
|
|
|
string (obj size 1) ; temporary hack
|
|
|
|
; arrays consist of an integer length followed by the right number of elems
|
|
|
|
integer-array (obj array t elem 'integer)
|
|
|
|
integer-address (obj size 1 address t elem 'integer) ; pointer to int
|
|
|
|
; records consist of a series of elems, corresponding to a list of types
|
|
|
|
integer-boolean-pair (obj size 2 record t elems '(integer boolean))
|
|
|
|
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-integer-pair (obj size 2 record t elems '(integer integer))
|
|
|
|
integer-point-pair (obj size 2 record t elems '(integer integer-integer-pair))
|
|
|
|
; tagged-values are the foundation of dynamic types
|
|
|
|
tagged-value (obj size 2 record t elems '(type location))
|
|
|
|
tagged-value-address (obj size 1 address t elem 'tagged-value)
|
|
|
|
; heterogeneous lists
|
|
|
|
list (obj size 2 record t elems '(tagged-value list-address))
|
|
|
|
list-address (obj size 1 address t elem 'list)
|
|
|
|
list-address-address (obj size 1 address t elem 'list-address)
|
2014-10-28 18:41:59 +00:00
|
|
|
; 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)
|
2014-10-28 18:32:00 +00:00
|
|
|
)))
|
|
|
|
|
2014-10-10 22:09:16 +00:00
|
|
|
;; persisting and checking traces for each test
|
2014-10-07 17:26:14 +00:00
|
|
|
(= traces* (queue))
|
|
|
|
(= trace-dir* ".traces/")
|
|
|
|
(ensure-dir trace-dir*)
|
|
|
|
(= curr-trace-file* nil)
|
2014-08-29 02:53:41 +00:00
|
|
|
(on-init
|
2014-10-07 17:26:14 +00:00
|
|
|
(awhen curr-trace-file*
|
|
|
|
;? (prn "reset: " it)
|
|
|
|
(tofile (+ trace-dir* it)
|
|
|
|
(each (label trace) (as cons traces*)
|
|
|
|
(pr label ": " trace))))
|
|
|
|
(= curr-trace-file* nil)
|
2014-08-29 03:42:15 +00:00
|
|
|
(= traces* (queue)))
|
2014-10-07 17:26:14 +00:00
|
|
|
|
|
|
|
(def new-trace (filename)
|
|
|
|
;? (prn "new-trace " filename)
|
|
|
|
(= curr-trace-file* filename))
|
|
|
|
|
2014-10-07 20:26:01 +00:00
|
|
|
(= dump-trace* nil)
|
2014-08-29 02:53:41 +00:00
|
|
|
(def trace (label . args)
|
2014-10-07 20:26:01 +00:00
|
|
|
;? (prn "trace: " dump-trace*)
|
|
|
|
(if dump-trace* (apply prn label ": " args))
|
2014-08-29 03:42:15 +00:00
|
|
|
(enq (list label (apply tostring:prn args))
|
|
|
|
traces*))
|
|
|
|
|
|
|
|
(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)))
|
2014-08-29 02:53:41 +00:00
|
|
|
|
2014-07-06 08:41:37 +00:00
|
|
|
(def add-fns (fns)
|
|
|
|
(each (name . body) fns
|
2014-10-07 15:32:28 +00:00
|
|
|
(= function*.name (convert-braces body))))
|
2014-07-06 07:07:03 +00:00
|
|
|
|
2014-10-10 22:09:16 +00:00
|
|
|
;; running mu
|
2014-08-21 02:49:05 +00:00
|
|
|
(def v (operand) ; for value
|
|
|
|
operand.0)
|
2014-07-31 08:53:14 +00:00
|
|
|
|
2014-08-21 02:49:05 +00:00
|
|
|
(def metadata (operand)
|
|
|
|
cdr.operand)
|
2014-07-31 09:27:41 +00:00
|
|
|
|
2014-08-21 02:49:05 +00:00
|
|
|
(def ty (operand)
|
|
|
|
operand.1) ; assume type is always first bit of metadata, and it's always present
|
2014-07-31 08:53:14 +00:00
|
|
|
|
2014-08-22 02:55:16 +00:00
|
|
|
(def typeinfo (operand)
|
|
|
|
(types* ty.operand))
|
|
|
|
|
2014-08-21 02:49:05 +00:00
|
|
|
(def sz (operand)
|
2014-10-11 18:17:04 +00:00
|
|
|
(trace "sz" operand)
|
2014-10-11 17:09:41 +00:00
|
|
|
(if (is 'literal ty.operand)
|
|
|
|
'literal
|
2014-10-11 18:17:04 +00:00
|
|
|
(pos 'deref metadata.operand)
|
|
|
|
(do (assert typeinfo.operand!address)
|
|
|
|
(sz (list (m `(,(v operand) location))
|
|
|
|
typeinfo.operand!elem)))
|
2014-10-11 17:09:41 +00:00
|
|
|
(let-or it typeinfo.operand (err "no such type: @operand")
|
|
|
|
(if it!array
|
|
|
|
array-len.operand
|
|
|
|
it!size))))
|
2014-08-21 07:29:55 +00:00
|
|
|
(defextend sz (typename) (isa typename 'sym)
|
2014-10-07 06:39:13 +00:00
|
|
|
(or types*.typename!size
|
|
|
|
(err "type @typename doesn't have a size: " (tostring:pr types*.typename))))
|
2014-08-21 00:43:15 +00:00
|
|
|
|
2014-08-27 05:05:30 +00:00
|
|
|
(def addr (loc)
|
2014-10-05 21:35:57 +00:00
|
|
|
(if (pos 'deref metadata.loc)
|
|
|
|
(memory* v.loc)
|
|
|
|
v.loc))
|
2014-08-20 06:37:50 +00:00
|
|
|
|
|
|
|
(def addrs (n sz)
|
|
|
|
(accum yield
|
|
|
|
(repeat sz
|
|
|
|
(yield n)
|
|
|
|
(++ n))))
|
|
|
|
|
2014-08-27 05:05:30 +00:00
|
|
|
(def m (loc) ; read memory, respecting metadata
|
2014-10-28 07:29:58 +00:00
|
|
|
;? (if (~isa v.loc 'int) prn.loc)
|
|
|
|
(assert (or (isa v.loc 'int)
|
|
|
|
(is ty.loc 'literal)))
|
2014-10-11 18:17:04 +00:00
|
|
|
(trace "m" loc " " sz.loc)
|
2014-10-05 17:36:09 +00:00
|
|
|
(if (is 'literal ty.loc)
|
|
|
|
(v loc)
|
|
|
|
(is 1 sz.loc)
|
2014-10-05 21:35:57 +00:00
|
|
|
(memory* addr.loc)
|
2014-10-05 17:36:09 +00:00
|
|
|
:else
|
|
|
|
(annotate 'record
|
2014-10-05 21:35:57 +00:00
|
|
|
(map memory* (addrs addr.loc sz.loc)))))
|
2014-07-27 17:55:08 +00:00
|
|
|
|
2014-08-27 05:05:30 +00:00
|
|
|
(def setm (loc val) ; set memory, respecting metadata
|
2014-10-28 07:29:58 +00:00
|
|
|
(assert (isa v.loc 'int))
|
2014-10-11 18:17:04 +00:00
|
|
|
(trace "setm" loc " <= " val)
|
|
|
|
(let n sz.loc
|
2014-10-13 01:04:29 +00:00
|
|
|
(trace "setm" "size of " loc " is " n)
|
2014-10-11 18:17:04 +00:00
|
|
|
(assert n)
|
|
|
|
(if (is 1 n)
|
|
|
|
(do (assert (~isa val 'record))
|
|
|
|
(= (memory* addr.loc) val))
|
|
|
|
(do (assert (isa val 'record))
|
|
|
|
(each (dest src) (zip (addrs addr.loc n)
|
|
|
|
(rep val))
|
|
|
|
(= (memory* dest) src))))))
|
2014-07-31 09:27:41 +00:00
|
|
|
|
2014-08-22 03:40:02 +00:00
|
|
|
(def array-len (operand)
|
2014-10-07 06:39:13 +00:00
|
|
|
;? (prn operand)
|
|
|
|
;? (prn (memory* 1000))
|
|
|
|
(if typeinfo.operand!array
|
|
|
|
(m `(,v.operand integer))
|
|
|
|
(and typeinfo.operand!address (pos 'deref metadata.operand))
|
|
|
|
(array-len (m operand) typeinfo.operand!elem)
|
|
|
|
:else
|
|
|
|
(err "can't take len of non-array @operand")))
|
2014-08-22 03:40:02 +00:00
|
|
|
|
2014-10-05 18:34:23 +00:00
|
|
|
(def array-ref-addr (operand idx)
|
2014-10-07 06:39:13 +00:00
|
|
|
;? (prn "aref addr: @operand @idx")
|
2014-10-05 18:34:23 +00:00
|
|
|
(assert typeinfo.operand!array)
|
|
|
|
(assert (< -1 idx (array-len operand)))
|
|
|
|
(withs (elem typeinfo.operand!elem
|
|
|
|
offset (+ 1 (* idx sz.elem)))
|
|
|
|
(+ v.operand offset)))
|
|
|
|
|
2014-08-22 02:55:16 +00:00
|
|
|
(def array-ref (operand idx)
|
2014-10-07 15:32:45 +00:00
|
|
|
;? (prn "aref: @operand @idx")
|
2014-08-22 03:40:02 +00:00
|
|
|
(assert typeinfo.operand!array)
|
|
|
|
(assert (< -1 idx (array-len operand)))
|
2014-10-07 15:32:45 +00:00
|
|
|
;? (prn "aref2: @operand @idx")
|
2014-08-22 02:55:16 +00:00
|
|
|
(withs (elem typeinfo.operand!elem
|
|
|
|
offset (+ 1 (* idx sz.elem)))
|
2014-10-07 15:32:45 +00:00
|
|
|
;? (prn "aref3: @elem @v.operand @offset")
|
2014-08-22 02:55:16 +00:00
|
|
|
(m `(,(+ v.operand offset) ,elem))))
|
|
|
|
|
2014-08-29 02:23:38 +00:00
|
|
|
; context contains the call-stack of functions that haven't yet returned
|
2014-08-28 19:44:01 +00:00
|
|
|
|
2014-08-29 02:54:37 +00:00
|
|
|
(def make-context (fn-name)
|
|
|
|
(annotate 'context (obj call-stack (list
|
|
|
|
(obj fn-name fn-name pc 0 caller-arg-idx 0)))))
|
|
|
|
|
2014-08-29 02:23:38 +00:00
|
|
|
(defextend empty (x) (isa x 'context)
|
|
|
|
(no rep.x!call-stack))
|
2014-08-28 19:44:01 +00:00
|
|
|
|
2014-08-29 02:23:38 +00:00
|
|
|
(def stack (context)
|
|
|
|
((rep context) 'call-stack))
|
2014-08-28 19:44:01 +00:00
|
|
|
|
2014-08-29 02:23:38 +00:00
|
|
|
(mac push-stack (context op)
|
|
|
|
`(push (obj fn-name ,op pc 0 caller-arg-idx 0)
|
|
|
|
((rep ,context) 'call-stack)))
|
|
|
|
|
|
|
|
(mac pop-stack (context)
|
|
|
|
`(pop ((rep ,context) 'call-stack)))
|
|
|
|
|
|
|
|
(def top (context)
|
|
|
|
stack.context.0)
|
|
|
|
|
|
|
|
(def body (context (o idx 0))
|
|
|
|
(function* stack.context.idx!fn-name))
|
|
|
|
|
|
|
|
(mac pc (context (o idx 0)) ; assignable
|
|
|
|
`((((rep ,context) 'call-stack) ,idx) 'pc))
|
|
|
|
|
|
|
|
(mac caller-arg-idx (context (o idx 0)) ; assignable
|
|
|
|
`((((rep ,context) 'call-stack) ,idx) 'caller-arg-idx))
|
2014-08-28 19:44:01 +00:00
|
|
|
|
2014-10-05 17:31:38 +00:00
|
|
|
(= scheduling-interval* 500)
|
2014-08-28 19:44:01 +00:00
|
|
|
|
|
|
|
(def parse-instr (instr)
|
|
|
|
(iflet delim (pos '<- instr)
|
|
|
|
(list (cut instr 0 delim) ; oargs
|
|
|
|
(instr (+ delim 1)) ; op
|
|
|
|
(cut instr (+ delim 2))) ; args
|
|
|
|
(list nil instr.0 cdr.instr)))
|
|
|
|
|
|
|
|
(def caller-args (context) ; not assignable
|
2014-08-29 02:23:38 +00:00
|
|
|
(let (_ _ args) (parse-instr ((body context 1) (pc context 1)))
|
2014-08-28 19:44:01 +00:00
|
|
|
args))
|
|
|
|
|
|
|
|
(def caller-oargs (context) ; not assignable
|
2014-08-29 02:23:38 +00:00
|
|
|
(let (oargs _ _) (parse-instr ((body context 1) (pc context 1)))
|
2014-08-28 19:44:01 +00:00
|
|
|
oargs))
|
|
|
|
|
2014-08-29 03:44:16 +00:00
|
|
|
(= contexts* (queue))
|
|
|
|
|
2014-08-31 18:27:58 +00:00
|
|
|
(def run fn-names
|
2014-08-28 23:47:09 +00:00
|
|
|
(ret result 0
|
2014-08-31 18:27:58 +00:00
|
|
|
(each it fn-names
|
2014-08-29 03:44:16 +00:00
|
|
|
(enq make-context.it contexts*))
|
|
|
|
; simple round-robin scheduler
|
|
|
|
(while (~empty contexts*)
|
|
|
|
(let context deq.contexts*
|
|
|
|
(trace "schedule" top.context!fn-name)
|
2014-08-29 02:23:38 +00:00
|
|
|
(let insts-run (run-for-time-slice context scheduling-interval*)
|
2014-08-29 03:44:16 +00:00
|
|
|
(= result (+ result insts-run)))
|
|
|
|
(if (~empty context)
|
|
|
|
(enq context contexts*))))))
|
2014-08-28 23:47:09 +00:00
|
|
|
|
2014-10-05 03:18:55 +00:00
|
|
|
($:require "charterm/main.rkt")
|
|
|
|
|
2014-08-29 02:23:38 +00:00
|
|
|
(def run-for-time-slice (context time-slice)
|
2014-08-28 19:44:01 +00:00
|
|
|
;? (prn "AAA")
|
2014-08-28 23:40:28 +00:00
|
|
|
(point return
|
2014-08-28 19:44:01 +00:00
|
|
|
;? (prn "BBB")
|
2014-08-28 23:47:09 +00:00
|
|
|
(for ninstrs 0 (< ninstrs time-slice) (++ ninstrs)
|
2014-08-29 02:23:38 +00:00
|
|
|
;? (prn "CCC " pc.context " " context " " (len body.context))
|
2014-10-05 21:26:04 +00:00
|
|
|
(if (empty body.context) (err "@stack.context.0!fn-name not defined"))
|
2014-08-29 02:23:38 +00:00
|
|
|
(while (>= pc.context (len body.context))
|
|
|
|
(pop-stack context)
|
|
|
|
(if empty.context (return ninstrs))
|
|
|
|
(++ pc.context))
|
2014-10-12 17:31:57 +00:00
|
|
|
(trace "run" "-- " (sort (compare < string:car) (as cons memory*)))
|
2014-08-29 03:44:16 +00:00
|
|
|
(trace "run" top.context!fn-name " " pc.context ": " (body.context pc.context))
|
2014-08-29 02:23:38 +00:00
|
|
|
;? (prn "--- " top.context!fn-name " " pc.context ": " (body.context pc.context))
|
|
|
|
(let (oarg op arg) (parse-instr (body.context pc.context))
|
2014-10-07 15:32:45 +00:00
|
|
|
;? (prn op " " arg " -> " oarg)
|
2014-08-28 19:44:01 +00:00
|
|
|
(let tmp
|
2014-07-31 10:46:05 +00:00
|
|
|
(case op
|
2014-10-10 22:04:14 +00:00
|
|
|
; arithmetic
|
2014-07-31 10:46:05 +00:00
|
|
|
add
|
2014-10-07 20:26:01 +00:00
|
|
|
(do (trace "add" (m arg.0) " " (m arg.1))
|
2014-07-31 10:46:05 +00:00
|
|
|
(+ (m arg.0) (m arg.1))
|
2014-10-07 20:26:01 +00:00
|
|
|
)
|
2014-07-31 10:46:05 +00:00
|
|
|
sub
|
|
|
|
(- (m arg.0) (m arg.1))
|
|
|
|
mul
|
|
|
|
(* (m arg.0) (m arg.1))
|
|
|
|
div
|
|
|
|
(/ (real (m arg.0)) (m arg.1))
|
|
|
|
idiv
|
2014-08-27 05:00:23 +00:00
|
|
|
(list (trunc:/ (m arg.0) (m arg.1))
|
|
|
|
(mod (m arg.0) (m arg.1)))
|
2014-10-10 22:04:14 +00:00
|
|
|
|
|
|
|
; boolean
|
2014-07-31 10:46:05 +00:00
|
|
|
and
|
|
|
|
(and (m arg.0) (m arg.1))
|
|
|
|
or
|
|
|
|
(or (m arg.0) (m arg.1))
|
|
|
|
not
|
|
|
|
(not (m arg.0))
|
2014-10-10 22:04:14 +00:00
|
|
|
|
|
|
|
; comparison
|
2014-07-31 10:46:05 +00:00
|
|
|
eq
|
|
|
|
(is (m arg.0) (m arg.1))
|
|
|
|
neq
|
2014-10-07 20:26:01 +00:00
|
|
|
(do (trace "neq" (m arg.0) " " (m arg.1))
|
2014-07-31 10:46:05 +00:00
|
|
|
(~is (m arg.0) (m arg.1))
|
2014-10-07 20:26:01 +00:00
|
|
|
)
|
2014-07-31 10:46:05 +00:00
|
|
|
lt
|
|
|
|
(< (m arg.0) (m arg.1))
|
|
|
|
gt
|
|
|
|
(> (m arg.0) (m arg.1))
|
|
|
|
le
|
|
|
|
(<= (m arg.0) (m arg.1))
|
|
|
|
ge
|
|
|
|
(>= (m arg.0) (m arg.1))
|
2014-10-10 22:04:14 +00:00
|
|
|
|
|
|
|
; control flow
|
2014-10-15 00:51:30 +00:00
|
|
|
jump
|
2014-08-29 02:23:38 +00:00
|
|
|
(do (= pc.context (+ 1 pc.context (v arg.0)))
|
2014-10-15 01:24:46 +00:00
|
|
|
;? (trace "jump" "jumping to " pc.context)
|
2014-07-31 10:46:05 +00:00
|
|
|
(continue))
|
2014-10-15 00:51:30 +00:00
|
|
|
jump-if
|
2014-07-31 10:46:05 +00:00
|
|
|
(when (is t (m arg.0))
|
2014-08-29 02:23:38 +00:00
|
|
|
(= pc.context (+ 1 pc.context (v arg.1)))
|
2014-10-15 01:24:46 +00:00
|
|
|
;? (trace "jump-if" "jumping to " pc.context)
|
|
|
|
(continue))
|
|
|
|
jump-unless ; convenient helper
|
|
|
|
(unless (is t (m arg.0))
|
|
|
|
(= pc.context (+ 1 pc.context (v arg.1)))
|
|
|
|
;? (trace "jump-unless" "jumping to " pc.context)
|
2014-07-12 04:29:43 +00:00
|
|
|
(continue))
|
2014-10-10 22:04:14 +00:00
|
|
|
|
|
|
|
; data management: scalars, arrays, records
|
2014-07-31 10:46:05 +00:00
|
|
|
copy
|
|
|
|
(m arg.0)
|
2014-08-20 04:33:48 +00:00
|
|
|
get
|
2014-08-22 02:55:16 +00:00
|
|
|
(with (base arg.0 ; integer (non-symbol) memory location including metadata
|
|
|
|
idx (v arg.1)) ; literal integer
|
2014-10-05 22:02:28 +00:00
|
|
|
;? (prn base ": " (memory* v.base))
|
|
|
|
(when typeinfo.base!address
|
|
|
|
(assert (pos 'deref metadata.base))
|
|
|
|
(= base (list (memory* v.base) typeinfo.base!elem)))
|
|
|
|
;? (prn "after: " base)
|
2014-10-06 03:03:03 +00:00
|
|
|
(if typeinfo.base!record
|
|
|
|
(do (assert (< -1 idx (len typeinfo.base!elems)))
|
|
|
|
(m `(,(+ v.base
|
|
|
|
(apply + (map sz
|
|
|
|
(firstn idx typeinfo.base!elems))))
|
|
|
|
,typeinfo.base!elems.idx)))
|
|
|
|
(assert nil "get on invalid type @base")))
|
2014-10-05 18:34:23 +00:00
|
|
|
get-address
|
|
|
|
(with (base arg.0
|
|
|
|
idx (v arg.1))
|
2014-10-12 21:27:26 +00:00
|
|
|
(trace "get-address" base "." idx)
|
2014-10-05 22:10:29 +00:00
|
|
|
(when typeinfo.base!address
|
|
|
|
(assert (pos 'deref metadata.base))
|
|
|
|
(= base (list (memory* v.base) typeinfo.base!elem)))
|
2014-10-12 21:27:26 +00:00
|
|
|
(trace "get-address" "after: " base)
|
2014-10-06 03:03:03 +00:00
|
|
|
(if typeinfo.base!record
|
|
|
|
(do (assert (< -1 idx (len typeinfo.base!elems)))
|
|
|
|
(+ v.base
|
|
|
|
(apply + (map sz
|
|
|
|
(firstn idx typeinfo.base!elems)))))
|
|
|
|
(assert nil "get-address on invalid type @base")))
|
|
|
|
index
|
|
|
|
(with (base arg.0 ; integer (non-symbol) memory location including metadata
|
|
|
|
idx (m arg.1))
|
2014-10-07 06:39:13 +00:00
|
|
|
;? (prn "processing index: @base @idx")
|
2014-10-06 03:03:03 +00:00
|
|
|
(when typeinfo.base!address
|
|
|
|
(assert (pos 'deref metadata.base))
|
|
|
|
(= base (list (memory* v.base) typeinfo.base!elem)))
|
2014-10-07 06:39:13 +00:00
|
|
|
;? (prn "after maybe deref: @base @idx")
|
|
|
|
;? (prn Memory-in-use-until ": " memory*)
|
2014-10-06 03:03:03 +00:00
|
|
|
(if typeinfo.base!array
|
|
|
|
(array-ref base idx)
|
|
|
|
(assert nil "get on invalid type @arg.0 => @base")))
|
|
|
|
index-address
|
|
|
|
(with (base arg.0
|
|
|
|
idx (m arg.1))
|
|
|
|
(when typeinfo.base!address
|
|
|
|
(assert (pos 'deref metadata.base))
|
|
|
|
(= base (list (memory* v.base) typeinfo.base!elem)))
|
2014-10-05 18:34:23 +00:00
|
|
|
(if typeinfo.base!array
|
2014-10-06 03:03:03 +00:00
|
|
|
(array-ref-addr base idx)
|
|
|
|
(assert nil "get-address on invalid type @arg.0 => @base")))
|
2014-08-31 18:20:28 +00:00
|
|
|
new
|
|
|
|
(let type (v arg.0)
|
|
|
|
(if types*.type!array
|
2014-10-07 05:58:06 +00:00
|
|
|
(new-array type (m arg.1))
|
2014-08-31 18:20:28 +00:00
|
|
|
(new-scalar type)))
|
2014-10-05 18:32:25 +00:00
|
|
|
sizeof
|
2014-10-12 19:01:04 +00:00
|
|
|
(sizeof (m arg.0))
|
2014-10-05 18:32:25 +00:00
|
|
|
len
|
|
|
|
(let base arg.0
|
|
|
|
(if typeinfo.base!array
|
|
|
|
array-len.base
|
|
|
|
-1))
|
2014-10-05 03:19:12 +00:00
|
|
|
|
2014-10-24 18:38:02 +00:00
|
|
|
; tagged-values require one primitive
|
|
|
|
save-type
|
2014-10-25 09:32:30 +00:00
|
|
|
(annotate 'record `(,(ty arg.0) ,(m arg.0)))
|
2014-10-24 18:38:02 +00:00
|
|
|
|
2014-10-05 03:19:12 +00:00
|
|
|
; multiprocessing
|
|
|
|
run
|
|
|
|
(run (v arg.0))
|
|
|
|
fork
|
|
|
|
(enq (make-context (v arg.0)) contexts*)
|
2014-10-12 19:01:04 +00:00
|
|
|
; todo: errors should stall a process and let its parent
|
|
|
|
; inspect it
|
|
|
|
assert
|
|
|
|
(assert (m arg.0))
|
2014-10-05 03:19:12 +00:00
|
|
|
|
2014-10-05 06:00:19 +00:00
|
|
|
; text interaction
|
|
|
|
cls
|
|
|
|
(do1 nil ($.charterm-clear-screen))
|
|
|
|
cll
|
|
|
|
(do1 nil ($.charterm-clear-line))
|
|
|
|
cursor
|
|
|
|
(do1 nil ($.charterm-cursor (m arg.0) (m arg.1)))
|
2014-10-15 00:27:10 +00:00
|
|
|
print-primitive
|
2014-10-05 17:44:14 +00:00
|
|
|
(do1 nil ((if ($.current-charterm) $.charterm-display pr) (m arg.0)))
|
2014-10-05 06:00:19 +00:00
|
|
|
getc
|
2014-10-08 07:38:08 +00:00
|
|
|
(and ($.charterm-byte-ready?) ($.charterm-read-key))
|
2014-10-05 06:00:19 +00:00
|
|
|
bold-mode
|
|
|
|
(do1 nil ($.charterm-bold))
|
|
|
|
non-bold-mode
|
|
|
|
(do1 nil ($.charterm-normal))
|
2014-10-05 17:44:14 +00:00
|
|
|
console-on
|
2014-10-15 00:21:39 +00:00
|
|
|
(do1 nil (if (no ($.current-charterm)) ($.open-charterm)))
|
2014-10-05 17:44:14 +00:00
|
|
|
console-off
|
|
|
|
(do1 nil (if ($.current-charterm) ($.close-charterm)))
|
2014-10-05 06:00:19 +00:00
|
|
|
|
2014-10-10 22:04:14 +00:00
|
|
|
; user-defined functions
|
|
|
|
arg
|
|
|
|
(let idx (if arg
|
|
|
|
arg.0
|
|
|
|
(do1 caller-arg-idx.context
|
|
|
|
(++ caller-arg-idx.context)))
|
2014-10-11 18:17:04 +00:00
|
|
|
(trace "arg" arg " " idx " " caller-args.context)
|
2014-10-12 17:17:46 +00:00
|
|
|
(if (len> caller-args.context idx)
|
2014-10-12 17:49:08 +00:00
|
|
|
(list (m caller-args.context.idx) t)
|
|
|
|
(list nil nil)))
|
2014-07-31 10:46:05 +00:00
|
|
|
reply
|
2014-08-29 02:23:38 +00:00
|
|
|
(do (pop-stack context)
|
|
|
|
(if empty.context (return ninstrs))
|
|
|
|
(let (caller-oargs _ _) (parse-instr (body.context pc.context))
|
2014-10-13 01:04:29 +00:00
|
|
|
(trace "reply" arg " " caller-oargs)
|
2014-08-28 19:44:01 +00:00
|
|
|
(each (dest src) (zip caller-oargs arg)
|
2014-10-13 01:04:29 +00:00
|
|
|
(trace "reply" src " => " dest)
|
2014-08-28 19:44:01 +00:00
|
|
|
(setm dest (m src))))
|
2014-08-29 02:23:38 +00:00
|
|
|
(++ pc.context)
|
|
|
|
(while (>= pc.context (len body.context))
|
|
|
|
(pop-stack context)
|
2014-10-13 01:04:29 +00:00
|
|
|
(when empty.context (return ninstrs))
|
2014-08-29 02:23:38 +00:00
|
|
|
(++ pc.context))
|
2014-08-28 19:44:01 +00:00
|
|
|
(continue))
|
2014-10-10 22:04:14 +00:00
|
|
|
; else try to call as a user-defined function
|
2014-10-05 18:33:25 +00:00
|
|
|
(do (if function*.op
|
|
|
|
(push-stack context op)
|
|
|
|
(err "no such op @op"))
|
2014-08-28 19:44:01 +00:00
|
|
|
(continue))
|
2014-07-31 10:46:05 +00:00
|
|
|
)
|
2014-08-26 17:17:55 +00:00
|
|
|
; opcode generated some value, stored in 'tmp'
|
2014-10-10 22:04:14 +00:00
|
|
|
; copy to output args
|
2014-08-28 19:44:01 +00:00
|
|
|
;? (prn "store: " tmp " " oarg)
|
2014-07-31 10:46:05 +00:00
|
|
|
(if (acons tmp)
|
|
|
|
(for i 0 (< i (min len.tmp len.oarg)) ++.i
|
|
|
|
(setm oarg.i tmp.i))
|
|
|
|
(when oarg ; must be a list
|
2014-10-11 18:17:04 +00:00
|
|
|
(trace "run" "writing to oarg " tmp " => " oarg.0)
|
2014-07-31 10:46:05 +00:00
|
|
|
(setm oarg.0 tmp)))
|
2014-08-28 19:44:01 +00:00
|
|
|
)
|
2014-08-29 02:23:38 +00:00
|
|
|
(++ pc.context)))
|
2014-08-28 23:47:09 +00:00
|
|
|
(return time-slice)))
|
2014-07-06 07:07:03 +00:00
|
|
|
|
2014-08-26 19:20:08 +00:00
|
|
|
(enq (fn () (= Memory-in-use-until 1000))
|
|
|
|
initialization-fns*)
|
|
|
|
(def new-scalar (type)
|
|
|
|
(ret result Memory-in-use-until
|
|
|
|
(++ Memory-in-use-until sizeof.type)))
|
|
|
|
|
|
|
|
(def new-array (type size)
|
2014-10-07 06:39:13 +00:00
|
|
|
;? (prn "new array: @type @size")
|
2014-08-26 19:20:08 +00:00
|
|
|
(ret result Memory-in-use-until
|
2014-10-07 21:01:58 +00:00
|
|
|
(++ Memory-in-use-until (+ 1 (* (sizeof types*.type!elem) size)))))
|
2014-08-26 19:20:08 +00:00
|
|
|
|
|
|
|
(def sizeof (type)
|
2014-10-12 19:01:04 +00:00
|
|
|
(trace "sizeof" type)
|
2014-08-26 19:20:08 +00:00
|
|
|
(if (~or types*.type!record types*.type!array)
|
|
|
|
types*.type!size
|
|
|
|
types*.type!record
|
|
|
|
(sum idfn
|
|
|
|
(accum yield
|
|
|
|
(each elem types*.type!elems
|
|
|
|
(yield sizeof.elem))))))
|
|
|
|
|
2014-10-10 22:09:16 +00:00
|
|
|
;; desugar structured assembly based on blocks
|
2014-10-10 22:04:14 +00:00
|
|
|
|
2014-07-17 16:02:43 +00:00
|
|
|
(def convert-braces (instrs)
|
|
|
|
(let locs () ; list of information on each brace: (open/close pc)
|
|
|
|
(let pc 0
|
|
|
|
(loop (instrs instrs)
|
|
|
|
(each instr instrs
|
|
|
|
(if (~is 'begin instr.0)
|
|
|
|
(do
|
2014-10-07 20:26:01 +00:00
|
|
|
(trace "cvt0" pc " " instr " -- " locs)
|
2014-07-17 16:02:43 +00:00
|
|
|
(++ pc))
|
2014-07-17 16:21:27 +00:00
|
|
|
; hack: racket replaces curlies with parens, so we need the
|
|
|
|
; keyword begin to delimit blocks.
|
|
|
|
; ultimately there'll be no nesting and curlies will just be in a
|
|
|
|
; line by themselves.
|
2014-07-17 16:02:43 +00:00
|
|
|
(do
|
|
|
|
;? (prn `(open ,pc))
|
|
|
|
(push `(open ,pc) locs)
|
|
|
|
(recur cdr.instr)
|
|
|
|
;? (prn `(close ,pc))
|
|
|
|
(push `(close ,pc) locs))))))
|
|
|
|
(zap rev locs)
|
|
|
|
;? (prn locs)
|
|
|
|
(with (pc 0
|
|
|
|
stack ()) ; elems are pcs
|
|
|
|
(accum yield
|
|
|
|
(loop (instrs instrs)
|
|
|
|
(each instr instrs
|
2014-10-07 20:26:01 +00:00
|
|
|
(point continue
|
2014-07-17 16:02:43 +00:00
|
|
|
(let delim (or (pos '<- instr) -1)
|
|
|
|
(with (oarg (if (>= delim 0)
|
|
|
|
(cut instr 0 delim))
|
|
|
|
op (instr (+ delim 1))
|
|
|
|
arg (cut instr (+ delim 2)))
|
2014-10-07 20:26:01 +00:00
|
|
|
(trace "cvt1" pc " " op " " oarg)
|
2014-07-17 16:02:43 +00:00
|
|
|
(case op
|
|
|
|
begin
|
|
|
|
(do
|
|
|
|
(push pc stack)
|
|
|
|
(assert:is oarg nil)
|
|
|
|
(recur arg)
|
2014-10-07 20:26:01 +00:00
|
|
|
(pop stack)
|
|
|
|
(continue))
|
2014-07-17 16:21:27 +00:00
|
|
|
break
|
|
|
|
(do
|
|
|
|
(assert:is oarg nil)
|
|
|
|
(assert:is arg nil)
|
2014-10-15 00:51:30 +00:00
|
|
|
(yield `(jump (,(close-offset pc locs) offset))))
|
|
|
|
break-if
|
2014-07-17 16:02:43 +00:00
|
|
|
(do
|
2014-10-15 00:51:30 +00:00
|
|
|
;? (prn "break-if: " instr)
|
2014-07-17 16:21:27 +00:00
|
|
|
(assert:is oarg nil)
|
2014-10-15 00:51:30 +00:00
|
|
|
(yield `(jump-if ,arg.0 (,(close-offset pc locs) offset))))
|
2014-10-15 01:24:46 +00:00
|
|
|
break-unless
|
|
|
|
(do
|
|
|
|
;? (prn "break-if: " instr)
|
|
|
|
(assert:is oarg nil)
|
|
|
|
(yield `(jump-unless ,arg.0 (,(close-offset pc locs) offset))))
|
2014-07-17 16:21:27 +00:00
|
|
|
continue
|
|
|
|
(do
|
|
|
|
(assert:is oarg nil)
|
|
|
|
(assert:is arg nil)
|
2014-10-25 09:32:30 +00:00
|
|
|
(yield `(jump (,(- stack.0 1 pc) offset))))
|
2014-10-15 00:51:30 +00:00
|
|
|
continue-if
|
2014-07-17 16:21:27 +00:00
|
|
|
(do
|
2014-10-15 00:51:30 +00:00
|
|
|
(trace "cvt0" "continue-if: " instr " => " (- stack.0 1))
|
2014-07-17 16:21:27 +00:00
|
|
|
(assert:is oarg nil)
|
2014-10-15 00:51:30 +00:00
|
|
|
(yield `(jump-if ,arg.0 (,(- stack.0 1 pc) offset))))
|
2014-10-15 01:24:46 +00:00
|
|
|
continue-unless
|
|
|
|
(do
|
|
|
|
(trace "cvt0" "continue-if: " instr " => " (- stack.0 1))
|
|
|
|
(assert:is oarg nil)
|
|
|
|
(yield `(jump-unless ,arg.0 (,(- stack.0 1 pc) offset))))
|
2014-07-17 16:02:43 +00:00
|
|
|
;else
|
|
|
|
(yield instr))))
|
2014-10-07 20:26:01 +00:00
|
|
|
(++ pc))))))))
|
2014-07-17 16:02:43 +00:00
|
|
|
|
|
|
|
(def close-offset (pc locs)
|
|
|
|
(let close 0
|
|
|
|
(with (stacksize 0
|
|
|
|
done nil)
|
|
|
|
(each (state loc) locs
|
|
|
|
;? (prn " :" close " " state " - " loc)
|
|
|
|
(if (< loc pc)
|
|
|
|
nil ; do nothing
|
|
|
|
(no done)
|
|
|
|
(do
|
|
|
|
; first time
|
|
|
|
(when (and (is 0 stacksize) (~is loc pc))
|
|
|
|
(++ stacksize))
|
|
|
|
(if (is 'open state) (++ stacksize) (-- stacksize))
|
|
|
|
; last time
|
|
|
|
(when (is 0 stacksize)
|
|
|
|
(= close loc)
|
|
|
|
(set done))))))
|
|
|
|
(- close pc 1)))
|
|
|
|
|
2014-10-11 17:09:41 +00:00
|
|
|
;; system software
|
|
|
|
|
|
|
|
(init-fn maybe-coerce
|
2014-10-28 07:29:58 +00:00
|
|
|
((101 tagged-value-address) <- new (tagged-value type))
|
|
|
|
((101 tagged-value-address deref) <- arg)
|
|
|
|
((102 type) <- arg)
|
|
|
|
((103 type) <- get (101 tagged-value-address deref) (0 offset))
|
|
|
|
((104 boolean) <- eq (103 type) (102 type))
|
2014-10-11 17:09:41 +00:00
|
|
|
{ begin
|
2014-10-28 07:29:58 +00:00
|
|
|
(break-if (104 boolean))
|
|
|
|
(reply (0 literal) (nil literal))
|
2014-10-11 17:09:41 +00:00
|
|
|
}
|
2014-10-28 07:29:58 +00:00
|
|
|
((105 location) <- get (101 tagged-value-address deref) (1 offset))
|
|
|
|
(reply (105 location) (104 boolean)))
|
2014-10-11 17:09:41 +00:00
|
|
|
|
2014-10-12 19:01:04 +00:00
|
|
|
(init-fn new-tagged-value
|
2014-10-28 07:29:58 +00:00
|
|
|
((201 type) <- arg)
|
|
|
|
((202 integer) <- sizeof (201 type))
|
|
|
|
((203 boolean) <- eq (202 integer) (1 literal))
|
|
|
|
(assert (203 boolean))
|
2014-10-12 19:01:04 +00:00
|
|
|
; todo: check that arg 0 matches the type? or is that for the future typechecker?
|
2014-10-28 07:29:58 +00:00
|
|
|
((204 tagged-value-address) <- new (tagged-value type))
|
|
|
|
((205 location) <- get-address (204 tagged-value-address deref) (0 offset))
|
|
|
|
((205 location deref) <- copy (201 type))
|
|
|
|
((206 location) <- get-address (204 tagged-value-address deref) (1 offset))
|
|
|
|
((206 location deref) <- arg)
|
|
|
|
(reply (204 tagged-value-address)))
|
2014-10-12 19:01:04 +00:00
|
|
|
|
2014-10-13 01:04:29 +00:00
|
|
|
(init-fn list-next ; list-address -> list-address
|
2014-10-28 07:29:58 +00:00
|
|
|
((301 list-address) <- arg)
|
|
|
|
((302 list-address) <- get (301 list-address deref) (1 offset))
|
|
|
|
(reply (302 list-address)))
|
2014-10-13 01:04:29 +00:00
|
|
|
|
|
|
|
(init-fn list-value-address ; list-address -> tagged-value-address
|
2014-10-28 07:29:58 +00:00
|
|
|
((401 list-address) <- arg)
|
|
|
|
((402 tagged-value-address) <- get-address (401 list-address deref) (0 offset))
|
|
|
|
(reply (402 tagged-value-address)))
|
2014-10-12 21:27:26 +00:00
|
|
|
|
2014-10-25 09:32:30 +00:00
|
|
|
(init-fn new-list
|
2014-10-28 07:29:58 +00:00
|
|
|
((501 list-address) <- new (list type))
|
|
|
|
((502 list-address) <- copy (501 list-address))
|
2014-10-25 09:32:30 +00:00
|
|
|
{ begin
|
2014-10-28 07:29:58 +00:00
|
|
|
((503 integer) (504 boolean) <- arg)
|
|
|
|
(break-unless (504 boolean))
|
|
|
|
((505 list-address-address) <- get-address (502 list-address deref) (1 offset))
|
|
|
|
((505 list-address-address deref) <- new (list type))
|
|
|
|
((502 list-address) <- list-next (502 list-address))
|
|
|
|
((506 tagged-value-address) <- list-value-address (502 list-address))
|
|
|
|
((506 tagged-value-address deref) <- save-type (503 integer))
|
2014-10-25 09:32:30 +00:00
|
|
|
(continue)
|
|
|
|
}
|
2014-10-28 07:29:58 +00:00
|
|
|
((501 list-address) <- list-next (501 list-address)) ; memory leak
|
|
|
|
(reply (501 list-address)))
|
2014-10-25 09:32:30 +00:00
|
|
|
|
2014-10-11 17:09:41 +00:00
|
|
|
; drop all traces while processing above functions
|
|
|
|
(on-init
|
|
|
|
(= traces* (queue)))
|
|
|
|
|
2014-10-29 04:17:40 +00:00
|
|
|
(def prn2 (msg . args)
|
|
|
|
(pr msg)
|
|
|
|
(apply prn args))
|
|
|
|
|
2014-10-10 22:09:16 +00:00
|
|
|
;; after loading all files, start at 'main'
|
2014-08-22 18:05:51 +00:00
|
|
|
(reset)
|
2014-07-06 08:41:37 +00:00
|
|
|
(awhen cdr.argv
|
2014-07-27 17:09:00 +00:00
|
|
|
(map add-fns:readfile it)
|
2014-08-28 19:44:01 +00:00
|
|
|
(run 'main)
|
2014-10-05 17:44:14 +00:00
|
|
|
(if ($.current-charterm) ($.close-charterm))
|
2014-07-06 07:07:03 +00:00
|
|
|
(prn memory*))
|