; things that a future assembler will need separate memory for:
; code; types; args channel
(= initialization-fns* (queue))
(def reset ()
(each f (as cons initialization-fns*)
(f)))
(mac init-fn (name . body)
`(enq (fn () (= (function* ',name) ',body))
initialization-fns*))
(mac on-init body
`(enq (fn () (run ',body))
initialization-fns*))
(def clear ()
(= types* (obj
; must be scalar or array, sum or product or primitive
type (obj size 5 record t elems '(integer boolean boolean boolean type-array))
location (obj size 1)
integer (obj size 1)
boolean (obj size 1)
; 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))
custodian (obj size 1 record t elems '(integer))
))
(= memory* (table))
(= function* (table)))
(enq clear initialization-fns*)
(def add-fns (fns)
(each (name . body) fns
(= function*.name body)))
(def v (operand) ; for value
operand.0)
(def metadata (operand)
cdr.operand)
(def ty (operand)
operand.1) ; assume type is always first bit of metadata, and it's always present
(def typeinfo (operand)
(types* ty.operand))
(def sz (operand)
;? (prn "sz " operand)
; todo: override this for arrays
typeinfo.operand!size)
(defextend sz (typename) (isa typename 'sym)
types*.typename!size)
(mac addr (loc)
`(let loc@ ,loc
(if (pos 'deref (metadata loc@))
(memory* (v loc@))
(v loc@))))
(def addrs (n sz)
(accum yield
(repeat sz
(yield n)
(++ n))))
(mac m (loc) ; read memory, respecting metadata
`(let loc@ ,loc
;? (prn "m " loc@ sz.loc@)
(if (is 1 sz.loc@)
(memory* (addr loc@))
(annotate 'record
(map memory* (addrs (addr loc@) sz.loc@))))))
(mac setm (loc val) ; set memory, respecting metadata
`(with (loc@ ,loc
val@ ,val)
;? (prn "setm " loc@ " " val@)
(if (is 1 sz.loc@)
(= (memory* (addr loc@)) val@)
(each (dest@ src@) (zip (addrs (addr loc@) sz.loc@)
(rep val@))
(= (memory* dest@) src@)))))
(def array-len (operand)
(m `(,v.operand integer)))
(def array-ref (operand idx)
(assert typeinfo.operand!array)
(assert (< -1 idx (array-len operand)))
(withs (elem typeinfo.operand!elem
offset (+ 1 (* idx sz.elem)))
(m `(,(+ v.operand offset) ,elem))))
(def run (instrs (o fn-args) (o fn-oargs))
(ret result nil
(with (ninstrs 0 fn-arg-idx 0)
;? (prn instrs)
(for pc 0 (< pc len.instrs) (do ++.ninstrs ++.pc)
;? (if (> ninstrs 10) (break))
(let instr instrs.pc
;? (prn memory*)
;? (prn pc ": " instr)
(let delim (or (pos '<- instr) -1)
(with (oarg (if (>= delim 0)
(cut instr 0 delim))
op (instr (+ delim 1))
arg (cut instr (+ delim 2)))
;? (prn op " " oarg)
(let tmp
(case op
literal
arg.0
add
;? (do (prn "add " (m arg.0) (m arg.1))
(+ (m arg.0) (m arg.1))
;? (prn "add2"))
sub
(- (m arg.0) (m arg.1))
mul
(* (m arg.0) (m arg.1))
div
(/ (real (m arg.0)) (m arg.1))
idiv
(list
(trunc:/ (m arg.0) (m arg.1))
(mod (m arg.0) (m arg.1)))
and
(and (m arg.0) (m arg.1))
or
(or (m arg.0) (m arg.1))
not
(not (m arg.0))
eq
(is (m arg.0) (m arg.1))
neq
(~is (m arg.0) (m arg.1))
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))
arg
(let idx (if arg
arg.0
(do1 fn-arg-idx
++.fn-arg-idx))
(m fn-args.idx))
type
(ty (fn-args arg.0))
otype
(ty (fn-oargs arg.0))
jmp
(do (= pc (+ pc (v arg.0)))
;? (prn "jumping to " pc)
(continue))
jif
(when (is t (m arg.0))
(= pc (+ pc (v arg.1)))
;? (prn "jumping to " pc)
(continue))
copy
(m arg.0)
get
(with (base arg.0 ; integer (non-symbol) memory location including metadata
idx (v arg.1)) ; literal integer
(if
typeinfo.base!array
(do (assert (is 0 idx)) ; 'get' can only lookup array length
(array-len base))
typeinfo.base!record
; field index
(do (assert (< -1 idx (len typeinfo.base!elems)))
(m `(,(+ v.base
(apply + (map sz
(firstn idx typeinfo.base!elems))))
,typeinfo.base!elems.idx)))
'else
(assert nil "get on invalid type @base")))
aref
(array-ref arg.0 (v arg.1))
reply
(do (= result arg)
(break))
; else user-defined function
(let-or new-body function*.op (prn "no definition for " op)
;? (prn "== " memory*)
(let results (run new-body arg oarg)
;? (prn "=> " oarg " " results)
(each o oarg
;? (prn o)
(setm o (m pop.results))))
(continue))
)
; opcode generated some value, stored in 'tmp'
;? (prn tmp " " oarg)
(if (acons tmp)
(for i 0 (< i (min len.tmp len.oarg)) ++.i
(setm oarg.i tmp.i))
(when oarg ; must be a list
;? (prn oarg.0)
(setm oarg.0 tmp)))
)))))
;? (prn "return " result)
)))
(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
;? (prn pc " " instr)
(++ pc))
; 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.
(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
(let delim (or (pos '<- instr) -1)
(with (oarg (if (>= delim 0)
(cut instr 0 delim))
op (instr (+ delim 1))
arg (cut instr (+ delim 2)))
;? (prn op " " oarg)
(case op
begin
(do
(push pc stack)
(assert:is oarg nil)
(recur arg)
(pop stack))
break
(do
(assert:is oarg nil)
(assert:is arg nil)
(yield `(jmp (,(close-offset pc locs) offset))))
breakif
(do
;? (prn "breakif: " instr)
(assert:is oarg nil)
(yield `(jif ,arg.0 (,(close-offset pc locs) offset))))
continue
(do
(assert:is oarg nil)
(assert:is arg nil)
(yield `(jmp (,(- stack.0 pc) offset))))
continueif
(do
;? (prn "continueif: " instr)
(assert:is oarg nil)
(yield `(jif ,arg.0 (,(- stack.0 pc) offset))))
;else
(yield instr))))
(++ pc)))))))
(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)))
(reset)
(awhen cdr.argv
(map add-fns:readfile it)
(run function*!main)
(prn memory*))