From 701144ace12d8fa621c900c16c725da170494c77 Mon Sep 17 00:00:00 2001 From: "Kartik K. Agaram" Date: Fri, 28 Nov 2014 18:02:16 -0800 Subject: 366 - reorg run's helpers First step to using our new 'deref' and 'absolutize' helpers more coherently. --- mu.arc | 297 ++++++++++++++++++++++++++++++++++------------------------------- 1 file changed, 155 insertions(+), 142 deletions(-) (limited to 'mu.arc') diff --git a/mu.arc b/mu.arc index 5ca46993..9a521451 100644 --- a/mu.arc +++ b/mu.arc @@ -278,6 +278,17 @@ (abort-continuation))) ;; running a single routine + +; routines consist of instrs +; instrs consist of oargs, op and args +(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))) + +; operand accessors (def nondummy (operand) ; precondition for helpers below (~is '_ operand)) @@ -294,133 +305,9 @@ (or (types* ty.operand) (err "unknown type @(tostring prn.operand)"))) -(def sz (operand) - (trace "sz" operand) - (if (is 'literal ty.operand) - 'literal - (pos 'deref metadata.operand) - (do (assert typeinfo.operand!address "tried to deref non-address @operand") - (sz (list (m `(,(v operand) location)) - typeinfo.operand!elem))) - (let-or it typeinfo.operand (err "no such type: @operand") - (if it!array - array-len.operand - it!size)))) -(defextend sz (typename) (isa typename 'sym) - (or types*.typename!size - (err "type @typename doesn't have a size: " (tostring:pr types*.typename)))) - -(def addr (operand) - (let loc absolutize.operand - (while (pos 'deref metadata.loc) - (zap deref loc)) - v.loc)) - -(def addrs (n sz) - (accum yield - (repeat sz - (yield n) - (++ n)))) - -(def m (loc) ; read memory, respecting metadata - (point return - (if (in ty.loc 'literal 'offset) - (return v.loc)) - (when (is v.loc 'default-scope) - (return rep.routine*!call-stack.0!default-scope)) - (trace "m" loc) - (assert (isa v.loc 'int) "addresses must be numeric (problem in convert-names?) @loc") - (with (n sz.loc - addr addr.loc) -;? (trace "m" "reading " n " locations starting at " addr) - (if (is 1 n) - (memory* addr) - :else - (annotate 'record - (map memory* (addrs addr n))))))) - -(def setm (loc val) ; set memory, respecting metadata - (point return - (when (is v.loc 'default-scope) - (assert (is 1 sz.loc) "can't store compounds in default-scope @loc") - (= rep.routine*!call-stack.0!default-scope val) - (return)) - (assert (isa v.loc 'int) "can't store to non-numeric address (problem in convert-names?)") - (trace "setm" loc " <= " val) - (with (n sz.loc - addr addr.loc) - (trace "setm" "size of " loc " is " n) - (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 "setm" loc ": setting " addr " to " val) - (= (memory* addr) val)) - (do (assert (isa val 'record) "setm: non-record of size >1 @val") - (each (dest src) (zip (addrs addr n) - (rep val)) - (trace "setm" loc ": setting " dest " to " src) - (= (memory* dest) src))))))) - -; (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) - (trace "record-info" operand " " field-offset) - (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)) - (trace "record-info" "initial base " base " type " canon.basetype) - (when (pos 'deref metadata.operand) - (assert basetype!address "@operand requests deref, but it's not an address of a record") - (= basetype (types* basetype!elem)) - (trace "record-info" operand " requests deref => " canon.basetype)) - (assert basetype!record "get on non-record @operand") - (assert (< -1 idx (len basetype!elems)) "@idx is out of bounds of record @operand") - (list (+ base (apply + (map sz (firstn idx basetype!elems)))) - basetype!elems.idx))) - -(def array-info (operand offset) - (trace "array-info" operand " " offset) - (with (base addr.operand - basetype typeinfo.operand - idx (m offset)) - (trace "array-info" "initial base " base " type " canon.basetype) - (when (pos 'deref metadata.operand) - (assert basetype!address "@operand requests deref, but it's not an address of an array") - (= basetype (types* basetype!elem)) - (trace "array-info" operand " requests deref => " canon.basetype)) - (assert basetype!array "index on non-array @operand") - (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"))) - (list (+ base - 1 ; for array size - (* idx (sz basetype!elem))) - basetype!elem))) - -(def array-len (operand) - (trace "array-len" operand) - (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"))) - -(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))) - ($:require "charterm/main.rkt") +; run instructions from 'routine*' for 'time-slice' (def run-for-time-slice (time-slice) (point return (for ninstrs 0 (< ninstrs time-slice) (++ ninstrs) @@ -647,26 +534,129 @@ (each a args (yield (m a)))))) -(enq (fn () (= Memory-in-use-until 1000)) - initialization-fns*) +; helpers for memory access respecting +; immediate addressing - 'literal' and 'offset' +; direct addressing - default +; indirect addressing - 'deref' +; relative addressing - if routine* has 'default-scope' -(def new-scalar (type) - (ret result Memory-in-use-until - (++ Memory-in-use-until sizeof.type))) +(def m (loc) ; read memory, respecting metadata + (point return + (if (in ty.loc 'literal 'offset) + (return v.loc)) + (when (is v.loc 'default-scope) + (return rep.routine*!call-stack.0!default-scope)) + (trace "m" loc) + (assert (isa v.loc 'int) "addresses must be numeric (problem in convert-names?) @loc") + (with (n sz.loc + addr addr.loc) +;? (trace "m" "reading " n " locations starting at " addr) + (if (is 1 n) + (memory* addr) + :else + (annotate 'record + (map memory* (addrs addr n))))))) -(def new-array (type size) -;? (prn "new array: @type @size") - (ret result Memory-in-use-until - (++ Memory-in-use-until (+ 1 (* (sizeof types*.type!elem) size))) - (= (memory* result) size))) +(def setm (loc val) ; set memory, respecting metadata + (point return + (when (is v.loc 'default-scope) + (assert (is 1 sz.loc) "can't store compounds in default-scope @loc") + (= rep.routine*!call-stack.0!default-scope val) + (return)) + (assert (isa v.loc 'int) "can't store to non-numeric address (problem in convert-names?)") + (trace "setm" loc " <= " val) + (with (n sz.loc + addr addr.loc) + (trace "setm" "size of " loc " is " n) + (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 "setm" loc ": setting " addr " to " val) + (= (memory* addr) val)) + (do (assert (isa val 'record) "setm: non-record of size >1 @val") + (each (dest src) (zip (addrs addr n) + (rep val)) + (trace "setm" loc ": setting " dest " to " src) + (= (memory* dest) src))))))) -(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)))) +(def sz (operand) + (trace "sz" operand) + (if (is 'literal ty.operand) + 'literal + (pos 'deref metadata.operand) + (do (assert typeinfo.operand!address "tried to deref non-address @operand") + (sz (list (m `(,(v operand) location)) + typeinfo.operand!elem))) + (let-or it typeinfo.operand (err "no such type: @operand") + (if it!array + array-len.operand + it!size)))) +(defextend sz (typename) (isa typename 'sym) + (or types*.typename!size + (err "type @typename doesn't have a size: " (tostring:pr types*.typename)))) + +(def addr (operand) + (let loc absolutize.operand + (while (pos 'deref metadata.loc) + (zap deref loc)) + v.loc)) + +(def addrs (n sz) + (accum yield + (repeat sz + (yield n) + (++ n)))) + +; (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) + (trace "record-info" operand " " field-offset) + (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)) + (trace "record-info" "initial base " base " type " canon.basetype) + (when (pos 'deref metadata.operand) + (assert basetype!address "@operand requests deref, but it's not an address of a record") + (= basetype (types* basetype!elem)) + (trace "record-info" operand " requests deref => " canon.basetype)) + (assert basetype!record "get on non-record @operand") + (assert (< -1 idx (len basetype!elems)) "@idx is out of bounds of record @operand") + (list (+ base (apply + (map sz (firstn idx basetype!elems)))) + basetype!elems.idx))) + +(def array-info (operand offset) + (trace "array-info" operand " " offset) + (with (base addr.operand + basetype typeinfo.operand + idx (m offset)) + (trace "array-info" "initial base " base " type " canon.basetype) + (when (pos 'deref metadata.operand) + (assert basetype!address "@operand requests deref, but it's not an address of an array") + (= basetype (types* basetype!elem)) + (trace "array-info" operand " requests deref => " canon.basetype)) + (assert basetype!array "index on non-array @operand") + (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"))) + (list (+ base + 1 ; for array size + (* idx (sz basetype!elem))) + basetype!elem))) + +(def array-len (operand) + (trace "array-len" operand) + (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"))) (def sizeof (x) (trace "sizeof" x) @@ -721,6 +711,29 @@ cdr.x (cons car.x (drop-one f x))))) +; memory allocation + +(enq (fn () (= Memory-in-use-until 1000)) + initialization-fns*) + +(def new-scalar (type) + (ret result Memory-in-use-until + (++ Memory-in-use-until sizeof.type))) + +(def new-array (type size) +;? (prn "new array: @type @size") + (ret result Memory-in-use-until + (++ Memory-in-use-until (+ 1 (* (sizeof types*.type!elem) size))) + (= (memory* result) size))) + +(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)))) + ;; desugar structured assembly based on blocks (def convert-braces (instrs) -- cgit 1.4.1-2-gfad0