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-11-27 08:34:29 +00:00
|
|
|
`(enq (fn ()
|
|
|
|
;? (prn ',name)
|
|
|
|
(= (function* ',name) (convert-names:convert-braces:insert-code ',body ',name)))
|
2014-10-10 22:04:14 +00:00
|
|
|
initialization-fns*))
|
|
|
|
|
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*
|
|
|
|
(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)
|
2014-11-22 08:58:13 +00:00
|
|
|
;? (prn "new-trace " filename)
|
2014-11-25 05:40:59 +00:00
|
|
|
;? )
|
2014-10-07 17:26:14 +00:00
|
|
|
(= 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-11-01 04:16:17 +00:00
|
|
|
(when (or (is dump-trace* t)
|
2014-11-21 22:40:03 +00:00
|
|
|
(and dump-trace* (is label "-"))
|
2014-11-06 18:21:15 +00:00
|
|
|
(and dump-trace* (pos label dump-trace*!whitelist))
|
|
|
|
(and dump-trace* (no dump-trace*!whitelist) (~pos label dump-trace*!blacklist)))
|
2014-11-01 00:35:24 +00:00
|
|
|
(apply prn label ": " args))
|
2014-08-29 03:42:15 +00:00
|
|
|
(enq (list label (apply tostring:prn args))
|
|
|
|
traces*))
|
|
|
|
|
2014-11-21 22:40:03 +00:00
|
|
|
(redef tr args ; why am I still returning to prn when debugging? Will this help?
|
|
|
|
(do1 nil
|
|
|
|
(apply trace "-" args)))
|
|
|
|
|
2014-11-22 02:21:15 +00:00
|
|
|
(def tr2 (msg arg)
|
|
|
|
(tr msg arg)
|
|
|
|
arg)
|
|
|
|
|
2014-08-29 03:42:15 +00:00
|
|
|
(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-11-25 05:56:12 +00:00
|
|
|
;; virtual machine state
|
|
|
|
|
|
|
|
; things that a future assembler will need separate memory for:
|
|
|
|
; code; types; args channel
|
|
|
|
(def clear ()
|
|
|
|
(= types* (table))
|
|
|
|
(= memory* (table))
|
2014-11-27 09:07:28 +00:00
|
|
|
(= function* (table))
|
2014-11-27 13:24:24 +00:00
|
|
|
)
|
2014-11-25 05:56:12 +00:00
|
|
|
(enq clear initialization-fns*)
|
|
|
|
|
|
|
|
(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 elem 'boolean)
|
|
|
|
byte (obj size 1)
|
2014-11-27 08:34:29 +00:00
|
|
|
byte-address (obj size 1 address t elem 'byte)
|
2014-11-27 06:26:55 +00:00
|
|
|
string (obj array t elem 'byte) ; inspired by Go
|
2014-11-27 06:48:48 +00:00
|
|
|
string-address (obj size 1 address t elem 'string)
|
2014-11-25 05:56:12 +00:00
|
|
|
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-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) 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 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) 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 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 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)
|
|
|
|
)))
|
2014-07-06 07:07:03 +00:00
|
|
|
|
2014-11-06 18:22:33 +00:00
|
|
|
;; managing concurrent routines
|
2014-11-06 23:24:00 +00:00
|
|
|
|
|
|
|
; routine = runtime state for a serial thread of execution
|
2014-11-19 08:19:57 +00:00
|
|
|
(def make-routine (fn-name . args)
|
2014-11-06 23:24:00 +00:00
|
|
|
(annotate 'routine (obj call-stack (list
|
2014-11-19 08:19:57 +00:00
|
|
|
(obj fn-name fn-name pc 0 args args caller-arg-idx 0)))))
|
2014-11-06 23:24:00 +00:00
|
|
|
|
|
|
|
(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))
|
|
|
|
|
2014-11-22 03:29:37 +00:00
|
|
|
(def waiting-for-exact-cycle? (routine)
|
2014-11-22 04:20:12 +00:00
|
|
|
(is 'literal rep.routine!sleep.1))
|
2014-11-22 03:29:37 +00:00
|
|
|
|
2014-11-22 04:25:41 +00:00
|
|
|
(def ready-to-wake-up (routine)
|
|
|
|
(assert no.routine*)
|
|
|
|
(if (is 'literal rep.routine!sleep.1)
|
|
|
|
(> curr-cycle* rep.routine!sleep.0)
|
2014-11-23 16:47:19 +00:00
|
|
|
(~is rep.routine!sleep.1 (memory* rep.routine!sleep.0))))
|
2014-11-22 04:25:41 +00:00
|
|
|
|
2014-11-06 18:22:33 +00:00
|
|
|
(on-init
|
2014-11-21 22:36:22 +00:00
|
|
|
(= running-routines* (queue)) ; simple round-robin scheduler
|
2014-11-06 23:38:00 +00:00
|
|
|
; set of sleeping routines; don't modify routines while they're in this table
|
|
|
|
(= sleeping-routines* (table))
|
2014-11-21 22:36:22 +00:00
|
|
|
(= completed-routines* nil) ; audit trail
|
2014-11-06 18:22:33 +00:00
|
|
|
(= routine* nil)
|
2014-11-06 19:36:16 +00:00
|
|
|
(= abort-routine* (parameter nil))
|
2014-11-06 23:24:16 +00:00
|
|
|
(= curr-cycle* 0)
|
|
|
|
(= scheduling-interval* 500)
|
2014-11-23 15:19:14 +00:00
|
|
|
(= scheduler-switch-table* nil) ; hook into scheduler for tests
|
2014-11-06 23:24:16 +00:00
|
|
|
)
|
2014-11-06 18:22:33 +00:00
|
|
|
|
|
|
|
; 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
|
2014-11-25 06:24:22 +00:00
|
|
|
(freeze-functions)
|
2014-11-27 07:23:44 +00:00
|
|
|
(= traces* (queue))
|
2014-11-06 19:36:16 +00:00
|
|
|
(each it fn-names
|
|
|
|
(enq make-routine.it running-routines*))
|
2014-11-21 22:36:22 +00:00
|
|
|
(while (~empty running-routines*)
|
2014-11-06 19:36:16 +00:00
|
|
|
(= routine* deq.running-routines*)
|
|
|
|
(trace "schedule" top.routine*!fn-name)
|
2014-11-21 22:36:22 +00:00
|
|
|
(routine-mark
|
|
|
|
(run-for-time-slice scheduling-interval*))
|
2014-11-22 03:29:37 +00:00
|
|
|
(update-scheduler-state)
|
|
|
|
;? (tr "after run iter " running-routines*)
|
|
|
|
;? (tr "after run iter " empty.running-routines*)
|
|
|
|
))
|
2014-11-21 22:36:22 +00:00
|
|
|
|
|
|
|
; 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 ()
|
2014-11-22 07:43:27 +00:00
|
|
|
;? (trace "schedule" curr-cycle*)
|
2014-11-22 02:31:48 +00:00
|
|
|
(when routine*
|
|
|
|
(if
|
|
|
|
rep.routine*!sleep
|
|
|
|
(do (trace "schedule" "pushing " top.routine*!fn-name " to sleep queue")
|
|
|
|
(set sleeping-routines*.routine*))
|
|
|
|
(~empty routine*)
|
2014-11-22 03:31:30 +00:00
|
|
|
(do (trace "schedule" "scheduling " top.routine*!fn-name " for further processing")
|
2014-11-22 02:31:48 +00:00
|
|
|
(enq routine* running-routines*))
|
|
|
|
:else
|
2014-11-22 08:47:05 +00:00
|
|
|
(do (trace "schedule" "done with routine")
|
2014-11-22 02:31:48 +00:00
|
|
|
(push routine* completed-routines*)))
|
|
|
|
(= routine* nil))
|
2014-11-22 03:29:37 +00:00
|
|
|
(each (routine _) canon.sleeping-routines*
|
2014-11-22 04:25:41 +00:00
|
|
|
(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*)))
|
2014-11-22 03:29:37 +00:00
|
|
|
(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*)
|
2014-11-22 04:47:48 +00:00
|
|
|
(update-scheduler-state))))
|
|
|
|
(detect-deadlock))
|
2014-11-21 22:36:22 +00:00
|
|
|
|
2014-11-08 05:39:00 +00:00
|
|
|
(def detect-deadlock ()
|
2014-11-22 07:43:27 +00:00
|
|
|
(when (and (empty running-routines*)
|
|
|
|
(~empty sleeping-routines*)
|
2014-11-08 05:39:00 +00:00
|
|
|
(~some 'literal (map (fn(_) rep._!sleep.1)
|
|
|
|
keys.sleeping-routines*)))
|
|
|
|
(each (routine _) sleeping-routines*
|
|
|
|
(wipe sleeping-routines*.routine)
|
|
|
|
(= rep.routine!error "deadlock detected")
|
2014-11-22 04:47:48 +00:00
|
|
|
(push routine completed-routines*))))
|
2014-11-08 05:39:00 +00:00
|
|
|
|
2014-11-06 18:22:33 +00:00
|
|
|
(def die (msg)
|
|
|
|
(= rep.routine*!error msg)
|
|
|
|
(= rep.routine*!stack-trace rep.routine*!call-stack)
|
|
|
|
(wipe rep.routine*!call-stack)
|
|
|
|
((abort-routine*)))
|
|
|
|
|
|
|
|
;; running a single routine
|
2014-11-07 19:56:34 +00:00
|
|
|
(def nondummy (operand) ; precondition for helpers below
|
|
|
|
(~is '_ operand))
|
|
|
|
|
2014-10-29 07:18:58 +00:00
|
|
|
(mac 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)
|
2014-11-01 09:16:16 +00:00
|
|
|
(or (types* ty.operand)
|
2014-11-07 08:59:23 +00:00
|
|
|
(err "unknown type @(tostring prn.operand)")))
|
2014-08-22 02:55:16 +00:00
|
|
|
|
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)
|
2014-11-01 00:50:38 +00:00
|
|
|
(do (assert typeinfo.operand!address "tried to deref non-address @operand")
|
2014-10-11 18:17:04 +00:00
|
|
|
(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-11-04 21:34:59 +00:00
|
|
|
(trace "addr" loc)
|
2014-10-30 05:39:53 +00:00
|
|
|
(ret result v.loc
|
2014-11-04 21:34:59 +00:00
|
|
|
(trace "addr" "initial result: " result)
|
2014-10-31 00:39:41 +00:00
|
|
|
(unless (pos 'global metadata.loc)
|
2014-11-22 04:25:41 +00:00
|
|
|
;? (tr "aa " routine*)
|
2014-10-31 23:11:12 +00:00
|
|
|
(whenlet base rep.routine*!call-stack.0!default-scope
|
2014-10-31 00:39:41 +00:00
|
|
|
(if (< result memory*.base)
|
2014-11-04 21:34:59 +00:00
|
|
|
(do (trace "addr" "incrementing by " base)
|
|
|
|
(++ result base))
|
|
|
|
(die "addr: no room for var @result"))))
|
2014-11-22 04:25:41 +00:00
|
|
|
;? (tr "mm")
|
2014-10-30 07:41:09 +00:00
|
|
|
(when (pos 'deref metadata.loc)
|
2014-11-04 21:34:59 +00:00
|
|
|
(trace "addr" "deref " result " => " memory*.result)
|
2014-11-22 04:25:41 +00:00
|
|
|
(zap memory* result))
|
|
|
|
;? (tr "zz")
|
|
|
|
))
|
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-29 17:29:30 +00:00
|
|
|
(point return
|
2014-10-31 00:21:47 +00:00
|
|
|
(if (in ty.loc 'literal 'offset)
|
2014-10-29 17:29:30 +00:00
|
|
|
(return v.loc))
|
2014-11-01 00:35:24 +00:00
|
|
|
(when (is v.loc 'default-scope)
|
|
|
|
(return rep.routine*!call-stack.0!default-scope))
|
2014-11-01 04:04:22 +00:00
|
|
|
(trace "m" loc)
|
|
|
|
(assert (isa v.loc 'int) "addresses must be numeric (problem in convert-names?) @loc")
|
2014-11-22 04:21:26 +00:00
|
|
|
(with (n sz.loc
|
|
|
|
addr addr.loc)
|
2014-11-22 04:25:41 +00:00
|
|
|
;? (trace "m" "reading " n " locations starting at " addr)
|
2014-11-22 04:21:26 +00:00
|
|
|
(if (is 1 n)
|
|
|
|
(memory* addr)
|
|
|
|
:else
|
|
|
|
(annotate 'record
|
|
|
|
(map memory* (addrs addr n)))))))
|
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-29 17:33:43 +00:00
|
|
|
(point return
|
|
|
|
(when (is v.loc 'default-scope)
|
2014-11-01 00:50:38 +00:00
|
|
|
(assert (is 1 sz.loc) "can't store compounds in default-scope @loc")
|
2014-10-31 23:11:12 +00:00
|
|
|
(= rep.routine*!call-stack.0!default-scope val)
|
2014-10-29 17:33:43 +00:00
|
|
|
(return))
|
2014-11-01 00:50:38 +00:00
|
|
|
(assert (isa v.loc 'int) "can't store to non-numeric address (problem in convert-names?)")
|
2014-10-29 17:33:43 +00:00
|
|
|
(trace "setm" loc " <= " val)
|
2014-11-04 21:34:59 +00:00
|
|
|
(with (n sz.loc
|
|
|
|
addr addr.loc)
|
2014-10-29 17:33:43 +00:00
|
|
|
(trace "setm" "size of " loc " is " n)
|
2014-11-01 00:50:38 +00:00
|
|
|
(assert n "setm: can't compute type of @loc")
|
2014-11-04 21:34:59 +00:00
|
|
|
(assert addr "setm: null pointer @loc")
|
2014-10-29 17:33:43 +00:00
|
|
|
(if (is 1 n)
|
2014-11-22 08:58:13 +00:00
|
|
|
(do (assert (~isa val 'record) "setm: record of size 1 @(tostring prn.val)")
|
2014-11-04 21:34:59 +00:00
|
|
|
(trace "setm" loc ": setting " addr " to " val)
|
|
|
|
(= (memory* addr) val))
|
2014-11-01 22:06:24 +00:00
|
|
|
(do (assert (isa val 'record) "setm: non-record of size >1 @val")
|
2014-11-04 21:34:59 +00:00
|
|
|
(each (dest src) (zip (addrs addr n)
|
2014-10-29 17:33:43 +00:00
|
|
|
(rep val))
|
2014-11-04 21:34:59 +00:00
|
|
|
(trace "setm" loc ": setting " dest " to " src)
|
2014-10-29 17:33:43 +00:00
|
|
|
(= (memory* dest) src)))))))
|
2014-07-31 09:27:41 +00:00
|
|
|
|
2014-11-01 04:07:47 +00:00
|
|
|
; (operand field-offset) -> (base-addr field-type)
|
|
|
|
; operand can be a deref address
|
|
|
|
; operand can be scope-based
|
|
|
|
; base-addr returned is always global
|
|
|
|
(def record-info (operand field-offset)
|
2014-11-04 21:34:59 +00:00
|
|
|
(trace "record-info" operand " " field-offset)
|
2014-11-01 04:07:47 +00:00
|
|
|
(assert (is 'offset (ty field-offset)) "record index @field-offset must have type 'offset'")
|
|
|
|
(with (base addr.operand
|
|
|
|
basetype typeinfo.operand
|
|
|
|
idx (v field-offset))
|
2014-11-04 21:34:59 +00:00
|
|
|
(trace "record-info" "initial base " base " type " canon.basetype)
|
2014-11-01 04:07:47 +00:00
|
|
|
(when (pos 'deref metadata.operand)
|
2014-11-01 09:17:23 +00:00
|
|
|
(assert basetype!address "@operand requests deref, but it's not an address of a record")
|
2014-11-04 21:34:59 +00:00
|
|
|
(= basetype (types* basetype!elem))
|
|
|
|
(trace "record-info" operand " requests deref => " canon.basetype))
|
2014-11-01 04:07:47 +00:00
|
|
|
(assert basetype!record "get on non-record @operand")
|
2014-11-01 09:17:23 +00:00
|
|
|
(assert (< -1 idx (len basetype!elems)) "@idx is out of bounds of record @operand")
|
2014-11-01 04:07:47 +00:00
|
|
|
(list (+ base (apply + (map sz (firstn idx basetype!elems))))
|
|
|
|
basetype!elems.idx)))
|
|
|
|
|
2014-11-01 09:23:32 +00:00
|
|
|
(def array-info (operand offset)
|
2014-11-04 21:34:59 +00:00
|
|
|
(trace "array-info" operand " " offset)
|
2014-11-01 09:23:32 +00:00
|
|
|
(with (base addr.operand
|
|
|
|
basetype typeinfo.operand
|
|
|
|
idx (m offset))
|
2014-11-04 21:34:59 +00:00
|
|
|
(trace "array-info" "initial base " base " type " canon.basetype)
|
2014-11-01 09:23:32 +00:00
|
|
|
(when (pos 'deref metadata.operand)
|
|
|
|
(assert basetype!address "@operand requests deref, but it's not an address of an array")
|
2014-11-04 21:34:59 +00:00
|
|
|
(= basetype (types* basetype!elem))
|
|
|
|
(trace "array-info" operand " requests deref => " canon.basetype))
|
2014-11-01 09:23:32 +00:00
|
|
|
(assert basetype!array "index on non-array @operand")
|
2014-11-04 21:34:59 +00:00
|
|
|
(let array-len array-len.operand
|
|
|
|
(trace "array-info" "array-len of " operand " is " array-len)
|
|
|
|
(assert array-len "can't compute array-len of @operand")
|
|
|
|
(unless (< -1 idx array-len)
|
|
|
|
(die "@idx is out of bounds of array @operand")))
|
2014-11-01 09:23:32 +00:00
|
|
|
(list (+ base
|
|
|
|
1 ; for array size
|
|
|
|
(* idx (sz basetype!elem)))
|
|
|
|
basetype!elem)))
|
2014-08-22 02:55:16 +00:00
|
|
|
|
2014-11-01 09:28:00 +00:00
|
|
|
(def array-len (operand)
|
2014-11-04 21:34:59 +00:00
|
|
|
(trace "array-len" operand)
|
2014-11-01 09:28:00 +00:00
|
|
|
(if typeinfo.operand!array
|
|
|
|
(m `(,v.operand integer))
|
|
|
|
(and typeinfo.operand!address (pos 'deref metadata.operand))
|
|
|
|
(m `(,v.operand integer-address ,@(cut operand 2)))
|
|
|
|
:else
|
|
|
|
(err "can't take len of non-array @operand")))
|
|
|
|
|
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)))
|
|
|
|
|
2014-10-05 03:18:55 +00:00
|
|
|
($:require "charterm/main.rkt")
|
|
|
|
|
2014-10-29 17:26:25 +00:00
|
|
|
(def run-for-time-slice (time-slice)
|
2014-08-28 23:40:28 +00:00
|
|
|
(point return
|
2014-08-28 23:47:09 +00:00
|
|
|
(for ninstrs 0 (< ninstrs time-slice) (++ ninstrs)
|
2014-10-29 20:05:08 +00:00
|
|
|
(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*))
|
2014-11-06 19:36:16 +00:00
|
|
|
(++ curr-cycle*)
|
2014-11-05 02:33:07 +00:00
|
|
|
(trace "run" "-- " int-canon.memory*)
|
2014-11-06 19:36:16 +00:00
|
|
|
(trace "run" curr-cycle* " " top.routine*!fn-name " " pc.routine* ": " (body.routine* pc.routine*))
|
2014-11-01 00:35:24 +00:00
|
|
|
;? (trace "run" routine*)
|
2014-11-23 06:26:11 +00:00
|
|
|
(when (atom (body.routine* pc.routine*)) ; label
|
2014-11-23 15:19:14 +00:00
|
|
|
(when (aand scheduler-switch-table*
|
|
|
|
(alref it (body.routine* pc.routine*)))
|
|
|
|
(++ pc.routine*)
|
|
|
|
(trace "run" "context-switch forced " abort-routine*)
|
|
|
|
((abort-routine*)))
|
2014-11-23 06:26:11 +00:00
|
|
|
(++ pc.routine*)
|
|
|
|
(continue))
|
2014-10-29 20:05:08 +00:00
|
|
|
(let (oarg op arg) (parse-instr (body.routine* pc.routine*))
|
2014-11-18 18:53:33 +00:00
|
|
|
(let results
|
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-10-29 20:05:08 +00:00
|
|
|
(do (= pc.routine* (+ 1 pc.routine* (v arg.0)))
|
2014-11-07 20:33:12 +00:00
|
|
|
(trace "jump" "jumping to " pc.routine*)
|
2014-07-31 10:46:05 +00:00
|
|
|
(continue))
|
2014-10-15 00:51:30 +00:00
|
|
|
jump-if
|
2014-11-07 20:33:12 +00:00
|
|
|
(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)))
|
2014-10-15 01:24:46 +00:00
|
|
|
jump-unless ; convenient helper
|
2014-11-07 20:33:12 +00:00
|
|
|
(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)))
|
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-11-01 04:07:47 +00:00
|
|
|
(let (addr type) (record-info arg.0 arg.1)
|
2014-11-04 21:34:59 +00:00
|
|
|
(trace "get" arg.0 " " arg.1 " => " addr " " type)
|
2014-11-01 04:07:47 +00:00
|
|
|
(m `(,addr ,type global)))
|
2014-10-05 18:34:23 +00:00
|
|
|
get-address
|
2014-11-01 04:07:47 +00:00
|
|
|
(let (addr _) (record-info arg.0 arg.1)
|
2014-11-04 21:34:59 +00:00
|
|
|
(trace "get-address" arg.0 " " arg.1 " => " addr)
|
2014-11-01 04:07:47 +00:00
|
|
|
addr)
|
2014-10-06 03:03:03 +00:00
|
|
|
index
|
2014-11-01 09:23:32 +00:00
|
|
|
(let (addr type) (array-info arg.0 arg.1)
|
2014-11-04 21:34:59 +00:00
|
|
|
(trace "index" arg.0 " " arg.1 " => " addr " " type)
|
2014-11-01 09:23:32 +00:00
|
|
|
(m `(,addr ,type global)))
|
2014-10-06 03:03:03 +00:00
|
|
|
index-address
|
2014-11-01 09:23:32 +00:00
|
|
|
(let (addr _) (array-info arg.0 arg.1)
|
2014-11-04 21:34:59 +00:00
|
|
|
(trace "index-address" arg.0 " " arg.1 " => " addr)
|
2014-11-01 09:23:32 +00:00
|
|
|
addr)
|
2014-08-31 18:20:28 +00:00
|
|
|
new
|
2014-11-27 06:43:51 +00:00
|
|
|
(if (isa arg.0 'string)
|
|
|
|
; special-case: allocate space for a literal string
|
|
|
|
(new-string arg.0)
|
|
|
|
(let type (v arg.0)
|
|
|
|
(assert (is 'literal (ty arg.0)) "new: second arg @arg.0 must be literal")
|
|
|
|
(if (no types*.type) (err "no such type @type"))
|
|
|
|
; todo: initialize memory. currently racket does it for us
|
|
|
|
(if types*.type!array
|
|
|
|
(new-array type (m arg.1))
|
|
|
|
(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
|
2014-11-01 09:16:16 +00:00
|
|
|
(if (or typeinfo.base!array typeinfo.base!address)
|
2014-10-05 18:32:25 +00:00
|
|
|
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
|
2014-11-19 08:27:10 +00:00
|
|
|
(enq (apply make-routine (v car.arg) (map m cdr.arg)) running-routines*)
|
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-11-06 23:38:00 +00:00
|
|
|
sleep
|
2014-11-07 03:05:20 +00:00
|
|
|
(let operand arg.0
|
2014-11-23 16:47:19 +00:00
|
|
|
; store sleep as either (<cycle number> literal) or (<location> <current value>)
|
2014-11-07 03:12:56 +00:00
|
|
|
(if (is ty.operand 'literal)
|
|
|
|
(let delay v.operand
|
|
|
|
(trace "run" "sleeping until " (+ curr-cycle* delay))
|
|
|
|
(= rep.routine*!sleep `(,(+ curr-cycle* delay) literal)))
|
2014-11-22 07:43:27 +00:00
|
|
|
(do
|
|
|
|
;? (tr "blocking on " operand " -> " (addr operand))
|
2014-11-23 16:47:19 +00:00
|
|
|
(= rep.routine*!sleep `(,addr.operand ,m.operand))))
|
2014-11-07 03:05:20 +00:00
|
|
|
((abort-routine*)))
|
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
|
2014-11-27 14:16:02 +00:00
|
|
|
(do (when arg
|
|
|
|
(assert (is '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))))
|
2014-10-31 23:22:21 +00:00
|
|
|
prepare-reply
|
2014-10-31 23:24:17 +00:00
|
|
|
(prepare-reply arg)
|
2014-07-31 10:46:05 +00:00
|
|
|
reply
|
2014-10-31 23:24:17 +00:00
|
|
|
(do (when arg
|
|
|
|
(prepare-reply arg))
|
2014-10-31 23:18:13 +00:00
|
|
|
(let results results.routine*
|
2014-10-29 20:05:08 +00:00
|
|
|
(pop-stack routine*)
|
2014-10-31 23:18:13 +00:00
|
|
|
(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)
|
2014-11-07 19:56:34 +00:00
|
|
|
(when nondummy.dest
|
2014-11-07 19:50:41 +00:00
|
|
|
(trace "reply" val " => " dest)
|
|
|
|
(setm dest val))))
|
2014-10-31 23:18:13 +00:00
|
|
|
(++ pc.routine*)
|
|
|
|
(while (>= pc.routine* (len body.routine*))
|
|
|
|
(pop-stack routine*)
|
|
|
|
(when empty.routine* (return ninstrs))
|
|
|
|
(++ pc.routine*))
|
|
|
|
(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
|
2014-11-01 00:35:24 +00:00
|
|
|
(let callee-args (accum yield
|
|
|
|
(each a arg
|
|
|
|
(yield (m a))))
|
|
|
|
(push-stack routine* op)
|
|
|
|
(= caller-args.routine* callee-args))
|
2014-10-05 18:33:25 +00:00
|
|
|
(err "no such op @op"))
|
2014-08-28 19:44:01 +00:00
|
|
|
(continue))
|
2014-07-31 10:46:05 +00:00
|
|
|
)
|
2014-11-18 18:53:33 +00:00
|
|
|
; opcode generated some 'results'
|
2014-10-10 22:04:14 +00:00
|
|
|
; copy to output args
|
2014-11-18 18:53:33 +00:00
|
|
|
(if (acons results)
|
|
|
|
(each (dest val) (zip oarg results)
|
2014-11-07 19:57:45 +00:00
|
|
|
(unless (is dest '_)
|
2014-11-18 19:02:22 +00:00
|
|
|
(trace "run" val " => " dest)
|
2014-11-07 19:57:45 +00:00
|
|
|
(setm dest val)))
|
2014-07-31 10:46:05 +00:00
|
|
|
(when oarg ; must be a list
|
2014-11-18 18:58:51 +00:00
|
|
|
(trace "run" results " => " oarg.0)
|
2014-11-18 18:53:33 +00:00
|
|
|
(setm oarg.0 results)))
|
2014-08-28 19:44:01 +00:00
|
|
|
)
|
2014-10-29 20:05:08 +00:00
|
|
|
(++ pc.routine*)))
|
2014-08-28 23:47:09 +00:00
|
|
|
(return time-slice)))
|
2014-07-06 07:07:03 +00:00
|
|
|
|
2014-10-31 23:24:17 +00:00
|
|
|
(def prepare-reply (args)
|
|
|
|
(= results.routine*
|
|
|
|
(accum yield
|
|
|
|
(each a args
|
|
|
|
(yield (m a))))))
|
|
|
|
|
2014-08-26 19:20:08 +00:00
|
|
|
(enq (fn () (= Memory-in-use-until 1000))
|
|
|
|
initialization-fns*)
|
2014-11-27 06:43:51 +00:00
|
|
|
|
2014-08-26 19:20:08 +00:00
|
|
|
(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-30 05:39:21 +00:00
|
|
|
(++ Memory-in-use-until (+ 1 (* (sizeof types*.type!elem) size)))
|
|
|
|
(= (memory* result) size)))
|
2014-08-26 19:20:08 +00:00
|
|
|
|
2014-11-27 06:43:51 +00:00
|
|
|
(def new-string (literal-string)
|
|
|
|
(ret result Memory-in-use-until
|
|
|
|
(= memory*.Memory-in-use-until len.literal-string)
|
|
|
|
(++ Memory-in-use-until)
|
|
|
|
(each c literal-string
|
|
|
|
(= memory*.Memory-in-use-until c)
|
|
|
|
(++ Memory-in-use-until))))
|
|
|
|
|
2014-08-26 19:20:08 +00:00
|
|
|
(def sizeof (type)
|
2014-10-12 19:01:04 +00:00
|
|
|
(trace "sizeof" type)
|
2014-11-07 22:09:59 +00:00
|
|
|
(assert types*.type "sizeof: no such type @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
|
2014-10-29 17:27:28 +00:00
|
|
|
(yield sizeof.elem))))
|
|
|
|
:else
|
2014-11-04 06:47:57 +00:00
|
|
|
(err "sizeof can't handle @type (arrays require a specific variable)")))
|
2014-08-26 19:20:08 +00:00
|
|
|
|
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
|
2014-11-23 06:26:11 +00:00
|
|
|
(if (or atom.instr (~is 'begin instr.0)) ; label or regular instruction
|
|
|
|
(do
|
|
|
|
(trace "c{0" pc " " instr " -- " locs)
|
|
|
|
(++ pc))
|
|
|
|
; hack: racket replaces curlies with parens, so we need the
|
2014-11-25 02:52:15 +00:00
|
|
|
; keyword 'begin' to delimit blocks.
|
|
|
|
; ultimately there'll be no nesting and curlies will just be
|
|
|
|
; in an instr by themselves.
|
2014-11-23 06:26:11 +00:00
|
|
|
:else ; brace
|
|
|
|
(do
|
|
|
|
(push `(open ,pc) locs)
|
|
|
|
(recur cdr.instr)
|
|
|
|
(push `(close ,pc) locs))))))
|
2014-07-17 16:02:43 +00:00
|
|
|
(zap rev 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-11-23 06:26:11 +00:00
|
|
|
(when (atom instr) ; label
|
|
|
|
(yield instr)
|
2014-11-23 14:06:04 +00:00
|
|
|
(++ pc)
|
2014-11-23 06:26:11 +00:00
|
|
|
(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-11-07 19:31:46 +00:00
|
|
|
(trace "c{1" pc " " op " " oarg)
|
2014-07-17 16:02:43 +00:00
|
|
|
(case op
|
|
|
|
begin
|
|
|
|
(do
|
|
|
|
(push pc stack)
|
2014-11-01 00:50:38 +00:00
|
|
|
(assert (is oarg nil) "begin: can't take oarg @instr")
|
2014-07-17 16:02:43 +00:00
|
|
|
(recur arg)
|
2014-10-07 20:26:01 +00:00
|
|
|
(pop stack)
|
|
|
|
(continue))
|
2014-07-17 16:21:27 +00:00
|
|
|
break
|
|
|
|
(do
|
2014-11-01 00:50:38 +00:00
|
|
|
(assert (is oarg nil) "break: can't take oarg @instr")
|
|
|
|
(assert (is arg nil) "break: can't take arg @instr")
|
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-11-01 00:50:38 +00:00
|
|
|
(assert (is oarg nil) "break-if: can't take oarg @instr")
|
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
|
2014-11-01 00:50:38 +00:00
|
|
|
(assert (is oarg nil) "break-unless: can't take oarg @instr")
|
2014-10-15 01:24:46 +00:00
|
|
|
(yield `(jump-unless ,arg.0 (,(close-offset pc locs) offset))))
|
2014-11-27 06:09:23 +00:00
|
|
|
loop
|
2014-07-17 16:21:27 +00:00
|
|
|
(do
|
2014-11-27 06:09:23 +00:00
|
|
|
(assert (is oarg nil) "loop: can't take oarg @instr")
|
|
|
|
(assert (is arg nil) "loop: can't take arg @instr")
|
2014-10-25 09:32:30 +00:00
|
|
|
(yield `(jump (,(- stack.0 1 pc) offset))))
|
2014-11-27 06:09:23 +00:00
|
|
|
loop-if
|
2014-07-17 16:21:27 +00:00
|
|
|
(do
|
2014-11-27 06:09:23 +00:00
|
|
|
(trace "cvt0" "loop-if: " instr " => " (- stack.0 1))
|
|
|
|
(assert (is oarg nil) "loop-if: can't take oarg @instr")
|
2014-10-15 00:51:30 +00:00
|
|
|
(yield `(jump-if ,arg.0 (,(- stack.0 1 pc) offset))))
|
2014-11-27 06:09:23 +00:00
|
|
|
loop-unless
|
2014-10-15 01:24:46 +00:00
|
|
|
(do
|
2014-11-27 06:09:23 +00:00
|
|
|
(trace "cvt0" "loop-if: " instr " => " (- stack.0 1))
|
|
|
|
(assert (is oarg nil) "loop-unless: can't take oarg @instr")
|
2014-10-15 01:24:46 +00:00
|
|
|
(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)
|
2014-11-23 14:12:15 +00:00
|
|
|
(point return
|
2014-11-23 14:06:04 +00:00
|
|
|
;? (tr "close " pc " " locs)
|
2014-11-23 14:12:15 +00:00
|
|
|
(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 -1 stacksize)
|
|
|
|
;? (tr "close now " loc)
|
|
|
|
(return (- loc pc 1))))))))
|
2014-07-17 16:02:43 +00:00
|
|
|
|
2014-11-07 19:59:22 +00:00
|
|
|
;; convert symbolic names to raw memory locations
|
2014-10-29 07:18:58 +00:00
|
|
|
|
|
|
|
(def convert-names (instrs)
|
2014-11-07 19:59:22 +00:00
|
|
|
(with (location (table)
|
2014-11-04 06:34:58 +00:00
|
|
|
isa-field (table))
|
2014-10-29 07:18:58 +00:00
|
|
|
(let idx 1
|
|
|
|
(each instr instrs
|
2014-11-23 06:26:11 +00:00
|
|
|
(point continue
|
|
|
|
(when atom.instr
|
|
|
|
(continue))
|
2014-11-07 19:59:22 +00:00
|
|
|
(trace "cn0" instr " " canon.location " " canon.isa-field)
|
2014-10-29 07:18:58 +00:00
|
|
|
(let (oargs op args) (parse-instr instr)
|
2014-11-04 06:34:58 +00:00
|
|
|
(if (in op 'get 'get-address)
|
2014-11-04 07:58:06 +00:00
|
|
|
(with (basetype (typeinfo args.0)
|
2014-11-04 06:34:58 +00:00
|
|
|
field (v args.1))
|
2014-11-07 22:09:59 +00:00
|
|
|
(assert basetype "no such type @args.0")
|
2014-11-07 19:50:41 +00:00
|
|
|
(trace "cn0" "field-access " field)
|
2014-11-04 21:43:57 +00:00
|
|
|
; todo: need to rename args.0 as well?
|
2014-11-04 07:58:06 +00:00
|
|
|
(when (pos 'deref (metadata args.0))
|
2014-11-07 19:50:41 +00:00
|
|
|
(trace "cn0" "field-access deref")
|
2014-11-04 07:58:06 +00:00
|
|
|
(assert basetype!address "@args.0 requests deref, but it's not an address of a record")
|
|
|
|
(= basetype (types* basetype!elem)))
|
2014-11-04 06:34:58 +00:00
|
|
|
(when (isa field 'sym)
|
2014-11-07 19:59:22 +00:00
|
|
|
(assert (or (~location field) isa-field.field) "field @args.1 is also a variable")
|
|
|
|
(when (~location field)
|
|
|
|
(trace "cn0" "new field; computing location")
|
2014-11-07 08:56:42 +00:00
|
|
|
(assert basetype!fields "no field names available for @instr")
|
|
|
|
(iflet idx (pos field basetype!fields)
|
|
|
|
(do (set isa-field.field)
|
2014-11-07 20:01:20 +00:00
|
|
|
(trace "cn0" "field location @idx")
|
2014-11-07 19:59:22 +00:00
|
|
|
(= location.field idx))
|
2014-11-07 08:56:42 +00:00
|
|
|
(assert nil "couldn't find field in @instr")))))
|
2014-11-04 06:34:58 +00:00
|
|
|
(each arg args
|
|
|
|
(assert (~isa-field v.arg) "arg @arg is also a field name")
|
2014-11-27 13:24:24 +00:00
|
|
|
(when (maybe-add arg location idx)
|
2014-11-07 19:50:41 +00:00
|
|
|
(err "use before set: @arg"))))
|
2014-10-29 07:18:58 +00:00
|
|
|
(each arg oargs
|
2014-11-07 19:50:41 +00:00
|
|
|
(trace "cn0" "checking " arg)
|
|
|
|
(unless (is arg '_)
|
|
|
|
(assert (~isa-field v.arg) "oarg @arg is also a field name")
|
2014-11-07 19:59:22 +00:00
|
|
|
(when (maybe-add arg location idx)
|
2014-11-07 19:50:41 +00:00
|
|
|
(trace "cn0" "location for arg " arg ": " idx)
|
2014-11-27 08:34:29 +00:00
|
|
|
; todo: can't allocate arrays on the stack
|
2014-11-23 06:26:11 +00:00
|
|
|
(++ idx (sizeof ty.arg)))))))))
|
2014-11-07 19:59:22 +00:00
|
|
|
(trace "cn1" "update names " canon.location " " canon.isa-field)
|
2014-10-29 07:18:58 +00:00
|
|
|
(each instr instrs
|
2014-11-23 06:26:11 +00:00
|
|
|
(when (acons instr)
|
|
|
|
(let (oargs op args) (parse-instr instr)
|
|
|
|
(each arg args
|
|
|
|
(when (and nondummy.arg (location v.arg))
|
|
|
|
(zap location v.arg)))
|
|
|
|
(each arg oargs
|
|
|
|
(when (and nondummy.arg (location v.arg))
|
|
|
|
(zap location v.arg))))))
|
2014-10-29 07:18:58 +00:00
|
|
|
instrs))
|
|
|
|
|
2014-11-07 19:59:22 +00:00
|
|
|
(def maybe-add (arg location idx)
|
2014-11-07 19:50:41 +00:00
|
|
|
(trace "maybe-add" arg)
|
2014-11-07 19:56:34 +00:00
|
|
|
(when (and nondummy.arg
|
2014-11-07 19:50:41 +00:00
|
|
|
(~in ty.arg 'literal 'offset 'fn)
|
2014-11-07 19:59:22 +00:00
|
|
|
(~location v.arg)
|
2014-11-04 06:38:28 +00:00
|
|
|
(isa v.arg 'sym)
|
|
|
|
(~in v.arg 'nil 'default-scope)
|
|
|
|
(~pos 'global metadata.arg))
|
2014-11-07 19:59:22 +00:00
|
|
|
(= (location v.arg) idx)))
|
2014-10-29 07:18:58 +00:00
|
|
|
|
2014-10-29 15:55:00 +00:00
|
|
|
;; literate tangling system for reordering code
|
|
|
|
|
|
|
|
(def convert-quotes (instrs)
|
|
|
|
(let deferred (queue)
|
|
|
|
(each instr instrs
|
2014-11-25 02:56:15 +00:00
|
|
|
(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))))))
|
2014-10-29 15:55:00 +00:00
|
|
|
(accum yield
|
|
|
|
(each instr instrs
|
2014-11-25 02:56:15 +00:00
|
|
|
(unless (and acons.instr
|
|
|
|
(in instr.0 'defer)) ; keep sync'd with case clauses above
|
2014-10-29 15:55:00 +00:00
|
|
|
(yield instr)))
|
|
|
|
(each instr (as cons deferred)
|
|
|
|
(yield instr)))))
|
|
|
|
|
2014-11-25 03:27:52 +00:00
|
|
|
(on-init
|
|
|
|
(= before* (table)) ; label -> queue of fragments
|
|
|
|
(= after* (table))) ; label -> list of fragments
|
|
|
|
|
2014-11-25 05:40:59 +00:00
|
|
|
; see add-code below for adding to before* and after*
|
2014-11-25 03:27:52 +00:00
|
|
|
|
2014-11-27 05:36:14 +00:00
|
|
|
(def insert-code (instrs (o name))
|
2014-11-25 06:05:56 +00:00
|
|
|
(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)
|
2014-11-27 05:36:14 +00:00
|
|
|
(each fragment (as cons (or (and name (before* (sym:string name '/ instr)))
|
|
|
|
before*.instr))
|
2014-11-25 06:05:56 +00:00
|
|
|
(each instr fragment
|
|
|
|
(yield instr)))
|
|
|
|
(yield instr)
|
2014-11-27 05:36:14 +00:00
|
|
|
(each fragment (or (and name (after* (sym:string name '/ instr)))
|
|
|
|
after*.instr)
|
2014-11-25 06:05:56 +00:00
|
|
|
(each instr fragment
|
|
|
|
(yield instr)))))))))
|
2014-11-25 03:27:52 +00:00
|
|
|
|
2014-10-11 17:09:41 +00:00
|
|
|
;; system software
|
|
|
|
|
|
|
|
(init-fn maybe-coerce
|
2014-11-01 00:35:24 +00:00
|
|
|
((default-scope scope-address) <- new (scope literal) (30 literal))
|
|
|
|
((x tagged-value-address) <- new (tagged-value literal))
|
|
|
|
((x tagged-value-address deref) <- arg)
|
|
|
|
((p type) <- arg)
|
|
|
|
((xtype type) <- get (x tagged-value-address deref) (0 offset))
|
|
|
|
((match? boolean) <- eq (xtype type) (p type))
|
2014-10-11 17:09:41 +00:00
|
|
|
{ begin
|
2014-11-01 00:35:24 +00:00
|
|
|
(break-if (match? boolean))
|
2014-10-28 07:29:58 +00:00
|
|
|
(reply (0 literal) (nil literal))
|
2014-10-11 17:09:41 +00:00
|
|
|
}
|
2014-11-01 00:35:24 +00:00
|
|
|
((xvalue location) <- get (x tagged-value-address deref) (1 offset))
|
|
|
|
(reply (xvalue location) (match? boolean)))
|
2014-10-11 17:09:41 +00:00
|
|
|
|
2014-10-12 19:01:04 +00:00
|
|
|
(init-fn new-tagged-value
|
2014-11-01 00:35:24 +00:00
|
|
|
((default-scope scope-address) <- new (scope literal) (30 literal))
|
2014-11-18 12:35:39 +00:00
|
|
|
; assert (sizeof arg.0) == 1
|
2014-11-01 00:35:24 +00:00
|
|
|
((xtype type) <- arg)
|
|
|
|
((xtypesize integer) <- sizeof (xtype type))
|
|
|
|
((xcheck boolean) <- eq (xtypesize integer) (1 literal))
|
|
|
|
(assert (xcheck 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-11-01 00:35:24 +00:00
|
|
|
((result tagged-value-address) <- new (tagged-value literal))
|
2014-11-18 12:35:39 +00:00
|
|
|
; result->type = arg 0
|
|
|
|
((resulttype location) <- get-address (result tagged-value-address deref) (type offset))
|
2014-11-01 00:35:24 +00:00
|
|
|
((resulttype location deref) <- copy (xtype type))
|
2014-11-18 12:35:39 +00:00
|
|
|
; result->payload = arg 1
|
|
|
|
((locaddr location) <- get-address (result tagged-value-address deref) (payload offset))
|
2014-11-01 00:35:24 +00:00
|
|
|
((locaddr location deref) <- arg)
|
|
|
|
(reply (result 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-11-01 00:35:24 +00:00
|
|
|
((default-scope scope-address) <- new (scope literal) (30 literal))
|
|
|
|
((base list-address) <- arg)
|
2014-11-18 12:35:39 +00:00
|
|
|
((result list-address) <- get (base list-address deref) (cdr offset))
|
2014-11-01 00:35:24 +00:00
|
|
|
(reply (result list-address)))
|
2014-10-13 01:04:29 +00:00
|
|
|
|
|
|
|
(init-fn list-value-address ; list-address -> tagged-value-address
|
2014-11-01 00:35:24 +00:00
|
|
|
((default-scope scope-address) <- new (scope literal) (30 literal))
|
|
|
|
((base list-address) <- arg)
|
2014-11-18 12:35:39 +00:00
|
|
|
((result tagged-value-address) <- get-address (base list-address deref) (car offset))
|
2014-11-01 00:35:24 +00:00
|
|
|
(reply (result tagged-value-address)))
|
2014-10-12 21:27:26 +00:00
|
|
|
|
2014-10-25 09:32:30 +00:00
|
|
|
(init-fn new-list
|
2014-11-01 00:35:24 +00:00
|
|
|
((default-scope scope-address) <- new (scope literal) (30 literal))
|
2014-11-18 12:35:39 +00:00
|
|
|
; new-list = curr = new list
|
2014-11-01 00:35:24 +00:00
|
|
|
((new-list-result list-address) <- new (list literal))
|
|
|
|
((curr list-address) <- copy (new-list-result list-address))
|
2014-10-25 09:32:30 +00:00
|
|
|
{ begin
|
2014-11-18 12:35:39 +00:00
|
|
|
; while read curr-value
|
2014-11-01 00:35:24 +00:00
|
|
|
((curr-value integer) (exists? boolean) <- arg)
|
|
|
|
(break-unless (exists? boolean))
|
2014-11-18 12:35:39 +00:00
|
|
|
; curr.cdr = new list
|
|
|
|
((next list-address-address) <- get-address (curr list-address deref) (cdr offset))
|
2014-11-01 00:35:24 +00:00
|
|
|
((next list-address-address deref) <- new (list literal))
|
2014-11-18 12:35:39 +00:00
|
|
|
; curr = curr.cdr
|
2014-11-01 00:35:24 +00:00
|
|
|
((curr list-address) <- list-next (curr list-address))
|
2014-11-18 12:35:39 +00:00
|
|
|
; curr.car = (type curr-value)
|
2014-11-01 00:35:24 +00:00
|
|
|
((dest tagged-value-address) <- list-value-address (curr list-address))
|
|
|
|
((dest tagged-value-address deref) <- save-type (curr-value integer))
|
2014-11-27 06:09:23 +00:00
|
|
|
(loop)
|
2014-10-25 09:32:30 +00:00
|
|
|
}
|
2014-11-18 12:35:39 +00:00
|
|
|
; return new-list.cdr
|
2014-11-01 00:35:24 +00:00
|
|
|
((new-list-result list-address) <- list-next (new-list-result list-address)) ; memory leak
|
|
|
|
(reply (new-list-result list-address)))
|
2014-10-25 09:32:30 +00:00
|
|
|
|
2014-11-04 08:01:57 +00:00
|
|
|
(init-fn new-channel
|
|
|
|
((default-scope scope-address) <- new (scope literal) (30 literal))
|
2014-11-18 12:35:39 +00:00
|
|
|
; result = new channel
|
2014-11-04 08:01:57 +00:00
|
|
|
((result channel-address) <- new (channel literal))
|
2014-11-18 12:35:39 +00:00
|
|
|
; result.first-full = 0
|
2014-11-04 08:01:57 +00:00
|
|
|
((full integer-address) <- get-address (result channel-address deref) (first-full offset))
|
|
|
|
((full integer-address deref) <- copy (0 literal))
|
2014-11-18 12:35:39 +00:00
|
|
|
; result.first-free = 0
|
2014-11-04 08:01:57 +00:00
|
|
|
((free integer-address) <- get-address (result channel-address deref) (first-free offset))
|
|
|
|
((free integer-address deref) <- copy (0 literal))
|
2014-11-18 12:35:39 +00:00
|
|
|
; result.circular-buffer = new tagged-value[arg+1]
|
|
|
|
((capacity integer) <- arg)
|
|
|
|
((capacity integer) <- add (capacity integer) (1 literal)) ; unused slot for full? below
|
2014-11-04 08:01:57 +00:00
|
|
|
((channel-buffer-address tagged-value-array-address-address) <- get-address (result channel-address deref) (circular-buffer offset))
|
2014-11-18 12:35:39 +00:00
|
|
|
((channel-buffer-address tagged-value-array-address-address deref) <- new (tagged-value-array literal) (capacity integer))
|
2014-11-04 08:01:57 +00:00
|
|
|
(reply (result channel-address)))
|
|
|
|
|
2014-11-18 12:39:24 +00:00
|
|
|
(init-fn capacity
|
|
|
|
((default-scope scope-address) <- new (scope literal) (30 literal))
|
|
|
|
((chan channel) <- arg)
|
|
|
|
((q tagged-value-array-address) <- get (chan channel) (circular-buffer offset))
|
|
|
|
((qlen integer) <- len (q tagged-value-array-address deref))
|
|
|
|
(reply (qlen integer)))
|
|
|
|
|
2014-11-04 21:46:31 +00:00
|
|
|
(init-fn write
|
|
|
|
((default-scope scope-address) <- new (scope literal) (30 literal))
|
2014-11-22 08:31:31 +00:00
|
|
|
((chan channel-address) <- arg)
|
2014-11-04 21:46:31 +00:00
|
|
|
((val tagged-value) <- arg)
|
2014-11-08 05:39:00 +00:00
|
|
|
{ begin
|
2014-11-08 18:31:37 +00:00
|
|
|
; block if chan is full
|
2014-11-22 08:31:31 +00:00
|
|
|
((full boolean) <- full? (chan channel-address deref))
|
2014-11-08 05:39:00 +00:00
|
|
|
(break-unless (full boolean))
|
2014-11-23 16:47:19 +00:00
|
|
|
((full-address integer-address) <- get-address (chan channel-address deref) (first-full offset))
|
|
|
|
(sleep (full-address integer-address deref))
|
2014-11-08 05:39:00 +00:00
|
|
|
}
|
2014-11-23 03:50:21 +00:00
|
|
|
; store val
|
2014-11-22 08:31:31 +00:00
|
|
|
((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))
|
2014-11-04 21:46:31 +00:00
|
|
|
((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))
|
2014-11-23 03:50:21 +00:00
|
|
|
; increment free
|
2014-11-04 21:46:31 +00:00
|
|
|
((free integer-address deref) <- add (free integer-address deref) (1 literal))
|
2014-11-07 20:33:12 +00:00
|
|
|
{ begin
|
2014-11-23 03:50:21 +00:00
|
|
|
; wrap free around to 0 if necessary
|
2014-11-07 20:33:12 +00:00
|
|
|
((qlen integer) <- len (q tagged-value-array-address deref))
|
|
|
|
((remaining? boolean) <- lt (free integer-address deref) (qlen integer))
|
|
|
|
(break-if (remaining? boolean))
|
|
|
|
((free integer-address deref) <- copy (0 literal))
|
|
|
|
}
|
2014-11-22 08:31:31 +00:00
|
|
|
(reply (chan channel-address deref)))
|
2014-11-04 21:46:31 +00:00
|
|
|
|
2014-11-05 02:35:13 +00:00
|
|
|
(init-fn read
|
|
|
|
((default-scope scope-address) <- new (scope literal) (30 literal))
|
2014-11-22 08:31:31 +00:00
|
|
|
((chan channel-address) <- arg)
|
2014-11-08 05:39:00 +00:00
|
|
|
{ begin
|
2014-11-08 18:31:37 +00:00
|
|
|
; block if chan is empty
|
2014-11-22 08:31:31 +00:00
|
|
|
((empty boolean) <- empty? (chan channel-address deref))
|
2014-11-08 05:39:00 +00:00
|
|
|
(break-unless (empty boolean))
|
2014-11-23 16:47:19 +00:00
|
|
|
((free-address integer-address) <- get-address (chan channel-address deref) (first-free offset))
|
|
|
|
(sleep (free-address integer-address deref))
|
2014-11-08 05:39:00 +00:00
|
|
|
}
|
2014-11-23 03:50:21 +00:00
|
|
|
; read result
|
2014-11-22 08:31:31 +00:00
|
|
|
((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))
|
2014-11-05 02:35:13 +00:00
|
|
|
((result tagged-value) <- index (q tagged-value-array-address deref) (full integer-address deref))
|
2014-11-23 03:50:21 +00:00
|
|
|
; increment full
|
2014-11-05 02:35:13 +00:00
|
|
|
((full integer-address deref) <- add (full integer-address deref) (1 literal))
|
2014-11-07 20:33:12 +00:00
|
|
|
{ begin
|
2014-11-23 03:50:21 +00:00
|
|
|
; wrap full around to 0 if necessary
|
2014-11-07 20:33:12 +00:00
|
|
|
((qlen integer) <- len (q tagged-value-array-address deref))
|
|
|
|
((remaining? boolean) <- lt (full integer-address deref) (qlen integer))
|
|
|
|
(break-if (remaining? boolean))
|
|
|
|
((full integer-address deref) <- copy (0 literal))
|
|
|
|
}
|
2014-11-22 08:31:31 +00:00
|
|
|
(reply (result tagged-value) (chan channel-address deref)))
|
2014-11-05 02:35:13 +00:00
|
|
|
|
2014-11-07 22:09:59 +00:00
|
|
|
; 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))
|
2014-11-18 12:35:39 +00:00
|
|
|
; return arg.first-full == arg.first-free
|
2014-11-07 22:09:59 +00:00
|
|
|
((chan channel) <- arg)
|
|
|
|
((full integer) <- get (chan channel) (first-full offset))
|
|
|
|
((free integer) <- get (chan channel) (first-free offset))
|
|
|
|
((result boolean) <- eq (full integer) (free integer))
|
|
|
|
(reply (result boolean)))
|
|
|
|
|
2014-11-08 18:31:37 +00:00
|
|
|
; 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)
|
2014-11-07 22:09:59 +00:00
|
|
|
(init-fn full?
|
|
|
|
((default-scope scope-address) <- new (scope literal) (30 literal))
|
|
|
|
((chan channel) <- arg)
|
2014-11-18 12:35:39 +00:00
|
|
|
; curr = chan.first-free + 1
|
2014-11-07 22:09:59 +00:00
|
|
|
((curr integer) <- get (chan channel) (first-free offset))
|
|
|
|
((curr integer) <- add (curr integer) (1 literal))
|
|
|
|
{ begin
|
2014-11-18 12:35:39 +00:00
|
|
|
; if (curr == chan.capacity) curr = 0
|
2014-11-18 12:39:24 +00:00
|
|
|
((qlen integer) <- capacity (chan channel))
|
2014-11-07 22:09:59 +00:00
|
|
|
((remaining? boolean) <- lt (curr integer) (qlen integer))
|
|
|
|
(break-if (remaining? boolean))
|
|
|
|
((curr integer) <- copy (0 literal))
|
|
|
|
}
|
2014-11-18 12:35:39 +00:00
|
|
|
; return chan.first-full == curr
|
|
|
|
((full integer) <- get (chan channel) (first-full offset))
|
2014-11-07 22:09:59 +00:00
|
|
|
((result boolean) <- eq (full integer) (curr integer))
|
|
|
|
(reply (result boolean)))
|
|
|
|
|
2014-11-27 08:34:29 +00:00
|
|
|
(init-fn strcat
|
|
|
|
((default-scope scope-address) <- new (scope literal) (30 literal))
|
|
|
|
; result = new string[a.length + b.length]
|
|
|
|
((a string-address) <- arg)
|
|
|
|
((a-len integer) <- len (a string-address deref))
|
|
|
|
((b string-address) <- arg)
|
|
|
|
((b-len integer) <- len (b string-address deref))
|
|
|
|
((result-len integer) <- add (a-len integer) (b-len integer))
|
|
|
|
((result string-address) <- new (string literal) (result-len integer))
|
|
|
|
; result-idx = i = 0
|
|
|
|
((result-idx integer) <- copy (0 literal))
|
|
|
|
; copy a into result
|
|
|
|
((i integer) <- copy (0 literal))
|
|
|
|
{ begin
|
|
|
|
; while (i < a.length)
|
|
|
|
((a-done? boolean) <- lt (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) <- lt (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)))
|
|
|
|
|
2014-11-04 21:34:59 +00:00
|
|
|
(def canon (table)
|
2014-11-07 05:44:16 +00:00
|
|
|
(sort (compare < [tostring (prn:car _)]) (as cons table)))
|
2014-11-04 21:34:59 +00:00
|
|
|
|
2014-11-05 02:33:07 +00:00
|
|
|
(def int-canon (table)
|
|
|
|
(sort (compare < car) (as cons table)))
|
|
|
|
|
2014-11-25 05:56:12 +00:00
|
|
|
;; loading code into the virtual machine
|
|
|
|
|
|
|
|
(def add-code (forms)
|
|
|
|
(each (op . rest) forms
|
|
|
|
(case op
|
2014-11-25 05:59:22 +00:00
|
|
|
; syntax: def <name> [ <instructions> ]
|
2014-11-25 06:44:42 +00:00
|
|
|
; don't apply our lightweight tools just yet
|
|
|
|
def!
|
2014-11-25 05:56:12 +00:00
|
|
|
(let (name (_make-br-fn body)) rest
|
|
|
|
(assert (is 'make-br-fn _make-br-fn))
|
2014-11-25 06:24:22 +00:00
|
|
|
(= function*.name body))
|
2014-11-25 06:44:42 +00:00
|
|
|
def
|
|
|
|
(let (name (_make-br-fn body)) rest
|
|
|
|
(assert (is 'make-br-fn _make-br-fn))
|
|
|
|
(= function*.name (join body function*.name)))
|
2014-11-25 05:59:22 +00:00
|
|
|
|
|
|
|
; syntax: before <label> [ <instructions> ]
|
|
|
|
;
|
2014-11-25 05:56:12 +00:00
|
|
|
; 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))
|
2014-11-25 05:59:22 +00:00
|
|
|
|
|
|
|
; syntax: after <label> [ <instructions> ]
|
|
|
|
;
|
2014-11-25 05:56:12 +00:00
|
|
|
; 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))
|
2014-11-27 09:07:28 +00:00
|
|
|
(push fragment after*.label))
|
|
|
|
)))
|
|
|
|
|
2014-11-25 06:24:22 +00:00
|
|
|
(def freeze-functions ()
|
|
|
|
(each (name body) canon.function*
|
|
|
|
;? (prn keys.before* " -- " keys.after*)
|
|
|
|
;? (= function*.name (convert-names:convert-braces:prn:insert-code body)))
|
2014-11-27 05:36:14 +00:00
|
|
|
(= function*.name (convert-names:convert-braces:insert-code body name))))
|
2014-11-25 06:24:22 +00:00
|
|
|
|
2014-11-25 06:13:39 +00:00
|
|
|
;; load all provided files and start at 'main'
|
2014-08-22 18:05:51 +00:00
|
|
|
(reset)
|
2014-07-06 08:41:37 +00:00
|
|
|
(awhen cdr.argv
|
2014-11-25 05:09:07 +00:00
|
|
|
(map add-code:readfile it)
|
2014-11-25 09:25:20 +00:00
|
|
|
;? (= dump-trace* (obj whitelist '("run" "schedule" "add")))
|
2014-11-27 03:11:14 +00:00
|
|
|
;? (freeze-functions)
|
|
|
|
;? (prn function*!factorial)
|
2014-08-28 19:44:01 +00:00
|
|
|
(run 'main)
|
2014-10-05 17:44:14 +00:00
|
|
|
(if ($.current-charterm) ($.close-charterm))
|
2014-11-01 23:34:33 +00:00
|
|
|
(prn memory*)
|
|
|
|
;? (prn completed-routines*)
|
|
|
|
)
|