diff options
author | Kartik K. Agaram <vc@akkartik.com> | 2014-12-17 14:03:34 -0800 |
---|---|---|
committer | Kartik K. Agaram <vc@akkartik.com> | 2014-12-17 14:08:30 -0800 |
commit | 8360714552621001be7c4c3b9daac8920170cf1c (patch) | |
tree | d8340aaa732816b6ecc0ffa65c893a71a9860567 | |
parent | a0bb6c04201ac347f597c63932ea9d8f70f70189 (diff) | |
download | mu-8360714552621001be7c4c3b9daac8920170cf1c.tar.gz |
436 - types* table can now contain integer-array:3, etc.
Biggest change was to the interface to the 'sizeof' helper. Where it used to accept either a type symbol or a cons operand, it now always accepts an operand, though the value of the operand can be _. In the process the implementation is radically simpler. Also reorg'd unit tests a little, putting those for 'deref' before 'sizeof'. Finally, I'm giving in and enabling the printing of test names as they're run. We still need this all the time in our surgery.
-rw-r--r-- | mu.arc | 174 | ||||
-rw-r--r-- | mu.arc.t | 71 |
2 files changed, 124 insertions, 121 deletions
diff --git a/mu.arc b/mu.arc index 0205b863..c86f660d 100644 --- a/mu.arc +++ b/mu.arc @@ -22,7 +22,7 @@ (= traces* (queue))) (def new-trace (filename) -;? (prn "new-trace " filename) + (prn "new-trace " filename) ;? ) (= curr-trace-file* filename)) @@ -86,56 +86,56 @@ (= 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 + 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) + boolean-address (obj size 1 address t elem '(boolean)) byte (obj size 1) - byte-address (obj size 1 address t elem 'byte) - string (obj array t elem 'byte) ; inspired by Go - string-address (obj size 1 address t elem 'string) + byte-address (obj size 1 address t elem '(byte)) + string (obj array t elem '(byte)) ; inspired by Go + string-address (obj size 1 address t elem '(string)) character (obj size 1) ; int32 like a Go rune - character-address (obj size 1 address t elem 'character) + 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) + scope (obj array t elem '(location)) ; by convention index 0 points to outer scope + scope-address (obj size 1 address t elem '(scope)) ; arrays consist of an integer length followed by the right number of elems - integer-array (obj array t elem 'integer) - integer-array-address (obj size 1 address t elem 'integer-array) - integer-array-address-address (obj size 1 address t elem 'integer-array-address) - integer-address (obj size 1 address t elem 'integer) ; pointer to int - integer-address-address (obj size 1 address t elem 'integer-address) + integer-array (obj array t elem '(integer)) + integer-array-address (obj size 1 address t elem '(integer-array)) + integer-array-address-address (obj size 1 address t elem '(integer-array-address)) + integer-address (obj size 1 address t elem '(integer)) ; pointer to int + integer-address-address (obj size 1 address t elem '(integer-address)) ; and-records consist of a series of elems, corresponding to a list of types - integer-boolean-pair (obj size 2 and-record t elems '(integer boolean) fields '(int bool)) - integer-boolean-pair-address (obj size 1 address t elem 'integer-boolean-pair) - integer-boolean-pair-array (obj array t elem 'integer-boolean-pair) - integer-boolean-pair-array-address (obj size 1 address t elem 'integer-boolean-pair-array) - integer-integer-pair (obj size 2 and-record t elems '(integer integer)) - integer-point-pair (obj size 2 and-record t elems '(integer integer-integer-pair)) - integer-point-pair-address (obj size 1 address t elem 'integer-point-pair) - integer-point-pair-address-address (obj size 1 address t elem 'integer-point-pair-address) + integer-boolean-pair (obj size 2 and-record t elems '((integer) (boolean)) fields '(int bool)) + integer-boolean-pair-address (obj size 1 address t elem '(integer-boolean-pair)) + integer-boolean-pair-array (obj array t elem '(integer-boolean-pair)) + integer-boolean-pair-array-address (obj size 1 address t elem '(integer-boolean-pair-array)) + integer-integer-pair (obj size 2 and-record t elems '((integer) (integer))) + integer-point-pair (obj size 2 and-record t elems '((integer) (integer-integer-pair))) + integer-point-pair-address (obj size 1 address t elem '(integer-point-pair)) + integer-point-pair-address-address (obj size 1 address t elem '(integer-point-pair-address)) ; tagged-values are the foundation of dynamic types - tagged-value (obj size 2 and-record t elems '(type location) fields '(type payload)) - tagged-value-address (obj size 1 address t elem 'tagged-value) - tagged-value-array (obj array t elem 'tagged-value) - tagged-value-array-address (obj size 1 address t elem 'tagged-value-array) - tagged-value-array-address-address (obj size 1 address t elem 'tagged-value-array-address) + 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) + list (obj size 2 and-record t elems '((tagged-value) (list-address)) fields '(car cdr)) + list-address (obj size 1 address t elem '(list)) + list-address-address (obj size 1 address t elem '(list-address)) ; parallel routines use channels to synchronize - channel (obj size 3 and-record t elems '(integer integer tagged-value-array-address) fields '(first-full first-free circular-buffer)) - channel-address (obj size 1 address t elem 'channel) + channel (obj size 3 and-record t elems '((integer) (integer) (tagged-value-array-address)) fields '(first-full first-free circular-buffer)) + channel-address (obj size 1 address t elem '(channel)) ; editor - line (obj array t elem 'character) - line-address (obj size 1 address t elem 'line) - line-address-address (obj size 1 address t elem 'line-address) - screen (obj array t elem 'line-address) - screen-address (obj size 1 address t elem 'screen) + line (obj array t elem '(character)) + line-address (obj size 1 address t elem '(line)) + line-address-address (obj size 1 address t elem '(line-address)) + screen (obj array t elem '(line-address)) + screen-address (obj size 1 address t elem '(screen)) ))) ;; managing concurrent routines @@ -409,8 +409,9 @@ (assert (iso '(offset) (ty arg.1)) "record index @arg.1 must have type 'offset'") (assert (< -1 idx (len typeinfo.operand!elems)) "@idx is out of bounds of record @operand") (m `((,(apply + v.operand - (map sizeof (firstn idx typeinfo.operand!elems))) - ,typeinfo.operand!elems.idx) + (map (fn(x) (sizeof `((_ ,@x)))) + (firstn idx typeinfo.operand!elems))) + ,@typeinfo.operand!elems.idx) (global)))) get-address (with (operand (canonize arg.0) @@ -418,7 +419,8 @@ (assert (iso '(offset) (ty arg.1)) "record index @arg.1 must have type 'offset'") (assert (< -1 idx (len typeinfo.operand!elems)) "@idx is out of bounds of record @operand") (apply + v.operand - (map sizeof (firstn idx typeinfo.operand!elems)))) + (map (fn(x) (sizeof `((_ ,@x)))) + (firstn idx typeinfo.operand!elems)))) index (withs (operand (canonize arg.0) elemtype typeinfo.operand!elem @@ -427,8 +429,8 @@ (die "@idx is out of bounds of array @operand")) (m `((,(+ v.operand 1 ; for array size - (* idx sizeof.elemtype)) - ,elemtype) + (* idx (sizeof `((_ ,@elemtype))))) + ,@elemtype) (global)))) index-address (withs (operand (canonize arg.0) @@ -438,7 +440,7 @@ (die "@idx is out of bounds of array @operand")) (+ v.operand 1 ; for array size - (* idx sizeof.elemtype))) + (* idx (sizeof `((_ ,@elemtype)))))) new (if (isa arg.0 'string) ; special-case: allocate space for a literal string @@ -451,7 +453,7 @@ (new-array type (m arg.1)) (new-scalar type)))) sizeof - (sizeof (m arg.0)) + (sizeof `((_ ,(m arg.0)))) length (let base arg.0 (if (or typeinfo.base!array typeinfo.base!address) @@ -608,7 +610,8 @@ (assert (isa v.loc 'int) "can't store to non-numeric address (problem in convert-names?)") (trace "setm" loc " <= " val) (with (n (if (isa val 'record) (len rep.val) 1) - addr addr.loc) + addr addr.loc + typ typeof.loc) (trace "setm" "size of " loc " is " n) (assert n "setm: can't compute type of @loc") (assert addr "setm: null pointer @loc") @@ -616,11 +619,11 @@ (do (assert (~isa val 'record) "setm: record of size 1 @(tostring prn.val)") (trace "setm" loc ": setting " addr " to " val) (= memory*.addr val)) - (do (if ((type* typeof.loc) 'array) + (do (if type*.typ!array ; size check for arrays (when (~is n (+ 1 ; array length - (* rep.val.0 (sizeof ((type* typeof.loc) 'elem))))) + (* rep.val.0 (sizeof `((_ ,@type*.typ!elem)))))) (die "writing invalid array @(tostring prn.val)")) ; size check for non-arrays (when (~is sizeof.loc n) @@ -668,34 +671,29 @@ (def sizeof (x) (trace "sizeof" x) + (assert acons.x) + (zap canonize x) (point return - (when (acons x) - (zap canonize x) -;? (tr "sizeof 1 @x") - (when typeinfo.x!array -;? (tr "sizeof 2") - (return (+ 1 (* array-len.x (sizeof typeinfo.x!elem)))))) -;? (tr "sizeof 3") - (let type (if (and acons.x (pos '(deref) metadata.x)) - typeinfo.x!elem ; deref pointer - acons.x - ty.x.0 - :else ; naked type - x) - (assert type*.type "sizeof: no such type @type") - (if (~or type*.type!and-record type*.type!array) - type*.type!size - type*.type!and-record - (sum idfn - (accum yield - (each elem type*.type!elems - (yield sizeof.elem)))) - :else - (err "sizeof can't handle @type (arrays require a specific variable)"))))) +;? (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 + (is '_ v.operand) + operand (pos '(global) metadata.operand) operand :else @@ -712,7 +710,7 @@ (def deref (operand) (assert (pos '(deref) metadata.operand)) (assert typeinfo.operand!address) - (cons `(,(memory* v.operand) ,typeinfo.operand!elem) + (cons `(,(memory* v.operand) ,@typeinfo.operand!elem) (drop-one '(deref) metadata.operand))) (def drop-one (f x) @@ -726,12 +724,12 @@ (def new-scalar (type) ;? (tr "new scalar: @type") (ret result rep.routine*!alloc - (++ rep.routine*!alloc sizeof.type))) + (++ rep.routine*!alloc (sizeof `((_ ,type)))))) (def new-array (type size) ;? (tr "new array: @type @size") (ret result rep.routine*!alloc - (++ rep.routine*!alloc (+ 1 (* (sizeof type*.type!elem) size))) + (++ rep.routine*!alloc (+ 1 (* (sizeof `((_ ,@type*.type!elem))) size))) (= memory*.result size))) (def new-string (literal-string) @@ -877,24 +875,21 @@ (continue)) (trace "cn0" instr " " canon.location " " canon.isa-field) (let (oargs op args) (parse-instr instr) -;? (tr "1") +;? (tr "about to rename args") ; rename args (if (in op 'get 'get-address) - (with (basetype (typeinfo args.0) + (with (basetype (typeof args.0) field (v args.1)) - (assert basetype "no such type @args.0") - (trace "cn0" "field-access " field) - ; todo: need to rename args.0 as well? - (when (pos '(deref) (metadata args.0)) - (trace "cn0" "field-access deref") - (assert basetype!address "@args.0 requests deref, but it's not an address") - (= basetype (type* basetype!elem))) + (assert type*.basetype!and-record "get on non-record @args.0") + (trace "cn0" "field-access @field in @args.0 of type @basetype") (when (isa field 'sym) (assert (or (~location field) isa-field.field) "field @args.1 is also a variable") (when (~location field) (trace "cn0" "new field; computing location") - (assert basetype!fields "no field names available for @instr") - (iflet idx (pos field basetype!fields) +;? (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)) @@ -904,7 +899,7 @@ (assert (~isa-field v.arg) "arg @arg is also a field name") (when (maybe-add arg location idx) (err "use before set: @arg"))))) -;? (tr "2") +;? (tr "about to rename oargs") ; rename oargs (each arg oargs (trace "cn0" "checking " arg) @@ -913,7 +908,7 @@ (when (maybe-add arg location idx) (trace "cn0" "location for arg " arg ": " idx) ; todo: can't allocate arrays on the stack - (++ idx (sizeof ty.arg.0))))))))) + (++ idx (sizeof `((_ ,@ty.arg))))))))))) (trace "cn1" "update names " canon.location " " canon.isa-field) (each instr instrs (when (acons instr) @@ -1021,6 +1016,7 @@ (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))))) diff --git a/mu.arc.t b/mu.arc.t index e6c0183c..89712d25 100644 --- a/mu.arc.t +++ b/mu.arc.t @@ -1693,6 +1693,7 @@ (reset) (new-trace "convert-names-record-fields") (= traces* (queue)) +;? (= dump-trace* (obj whitelist '("cn0"))) (if (~iso (convert-names '((((x integer)) <- ((get)) ((34 integer-boolean-pair)) ((bool offset))))) '((((1 integer)) <- ((get)) ((34 integer-boolean-pair)) ((1 offset))))) @@ -1717,10 +1718,12 @@ (reset) (new-trace "convert-names-record-fields-indirect") (= traces* (queue)) +;? (= dump-trace* (obj whitelist '("cn0"))) (if (~iso (convert-names '((((x integer)) <- ((get)) ((34 integer-boolean-pair-address) (deref)) ((bool offset))))) '((((1 integer)) <- ((get)) ((34 integer-boolean-pair-address) (deref)) ((1 offset))))) (prn "F - convert-names replaces field offsets for record addresses")) +;? (quit) (reset) (new-trace "convert-names-record-fields-multiple") @@ -1764,11 +1767,12 @@ (let before rep.routine!alloc ;? (set dump-trace*) (run) - ;? (prn memory*) +;? (prn memory*) (if (~iso memory*.1 before) (prn "F - 'new' returns current high-water mark")) (if (~iso rep.routine!alloc (+ before 1)) (prn "F - 'new' on primitive types increments high-water mark by their size")))) +;? (quit) (reset) (new-trace "new-array-literal") @@ -3332,7 +3336,7 @@ ;; unit tests for various helpers ; tokenize-args -;? (prn "tokenize-args") +(prn "tokenize-args") (assert:iso '((a b) (c d)) (tokenize-arg 'a:b/c:d)) (assert:iso '((a b) (1 d)) @@ -3369,7 +3373,7 @@ }))) ; absolutize -;? (prn "absolutize") +(prn "absolutize") (reset) (if (~iso '((4 integer)) (absolutize '((4 integer)))) (prn "F - 'absolutize' works without routine")) @@ -3384,9 +3388,31 @@ (absolutize '((5 integer))) (if (~posmatch "no room" rep.routine*!error) (prn "F - 'absolutize' checks against default-scope bounds")) +(if (~iso '((_ integer)) (absolutize '((_ integer)))) + (prn "F - 'absolutize' passes dummy args right through")) + +; deref +(prn "deref") +(reset) +(= memory*.3 4) +(if (~iso '((4 integer)) + (deref '((3 integer-address) + (deref)))) + (prn "F - 'deref' handles simple addresses")) +(if (~iso '((4 integer) (deref)) + (deref '((3 integer-address) + (deref) + (deref)))) + (prn "F - 'deref' deletes just one deref")) +(= memory*.4 5) +(if (~iso '((5 integer)) + (deref:deref '((3 integer-address-address) + (deref) + (deref)))) + (prn "F - 'deref' can be chained")) ; addr -;? (prn "addr") +(prn "addr") (reset) (= routine* nil) ;? (prn 111) @@ -3435,28 +3461,8 @@ (prn "F - 'addr' adds default-scope before 'deref', not after")) ;? (quit) -; deref -;? (prn "deref") -(reset) -(= memory*.3 4) -(if (~iso '((4 integer)) - (deref '((3 integer-address) - (deref)))) - (prn "F - 'deref' handles simple addresses")) -(if (~iso '((4 integer) (deref)) - (deref '((3 integer-address) - (deref) - (deref)))) - (prn "F - 'deref' deletes just one deref")) -(= memory*.4 5) -(if (~iso '((5 integer)) - (deref:deref '((3 integer-address-address) - (deref) - (deref)))) - (prn "F - 'deref' can be chained")) - ; array-len -;? (prn "array-len") +(prn "array-len") (reset) (= memory*.35 4) (if (~is 4 (array-len '((35 integer-boolean-pair-array)))) @@ -3467,16 +3473,17 @@ ;? (quit) ; sizeof -;? (prn "sizeof") +(prn "sizeof") (reset) +;? (set dump-trace*) ;? (prn 401) -(if (~is 1 sizeof!integer) +(if (~is 1 (sizeof '((_ integer)))) (prn "F - 'sizeof' works on primitives")) -(if (~is 1 sizeof!integer-address) +(if (~is 1 (sizeof '((_ integer-address)))) (prn "F - 'sizeof' works on addresses")) -(if (~is 2 sizeof!integer-boolean-pair) +(if (~is 2 (sizeof '((_ integer-boolean-pair)))) (prn "F - 'sizeof' works on and-records")) -(if (~is 3 sizeof!integer-point-pair) +(if (~is 3 (sizeof '((_ integer-point-pair)))) (prn "F - 'sizeof' works on and-records with and-record fields")) ;? (prn 410) @@ -3521,7 +3528,7 @@ ;? (quit) ; m -;? (prn "m") +(prn "m") (reset) (if (~is 4 (m '((4 literal)))) (prn "F - 'm' avoids reading memory for literals")) @@ -3551,7 +3558,7 @@ (prn "F - 'm' supports indirect access to arrays")) ; setm -;? (prn "setm") +(prn "setm") (reset) (setm '((4 integer)) 34) (if (~is 34 memory*.4) |