(ero "initializing mu.. (takes ~5s)") ;; profiler (http://arclanguage.org/item?id=11556) ; Keeping this right on top as a reminder to profile before guessing at why my ; program is slow. (mac proc (name params . body) `(def ,name ,params ,@body nil)) (mac filter-log (msg f x) `(ret x@ ,x (prn ,msg (,f x@)))) (= times* (table)) (mac deftimed (name args . body) `(do (def ,(sym (string name "_core")) ,args ,@body) (def ,name ,args (let t0 (msec) (ret ans ,(cons (sym (string name "_core")) args) (update-time ,(string name) t0)))))) (proc update-time(name t0) ; call directly in recursive functions (or= times*.name (list 0 0)) (with ((a b) times*.name timing (- (msec) t0)) (= times*.name (list (+ a timing) (+ b 1))))) (def print-times() (prn (current-process-milliseconds)) (prn "gc " (current-gc-milliseconds)) (each (name time) (tablist times*) (prn name " " time))) ;; what happens when our virtual machine starts up (= initialization-fns* (queue)) (def reset () (each f (as cons initialization-fns*) (f))) (mac on-init body `(enq (fn () ,@body) initialization-fns*)) ;; persisting and checking traces for each test (= traces* (queue)) (= trace-dir* ".traces/") (ensure-dir trace-dir*) (= curr-trace-file* nil) (on-init (awhen curr-trace-file* (tofile (+ trace-dir* it) (each (label trace) (as cons traces*) (pr label ": " trace)))) (= curr-trace-file* nil) (= traces* (queue))) (def new-trace (filename) (prn "== @filename") ;? ) (= curr-trace-file* filename)) (= dump-trace* nil) (def trace (label . args) (when (or (is dump-trace* t) (and dump-trace* (is label "-")) (and dump-trace* (pos label dump-trace*!whitelist)) (and dump-trace* (no dump-trace*!whitelist) (~pos label dump-trace*!blacklist))) (apply prn label ": " args)) (enq (list label (apply tostring:prn args)) traces*) (car args)) (on-init (wipe dump-trace*)) (redef tr args ; why am I still returning to prn when debugging? Will this help? (do1 nil (apply trace "-" args))) (def tr2 (msg arg) (tr msg arg) arg) (def check-trace-contents (msg expected-contents) (unless (trace-contents-match expected-contents) (prn "F - " msg) (prn " trace contents") (print-trace-contents-mismatch expected-contents))) (def trace-contents-match (expected-contents) (each (label msg) (as cons traces*) (when (and expected-contents (is label expected-contents.0.0) (posmatch expected-contents.0.1 msg)) (pop expected-contents))) (no expected-contents)) (def print-trace-contents-mismatch (expected-contents) (each (label msg) (as cons traces*) (whenlet (expected-label expected-msg) expected-contents.0 (if (and (is label expected-label) (posmatch expected-msg msg)) (do (pr " * ") (pop expected-contents)) (pr " ")) (pr label ": " msg))) (prn " couldn't find") (each (expected-label expected-msg) expected-contents (prn " ! " expected-label ": " expected-msg))) (def check-trace-doesnt-contain (msg (label unexpected-contents)) (when (some (fn ((l s)) (and (is l label) (posmatch unexpected-contents msg))) (as cons traces*)) (prn "F - " msg) (prn " trace contents") (each (l msg) (as cons traces*) (if (and (is l label) (posmatch unexpected-contents msg)) (pr " X ") (pr " ")) (pr label ": " msg)))) ;; virtual machine state ; things that a future assembler will need separate memory for: ; code; types; args channel ; at compile time: mapping names to locations (on-init (= type* (table)) ; name -> type info (= memory* (table)) ; address -> value (make this a vector?) (= function* (table)) ; name -> [instructions] ; transforming mu programs (= location* (table)) ; function -> {name -> index into default-space} (= next-space-generator* (table)) ; function -> name of function generating next space ; each function's next space will usually always come from a single function (= next-routine-id* 0) (= continuation* (table)) ) (on-init (= type* (obj ; Each type must be scalar or array, sum or product or primitive type (obj size 1) ; implicitly scalar and primitive type-address (obj size 1 address t elem '(type)) type-array (obj array t elem '(type)) type-array-address (obj size 1 address t elem '(type-array)) location (obj size 1 address t elem '(location)) ; assume it points to an atom integer (obj size 1) boolean (obj size 1) boolean-address (obj size 1 address t elem '(boolean)) byte (obj size 1) byte-address (obj size 1 address t elem '(byte)) string (obj array t elem '(byte)) ; inspired by Go ; an address contains the location of a specific type string-address (obj size 1 address t elem '(string)) string-address-address (obj size 1 address t elem '(string-address)) string-address-array (obj array t elem '(string-address)) string-address-array-address (obj size 1 address t elem '(string-address-array)) string-address-array-address-address (obj size 1 address t elem '(string-address-array-address)) ; 'character' will be of larger size when mu supports unicode ; we're currently undisciplined about mixing 'byte' and 'character' ; realistic test of indiscipline in general character (obj size 1) ; int32 like a Go rune character-address (obj size 1 address t elem '(character)) ; a buffer makes it easy to append to a string/array ; todo: make this generic ; data isn't a 'real' array: its length is stored outside it, ; so for example, 'print-string' won't work on it. buffer (obj size 2 and-record t elems '((integer) (string-address)) fields '(length data)) buffer-address (obj size 1 address t elem '(buffer)) ; a stream makes it easy to read from a string/array stream (obj size 2 and-record t elems '((integer) (string-address)) fields '(pointer data)) stream-address (obj size 1 address t elem '(stream)) ; isolating function calls space (obj array t elem '(location)) ; by convention index 0 points to outer space space-address (obj size 1 address t elem '(space)) ; arrays consist of an integer length followed by that many ; elements, all of the same type integer-array (obj array t elem '(integer)) integer-array-address (obj size 1 address t elem '(integer-array)) integer-array-address-address (obj size 1 address t elem '(integer-array-address)) integer-address (obj size 1 address t elem '(integer)) ; pointer to int integer-address-address (obj size 1 address t elem '(integer-address)) ; and-records consist of a multiple fields of different types integer-boolean-pair (obj size 2 and-record t elems '((integer) (boolean)) fields '(int bool)) integer-boolean-pair-address (obj size 1 address t elem '(integer-boolean-pair)) integer-boolean-pair-array (obj array t elem '(integer-boolean-pair)) integer-boolean-pair-array-address (obj size 1 address t elem '(integer-boolean-pair-array)) integer-integer-pair (obj size 2 and-record t elems '((integer) (integer))) integer-integer-pair-address (obj size 1 address t elem '(integer-integer-pair)) integer-point-pair (obj size 2 and-record t elems '((integer) (integer-integer-pair))) integer-point-pair-address (obj size 1 address t elem '(integer-point-pair)) integer-point-pair-address-address (obj size 1 address t elem '(integer-point-pair-address)) ; tagged-values are the foundation of dynamic types tagged-value (obj size 2 and-record t elems '((type) (location)) fields '(type payload)) tagged-value-address (obj size 1 address t elem '(tagged-value)) tagged-value-array (obj array t elem '(tagged-value)) tagged-value-array-address (obj size 1 address t elem '(tagged-value-array)) tagged-value-array-address-address (obj size 1 address t elem '(tagged-value-array-address)) ; heterogeneous lists list (obj size 2 and-record t elems '((tagged-value) (list-address)) fields '(car cdr)) list-address (obj size 1 address t elem '(list)) list-address-address (obj size 1 address t elem '(list-address)) ; parallel routines use channels to synchronize channel (obj size 3 and-record t elems '((integer) (integer) (tagged-value-array-address)) fields '(first-full first-free circular-buffer)) ; be careful of accidental copies to channels channel-address (obj size 1 address t elem '(channel)) ; opaque pointer to a call stack ; todo: save properly in allocated memory continuation (obj size 1) ; editor line (obj array t elem '(character)) line-address (obj size 1 address t elem '(line)) line-address-address (obj size 1 address t elem '(line-address)) screen (obj array t elem '(line-address)) screen-address (obj size 1 address t elem '(screen)) ; fake screen terminal (obj size 5 and-record t elems '((integer) (integer) (integer) (integer) (string-address)) fields '(num-rows num-cols cursor-row cursor-col data)) terminal-address (obj size 1 address t elem '(terminal)) ; fake keyboard keyboard (obj size 2 and-record t elems '((integer) (string-address)) fields '(index data)) keyboard-address (obj size 1 address t elem '(keyboard)) ))) ;; managing concurrent routines (on-init ;? (prn "-- resetting memory allocation") (= Memory-allocated-until 1000) (= Allocation-chunk 100000)) ; routine = runtime state for a serial thread of execution (def make-routine (fn-name . args) (let curr-alloc Memory-allocated-until ;? (prn "-- allocating routine: @curr-alloc") (++ Memory-allocated-until Allocation-chunk) (annotate 'routine (obj alloc curr-alloc alloc-max Memory-allocated-until call-stack (list (obj fn-name fn-name pc 0 args args caller-arg-idx 0)))) ; other fields we use in routine: ; sleep: conditions ; limit: number of cycles this routine can use ; running-since: start of the clock for counting cycles this routine has used ; todo: do memory management in mu )) (defextend empty (x) (isa x 'routine) (no rep.x!call-stack)) (def stack (routine) ((rep routine) 'call-stack)) (def push-stack (routine op) (push (obj fn-name op pc 0 caller-arg-idx 0 t0 (msec)) rep.routine!call-stack)) (def pop-stack (routine) ;? (update-time label.routine (msec)) ;? 1 (pop rep.routine!call-stack)) (def top (routine) stack.routine.0) (def label (routine) (whenlet stack stack.routine (or= stack.0!label (label2 stack)))) (def label2 (stack) (string:intersperse "/" (map [_ 'fn-name] stack)));)) (def body (routine) (function* stack.routine.0!fn-na
<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN">
<html><head><title>Python: module ranger.ext.waitpid_no_intr</title>
</head><body bgcolor="#f0f0f8">

<table width="100%" cellspacing=0 cellpadding=2 border=0 summary="heading">
<tr bgcolor="#7799ee">
<td valign=bottom>&nbsp;<br>
<font color="#ffffff" face="helvetica, arial">&nbsp;<br><big><big><strong><a href="ranger.html"><font color="#ffffff">ranger</font></a>.<a href="ranger.ext.html"><font color="#ffffff">ext</font></a>.waitpid_no_intr</strong></big></big></font></td
><td align=right valign=bottom
><font color="#ffffff" face="helvetica, arial"><a href=".">index</a><br><a href="file:/home/hut/ranger/ranger/ext/waitpid_no_intr.py">/home/hut/ranger/ranger/ext/waitpid_no_intr.py</a></font></td></tr></table>
    <p><tt>#&nbsp;Copyright&nbsp;(C)&nbsp;2009,&nbsp;2010&nbsp;&nbsp;Roman&nbsp;Zimbelmann&nbsp;&lt;romanz@lavabit.com&gt;<br>
#<br>
#&nbsp;This&nbsp;program&nbsp;is&nbsp;free&nbsp;software:&nbsp;you&nbsp;can&nbsp;redistribute&nbsp;it&nbsp;and/or&nbsp;modify<br>
#&nbsp;it&nbsp;under&nbsp;the&nbsp;terms&nbsp;of&nbsp;the&nbsp;GNU&nbsp;General&nbsp;Public&nbsp;License&nbsp;as&nbsp;published&nbsp;by<br>
#&nbsp;the&nbsp;Free&nbsp;Software&nbsp;Foundation,&nbsp;either&nbsp;version&nbsp;3&nbsp;of&nbsp;the&nbsp;License,&nbsp;or<br>
#&nbsp;(at&nbsp;your&nbsp;option)&nbsp;any&nbsp;later&nbsp;version.<br>
#<br>
#&nbsp;This&nbsp;program&nbsp;is&nbsp;distributed&nbsp;in&nbsp;the&nbsp;hope&nbsp;that&nbsp;it&nbsp;will&nbsp;be&nbsp;useful,<br>
#&nbsp;but&nbsp;WITHOUT&nbsp;ANY&nbsp;WARRANTY;&nbsp;without&nbsp;even&nbsp;the&nbsp;implied&nbsp;warranty&nbsp;of<br>
#&nbsp;MERCHANTABILITY&nbsp;or&nbsp;FITNESS&nbsp;FOR&nbsp;A&nbsp;PARTICULAR&nbsp;PURPOSE.&nbsp;&nbsp;See&nbsp;the<br>
#&nbsp;GNU&nbsp;General&nbsp;Public&nbsp;License&nbsp;for&nbsp;more&nbsp;details.<br>
#<br>
#&nbsp;You&nbsp;should&nbsp;have&nbsp;received&nbsp;a&nbsp;copy&nbsp;of&nbsp;the&nbsp;GNU&nbsp;General&nbsp;Public&nbsp;License<br>
#&nbsp;along&nbsp;with&nbsp;this&nbsp;program.&nbsp;&nbsp;If&nbsp;not,&nbsp;see&nbsp;&lt;<a href="http://www.gnu.org/licenses/">http://www.gnu.org/licenses/</a>&gt;.</tt></p>
<p>
<table width="100%" cellspacing=0 cellpadding=2 border=0 summary="section">
<tr bgcolor="#eeaa77">
<td colspan=3 valign=bottom>&nbsp;<br>
<font color="#ffffff" face="helvetica, arial"><big><strong>Functions</strong></big></font></td></tr>
    
<tr><td bgcolor="#eeaa77"><tt>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;</tt></td><td>&nbsp;</td>
<td width="100%"><dl><dt><a name="-waitpid_no_intr"><strong>waitpid_no_intr</strong></a>(pid)</dt><dd><tt>catch&nbsp;interrupts&nbsp;which&nbsp;occur&nbsp;while&nbsp;using&nbsp;os.waitpid</tt></dd></dl>
</td></tr></table>
</body></html>
generated by cgit-pink 1.4.1-2-gfad0 (git 2.36.2.497.gbbea4dcf42) at 2024-11-19 23:10:42 +0000
1 nil ($.open-graphics) (= Viewport ($.open-viewport (m arg.0) ; name (m arg.1) (m arg.2)))) ; width height window-off (do1 nil ($.close-viewport Viewport) ; why doesn't this close the window? works in naked racket. not racket vs arc. ($.close-graphics) (= Viewport nil)) mouse-position (aif ($.ready-mouse-click Viewport) (let posn ($.mouse-click-posn it) (list (annotate 'record (list ($.posn-x posn) ($.posn-y posn))) t)) (list nil nil)) wait-for-mouse (let posn ($.mouse-click-posn ($.get-mouse-click Viewport)) (list (annotate 'record (list ($.posn-x posn) ($.posn-y posn))) t)) ; clear-screen in cursor mode above rectangle (do1 nil (($.draw-solid-rectangle Viewport) ($.make-posn (m arg.0) (m arg.1)) ; origin (m arg.2) (m arg.3) ; width height (m arg.4))) ; color point (do1 nil (($.draw-pixel Viewport) ($.make-posn (m arg.0) (m arg.1)) (m arg.2))) ; color image (do1 nil (($.draw-pixmap Viewport) (m arg.0) ; filename ($.make-posn (m arg.1) (m arg.2)))) color-at (let pixel (($.get-color-pixel Viewport) ($.make-posn (m arg.0) (m arg.1))) (prn ($.rgb-red pixel) " " ($.rgb-blue pixel) " " ($.rgb-green pixel)) ($:rgb-red pixel)) ; debugging aides $dump-memory (do1 nil (prn:repr int-canon.memory*)) $dump-trace (tofile arg.0 (each (label trace) (as cons traces*) (pr label ": " trace))) $start-tracing (do1 nil (set dump-trace*)) $stop-tracing (do1 nil (wipe dump-trace*)) $dump-routine (do1 nil ($.close-charterm) (prn routine*) ($.open-charterm) ) $dump-channel (do1 nil ($.close-charterm) (withs (x (m arg.0) y (memory* (+ x 2))) (prn label.routine* " -- " x " -- " (list (memory* x) (memory* (+ x 1)) (memory* (+ x 2))) " -- " (list (memory* y) (memory* (+ y 1)) (repr:memory* (+ y 2)) (memory* (+ y 3)) (repr:memory* (+ y 4))))) ($.open-charterm) ) $quit (quit) $wait-for-key-from-host (when ($.current-charterm) (ret result ($.charterm-read-key) (case result ; charterm exceptions return (= result #\newline) backspace (= result #\backspace) ))) $print (do1 nil ;? (write (m arg.0)) (pr " => ") (prn (type (m arg.0))) (if (no ($.current-charterm)) (pr (m arg.0)) (unless disable-debug-prints-in-console-mode* (caselet x (m arg.0) #\newline (pr "\r\n") #\backspace ; backspace doesn't clear after moving the cursor (pr "\b \b") ctrl-c (do ($.close-charterm) (die "interrupted")) ;else (pr x))) )) $write (do1 nil (write (m arg.0))) $eval (new-string:repr:eval:read:to-arc-string (m arg.0)) ;? (let x (to-arc-string (m arg.0)) ;? 1 ;? (prn x) ;? 1 ;? (new-string:repr:eval x)) ;? 1 $clear-trace (do1 nil (wipe interactive-traces*)) $save-trace (let x (filter-log "CCC: " len (string (filter-log "BBB: " len (map [string:intersperse ": " _] (filter-log "AAA: " len (as cons (interactive-traces* (m arg.0))))) ))) ;? (let x (string:map [string:intersperse ": " _] ;? (apply join ;? (map [as cons _] rev.interactive-traces*))) (prn "computed trace; now saving to memory\n") ;? (write x)(write #\newline) ;? 1 ;? (prn x) ;? 1 (set new-string-foo*) (do1 (new-string x) (wipe new-string-foo*))) ; first-class continuations current-continuation (w/uniq continuation-name (trace "continuation" "saving @(repr rep.routine*!call-stack) to @continuation-name") (= continuation*.continuation-name (copy rep.routine*!call-stack)) continuation-name) continue-from (let continuation-name (m arg.0) (trace "continuation" "restoring @continuation-name") (trace "continuation" continuation*.continuation-name) (= rep.routine*!call-stack continuation*.continuation-name) (trace "continuation" "call stack is now @(repr rep.routine*!call-stack)") ;? (++ pc.routine*) ;? 1 (continue)) ;? ((abort-routine*))) ;? 1 ; user-defined functions next-input (let idx caller-arg-idx.routine* (++ caller-arg-idx.routine*) (trace "arg" repr.arg " " idx " " (repr caller-args.routine*)) (if (len> caller-args.routine* idx) (list caller-args.routine*.idx t) (list nil nil))) input (do (assert (iso '(literal) (ty arg.0))) (= caller-arg-idx.routine* (v arg.0)) (let idx caller-arg-idx.routine* (++ caller-arg-idx.routine*) (trace "arg" repr.arg " " idx " " (repr caller-args.routine*)) (if (len> caller-args.routine* idx) (list caller-args.routine*.idx t) (list nil nil)))) rewind-inputs (do1 nil (= caller-arg-idx.routine* 0)) ; type and otype won't always easily compile. be careful. type (ty (caller-operands.routine* (v arg.0))) otype (ty (caller-results.routine* (v arg.0))) prepare-reply (prepare-reply arg) reply (do (when arg (prepare-reply arg)) (with (results results.routine* reply-args reply-args.routine*) (pop-stack routine*) (if empty.routine* (return ninstrs)) (let (call-oargs _ call-args) (parse-instr (body.routine* pc.routine*)) ;? (trace "reply" repr.arg " " repr.call-oargs) ;? 1 (each (dest reply-arg val) (zip call-oargs reply-args results) (trace "run" label.routine* " " pc.routine* ": " repr.val " => " dest) (when nondummy.dest (whenlet argidx (alref metadata.reply-arg 'same-as-arg) (unless (is v.dest (v call-args.argidx)) (die "'same-as-arg' output arg in @repr.reply-args can't bind to @repr.call-oargs"))) (setm dest val)))) (++ pc.routine*) (while (>= pc.routine* (len body.routine*)) (pop-stack routine*) (when empty.routine* (return ninstrs)) (++ pc.routine*)) (continue))) ; else try to call as a user-defined function (do (if function*.op (with (callee-args (accum yield (each a arg (yield (m a)))) callee-operands (accum yield (each a arg (yield a))) callee-results (accum yield (each a oarg (yield a)))) (push-stack routine* op) (= caller-args.routine* callee-args) (= caller-operands.routine* callee-operands) (= caller-results.routine* callee-results)) (err "no such op @op")) (continue)) ) ; opcode generated some 'results' ; copy to output args (if (acons results) (each (dest val) (zip oarg results) (unless (is dest '_) (trace "run" label.routine* " " pc.routine* ": " repr.val " => " dest) (setm dest val))) (when oarg ; must be a list (trace "run" label.routine* " " pc.routine* ": " repr.results " => " oarg.0) (setm oarg.0 results))) ) (++ pc.routine*))) (return time-slice))) (def prepare-reply (args) (= results.routine* (accum yield (each a args (yield (m a))))) (= reply-args.routine* args)) ; helpers for memory access respecting ; immediate addressing - 'literal' and 'offset' ; direct addressing - default ; indirect addressing - 'deref' ; relative addressing - if routine* has 'default-space' (def m (loc) ; read memory, respecting metadata (point return (when (literal? loc) (return v.loc)) (when (is v.loc 'default-space) (return rep.routine*!call-stack.0!default-space)) ;? (trace "mem" loc) ;? 1 (assert (isa v.loc 'int) "addresses must be numeric (problem in convert-names?): @repr.loc") (ret result (with (n sizeof.loc addr addr.loc) ;? (trace "mem" "reading " n " locations starting at " addr) ;? 1 (if (is 1 n) memory*.addr :else (annotate 'record (map memory* (addrs addr n))))) (trace "mem" loc " => " result)))) (def setm (loc val) ; set memory, respecting metadata ;? (tr 111) (point return ;? (tr 112) (when (is v.loc 'default-space) (assert (is 1 sizeof.loc) "can't store compounds in default-space @loc") (= rep.routine*!call-stack.0!default-space val) (return)) ;? (tr 120) (assert (isa v.loc 'int) "can't store to non-numeric address (problem in convert-names?)") ;? (trace "mem" loc " <= " repr.val) ;? 1 (with (n (if (isa val 'record) (len rep.val) 1) addr addr.loc typ typeof.loc) ;? (trace "mem" "size of " loc " is " n) ;? 1 (assert n "setm: can't compute type of @loc") (assert addr "setm: null pointer @loc") (if (is 1 n) (do (assert (~isa val 'record) "setm: record of size 1 @(tostring prn.val)") (trace "mem" loc ": " addr " <= " repr.val) (= memory*.addr val)) (do (if type*.typ!array ; size check for arrays (when (~is n (+ 1 ; array length (* rep.val.0 (sizeof `((_ ,@type*.typ!elem)))))) (die "writing invalid array @(tostring prn.val)")) ; size check for non-arrays (when (~is sizeof.loc n) (die "writing to incorrect size @(tostring pr.val) => @loc"))) (let addrs (addrs addr n) (each (dest src) (zip addrs rep.val) (trace "mem" loc ": " dest " <= " repr.src) (= memory*.dest src)))))))) (def typeof (operand) (let loc absolutize.operand (while (pos '(deref) metadata.loc) (zap deref loc)) ty.loc.0)) (def addr (operand) (v canonize.operand)) (def addrs (n sz) (accum yield (repeat sz (yield n) (++ n)))) (def canonize (operand) ;? (tr "0: @operand") (ret operand ;? (prn "1: " operand) ;? (tr "1: " operand) ; todo: why does this die? (zap absolutize operand) ;? (tr "2: @repr.operand") (while (pos '(deref) metadata.operand) (zap deref operand) ;? (tr "3: @repr.operand") ))) (def array-len (operand) (trace "array-len" operand) (zap canonize operand) (if typeinfo.operand!array (m `((,v.operand integer) ,@metadata.operand)) :else (err "can't take len of non-array @operand"))) (def sizeof (x) ;? (trace "sizeof" x) ;? 1 (assert acons.x) (zap canonize x) (point return ;? (tr "sizeof: checking @x for array") (when typeinfo.x!array ;? (tr "sizeof: @x is an array") (assert (~is '_ v.x) "sizeof: arrays require a specific variable") (return (+ 1 (* array-len.x (sizeof `((_ ,@typeinfo.x!elem))))))) ;? (tr "sizeof: not an array") (when typeinfo.x!and-record ;? (tr "sizeof: @x is an and-record") (return (sum idfn (accum yield (each elem typeinfo.x!elems (yield (sizeof `((_ ,@elem))))))))) ;? (tr "sizeof: @x is a primitive") (return typeinfo.x!size))) (def absolutize (operand) (if (no routine*) operand (in v.operand '_ 'default-space) operand (pos '(raw) metadata.operand) operand (is 'global space.operand) (aif rep.routine*!globals `((,(+ it 1 v.operand) ,@(cdr operand.0)) ,@(rem [caris _ 'space] metadata.operand) (raw)) (die "routine has no globals: @operand")) :else (iflet base rep.routine*!call-stack.0!default-space (space-base (rem [caris _ 'space] operand) base space.operand) operand))) (def space-base (operand base space) ;? (prn operand " " base) ;? 1 (if (is 0 space) ; base case (if (< v.operand memory*.base) `((,(+ base 1 v.operand) ,@(cdr operand.0)) ,@metadata.operand (raw)) (die "no room for var @operand in routine of size @memory*.base")) ; recursive case (space-base operand (memory* (+ base 1)) ; location 0 points to next space (- space 1)))) (def space (operand) (or (alref metadata.operand 'space) 0)) (def deref (operand) (assert (pos '(deref) metadata.operand)) (assert address?.operand) (cons `(,(memory* v.operand) ,@typeinfo.operand!elem) (drop-one '(deref) metadata.operand))) (def drop-one (f x) (when acons.x ; proper lists only (if (testify.f car.x) cdr.x (cons car.x (drop-one f cdr.x))))) ; memory allocation (def alloc (sz) (when (> sz (- rep.routine*!alloc-max rep.routine*!alloc)) (let curr-alloc Memory-allocated-until (= rep.routine*!alloc curr-alloc) (++ Memory-allocated-until Allocation-chunk) (= rep.routine*!alloc-max Memory-allocated-until))) (ret result rep.routine*!alloc (++ rep.routine*!alloc sz))) (def new-scalar (type) ;? (tr "new scalar: @type") (alloc (sizeof `((_ ,type))))) (def new-array (type size) ;? (tr "new array: @type @size") (ret result (alloc (+ 1 (* (sizeof `((_ ,@type*.type!elem))) size))) (= memory*.result size))) (def new-string (literal-string) ;? (tr "new string: @literal-string") (ret result (alloc (+ 1 len.literal-string)) (= memory*.result len.literal-string) (on c literal-string (when (and new-string-foo* (is 0 (mod index 100))) (prn index " " repr.c)) (= (memory* (+ result 1 index)) c)))) (def to-arc-string (string-address) (let len (memory* string-address) (string:map memory* (range (+ string-address 1) (+ string-address len))))) ;; desugar structured assembly based on blocks (def convert-braces (instrs) ;? (prn "convert-braces " instrs) (let locs () ; list of information on each brace: (open/close pc) (let pc 0 (loop (instrs instrs) (each instr instrs ;? (tr instr) (if (or atom.instr (~is 'begin instr.0)) ; label or regular instruction (do (trace "c{0" pc " " instr " -- " locs) (++ pc)) ; hack: racket replaces braces with parens, so we need the ; keyword 'begin' to delimit blocks. ; ultimately there'll be no nesting and braces will just be ; in an instr by themselves. :else ; brace (do (push `(open ,pc) locs) (recur cdr.instr) (push `(close ,pc) locs)))))) (zap rev locs) ;? (tr "-") (with (pc 0 stack ()) ; elems are pcs (accum yield (loop (instrs instrs) (each instr instrs ;? (tr "- " instr) (point continue (when (atom instr) ; label (yield instr) (++ pc) (continue)) (when (is car.instr 'begin) (push pc stack) (recur cdr.instr) (pop stack) (continue)) (with ((oarg op arg) (parse-instr instr) yield-new-instr (fn (new-instr) (trace "c{1" "@pc X " instr " => " new-instr) (yield new-instr)) yield-unchanged (fn () (trace "c{1" "@pc ✓ " instr) (yield instr))) (when (in op 'break 'break-if 'break-unless 'loop 'loop-if 'loop-unless) (assert (is oarg nil) "@op: can't take oarg in @instr")) (case op break (yield-new-instr `(((jump)) ((,(close-offset pc locs (and arg (v arg.0))) offset)))) break-if (yield-new-instr `(((jump-if)) ,arg.0 ((,(close-offset pc locs (and cdr.arg (v arg.1))) offset)))) break-unless (yield-new-instr `(((jump-unless)) ,arg.0 ((,(close-offset pc locs (and cdr.arg (v arg.1))) offset)))) loop (yield-new-instr `(((jump)) ((,(open-offset pc stack (and arg (v arg.0))) offset)))) loop-if (yield-new-instr `(((jump-if)) ,arg.0 ((,(open-offset pc stack (and cdr.arg (v arg.1))) offset)))) loop-unless (yield-new-instr `(((jump-unless)) ,arg.0 ((,(open-offset pc stack (and cdr.arg (v arg.1))) offset)))) ;else (yield-unchanged))) (++ pc)))))))) (def close-offset (pc locs nblocks) (or= nblocks 1) ;? (tr nblocks) (point return ;? (tr "close " pc " " locs) (let stacksize 0 (each (state loc) locs (point continue ;? (tr stacksize "/" done " " state " " loc) (when (<= loc pc) (continue)) ;? (tr "process " stacksize loc) (if (is 'open state) (++ stacksize) (-- stacksize)) ; last time ;? (tr "process2 " stacksize loc) (when (is stacksize (* -1 nblocks)) ;? (tr "close now " loc) (return (- loc pc 1)))))))) (def open-offset (pc stack nblocks) (or= nblocks 1) (- (stack (- nblocks 1)) 1 pc)) ;; convert jump targets to offsets (def convert-labels (instrs) ;? (tr "convert-labels " instrs) (let labels (table) (let pc 0 (each instr instrs (when (~acons instr) ;? (tr "label " pc) (= labels.instr pc)) (++ pc))) (let pc 0 (each instr instrs (when (and acons.instr (acons car.instr) (in (v car.instr) 'jump 'jump-if 'jump-unless)) (each arg cdr.instr ;? (tr "trying " arg " " ty.arg ": " v.arg " => " (labels v.arg)) (when (and (is ty.arg.0 'offset) (isa v.arg 'sym) (labels v.arg)) (= v.arg (- (labels v.arg) pc 1))))) (++ pc)))) instrs) ;; convert symbolic names to raw memory locations (def add-next-space-generator (instrs name) ;? (prn "== @name") (each instr instrs (when acons.instr (let (oargs op args) (parse-instr instr) (each oarg oargs (when (and (nondummy oarg) (is v.oarg 0) (iso ty.oarg '(space-address))) (assert (or (no next-space-generator*.name) (is next-space-generator*.name (alref oarg 'names))) "function can have only one next-space-generator environment") (tr "next-space-generator of @name is @(alref oarg 'names)") (= next-space-generator*.name (alref oarg 'names)))))))) ; just a helper for testing; in practice we unbundle assign-names-to-location ; and replace-names-with-location. (def convert-names (instrs (o name)) ;? (tr "convert-names " instrs) (= location*.name (assign-names-to-location instrs name)) ;? (tr "save names for function @name: @(tostring:pr location*.name)") ;? 1 (replace-names-with-location instrs name)) (def assign-names-to-location (instrs name (o init-locations)) (trace "cn0" "convert-names in @name") ;? (prn name ": " location*) ;? 1 (point return (ret location (or init-locations (table)) ; if default-space in first instruction has a name, begin with its bindings (when (acons instrs.0) ; not a label (let first-oarg-of-first-instr instrs.0.0 ; hack: assumes the standard default-space boilerplate (when (and (nondummy first-oarg-of-first-instr) (is 'default-space (v first-oarg-of-first-instr)) (assoc 'names metadata.first-oarg-of-first-instr)) (let old-names (location*:alref metadata.first-oarg-of-first-instr 'names) (unless old-names ;? (prn "@name requires bindings for @(alref metadata.first-oarg-of-first-instr 'names) which aren't computed yet. Waiting.") ;? 1 (return nil)) (= location copy.old-names))))) ; assumption: we've already converted names for 'it' ;? (unless empty.location (prn location)) ;? 2 (with (isa-field (table) idx (+ 1 ; 0 always reserved for next space (or (apply max vals.location) ; skip past bindings already shared from elsewhere 0)) already-location (copy location) ) (each instr instrs (point continue (when atom.instr (continue)) (trace "cn0" instr " " canon.location " " canon.isa-field) (let (oargs op args) (parse-instr instr) ;? (tr "about to rename args: @op") (when (in op 'get 'get-address) ; special case: map field offset by looking up type table (with (basetype (typeof args.0) field (v args.1)) ;? (tr 111 " " args.0 " " basetype) (assert type*.basetype!and-record "get on non-record @args.0") ;? (tr 112) (trace "cn0" "field-access @field in @args.0 of type @basetype") (when (isa field 'sym) (unless (already-location field) (assert (or (~location field) isa-field.field) "field @args.1 is also a variable")) (when (~location field) (trace "cn0" "new field; computing location") ;? (tr "aa " type*.basetype) (assert type*.basetype!fields "no field names available for @instr") ;? (tr "bb") (iflet idx (pos field type*.basetype!fields) (do (set isa-field.field) (trace "cn0" "field location @idx") (= location.field idx)) (assert nil "couldn't find field in @instr")))))) ; map args to location indices (each arg args (trace "cn0" "checking arg " arg) (when (and nondummy.arg not-raw-string.arg (~literal? arg)) (assert (~isa-field v.arg) "arg @arg is also a field name") (when (maybe-add arg location idx) ; todo: test this (err "use before set: @arg")))) ;? (tr "about to rename oargs") ; map oargs to location indices (each arg oargs (trace "cn0" "checking oarg " arg) (when (and nondummy.arg not-raw-string.arg) (assert (~isa-field v.arg) "oarg @arg is also a field name") (when (maybe-add arg location idx) (trace "cn0" "location for oarg " arg ": " idx) ; todo: can't allocate arrays on the stack (++ idx (sizeof `((_ ,@ty.arg)))))))))))))) (def replace-names-with-location (instrs name) (each instr instrs (when (acons instr) (let (oargs op args) (parse-instr instr) (each arg args (convert-name arg name)) (each arg oargs (convert-name arg name))))) (each instr instrs (trace "cn1" instr)) instrs) (= allow-raw-addresses* nil) (def check-default-space (instrs name) (unless allow-raw-addresses* (let oarg-names (accum yield (each (oargs _ _) (map parse-instr (keep acons ; non-label instrs)) (each oarg oargs (when nondummy.oarg (yield v.oarg))))) (when (~pos 'default-space oarg-names) (prn "function @name has no default-space"))))) ; assign an index to an arg (def maybe-add (arg location idx) (trace "maybe-add" arg) (when (and nondummy.arg ;? (prn arg " " (assoc 'space arg)) (~assoc 'space arg) (~literal? arg) (~location v.arg) (isa v.arg 'sym) (~in v.arg 'nil 'default-space) (~pos '(raw) metadata.arg)) (= (location v.arg) idx))) ; convert the arg to corresponding index (def convert-name (arg default-name) ;? (prn "111 @arg @default-name") (when (and nondummy.arg not-raw-string.arg (~is ty.arg.0 'literal)) ; can't use 'literal?' because we want to rename offsets ;? (prn "112 @arg") (let name (space-to-name arg default-name) ;? (prn "113 @arg @name @keys.location* @(tostring:pr location*.name)") ;? (when (is arg '((y integer) (space 1))) ;? (prn "@arg => @name")) (when (aand location*.name (it v.arg)) ;? (prn 114) (zap location*.name v.arg)) ;? (prn 115) ))) (def space-to-name (arg default-name) (ret name default-name (when (~is space.arg 'global) (repeat space.arg (zap next-space-generator* name))))) (proc check-numeric-address (instrs name) (unless allow-raw-addresses* (on instr instrs (when acons.instr ; not a label (let (oargs op args) (parse-instr instr) (each arg oargs (when (and acons.arg ; not dummy _ or raw string (isa v.arg 'int) (~is v.arg 0) (~pos '(raw) metadata.arg) (~literal? arg)) (prn "using a raw integer address @repr.arg in @name (instruction #@index)"))) (each arg args (when (and acons.arg ; not dummy _ or raw string (isa v.arg 'int) (~is v.arg 0) (~pos '(raw) metadata.arg) (~literal? arg)) (prn "using a raw integer address @repr.arg in @name (instruction #@index)")))))))) ;; literate tangling system for reordering code (def convert-quotes (instrs) (let deferred (queue) (each instr instrs (when (acons instr) (case instr.0 defer (let (q qinstrs) instr.1 (assert (is 'make-br-fn q) "defer: first arg must be [quoted]") (each qinstr qinstrs (enq qinstr deferred)))))) (accum yield (each instr instrs (if atom.instr ; label (yield instr) (is instr.0 'defer) nil ; skip (is instr.0 'reply) (do (when cdr.instr ; return values (= instr.0 'prepare-reply) (yield instr)) (each instr (as cons deferred) (yield instr)) (yield '(reply))) :else (yield instr))) (each instr (as cons deferred) (yield instr))))) (on-init (= before* (table)) ; label -> queue of fragments (= after* (table))) ; label -> list of fragments ; see add-code below for adding to before* and after* (def insert-code (instrs (o name)) ;? (tr "insert-code " instrs) (loop (instrs instrs) (accum yield (each instr instrs (if (and (acons instr) (~is 'begin car.instr)) ; simple instruction (yield instr) (and (acons instr) (is 'begin car.instr)) ; block (yield `{begin ,@(recur cdr.instr)}) (atom instr) ; label (do ;? (prn "tangling " instr) (each fragment (as cons (or (and name (before* (sym:string name '/ instr))) before*.instr)) (each instr fragment (yield instr))) (yield instr) (each fragment (or (and name (after* (sym:string name '/ instr))) after*.instr) (each instr fragment (yield instr))))))))) ;; loading code into the virtual machine (def add-code (forms) (each (op . rest) forms (case op ; function [ ] ; don't apply our lightweight tools just yet function! (let (name (_make-br-fn body)) rest (assert (is 'make-br-fn _make-br-fn)) (= name (v tokenize-arg.name)) (= function*.name body)) function (let (name (_make-br-fn body)) rest (assert (is 'make-br-fn _make-br-fn)) (= name (v tokenize-arg.name)) (when function*.name (prn "adding new clause to @name")) (= function*.name (join body function*.name))) ; and-record [ ] and-record (let (name (_make-br-fn fields)) rest (assert (is 'make-br-fn _make-br-fn)) (= name (v tokenize-arg.name)) (let fields (map tokenize-arg fields) (= type*.name (obj size len.fields and-record t ; dump all metadata for now except field name and type elems (map cdar fields) fields (map caar fields))))) ; primitive primitive (let (name) rest (= name (v tokenize-arg.name)) (= type*.name (obj size 1))) ; address address (let (name types) rest (= name (v tokenize-arg.name)) (= type*.name (obj size 1 address t elem types))) ; array array (let (name types) rest (= name (v tokenize-arg.name)) (= type*.name (obj array t elem types))) ; before