diff options
| -rw-r--r-- | share/txr/stdlib/asm.tl | 300 |
1 files changed, 150 insertions, 150 deletions
diff --git a/share/txr/stdlib/asm.tl b/share/txr/stdlib/asm.tl index 911f65de..29decc71 100644 --- a/share/txr/stdlib/asm.tl +++ b/share/txr/stdlib/asm.tl @@ -34,156 +34,156 @@ "register destination operand" "register small destination operand" "integer" - "any object"))) - - (:postinit (me) - (set me.buf (get-buf-from-stream me.bstr))) - - (:method cur-pos (me) - (seek-stream me.bstr 0 :from-current)) - - (:method set-pos (me pos) - (seek-stream me.bstr pos :from-start)) - - (:method lookup-label (me sym oc) - (condlet - (((n [me.labdef sym])) n) - (t (push (cons oc (trunc me.(cur-pos) 4)) [me.labref sym]) - 0))) - - (:method define-label (me sym) - (let* ((pos me.(cur-pos)) - (ins (trunc pos 4))) - (set [me.labdef sym] ins) - (each ((entry (del [me.labref sym]))) - (tree-bind (oc . offs) entry - me.(set-pos (* 4 offs)) - oc.(backpatch me (* 4 offs) ins))) - me.(set-pos pos) - ins)) - - (:method read-buf (me bytes) - (let ((buf (make-buf bytes))) - (when (neql (fill-buf buf 0 me.bstr) bytes) - (error "assembler: read past instruction block")) - buf)) - - (:method put-word (me word) - (let* ((buf (make-buf 0))) - (buf-put-u32 buf 0 word) - (put-buf buf 0 me.bstr))) - - (:method put-insn (me code extension operand) - (let ((word (logior (ash code 26) (ash extension 16) operand)) - (buf (make-buf 0))) - (buf-put-u32 buf 0 word) - (put-buf buf 0 me.bstr))) - - (:method put-pair (me op1 op2) - (let ((word (logior (ash op1 16) op2)) - (buf (make-buf 0))) - (buf-put-u32 buf 0 word) - (put-buf buf 0 me.bstr))) - - (:method get-word (me) - (let* ((buf me.(read-buf (sizeof uint32)))) - (buf-get-u32 buf 0))) - - (:method get-insn (me) - (let* ((buf me.(read-buf (sizeof uint32))) - (word (buf-get-u32 buf 0))) - (list (ash word -26) - (logtrunc (ash word -16) 10) - (logtrunc word 16)))) - - (:method get-pair (me) - (let* ((buf me.(read-buf (sizeof uint32))) - (word (buf-get-u32 buf 0))) - (list (ash word -16) (logtrunc word 16)))) - - (:method immediate-fits-type (me arg operand-type) - (and (member (typeof arg) - '(fixnum bignum chr)) - (<= (+ (width arg) - [me.sign-bits (typeof arg)] - 2) - [me.imm-width operand-type]))) - - (:method parse-args (me oc syntax pattern) - (mapcar (lambda (type arg n) - (let ((parg (caseql type - ((si mi bi) - (when me.(immediate-fits-type arg type) - arg)) - (l (cond - ((is-label arg) me.(lookup-label arg oc)) - ((integerp arg) arg))) - (n (if (integerp arg) arg)) - (o arg) - ((r rs d ds) - (cond - ((null arg) 0) - ((consp arg) - (parse-compound-operand arg)) - ((symbolp arg) - (parse-operand (symbol-name arg))))) - (t (error "assembler: invalid arg type spec"))))) - (unless (or parg (eq type 'o)) - oc.(synerr "argument ~a of ~s invalid; ~a expected" - n syntax [me.operand-name type])) - (when (and (member type '(d ds)) - (or (zerop parg) (<= 256 parg 511))) - oc.(synerr "argument ~a of ~s cannot be destination" - n syntax)) - (when (and (member type '(rs ds)) - (not (< parg 1024))) - oc.(synerr "argument ~a of ~s isn't a small register" - n syntax)) - parg)) - pattern (rest syntax) (range 1))) - - (:method asm-one (me syntax) - (let ((oc (cond - ((is-label syntax) [%oc-hash% 'label]) - ((consp syntax) [%oc-hash% (car syntax)])))) - (unless oc - (error "assembler: invalid instruction ~s" syntax)) - oc.(asm me syntax))) - - (:method asm (me insns) - (each ((i insns)) - me.(asm-one i)) - (unless (empty me.labref) - (error "assembler: dangling label references")) - (whenlet ((n (cdr [find-max me.labdef : cdr]))) - (unless (< 0 n (len me.buf)) - (error "assembler: labels outside of code")))) - - (:method dis-one (me) - (tree-bind (code extension operand) me.(get-insn) - (let ((oc [%oc-hash% code])) - oc.(dis me extension operand)))) - - (:method dis (me) - me.(set-pos 0) - (build - (while (< me.(cur-pos) (len me.buf)) - (add me.(dis-one))))) - - (:method dis-listing (me : (stream *stdout*)) - (let ((p 0) - (l (len me.buf))) - me.(set-pos p) - (while (< p l) - (let* ((dis me.(dis-one)) - (dis-txt (cat-str [mapcar tostring dis] " ")) - (q me.(cur-pos))) - me.(set-pos p) - (format t "~,5d: ~,08X ~a\n" (trunc p 4) me.(get-word) dis-txt) - (while (< (inc p 4) q) - (format t "~,5d: ~,08X\n" (trunc p 4) me.(get-word))) - me.(set-pos q) - (set p q)))))) + "any object")))) + +(defmeth assembler :postinit (me) + (set me.buf (get-buf-from-stream me.bstr))) + +(defmeth assembler cur-pos (me) + (seek-stream me.bstr 0 :from-current)) + +(defmeth assembler set-pos (me pos) + (seek-stream me.bstr pos :from-start)) + +(defmeth assembler lookup-label (me sym oc) + (condlet + (((n [me.labdef sym])) n) + (t (push (cons oc (trunc me.(cur-pos) 4)) [me.labref sym]) + 0))) + +(defmeth assembler define-label (me sym) + (let* ((pos me.(cur-pos)) + (ins (trunc pos 4))) + (set [me.labdef sym] ins) + (each ((entry (del [me.labref sym]))) + (tree-bind (oc . offs) entry + me.(set-pos (* 4 offs)) + oc.(backpatch me (* 4 offs) ins))) + me.(set-pos pos) + ins)) + +(defmeth assembler read-buf (me bytes) + (let ((buf (make-buf bytes))) + (when (neql (fill-buf buf 0 me.bstr) bytes) + (error "assembler: read past instruction block")) + buf)) + +(defmeth assembler put-word (me word) + (let* ((buf (make-buf 0))) + (buf-put-u32 buf 0 word) + (put-buf buf 0 me.bstr))) + +(defmeth assembler put-insn (me code extension operand) + (let ((word (logior (ash code 26) (ash extension 16) operand)) + (buf (make-buf 0))) + (buf-put-u32 buf 0 word) + (put-buf buf 0 me.bstr))) + +(defmeth assembler put-pair (me op1 op2) + (let ((word (logior (ash op1 16) op2)) + (buf (make-buf 0))) + (buf-put-u32 buf 0 word) + (put-buf buf 0 me.bstr))) + +(defmeth assembler get-word (me) + (let* ((buf me.(read-buf (sizeof uint32)))) + (buf-get-u32 buf 0))) + +(defmeth assembler get-insn (me) + (let* ((buf me.(read-buf (sizeof uint32))) + (word (buf-get-u32 buf 0))) + (list (ash word -26) + (logtrunc (ash word -16) 10) + (logtrunc word 16)))) + +(defmeth assembler get-pair (me) + (let* ((buf me.(read-buf (sizeof uint32))) + (word (buf-get-u32 buf 0))) + (list (ash word -16) (logtrunc word 16)))) + +(defmeth assembler immediate-fits-type (me arg operand-type) + (and (member (typeof arg) + '(fixnum bignum chr)) + (<= (+ (width arg) + [me.sign-bits (typeof arg)] + 2) + [me.imm-width operand-type]))) + +(defmeth assembler parse-args (me oc syntax pattern) + (mapcar (lambda (type arg n) + (let ((parg (caseql type + ((si mi bi) + (when me.(immediate-fits-type arg type) + arg)) + (l (cond + ((is-label arg) me.(lookup-label arg oc)) + ((integerp arg) arg))) + (n (if (integerp arg) arg)) + (o arg) + ((r rs d ds) + (cond + ((null arg) 0) + ((consp arg) + (parse-compound-operand arg)) + ((symbolp arg) + (parse-operand (symbol-name arg))))) + (t (error "assembler: invalid arg type spec"))))) + (unless (or parg (eq type 'o)) + oc.(synerr "argument ~a of ~s invalid; ~a expected" + n syntax [me.operand-name type])) + (when (and (member type '(d ds)) + (or (zerop parg) (<= 256 parg 511))) + oc.(synerr "argument ~a of ~s cannot be destination" + n syntax)) + (when (and (member type '(rs ds)) + (not (< parg 1024))) + oc.(synerr "argument ~a of ~s isn't a small register" + n syntax)) + parg)) + pattern (rest syntax) (range 1))) + +(defmeth assembler asm-one (me syntax) + (let ((oc (cond + ((is-label syntax) [%oc-hash% 'label]) + ((consp syntax) [%oc-hash% (car syntax)])))) + (unless oc + (error "assembler: invalid instruction ~s" syntax)) + oc.(asm me syntax))) + +(defmeth assembler asm (me insns) + (each ((i insns)) + me.(asm-one i)) + (unless (empty me.labref) + (error "assembler: dangling label references")) + (whenlet ((n (cdr [find-max me.labdef : cdr]))) + (unless (< 0 n (len me.buf)) + (error "assembler: labels outside of code")))) + +(defmeth assembler dis-one (me) + (tree-bind (code extension operand) me.(get-insn) + (let ((oc [%oc-hash% code])) + oc.(dis me extension operand)))) + +(defmeth assembler dis (me) + me.(set-pos 0) + (build + (while (< me.(cur-pos) (len me.buf)) + (add me.(dis-one))))) + +(defmeth assembler dis-listing (me : (stream *stdout*)) + (let ((p 0) + (l (len me.buf))) + me.(set-pos p) + (while (< p l) + (let* ((dis me.(dis-one)) + (dis-txt (cat-str [mapcar tostring dis] " ")) + (q me.(cur-pos))) + me.(set-pos p) + (format t "~,5d: ~,08X ~a\n" (trunc p 4) me.(get-word) dis-txt) + (while (< (inc p 4) q) + (format t "~,5d: ~,08X\n" (trunc p 4) me.(get-word))) + me.(set-pos q) + (set p q))))) (defvarl %oc-list-builder% (new list-builder)) |