movitz-cvs January 2008

movitz-cvs@common-lisp.net

1 participants
15 discussions

[movitz-cvs] CVS movitz
by ffjeld 31 Jan '08

31 Jan '08

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv9078 Modified Files: asm-x86.lisp Log Message: Work on asm:proglist-encode. It's now (apparently) working (i.e. able to resolve forward references), but still lacking in features required by the movitz compiler. --- /project/movitz/cvsroot/movitz/asm-x86.lisp 2008/01/29 22:25:09 1.10 +++ /project/movitz/cvsroot/movitz/asm-x86.lisp 2008/01/31 21:11:28 1.11 @@ -6,7 +6,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: asm-x86.lisp,v 1.10 2008/01/29 22:25:09 ffjeld Exp $ +;;;; $Id: asm-x86.lisp,v 1.11 2008/01/31 21:11:28 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -304,9 +304,10 @@ x) (symbol-reference (let ((s (symbol-reference-symbol x))) - (cdr (or (assoc s *symtab*) - (error 'unresolved-symbol - :symbol s))))))) + (loop (with-simple-restart (retry-symbol-resolve "Retry resolving ~S." s) + (return (cdr (or (assoc s *symtab*) + (error 'unresolved-symbol + :symbol s)))))))))) (defun resolve-and-encode (x type &key size) (encode-integer (cond

1 0

[movitz-cvs] CVS movitz
by ffjeld 31 Jan '08

31 Jan '08

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv9047 Modified Files: asm.lisp Log Message: Work on asm:proglist-encode. It's now (apparently) working (i.e. able to resolve forward references), but still lacking in features required by the movitz compiler. --- /project/movitz/cvsroot/movitz/asm.lisp 2008/01/29 22:04:31 1.3 +++ /project/movitz/cvsroot/movitz/asm.lisp 2008/01/31 21:11:24 1.4 @@ -6,7 +6,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: asm.lisp,v 1.3 2008/01/29 22:04:31 ffjeld Exp $ +;;;; $Id: asm.lisp,v 1.4 2008/01/31 21:11:24 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -21,6 +21,7 @@ #:indirect-operand #:register-operand #:unresolved-symbol + #:retry-symbol-resolve #:pc-relative-operand #:proglist-encode #:*pc* @@ -76,19 +77,64 @@ ;;;;;;;;;;;; -(defun proglist-encode (proglist &key symtab (pc 0) (encoder (find-symbol (string '#:encode-instruction) '#:asm-x86))) - (let ((*pc* pc) - (*symtab* symtab)) - (loop for instruction in proglist - appending - (etypecase instruction - (symbol - (when (assoc instruction *symtab*) - (error "Label ~S doubly defined." instruction)) - (push (cons instruction *pc*) - *symtab*) - nil) - (cons - (let ((code (funcall encoder instruction))) - (incf *pc* (length code)) - code)))))) +(defun proglist-encode (proglist &key corrections (start-pc 0) (cpu-package '#:asm-x86)) + "Encode a proglist, using instruction-encoder in symbol encode-instruction from cpu-package." + (let ((encoder (find-symbol (string '#:encode-instruction) cpu-package)) + (*pc* start-pc) + (*symtab* corrections) + (assumptions nil) + (new-corrections nil)) + (values (loop for instruction in proglist + appending + (etypecase instruction + (symbol + (let ((previous-definition (assoc instruction *symtab*))) + (cond + ((null previous-definition) + (push (cons instruction *pc*) + *symtab*)) + ((assoc instruction new-corrections) + (error "prev-def in new-corrections?? new: ~S, old: ~S" + *pc* + (cdr (assoc instruction new-corrections)))) + ((member previous-definition assumptions) + (setf (cdr previous-definition) *pc*) + (setf assumptions (delete previous-definition assumptions)) + (push previous-definition new-corrections)) + ((member previous-definition corrections) + (cond + ((> *pc* (cdr previous-definition)) + (setf (cdr previous-definition) *pc*) + (push previous-definition new-corrections)) + ((< *pc* (cdr previous-definition)) + (error "Definition for ~S shrunk from ~S to ~S." + instruction + (cdr previous-definition) + *pc*)))) + (t (error "Label ~S doubly defined. Old value: ~S, new value: ~S" + instruction + (cdr previous-definition) + *pc*)))) + nil) + (cons + (let ((code (handler-bind + ((unresolved-symbol (lambda (c) + (let ((a (cons (unresolved-symbol c) 0))) + (push a assumptions) + (push a *symtab*) + (invoke-restart 'retry-symbol-resolve))))) + (funcall encoder instruction)))) + (incf *pc* (length code)) + code))) + finally + (cond + ((not (null assumptions)) + (error "Undefined symbol~P: ~{~S~^, ~}" + (length assumptions) + (mapcar #'car assumptions))) + ((not (null new-corrections)) + (return (proglist-encode proglist + :start-pc start-pc + :cpu-package cpu-package + :corrections new-corrections))))) + *symtab*)))

1 0

[movitz-cvs] CVS movitz
by ffjeld 29 Jan '08

29 Jan '08

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv25851 Modified Files: asm-x86.lisp Log Message: Weed out some more bugs. --- /project/movitz/cvsroot/movitz/asm-x86.lisp 2008/01/29 22:09:05 1.9 +++ /project/movitz/cvsroot/movitz/asm-x86.lisp 2008/01/29 22:25:09 1.10 @@ -6,7 +6,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: asm-x86.lisp,v 1.9 2008/01/29 22:09:05 ffjeld Exp $ +;;;; $Id: asm-x86.lisp,v 1.10 2008/01/29 22:25:09 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -670,6 +670,7 @@ (defun encode-pc-rel (opcode operand type &rest extras) (when (typep operand '(or pc-relative-operand symbol-reference)) + (assert *pc* (*pc*) "Cannot encode a pc-relative operand without a value for ~S." '*pc*) (let* ((estimated-code-size (+ (type-octet-size type) (opcode-octet-size opcode))) (offset (let ((*pc* (+ *pc* estimated-code-size))) @@ -799,7 +800,8 @@ (t default-rex))))))) (defmacro opcode-reg (opcode op-reg) - `(encode-opcode-reg ,opcode ,op-reg operator-mode default-rex)) + `(return-when + (encode-opcode-reg ,opcode ,op-reg operator-mode default-rex))) (defun encode-opcode-reg-imm (opcode op-reg op-imm type operator-mode default-rex) (when (immediate-p op-imm) @@ -816,7 +818,7 @@ (when reg-index (encode (encoded-values :opcode (+ opcode (ldb (byte 3 0) reg-index)) :operand-size operator-mode - :immediate (encode-integer immediate 'type) + :immediate (encode-integer immediate type) :rex (cond ((>= reg-index 8) (assert (eq :64-bit operator-mode)) @@ -824,7 +826,8 @@ (t default-rex)))))))))) (defmacro opcode-reg-imm (opcode op-reg op-imm type) - `(encode-opcode-reg-imm ,opcode ,op-reg ,op-imm ',type operator-mode default-rex)) + `(return-when + (encode-opcode-reg-imm ,opcode ,op-reg ,op-imm ',type operator-mode default-rex))) ;;;;;;;;;;;;;;;;

1 0

[movitz-cvs] CVS movitz
by ffjeld 29 Jan '08

29 Jan '08

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv22399 Modified Files: asm-x86.lisp Log Message: Macro encoded-result is used no more. --- /project/movitz/cvsroot/movitz/asm-x86.lisp 2008/01/29 22:04:34 1.8 +++ /project/movitz/cvsroot/movitz/asm-x86.lisp 2008/01/29 22:09:05 1.9 @@ -6,7 +6,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: asm-x86.lisp,v 1.8 2008/01/29 22:04:34 ffjeld Exp $ +;;;; $Id: asm-x86.lisp,v 1.9 2008/01/29 22:09:05 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -237,7 +237,8 @@ (default-rex nil)) (declare (ignorable operator-mode default-rex)) (macrolet ((yield (&rest args) - `(encoded-result :operand-size 8 ,@args))) + `(return-from operator + (encode (encoded-values :operand-size operator-mode ,@args))))) ,@body)))) (defmacro define-operator/16 (operator lambda-list &body body) @@ -246,7 +247,8 @@ (default-rex nil)) (declare (ignorable operator-mode default-rex)) (macrolet ((yield (&rest args) - `(encoded-result :operand-size operator-mode ,@args))) + `(return-from operator + (encode (encoded-values :operand-size operator-mode ,@args))))) ,@body)))) (defmacro define-operator/32 (operator lambda-list &body body) @@ -255,7 +257,8 @@ (default-rex nil)) (declare (ignorable operator-mode default-rex)) (macrolet ((yield (&rest args) - `(encoded-result :operand-size operator-mode ,@args))) + `(return-from operator + (encode (encoded-values :operand-size operator-mode ,@args))))) ,@body)))) (defmacro define-operator/64 (operator lambda-list &body body) @@ -264,7 +267,8 @@ (default-rex '(:rex.w))) (declare (ignorable operator-mode default-rex)) (macrolet ((yield (&rest args) - `(encoded-result :operand-size operator-mode ,@args))) + `(return-from operator + (encode (encoded-values :operand-size operator-mode ,@args))))) ,@body)))) (defmacro define-operator/64* (operator lambda-list &body body) @@ -633,11 +637,6 @@ ))))))))))) - -;; (defmacro encoded-result (&rest args &key prefixes prefix rex opcode mod reg rm scale index base displacement immediate operand-size address-size) -;; (declare (ignore prefixes prefix rex opcode mod reg rm scale index base displacement immediate operand-size address-size)) -;; `(return-from operator (encoded-values ,@args))) - (defmacro return-when (form) `(let ((x ,form)) (when x (return-from operator x))))

1 0

[movitz-cvs] CVS movitz
by ffjeld 29 Jan '08

29 Jan '08

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv21914 Modified Files: asm-x86.lisp Log Message: More assembler hackery. --- /project/movitz/cvsroot/movitz/asm-x86.lisp 2008/01/18 23:57:41 1.7 +++ /project/movitz/cvsroot/movitz/asm-x86.lisp 2008/01/29 22:04:34 1.8 @@ -6,7 +6,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: asm-x86.lisp,v 1.7 2008/01/18 23:57:41 ffjeld Exp $ +;;;; $Id: asm-x86.lisp,v 1.8 2008/01/29 22:04:34 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -15,9 +15,7 @@ (in-package asm-x86) -(defvar *symtab* nil) (defvar *cpu-mode* :32-bit) -(defvar *pc* nil "Current program counter.") (defvar *instruction-encoders* (make-hash-table :test 'eq)) @@ -74,63 +72,61 @@ (loop for b from 0 below (* 8 n) by 8 collect (ldb (byte 8 b) i))) -(defun encode-instruction (instruction &key - ((:symtab *symtab*) *symtab*) - ((:cpu-mode *cpu-mode*) *cpu-mode*)) - "Return list of octets," - (multiple-value-bind (prefixes rexes opcode mod reg rm scale index base displacement immediate operand-size address-size) - (encode-to-parts instruction) - (unless opcode - (error "Unable to encode instruction ~S." instruction)) - (when (or (and (eq address-size :32-bit) - (eq *cpu-mode* :64-bit)) - (and (eq address-size :16-bit) - (eq *cpu-mode* :32-bit)) - (and (eq address-size :64-bit) - (eq *cpu-mode* :32-bit)) - (and (eq address-size :32-bit) - (eq *cpu-mode* :16-bit))) - (pushnew :address-size-override - prefixes)) - (when (or (and (eq operand-size :16-bit) - (eq *cpu-mode* :64-bit)) - (and (eq operand-size :16-bit) - (eq *cpu-mode* :32-bit)) - (and (eq operand-size :32-bit) - (eq *cpu-mode* :16-bit))) - (pushnew :operand-size-override - prefixes)) - (append (mapcar #'prefix-lookup (reverse prefixes)) - (rex-encode rexes :rm rm) - (when (< 16 (integer-length opcode)) - (list (ldb (byte 8 16) opcode))) - (when (< 8(integer-length opcode)) - (list (ldb (byte 8 8) opcode))) - (list (ldb (byte 8 0) opcode)) - (when (or mod reg rm) - (assert (and mod reg rm) (mod reg rm) - "Either all or none of mod, reg, and rm must be defined. mod=~S, reg=~S, rm=~S." mod reg rm) - (check-type mod (unsigned-byte 2)) - (list (logior (ash (ldb (byte 2 0) mod) - 6) - (ash (ldb (byte 3 0) reg) - 3) - (ash (ldb (byte 3 0) rm) - 0)))) - (when (or scale index base) - (assert (and scale index base) (scale index base) - "Either all or none of scale, index, and base must be defined. scale=~S, index=~S, base=~S." scale index base) - (check-type scale (unsigned-byte 2)) - (check-type index (unsigned-byte 4)) - (check-type base (unsigned-byte 4)) - (list (logior (ash (ldb (byte 2 0) scale) - 6) - (ash (ldb (byte 3 0) index) - 3) - (ash (ldb (byte 3 0) base) - 0)))) - displacement - immediate))) +(defun encode-values-fun (prefixes rexes opcode mod reg rm scale index base displacement immediate operand-size address-size) + (assert opcode) + (when (or (and (eq address-size :32-bit) + (eq *cpu-mode* :64-bit)) + (and (eq address-size :16-bit) + (eq *cpu-mode* :32-bit)) + (and (eq address-size :64-bit) + (eq *cpu-mode* :32-bit)) + (and (eq address-size :32-bit) + (eq *cpu-mode* :16-bit))) + (pushnew :address-size-override + prefixes)) + (when (or (and (eq operand-size :16-bit) + (eq *cpu-mode* :64-bit)) + (and (eq operand-size :16-bit) + (eq *cpu-mode* :32-bit)) + (and (eq operand-size :32-bit) + (eq *cpu-mode* :16-bit))) + (pushnew :operand-size-override + prefixes)) + (append (mapcar #'prefix-lookup (reverse prefixes)) + (rex-encode rexes :rm rm) + (when (< 16 (integer-length opcode)) + (list (ldb (byte 8 16) opcode))) + (when (< 8(integer-length opcode)) + (list (ldb (byte 8 8) opcode))) + (list (ldb (byte 8 0) opcode)) + (when (or mod reg rm) + (assert (and mod reg rm) (mod reg rm) + "Either all or none of mod, reg, and rm must be defined. mod=~S, reg=~S, rm=~S." mod reg rm) + (check-type mod (unsigned-byte 2)) + (list (logior (ash (ldb (byte 2 0) mod) + 6) + (ash (ldb (byte 3 0) reg) + 3) + (ash (ldb (byte 3 0) rm) + 0)))) + (when (or scale index base) + (assert (and scale index base) (scale index base) + "Either all or none of scale, index, and base must be defined. scale=~S, index=~S, base=~S." scale index base) + (check-type scale (unsigned-byte 2)) + (check-type index (unsigned-byte 4)) + (check-type base (unsigned-byte 4)) + (list (logior (ash (ldb (byte 2 0) scale) + 6) + (ash (ldb (byte 3 0) index) + 3) + (ash (ldb (byte 3 0) base) + 0)))) + displacement + immediate)) + +(defmacro encode (values-form) + `(multiple-value-call #'encode-values-fun ,values-form)) + (defmacro merge-encodings (form1 form2) `(multiple-value-bind (prefixes1 rexes1 opcode1 mod1 reg1 rm1 scale1 index1 base1 displacement1 immediate1 operand-size1 address-size1) @@ -179,6 +175,20 @@ operand-size address-size)) +(defun encode-instruction (instruction) + (multiple-value-bind (legacy-prefixes instruction) + (if (listp (car instruction)) + (values (car instruction) + (cdr instruction)) + (values nil + instruction)) + (destructuring-bind (operator &rest operands) + instruction + (nconc (mapcar #'prefix-lookup legacy-prefixes) + (apply (or (gethash operator *instruction-encoders*) + (error "Unknown instruction operator ~S in ~S." operator instruction)) + operands))))) + (defun encode-to-parts (instruction) (multiple-value-bind (legacy-prefixes instruction) (if (listp (car instruction)) @@ -234,6 +244,7 @@ `(define-operator ,operator ,lambda-list (let ((operator-mode :16-bit) (default-rex nil)) + (declare (ignorable operator-mode default-rex)) (macrolet ((yield (&rest args) `(encoded-result :operand-size operator-mode ,@args))) ,@body)))) @@ -242,7 +253,7 @@ `(define-operator ,operator ,lambda-list (let ((operator-mode :32-bit) (default-rex nil)) - (declare (ignorable operator-mode)) + (declare (ignorable operator-mode default-rex)) (macrolet ((yield (&rest args) `(encoded-result :operand-size operator-mode ,@args))) ,@body)))) @@ -251,7 +262,7 @@ `(define-operator ,operator ,lambda-list (let ((operator-mode :64-bit) (default-rex '(:rex.w))) - (declare (ignorable operator-mode)) + (declare (ignorable operator-mode default-rex)) (macrolet ((yield (&rest args) `(encoded-result :operand-size operator-mode ,@args))) ,@body)))) @@ -307,12 +318,13 @@ type)) (defun resolve-pc-relative (operand) - (typecase operand + (etypecase operand ((cons (eql :pc+)) (reduce #'+ (cdr operand) - :key #'resolve)) + :key #'resolve)) (symbol-reference - (- (resolve operand) *pc*)))) + (- (resolve operand) + *pc*)))) (defun encode-integer (i type) (assert (typep i type)) @@ -320,6 +332,17 @@ (loop for b upfrom 0 below bit-size by 8 collect (ldb (byte 8 b) i)))) +(defun type-octet-size (type) + (assert (member (car type) + '(sint uint xint)) + (type)) + (values (ceiling (cadr type) 8))) + +(defun opcode-octet-size (opcode) + (loop do (setf opcode (ash opcode -8)) + count t + while (plusp opcode))) + (defun parse-indirect-operand (operand) (assert (indirect-operand-p operand)) (let (reg offsets reg2 reg-scale) @@ -611,93 +634,129 @@ -(defmacro encoded-result (&rest args &key prefixes prefix rex opcode mod reg rm scale index base displacement immediate operand-size address-size) - (declare (ignore prefixes prefix rex opcode mod reg rm scale index base displacement immediate operand-size address-size)) - `(return-from operator (encoded-values ,@args))) +;; (defmacro encoded-result (&rest args &key prefixes prefix rex opcode mod reg rm scale index base displacement immediate operand-size address-size) +;; (declare (ignore prefixes prefix rex opcode mod reg rm scale index base displacement immediate operand-size address-size)) +;; `(return-from operator (encoded-values ,@args))) + +(defmacro return-when (form) + `(let ((x ,form)) + (when x (return-from operator x)))) + +(defmacro return-values-when (form) + `(let ((x (encode ,form))) + (when x (return-from operator x)))) (defmacro imm (imm-operand opcode imm-type &rest extras) `(when (immediate-p ,imm-operand) (let ((immediate (resolve ,imm-operand))) (when (typep immediate ',imm-type) - (encoded-result :opcode ,opcode - :immediate (encode-integer immediate ',imm-type) - :operand-size operator-mode - :rex default-rex - ,@extras))))) + (return-values-when + (encoded-values :opcode ,opcode + :immediate (encode-integer immediate ',imm-type) + :operand-size operator-mode + :rex default-rex + ,@extras)))))) (defmacro imm-modrm (op-imm op-modrm opcode digit type) `(when (immediate-p ,op-imm) (let ((immediate (resolve ,op-imm))) (when (typep immediate ',type) - (return-from operator - (merge-encodings (encoded-values :opcode ,opcode - :reg ,digit - :operand-size operator-mode - :rex default-rex - :immediate (encode-integer immediate ',type)) - (encode-reg/mem ,op-modrm operator-mode))))))) + (return-values-when + (merge-encodings (encoded-values :opcode ,opcode + :reg ,digit + :operand-size operator-mode + :rex default-rex + :immediate (encode-integer immediate ',type)) + (encode-reg/mem ,op-modrm operator-mode))))))) + +(defun encode-pc-rel (opcode operand type &rest extras) + (when (typep operand '(or pc-relative-operand symbol-reference)) + (let* ((estimated-code-size (+ (type-octet-size type) + (opcode-octet-size opcode))) + (offset (let ((*pc* (+ *pc* estimated-code-size))) + (resolve-pc-relative operand)))) + (when (typep offset type) + (let ((code (encode (apply #'encoded-values + :opcode opcode + :displacement (encode-integer offset type) + extras)))) + (if (= (length code) + estimated-code-size) + code + (let* ((code-size (length code)) + (offset (let ((*pc* (+ *pc* code-size))) + (resolve-pc-relative operand)))) + (when (typep offset type) + (let ((code (encode (apply #'encoded-values + :opcode opcode + :displacement (encode-integer offset type) + extras)))) + (assert (= code-size (length code))) + code))))))))) (defmacro pc-rel (opcode operand type &rest extras) - `(let ((offset (resolve-pc-relative ,operand))) - (when (typep offset ',type) - (return-from operator - (encoded-values :opcode ,opcode - :displacement (encode-integer offset ',type) - ,@extras))))) + `(return-when (encode-pc-rel ,opcode ,operand ',type ,@extras))) (defmacro modrm (operand opcode digit) `(when (typep ,operand '(or register-operand indirect-operand)) - (return-from operator - (merge-encodings (encoded-values :opcode ,opcode - :reg ,digit - :operand-size operator-mode - :rex default-rex) - (encode-reg/mem ,operand operator-mode))))) + (return-values-when + (merge-encodings (encoded-values :opcode ,opcode + :reg ,digit + :operand-size operator-mode + :rex default-rex) + (encode-reg/mem ,operand operator-mode))))) + +(defun encode-reg-modrm (op-reg op-modrm opcode operator-mode default-rex &rest extras) + (let* ((reg-map (ecase operator-mode + (:8-bit '(:al :cl :dl :bl :ah :ch :dh :bh)) + (:16-bit '(:ax :cx :dx :bx :sp :bp :si :di)) + (:32-bit '(:eax :ecx :edx :ebx :esp :ebp :esi :edi)) + (:64-bit '(:rax :rcx :rdx :rbx :rsp :rbp :rsi :rdi :r8 :r9 :r10 :r11 :r12 :r13 :r14 :r15)) + (:mm '(:mm0 :mm1 :mm2 :mm3 :mm4 :mm5 :mm6 :mm7 :mm8)) + (:xmm '(:xmm0 :xmm1 :xmm2 :xmm3 :xmm4 :xmm5 :xmm6 :xmm7)))) + (reg-index (position op-reg reg-map))) + (when reg-index + (encode (merge-encodings (apply #'encoded-values + :opcode opcode + :reg reg-index + :operand-size operator-mode + :rex default-rex + extras) + (encode-reg/mem op-modrm operator-mode)))))) (defmacro reg-modrm (op-reg op-modrm opcode &rest extras) - `(let* ((reg-map (ecase operator-mode - (:8-bit '(:al :cl :dl :bl :ah :ch :dh :bh)) - (:16-bit '(:ax :cx :dx :bx :sp :bp :si :di)) - (:32-bit '(:eax :ecx :edx :ebx :esp :ebp :esi :edi)) - (:64-bit '(:rax :rcx :rdx :rbx :rsp :rbp :rsi :rdi :r8 :r9 :r10 :r11 :r12 :r13 :r14 :r15)) - (:mm '(:mm0 :mm1 :mm2 :mm3 :mm4 :mm5 :mm6 :mm7 :mm8)) - (:xmm '(:xmm0 :xmm1 :xmm2 :xmm3 :xmm4 :xmm5 :xmm6 :xmm7)))) - (reg-index (position ,op-reg reg-map))) - (when reg-index - (return-from operator - (merge-encodings (encoded-values :opcode ,opcode - :reg reg-index - :operand-size operator-mode - :rex default-rex - ,@extras) - (encode-reg/mem ,op-modrm operator-mode)))))) + `(return-when (encode-reg-modrm ,op-reg ,op-modrm ,opcode operator-mode default-rex ,@extras))) + + +(defun encode-reg-cr (op-reg op-cr opcode operator-mode default-rex &rest extras) + (let* ((reg-map (ecase operator-mode + (:32-bit '(:eax :ecx :edx :ebx :esp :ebp :esi :edi)) + (:64-bit '(:rax :rcx :rdx :rbx :rsp :rbp :rsi :rdi :r8 :r9 :r10 :r11 :r12 :r13 :r14 :r15)))) + (reg-index (position op-reg reg-map)) + (cr-index (position op-cr '(:cr0 :cr1 :cr2 :cr3 :cr4 :cr5 :cr6 :cr7)))) + (when (and reg-index + cr-index) + (encode (apply #'encoded-values + :opcode opcode + :mod #b11 + :rm reg-index + :reg cr-index + :operand-size operator-mode + :rex default-rex + extras))))) (defmacro reg-cr (op-reg op-cr opcode &rest extras) - `(let* ((reg-map (ecase operator-mode - (:32-bit '(:eax :ecx :edx :ebx :esp :ebp :esi :edi)) - (:64-bit '(:rax :rcx :rdx :rbx :rsp :rbp :rsi :rdi :r8 :r9 :r10 :r11 :r12 :r13 :r14 :r15)))) - (reg-index (position ,op-reg reg-map)) - (cr-index (position ,op-cr '(:cr0 :cr1 :cr2 :cr3 :cr4 :cr5 :cr6 :cr7)))) - (when (and reg-index - cr-index) - (return-from operator - (encoded-values :opcode ,opcode - :mod #b11 - :rm reg-index - :reg cr-index - :operand-size operator-mode - :rex default-rex - ,@extras))))) + `(return-when (encode-reg-cr ,op-reg ,op-cr ,opcode operator-mode default-rex ,@extras))) (defmacro sreg-modrm (op-sreg op-modrm opcode) `(let* ((reg-map '(:es :cs :ss :ds :fs :gs)) [134 lines skipped]

1 0

[movitz-cvs] CVS movitz
by ffjeld 29 Jan '08

29 Jan '08

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv21898 Modified Files: asm.lisp Log Message: More assembler hackery. --- /project/movitz/cvsroot/movitz/asm.lisp 2008/01/03 10:34:20 1.2 +++ /project/movitz/cvsroot/movitz/asm.lisp 2008/01/29 22:04:31 1.3 @@ -6,7 +6,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: asm.lisp,v 1.2 2008/01/03 10:34:20 ffjeld Exp $ +;;;; $Id: asm.lisp,v 1.3 2008/01/29 22:04:31 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -20,10 +20,17 @@ #:indirect-operand-p #:indirect-operand #:register-operand - #:unresolved-symbol)) + #:unresolved-symbol + #:pc-relative-operand + #:proglist-encode + #:*pc* + #:*symtab*)) (in-package asm) +(defvar *pc* nil "Current program counter.") +(defvar *symtab* nil "Current symbol table.") + (deftype symbol-reference () '(cons (eql quote) (cons symbol null))) @@ -52,9 +59,36 @@ (defun indirect-operand-p (operand) (typep operand 'indirect-operand)) +(deftype pc-relative-operand () + '(cons (eql :pc+))) + +(defun pc-relative-operand-p (operand) + (typep operand 'pc-relative-operand)) + (define-condition unresolved-symbol () ((symbol :initarg :symbol :reader unresolved-symbol)) (:report (lambda (c s) (format s "Unresolved symbol ~S." (unresolved-symbol c))))) + + +;;;;;;;;;;;; + + +(defun proglist-encode (proglist &key symtab (pc 0) (encoder (find-symbol (string '#:encode-instruction) '#:asm-x86))) + (let ((*pc* pc) + (*symtab* symtab)) + (loop for instruction in proglist + appending + (etypecase instruction + (symbol + (when (assoc instruction *symtab*) + (error "Label ~S doubly defined." instruction)) + (push (cons instruction *pc*) + *symtab*) + nil) + (cons + (let ((code (funcall encoder instruction))) + (incf *pc* (length code)) + code))))))

1 0

[movitz-cvs] CVS movitz
by ffjeld 18 Jan '08

18 Jan '08

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv23036 Modified Files: asm-x86.lisp Log Message: Still more instructions. --- /project/movitz/cvsroot/movitz/asm-x86.lisp 2008/01/18 21:37:41 1.6 +++ /project/movitz/cvsroot/movitz/asm-x86.lisp 2008/01/18 23:57:41 1.7 @@ -6,7 +6,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: asm-x86.lisp,v 1.6 2008/01/18 21:37:41 ffjeld Exp $ +;;;; $Id: asm-x86.lisp,v 1.7 2008/01/18 23:57:41 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -672,6 +672,23 @@ ,@extras) (encode-reg/mem ,op-modrm operator-mode)))))) +(defmacro reg-cr (op-reg op-cr opcode &rest extras) + `(let* ((reg-map (ecase operator-mode + (:32-bit '(:eax :ecx :edx :ebx :esp :ebp :esi :edi)) + (:64-bit '(:rax :rcx :rdx :rbx :rsp :rbp :rsi :rdi :r8 :r9 :r10 :r11 :r12 :r13 :r14 :r15)))) + (reg-index (position ,op-reg reg-map)) + (cr-index (position ,op-cr '(:cr0 :cr1 :cr2 :cr3 :cr4 :cr5 :cr6 :cr7)))) + (when (and reg-index + cr-index) + (return-from operator + (encoded-values :opcode ,opcode + :mod #b11 + :rm reg-index + :reg cr-index + :operand-size operator-mode + :rex default-rex + ,@extras))))) + (defmacro sreg-modrm (op-sreg op-modrm opcode) `(let* ((reg-map '(:es :cs :ss :ds :fs :gs)) (reg-index (position ,op-sreg reg-map))) @@ -815,7 +832,7 @@ (define-operator* (:16 :bsrw :32 :bsrl :64 :bsrr) (src dst) (reg-modrm dst src #x0fbd)) -(define-operator* (:32 :bswapl :64 :bswapr) (dst) +(define-operator* (:32 :bswap :64 :bswapr) (dst) (opcode-reg #x0fc8 dst)) ;;;;;;;;;;; BT, BTC, BTR, BTS @@ -1250,6 +1267,16 @@ (reg-modrm dst src #x8b) (reg-modrm src dst #x89)) +;;;;;;;;;;; MOVCR + +(define-operator/32 :movcr (src dst) + (when (eq src :cr8) + (reg-cr dst :cr0 #xf00f20)) + (when (eq dst :cr8) + (reg-cr src :cr0 #xf00f22)) + (reg-cr src dst #x0f22) + (reg-cr dst src #x0f20)) + ;;;;;;;;;;; MOVSX (define-operator* (:32 :movsxb) (src dst) @@ -1266,6 +1293,22 @@ (define-operator* (:32 :movzxw) (src dst) (reg-modrm dst src #x0fb7)) +;;;;;;;;;;; NEG + +(define-operator/8 :negb (dst) + (modrm dst #xf6 3)) + +(define-operator* (:16 :negw :32 :negl :64 :negr) (dst) + (modrm dst #xf7 3)) + +;;;;;;;;;;; NOT + +(define-operator/8 :notb (dst) + (modrm dst #xf6 2)) + +(define-operator* (:16 :notw :32 :notl :64 :notr) (dst) + (modrm dst #xf7 2)) + ;;;;;;;;;;; OR (define-operator/8 :orb (src dst) @@ -1325,6 +1368,11 @@ (opcode-reg #x58 dst) (modrm dst #x8f 0)) +;;;;;;;;;;; POPF + +(define-operator* (:16 :popfw :32 :popfl :64 :popfr) () + (opcode #x9d)) + ;;;;;;;;;;; PUSH (define-operator* (:16 :pushw :32 :pushl) (src) @@ -1347,6 +1395,16 @@ (imm src #x68 (sint 32)) (modrm src #xff 6)) +;;;;;;;;;;; PUSHF + +(define-operator* (:16 :pushfw :32 :pushfl :64 :pushfr) () + (opcode #x9c)) + +;;;;;;;;;;; RDTSC + +(define-operator :rdtsc () + (opcode #x0f31)) + ;;;;;;;;;;; RET (define-operator :ret () @@ -1366,6 +1424,23 @@ (:cl (modrm dst #xd3 7))) (imm-modrm count dst #xc1 7 (uint 8))) +;;;;;;;;;;; SBB + +(define-operator/8 :sbbb (subtrahend dst) + (when (eq dst :al) + (imm subtrahend #x1c (xint 8))) + (imm-modrm subtrahend dst #x80 3 (xint 8)) + (reg-modrm dst subtrahend #x1a) + (reg-modrm subtrahend dst #x18)) + +(define-operator* (:16 :sbbw :32 :sbbl :64 :sbbr) (subtrahend dst) + (imm-modrm subtrahend dst #x83 3 (sint 8)) + (when (eq dst :ax-eax-rax) + (imm subtrahend #x1d :int-16-32-64)) + (imm-modrm subtrahend dst #x81 3 :int-16-32-64) + (reg-modrm dst subtrahend #x1b) + (reg-modrm subtrahend dst #x19)) + ;;;;;;;;;;; SHL (define-operator/8 :shlb (count dst) @@ -1380,6 +1455,17 @@ (:cl (modrm dst #xd3 4))) (imm-modrm count dst #xc1 4 (uint 8))) +;;;;;;;;;;; SHLD + +(define-operator* (:16 :shldw :32 :shldl :64 :shldr) (count dst1 dst2) + (when (eq :cl count) + (reg-modrm dst1 dst2 #x0fa5)) + (when (immediate-p count) + (let ((immediate (resolve count))) + (when (typep immediate '(uint #x8)) + (reg-modrm dst1 dst2 #x0fa4 + :immediate (encode-integer count '(uint 8))))))) + ;;;;;;;;;;; SHR (define-operator/8 :shrb (count dst) @@ -1394,6 +1480,18 @@ (:cl (modrm dst #xd3 5))) (imm-modrm count dst #xc1 5 (uint 8))) +;;;;;;;;;;; SHRD + +(define-operator* (:16 :shrdw :32 :shrdl :64 :shrdr) (count dst1 dst2) + (when (eq :cl count) + (reg-modrm dst1 dst2 #x0fad)) + (when (immediate-p count) + (let ((immediate (resolve count))) + (when (typep immediate '(uint #x8)) + (reg-modrm dst1 dst2 #x0fac + :immediate (encode-integer count '(uint 8))))))) + + ;;;;;;;;;;; STC, STD, STI (define-operator :stc () @@ -1437,8 +1535,21 @@ (reg-modrm mask dst #x85)) -;;;;;;;;;;; XOR +;;;;;;;;;;; XCHG +(define-operator/8 :xchgb (x y) + (reg-modrm y x #x86) + (reg-modrm x y #x86)) + +(define-operator* (:16 :xchgw :32 :xchgl :64 :xchgr) (x y) + (when (eq y :ax-eax-rax) + (opcode-reg #x90 x)) + (when (eq x :ax-eax-rax) + (opcode-reg #x90 y)) + (reg-modrm x y #x87) + (reg-modrm y x #x87)) + +;;;;;;;;;;; XOR (define-operator/8 :xorb (src dst) (when (eq dst :al)

1 0

[movitz-cvs] CVS movitz
by ffjeld 18 Jan '08

18 Jan '08

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv18702 Modified Files: asm-x86.lisp Log Message: More instructions. --- /project/movitz/cvsroot/movitz/asm-x86.lisp 2008/01/03 10:34:18 1.5 +++ /project/movitz/cvsroot/movitz/asm-x86.lisp 2008/01/18 21:37:41 1.6 @@ -6,7 +6,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: asm-x86.lisp,v 1.5 2008/01/03 10:34:18 ffjeld Exp $ +;;;; $Id: asm-x86.lisp,v 1.6 2008/01/18 21:37:41 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -102,7 +102,9 @@ prefixes)) (append (mapcar #'prefix-lookup (reverse prefixes)) (rex-encode rexes :rm rm) - (when (< 8(integer-length opcode)) + (when (< 16 (integer-length opcode)) + (list (ldb (byte 8 16) opcode))) + (when (< 8(integer-length opcode)) (list (ldb (byte 8 8) opcode))) (list (ldb (byte 8 0) opcode)) (when (or mod reg rm) @@ -479,7 +481,8 @@ ((and (not reg2) register-index (= 1 reg-scale) - (zerop offset)) + (and (zerop offset) + (not (= register-index #b101)))) (encoded-values :mod #b00 :rm register-index :address-size address-size)) @@ -803,7 +806,7 @@ ;;;;;;;;;;; BOUND, BSF, BSR, BSWAP -(define-operator* (:16 :boundw :32 :boundl) (bounds reg) +(define-operator* (:16 :boundw :32 :bound) (bounds reg) (reg-modrm reg bounds #x62)) (define-operator* (:16 :bsfw :32 :bsfl :64 :bsfr) (src dst) @@ -954,56 +957,6 @@ (reg-modrm dst src #x3b) (reg-modrm src dst #x39)) -;;;;;;;;;;; MOV - -(define-operator/8 :movb (src dst) - (when (eq src :al) - (moffset #xa2 dst (uint 8))) - (when (eq dst :al) - (moffset #xa0 src (uint 8))) - (opcode-reg-imm #xb0 dst src (xint 8)) - (imm-modrm src dst #xc6 0 (xint 8)) - (reg-modrm dst src #x8a) - (reg-modrm src dst #x88)) - -(define-operator/16 :movw (src dst) - (when (eq src :ax) - (moffset #xa3 dst (uint 16))) - (when (eq dst :ax) - (moffset #xa0 src (uint 16))) - (opcode-reg-imm #xb8 dst src (xint 16)) - (imm-modrm src dst #xc7 0 (xint 16)) - (sreg-modrm src dst #x8c) - (sreg-modrm dst src #x8e) - (reg-modrm dst src #x8b) - (reg-modrm src dst #x89)) - -(define-operator/32 :movl (src dst) - (when (eq src :eax) - (moffset #xa3 dst (uint 32))) - (when (eq dst :eax) - (moffset #xa0 src (uint 32))) - (opcode-reg-imm #xb8 dst src (xint 32)) - (imm-modrm src dst #xc7 0 (xint 32)) - (reg-modrm dst src #x8b) - (reg-modrm src dst #x89)) - -;;;;;;;;;;; POP - -(define-operator* (:16 :popw :32 :popl) (dst) - (case dst - (:ds (yield :opcode #x1f)) - (:es (yield :opcode #x07)) - (:ss (yield :opcode #x17)) - (:fs (yield :opcode #x0fa1)) - (:gs (yield :opcode #x0fa9))) - (opcode-reg #x58 dst) - (modrm dst #x8f 0)) - -(define-operator/64* :popr (dst) - (opcode-reg #x58 dst) - (modrm dst #x8f 0)) - ;;;;;;;;;;; CMPXCHG (define-operator/8 :cmpxchgb (cmp-reg cmp-modrm al-dst) @@ -1206,6 +1159,11 @@ (define-jcc :jpo #x7b) (define-jcc :js #x78) (define-jcc :jz #x74) + +(define-operator* (:16 :jcxz :32 :jecxz :64 :jrcxz) (dst) + (pc-rel #xe3 dst (sint 8) + :operand-size operator-mode + :rex default-rex)) ;;;;;;;;;;; JMP @@ -1242,6 +1200,131 @@ (define-operator* (:16 :lidtw :32 :lidtl :64 :lidtr) (addr) (modrm addr #x0f01 3)) +;;;;;;;;;;; LFENCE + +(define-operator :lfence () + (opcode #x0faee8)) + +;;;;;;;;;;; LOOP, LOOPE, LOOPNE + +(define-operator :loop (dst) + (pc-rel #xe2 dst (sint 8))) + +(define-operator :loope (dst) + (pc-rel #xe1 dst (sint 8))) + +(define-operator :loopne (dst) + (pc-rel #xe0 dst (sint 8))) + +;;;;;;;;;;; MOV + +(define-operator/8 :movb (src dst) + (when (eq src :al) + (moffset #xa2 dst (uint 8))) + (when (eq dst :al) + (moffset #xa0 src (uint 8))) + (opcode-reg-imm #xb0 dst src (xint 8)) + (imm-modrm src dst #xc6 0 (xint 8)) + (reg-modrm dst src #x8a) + (reg-modrm src dst #x88)) + +(define-operator/16 :movw (src dst) + (when (eq src :ax) + (moffset #xa3 dst (uint 16))) + (when (eq dst :ax) + (moffset #xa0 src (uint 16))) + (opcode-reg-imm #xb8 dst src (xint 16)) + (imm-modrm src dst #xc7 0 (xint 16)) + (sreg-modrm src dst #x8c) + (sreg-modrm dst src #x8e) + (reg-modrm dst src #x8b) + (reg-modrm src dst #x89)) + +(define-operator/32 :movl (src dst) + (when (eq src :eax) + (moffset #xa3 dst (uint 32))) + (when (eq dst :eax) + (moffset #xa0 src (uint 32))) + (opcode-reg-imm #xb8 dst src (xint 32)) + (imm-modrm src dst #xc7 0 (xint 32)) + (reg-modrm dst src #x8b) + (reg-modrm src dst #x89)) + +;;;;;;;;;;; MOVSX + +(define-operator* (:32 :movsxb) (src dst) + (reg-modrm dst src #x0fbe)) + +(define-operator* (:32 :movsxw) (src dst) + (reg-modrm dst src #x0fbf)) + +;;;;;;;;;;; MOVZX + +(define-operator* (:32 :movzxb) (src dst) + (reg-modrm dst src #x0fb6)) + +(define-operator* (:32 :movzxw) (src dst) + (reg-modrm dst src #x0fb7)) + +;;;;;;;;;;; OR + +(define-operator/8 :orb (src dst) + (when (eq dst :al) + (imm src #x0c (xint 8))) + (imm-modrm src dst #x80 1 (xint 8)) + (reg-modrm dst src #x0a) + (reg-modrm src dst #x08)) + +(define-operator* (:16 :orw :32 :orl :64 :orr) (src dst) + (imm-modrm src dst #x83 1 (sint 8)) + (when (eq dst :ax-eax-rax) + (imm src #x0d :int-16-32-64)) + (imm-modrm src dst #x81 1 :int-16-32-64) + (reg-modrm dst src #x0b) + (reg-modrm src dst #x09)) + +;;;;;;;;;;; OUT + +(define-operator/8 :outb (src port) + (when (eq :al src) + (typecase port + ((eql :dx) + (opcode #xee)) + ((uint 8) + (imm port #xe6 (uint 8)))))) + +(define-operator/16 :outw (src port) + (when (eq :ax src) + (typecase port + ((eql :dx) + (opcode #xef)) + ((uint 8) + (imm port #xe7 (uint 8)))))) + +(define-operator/32 :outl (src port) + (when (eq :eax src) + (typecase port + ((eql :dx) + (opcode #xef)) + ((uint 8) + (imm port #xe7 (uint 8)))))) + +;;;;;;;;;;; POP + +(define-operator* (:16 :popw :32 :popl) (dst) + (case dst + (:ds (yield :opcode #x1f)) + (:es (yield :opcode #x07)) + (:ss (yield :opcode #x17)) + (:fs (yield :opcode #x0fa1)) + (:gs (yield :opcode #x0fa9))) + (opcode-reg #x58 dst) + (modrm dst #x8f 0)) + +(define-operator/64* :popr (dst) + (opcode-reg #x58 dst) + (modrm dst #x8f 0)) + ;;;;;;;;;;; PUSH (define-operator* (:16 :pushw :32 :pushl) (src) @@ -1268,3 +1351,106 @@ (define-operator :ret () (opcode #xc3)) + +;;;;;;;;;;; SAR + +(define-operator/8 :sarb (count dst) + (case count + (1 (modrm dst #xd0 7)) + (:cl (modrm dst #xd2 7))) + (imm-modrm count dst #xc0 7 (uint 8))) + +(define-operator* (:16 :sarw :32 :sarl :64 :sarr) (count dst) + (case count + (1 (modrm dst #xd1 7)) + (:cl (modrm dst #xd3 7))) + (imm-modrm count dst #xc1 7 (uint 8))) + +;;;;;;;;;;; SHL + +(define-operator/8 :shlb (count dst) + (case count + (1 (modrm dst #xd0 4)) + (:cl (modrm dst #xd2 4))) + (imm-modrm count dst #xc0 4 (uint 8))) + +(define-operator* (:16 :shlw :32 :shll :64 :shlr) (count dst) + (case count + (1 (modrm dst #xd1 4)) + (:cl (modrm dst #xd3 4))) + (imm-modrm count dst #xc1 4 (uint 8))) + +;;;;;;;;;;; SHR + +(define-operator/8 :shrb (count dst) + (case count + (1 (modrm dst #xd0 5)) + (:cl (modrm dst #xd2 5))) + (imm-modrm count dst #xc0 5 (uint 8))) + +(define-operator* (:16 :shrw :32 :shrl :64 :shrr) (count dst) + (case count + (1 (modrm dst #xd1 5)) + (:cl (modrm dst #xd3 5))) + (imm-modrm count dst #xc1 5 (uint 8))) + +;;;;;;;;;;; STC, STD, STI + +(define-operator :stc () + (opcode #xf9)) + +(define-operator :std () + (opcode #xfd)) + +(define-operator :sti () + (opcode #xfb)) + +;;;;;;;;;;; SUB + +(define-operator/8 :subb (subtrahend dst) + (when (eq dst :al) + (imm subtrahend #x2c (xint 8))) + (imm-modrm subtrahend dst #x80 5 (xint 8)) + (reg-modrm dst subtrahend #x2a) + (reg-modrm subtrahend dst #x28)) + +(define-operator* (:16 :subw :32 :subl :64 :subr) (subtrahend dst) + (imm-modrm subtrahend dst #x83 5 (sint 8)) + (when (eq dst :ax-eax-rax) + (imm subtrahend #x2d :int-16-32-64)) + (imm-modrm subtrahend dst #x81 5 :int-16-32-64) + (reg-modrm dst subtrahend #x2b) + (reg-modrm subtrahend dst #x29)) + +;;;;;;;;;;; TEST + +(define-operator/8 :testb (mask dst) + (when (eq dst :al) + (imm mask #xa8 (xint 8))) + (imm-modrm mask dst #xf6 0 (xint 8)) + (reg-modrm mask dst #x84)) + +(define-operator* (:16 :testw :32 :testl :64 :testr) (mask dst) + (when (eq dst :ax-eax-rax) + (imm mask #xa9 :int-16-32-64)) + (imm-modrm mask dst #xf7 0 :int-16-32-64) + (reg-modrm mask dst #x85)) + + +;;;;;;;;;;; XOR + + +(define-operator/8 :xorb (src dst) + (when (eq dst :al) + (imm src #x34 (xint 8))) + (imm-modrm src dst #x80 6 (xint 8)) + (reg-modrm dst src #x32) + (reg-modrm src dst #x30)) + +(define-operator* (:16 :xorw :32 :xorl :64 :xorr) (src dst) + (imm-modrm src dst #x83 6 (sint 8)) + (when (eq dst :ax-eax-rax) + (imm src #x35 :int-16-32-64)) + (imm-modrm src dst #x81 6 :int-16-32-64) + (reg-modrm dst src #x33) + (reg-modrm src dst #x31))

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 17 Jan '08

17 Jan '08

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv24499 Modified Files: memref.lisp Log Message: Add/improve support for physicalp for memref and (setf memref). --- /project/movitz/cvsroot/movitz/losp/muerte/memref.lisp 2008/01/15 23:01:09 1.51 +++ /project/movitz/cvsroot/movitz/losp/muerte/memref.lisp 2008/01/17 20:20:33 1.52 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Mar 6 21:25:49 2001 ;;;; -;;;; $Id: memref.lisp,v 1.51 2008/01/15 23:01:09 ffjeld Exp $ +;;;; $Id: memref.lisp,v 1.52 2008/01/17 20:20:33 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -74,8 +74,11 @@ offset constant-offset index constant-index) (let ((type (movitz:movitz-eval type env)) - (physicalp (movitz:movitz-eval physicalp env))) - (when (and physicalp (not (eq type :unsigned-byte32))) + (physicalp (movitz:movitz-eval physicalp env)) + (prefixes (if (not physicalp) + () + movitz:*compiler-physical-segment-prefix*))) + (when (and physicalp (member type '(:lisp :code-vector))) (warn "(memref physicalp) unsupported for type ~S." type)) (case type (:unsigned-byte8 @@ -83,7 +86,7 @@ ((and (eql 0 offset) (eql 0 index)) `(with-inline-assembly (:returns :untagged-fixnum-ecx :type (unsigned-byte 8)) (:compile-form (:result-mode :eax) ,object) - (:movzxb (:eax ,(offset-by 1)) :ecx))) + (,prefixes :movzxb (:eax ,(offset-by 1)) :ecx))) ((eql 0 index) (let ((object-var (gensym "memref-object-")) (offset-var (gensym "memref-offset-"))) @@ -93,12 +96,11 @@ :type (unsigned-byte 8)) (:compile-two-forms (:eax :untagged-fixnum-ecx) ,object-var ,offset-var) ;; (:sarl ,movitz:+movitz-fixnum-shift+ :ecx) - (:movzxb (:eax :ecx ,(offset-by 1)) :ecx) - )))) + (,prefixes :movzxb (:eax :ecx ,(offset-by 1)) :ecx))))) ((eql 0 offset) `(with-inline-assembly (:returns :untagged-fixnum-ecx :type (unsigned-byte 8)) (:compile-two-forms (:eax :untagged-fixnum-ecx) ,object ,index) - (:movzxb (:eax :ecx ,(offset-by 1)) :ecx))) + (,prefixes :movzxb (:eax :ecx ,(offset-by 1)) :ecx))) (t (let ((object-var (gensym "memref-object-"))) `(let ((,object-var ,object)) (with-inline-assembly (:returns :untagged-fixnum-ecx :type (unsigned-byte 8)) @@ -106,7 +108,7 @@ (:load-lexical (:lexical-binding ,object-var) :eax) (:addl :ebx :ecx) ; index += offset (:sarl ,movitz::+movitz-fixnum-shift+ :ecx) - (:movzxb (:eax :ecx ,(offset-by 1)) :ecx))))))) + (,prefixes :movzxb (:eax :ecx ,(offset-by 1)) :ecx))))))) (:unsigned-byte16 (let* ((endian (ecase (movitz:movitz-eval endian env) ((:host :little) :little) @@ -119,7 +121,7 @@ `(with-inline-assembly (:returns :untagged-fixnum-ecx :type (unsigned-byte 16)) (:compile-form (:result-mode :eax) ,object) - (:movzxw (:eax ,(offset-by 2)) :ecx) + (,prefixes :movzxw (:eax ,(offset-by 2)) :ecx) ,@endian-fix-ecx)) ((eql 0 index) (let ((object-var (gensym "memref-object-")) @@ -130,7 +132,7 @@ :type (unsigned-byte 16)) (:compile-two-forms (:eax :ecx) ,object-var ,offset-var) (:sarl ,movitz:+movitz-fixnum-shift+ :ecx) - (:movzxw (:eax :ecx ,(offset-by 2)) :ecx) + (,prefixes :movzxw (:eax :ecx ,(offset-by 2)) :ecx) ,@endian-fix-ecx)))) ((eql 0 offset) (let ((object-var (gensym "memref-object-")) @@ -141,7 +143,7 @@ :type (unsigned-byte 16)) (:compile-two-forms (:eax :ecx) ,object-var ,index-var) (:sarl ,(1- movitz:+movitz-fixnum-shift+) :ecx) - (:movzxw (:eax :ecx ,(offset-by 2)) :ecx) + (,prefixes :movzxw (:eax :ecx ,(offset-by 2)) :ecx) ,@endian-fix-ecx)))) (t (let ((object-var (gensym "memref-object-")) (offset-var (gensym "memref-offset-")) @@ -155,14 +157,14 @@ (:leal (:ecx (:ebx 2)) :ecx) (:load-lexical (:lexical-binding ,object-var) :eax) (:sarl ,movitz::+movitz-fixnum-shift+ :ecx) - (:movzxw (:eax :ecx ,(offset-by 2)) :ecx) + (,prefixes :movzxw (:eax :ecx ,(offset-by 2)) :ecx) ,@endian-fix-ecx))))))) (:unsigned-byte14 (cond ((and (eq 0 offset) (eq 0 index)) `(with-inline-assembly (:returns :ecx :type (unsigned-byte 14)) (:compile-form (:result-mode :eax) ,object) - (:movzxw (:eax ,(offset-by 2)) :ecx) + (,prefixes :movzxw (:eax ,(offset-by 2)) :ecx) (:testb ,movitz:+movitz-fixnum-zmask+ :cl) (:jnz '(:sub-program () (:int 63))))) ((eq 0 offset) @@ -173,7 +175,7 @@ (with-inline-assembly (:returns :ecx) (:compile-two-forms (:eax :ecx) ,object-var ,index-var) (:sarl ,(1- movitz:+movitz-fixnum-shift+) :ecx) - (:movzxw (:eax :ecx ,(offset-by 2)) :ecx) + (,prefixes :movzxw (:eax :ecx ,(offset-by 2)) :ecx) (:testb ,movitz:+movitz-fixnum-zmask+ :cl) (:jnz '(:sub-program () (:int 63))))))) (t (let ((object-var (gensym "memref-object-")) @@ -187,7 +189,7 @@ (:leal (:ecx (:ebx 2)) :ecx) (:load-lexical (:lexical-binding ,object-var) :eax) (:sarl ,movitz::+movitz-fixnum-shift+ :ecx) - (:movzxw (:eax :ecx ,(offset-by 2)) :ecx) + (,prefixes :movzxw (:eax :ecx ,(offset-by 2)) :ecx) (:testb ,movitz:+movitz-fixnum-shift+ :cl) (:jnz '(:sub-program () (:int 63))))))))) (:unsigned-byte29+3 @@ -200,7 +202,7 @@ (:sarl ,movitz::+movitz-fixnum-shift+ :ecx) (:addl :ebx :ecx) (:popl :eax) ; object - (:movl (:eax :ecx ,(offset-by 4)) :ecx) + (,prefixes :movl (:eax :ecx ,(offset-by 4)) :ecx) (:leal ((:ecx 4)) :ebx) (:shrl 1 :ecx) (:andl #b11100 :ebx) @@ -222,12 +224,12 @@ ((and (eq 0 offset) (eq 0 index)) `(with-inline-assembly (:returns :multiple-values) (:compile-form (:result-mode :eax) ,object) - (:movl (:eax ,(offset-by 4)) :ecx) + (,prefixes :movl (:eax ,(offset-by 4)) :ecx) ,@fix-ecx)) ((eq 0 offset) `(with-inline-assembly (:returns :multiple-values) (:compile-two-forms (:eax :ecx) ,object ,index) - (:movl (:eax :ecx ,(offset-by 4)) :ecx) + (,prefixes :movl (:eax :ecx ,(offset-by 4)) :ecx) ,@fix-ecx)) (t (let ((object-var (gensym "memref-object-"))) `(let ((,object-var ,object)) @@ -261,7 +263,7 @@ (:xorl :eax :eax) (:movb ,(movitz:tag :character) :al) (:sarl ,movitz::+movitz-fixnum-shift+ :ecx) ; scale index - (:movb (:ebx :ecx ,(offset-by 1)) :ah))) + (,prefixes :movb (:ebx :ecx ,(offset-by 1)) :ah))) (t (let ((object-var (gensym "memref-object-"))) `(let ((,object-var ,object)) (with-inline-assembly (:returns :eax) @@ -271,19 +273,19 @@ (:movb ,(movitz:tag :character) :al) (:load-lexical (:lexical-binding ,object-var) :ebx) (:sarl ,movitz::+movitz-fixnum-shift+ :ecx) ; scale offset+index - (:movb (:ebx :ecx ,(offset-by 1)) :ah))))))) + (,prefixes :movb (:ebx :ecx ,(offset-by 1)) :ah))))))) (:location (assert (= 4 movitz::+movitz-fixnum-factor+)) (cond ((and (eq 0 offset) (eq 0 index)) `(with-inline-assembly (:returns :ecx :type (signed-byte 30)) (:compile-form (:result-mode :eax) ,object) - (:movl (:eax ,(offset-by 4)) :ecx) + (,prefixes :movl (:eax ,(offset-by 4)) :ecx) (:andl -4 :ecx))) ((eq 0 offset) `(with-inline-assembly (:returns :ecx :type (signed-byte 30)) (:compile-two-forms (:eax :ecx) ,object ,index) - (:movl (:eax :ecx ,(offset-by 4)) :ecx) + (,prefixes :movl (:eax :ecx ,(offset-by 4)) :ecx) (:andl -4 :ecx))) (t (let ((object-var (gensym "memref-object-"))) `(let ((,object-var ,object)) @@ -292,7 +294,7 @@ (:sarl ,movitz::+movitz-fixnum-shift+ :ecx) (:load-lexical (:lexical-binding ,object-var) :eax) (:addl :ebx :ecx) - (:movl (:eax :ecx ,(offset-by 4)) :ecx) + (,prefixes :movl (:eax :ecx ,(offset-by 4)) :ecx) (:andl -4 :ecx))))))) (:tag (assert (= 4 movitz::+movitz-fixnum-factor+)) @@ -300,12 +302,12 @@ ((and (eq 0 offset) (eq 0 index)) `(with-inline-assembly (:returns :untagged-fixnum-ecx :type (unsigned-byte 3)) (:compile-form (:result-mode :eax) ,object) - (:movl (:eax ,(offset-by 4)) :ecx) + (,prefixes :movl (:eax ,(offset-by 4)) :ecx) (:andl 7 :ecx))) ((eq 0 offset) `(with-inline-assembly (:returns :untagged-fixnum-ecx :type (unsigned-byte 3)) (:compile-two-forms (:eax :ecx) ,object ,index) - (:movl (:eax :ecx ,(offset-by 4)) :ecx) + (,prefixes :movl (:eax :ecx ,(offset-by 4)) :ecx) (:andl 7 :ecx))) (t (let ((object-var (gensym "memref-object-"))) `(let ((,object-var ,object)) @@ -314,39 +316,36 @@ (:sarl ,movitz::+movitz-fixnum-shift+ :ecx) (:load-lexical (:lexical-binding ,object-var) :eax) (:addl :ebx :ecx) - (:movl (:eax :ecx ,(offset-by 4)) :ecx) + (,prefixes :movl (:eax :ecx ,(offset-by 4)) :ecx) (:andl 7 :ecx))))))) (:unsigned-byte32 - (let ((prefixes (if (not physicalp) - () - movitz:*compiler-physical-segment-prefix*)) - (fix-endian (ecase (movitz:movitz-eval endian env) + (let ((fix-endian (ecase (movitz:movitz-eval endian env) ((:host :little) ()) (:big `((:bswap :ecx)))))) (assert (= 4 movitz::+movitz-fixnum-factor+)) (cond - ((and (eq 0 offset) (eq 0 index)) - `(with-inline-assembly (:returns :untagged-fixnum-ecx - :type (unsigned-byte 32)) - (:compile-form (:result-mode :eax) ,object) - (,prefixes :movl (:eax ,(offset-by 4)) :ecx) - ,@fix-endian)) - ((eq 0 offset) - `(with-inline-assembly (:returns :untagged-fixnum-ecx - :type (unsigned-byte 32)) - (:compile-two-forms (:eax :ecx) ,object ,index) - (,prefixes :movl (:eax :ecx ,(offset-by 4)) :ecx) - ,@fix-endian)) - (t (let ((object-var (gensym "memref-object-"))) - `(let ((,object-var ,object)) - (with-inline-assembly (:returns :untagged-fixnum-ecx - :type (unsigned-byte 32)) - (:compile-two-forms (:ecx :ebx) ,offset ,index) - (:sarl ,movitz::+movitz-fixnum-shift+ :ecx) - (:load-lexical (:lexical-binding ,object-var) :eax) - (:addl :ebx :ecx) - (,prefixes :movl (:eax :ecx ,(offset-by 4)) :ecx) - ,@fix-endian))))))) + ((and (eq 0 offset) (eq 0 index)) + `(with-inline-assembly (:returns :untagged-fixnum-ecx + :type (unsigned-byte 32)) + (:compile-form (:result-mode :eax) ,object) + (,prefixes :movl (:eax ,(offset-by 4)) :ecx) + ,@fix-endian)) + ((eq 0 offset) + `(with-inline-assembly (:returns :untagged-fixnum-ecx + :type (unsigned-byte 32)) + (:compile-two-forms (:eax :ecx) ,object ,index) + (,prefixes :movl (:eax :ecx ,(offset-by 4)) :ecx) + ,@fix-endian)) + (t (let ((object-var (gensym "memref-object-"))) + `(let ((,object-var ,object)) + (with-inline-assembly (:returns :untagged-fixnum-ecx + :type (unsigned-byte 32)) + (:compile-two-forms (:ecx :ebx) ,offset ,index) + (:sarl ,movitz::+movitz-fixnum-shift+ :ecx) + (:load-lexical (:lexical-binding ,object-var) :eax) + (:addl :ebx :ecx) + (,prefixes :movl (:eax :ecx ,(offset-by 4)) :ecx) + ,@fix-endian))))))) (:lisp (let* ((localp (movitz:movitz-eval localp env)) (prefixes (if localp @@ -433,469 +432,488 @@ form)))))))) (defun memref (object offset &key (index 0) (type :lisp) localp (endian :host) physicalp) - (macrolet - ((do-memref (physicalp) - `(ecase type - (:lisp - (if localp - (memref object offset :index index :localp t :physicalp ,physicalp) - (memref object offset :index index :localp nil :physicalp ,physicalp))) - (:unsigned-byte32 - (memref object offset :index index :type :unsigned-byte32 :physicalp ,physicalp)) - (:character - (memref object offset :index index :type :character :physicalp ,physicalp)) - (:unsigned-byte8 - (memref object offset :index index :type :unsigned-byte8 :physicalp ,physicalp)) - (:location - (memref object offset :index index :type :location :physicalp ,physicalp)) - (:unsigned-byte16 - (ecase endian - ((:host :little) - (memref object offset :index index :type :unsigned-byte16 :endian :little :physicalp ,physicalp)) - ((:big) - (memref object offset :index index :type :unsigned-byte16 :endian :big :physicalp ,physicalp)))) - (:code-vector - (memref object offset :index index :type :code-vector :physicalp ,physicalp)) - (:unsigned-byte14 - (memref object offset :index index :type :unsigned-byte14 :physicalp ,physicalp)) - (:signed-byte30+2 - (memref object offset :index index :type :signed-byte30+2 :physicalp ,physicalp)) - (:unsigned-byte29+3 - (memref object offset :index index :type :unsigned-byte29+3 :physicalp ,physicalp))))) - (if physicalp - (do-memref t) - (do-memref nil)))) + (case type + (:lisp + (if localp + (memref object offset :index index :localp t) + (memref object offset :index index :localp nil))) + (:code-vector + (memref object offset :index index :type :code-vector)) + (t (macrolet + ((do-memref (physicalp) + `(ecase type + + (:unsigned-byte32 + (memref object offset :index index :type :unsigned-byte32 :physicalp ,physicalp)) + (:character + (memref object offset :index index :type :character :physicalp ,physicalp)) + (:unsigned-byte8 + (memref object offset :index index :type :unsigned-byte8 :physicalp ,physicalp)) + (:location + (memref object offset :index index :type :location :physicalp ,physicalp)) + (:unsigned-byte16 + (ecase endian + ((:host :little) + (memref object offset :index index :type :unsigned-byte16 :endian :little :physicalp ,physicalp)) + ((:big) + (memref object offset :index index :type :unsigned-byte16 :endian :big :physicalp ,physicalp)))) + + (:unsigned-byte14 + (memref object offset :index index :type :unsigned-byte14 :physicalp ,physicalp)) + (:signed-byte30+2 + (memref object offset :index index :type :signed-byte30+2 :physicalp ,physicalp)) + (:unsigned-byte29+3 + (memref object offset :index index :type :unsigned-byte29+3 :physicalp ,physicalp))))) + (if physicalp + (do-memref t) + (do-memref nil)))))) -(define-compiler-macro (setf memref) (&whole form &environment env value object offset - &key (index 0) (type :lisp) (localp nil) (endian :host)) +(define-compiler-macro (setf memref) + (&whole form &environment env value object offset + &key (index 0) (type :lisp) (localp nil) (endian :host) (physicalp nil)) (if (or (not (movitz:movitz-constantp type env)) (not (movitz:movitz-constantp localp env)) - (not (movitz:movitz-constantp endian env))) + (not (movitz:movitz-constantp endian env)) + (not (movitz:movitz-constantp physicalp env))) form - (multiple-value-bind (constant-index xindex) - (extract-constant-delta index env) - (multiple-value-bind (constant-offset xoffset) - (extract-constant-delta offset env) - (flet ((offset-by (element-size) - (+ constant-offset (* constant-index element-size)))) - (case (movitz::movitz-eval type env) - (:character - (cond - ((and (movitz:movitz-constantp value env) - (movitz:movitz-constantp offset env) - (movitz:movitz-constantp index env)) - (let ((value (movitz:movitz-eval value env))) - (check-type value movitz::movitz-character) - `(progn - (with-inline-assembly (:returns :nothing) - (:compile-form (:result-mode :ebx) ,object) - (:movb ,(movitz:movitz-intern value) - (:ebx ,(+ (movitz:movitz-eval offset env) - (* 1 (movitz:movitz-eval index env)))))) - ,value))) - ((and (movitz:movitz-constantp offset env) - (movitz:movitz-constantp index env)) - `(with-inline-assembly (:returns :eax) - (:compile-two-forms (:eax :ebx) ,value ,object) - (:movb :ah (:ebx ,(+ (movitz:movitz-eval offset env) - (* 1 (movitz:movitz-eval index env))))))) - ((movitz:movitz-constantp offset env) - (let ((value-var (gensym "memref-value-"))) - `(let ((,value-var ,value)) - (with-inline-assembly (:returns :eax) - (:compile-two-forms (:ebx :untagged-fixnum-ecx) ,object ,index) - (:load-lexical (:lexical-binding ,value-var) :eax) - (:movb :ah (:ebx :ecx ,(+ (movitz:movitz-eval offset env)))))))) - (t (let ((object-var (gensym "memref-object-")) - (offset-var (gensym "memref-offset-"))) - `(let ((,object-var ,object) (,offset-var ,offset)) - (with-inline-assembly (:returns :nothing) - (:compile-two-forms (:ecx :eax) ,index ,value) - (:load-lexical (:lexical-binding ,offset-var) :ebx) - (:addl :ebx :ecx) - (:sarl ,movitz::+movitz-fixnum-shift+ :ecx) - (:load-lexical (:lexical-binding ,object-var) :ebx) - (:movb :ah (:ebx :ecx)))))))) - (:unsigned-byte32 - (let ((endian (ecase (movitz:movitz-eval endian env) - ((:host :little) :little) - (:big :big)))) - (assert (= 4 movitz::+movitz-fixnum-factor+)) - (cond - ((and (movitz:movitz-constantp value env) - (movitz:movitz-constantp offset env) - (movitz:movitz-constantp index env)) [805 lines skipped]

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 15 Jan '08

15 Jan '08

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv14571 Modified Files: memref.lisp Log Message: Fix several (more) bugs in (memref-int :type :unsigned-byte32) reader and writer. --- /project/movitz/cvsroot/movitz/losp/muerte/memref.lisp 2008/01/13 22:27:10 1.50 +++ /project/movitz/cvsroot/movitz/losp/muerte/memref.lisp 2008/01/15 23:01:09 1.51 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Mar 6 21:25:49 2001 ;;;; -;;;; $Id: memref.lisp,v 1.50 2008/01/13 22:27:10 ffjeld Exp $ +;;;; $Id: memref.lisp,v 1.51 2008/01/15 23:01:09 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -432,24 +432,39 @@ (t (error "Unknown memref type: ~S" (movitz:movitz-eval type nil nil)) form)))))))) -(defun memref (object offset &key (index 0) (type :lisp) localp (endian :host)) - (ecase type - (:lisp (if localp - (memref object offset :index index :localp t) - (memref object offset :index index :localp nil))) - (:unsigned-byte32 (memref object offset :index index :type :unsigned-byte32)) - (:character (memref object offset :index index :type :character)) - (:unsigned-byte8 (memref object offset :index index :type :unsigned-byte8)) - (:location (memref object offset :index index :type :location)) - (:unsigned-byte16 (ecase endian - ((:host :little) - (memref object offset :index index :type :unsigned-byte16 :endian :little)) - ((:big) - (memref object offset :index index :type :unsigned-byte16 :endian :big)))) - (:code-vector (memref object offset :index index :type :code-vector)) - (:unsigned-byte14 (memref object offset :index index :type :unsigned-byte14)) - (:signed-byte30+2 (memref object offset :index index :type :signed-byte30+2)) - (:unsigned-byte29+3 (memref object offset :index index :type :unsigned-byte29+3)))) +(defun memref (object offset &key (index 0) (type :lisp) localp (endian :host) physicalp) + (macrolet + ((do-memref (physicalp) + `(ecase type + (:lisp + (if localp + (memref object offset :index index :localp t :physicalp ,physicalp) + (memref object offset :index index :localp nil :physicalp ,physicalp))) + (:unsigned-byte32 + (memref object offset :index index :type :unsigned-byte32 :physicalp ,physicalp)) + (:character + (memref object offset :index index :type :character :physicalp ,physicalp)) + (:unsigned-byte8 + (memref object offset :index index :type :unsigned-byte8 :physicalp ,physicalp)) + (:location + (memref object offset :index index :type :location :physicalp ,physicalp)) + (:unsigned-byte16 + (ecase endian + ((:host :little) + (memref object offset :index index :type :unsigned-byte16 :endian :little :physicalp ,physicalp)) + ((:big) + (memref object offset :index index :type :unsigned-byte16 :endian :big :physicalp ,physicalp)))) + (:code-vector + (memref object offset :index index :type :code-vector :physicalp ,physicalp)) + (:unsigned-byte14 + (memref object offset :index index :type :unsigned-byte14 :physicalp ,physicalp)) + (:signed-byte30+2 + (memref object offset :index index :type :signed-byte30+2 :physicalp ,physicalp)) + (:unsigned-byte29+3 + (memref object offset :index index :type :unsigned-byte29+3 :physicalp ,physicalp))))) + (if physicalp + (do-memref t) + (do-memref nil)))) (define-compiler-macro (setf memref) (&whole form &environment env value object offset &key (index 0) (type :lisp) (localp nil) (endian :host)) @@ -885,14 +900,14 @@ (define-compiler-macro memref-int (&whole form address &key (offset 0) (index 0) (type :unsigned-byte32) (physicalp t) &environment env) - (if (or (not (movitz:movitz-constantp type physicalp)) + (if (or (not (movitz:movitz-constantp type env)) (not (movitz:movitz-constantp physicalp env))) form (let* ((physicalp (movitz::eval-form physicalp env)) (prefixes (if (not physicalp) () movitz:*compiler-physical-segment-prefix*))) - (ecase (movitz::eval-form type) + (ecase (movitz::movitz-eval type env) (:lisp (let ((address-var (gensym "memref-int-address-"))) `(let ((,address-var ,address)) @@ -909,17 +924,22 @@ (:shrl ,movitz::+movitz-fixnum-shift+ :ecx) ; scale down address (,prefixes :movl (:ecx) :eax))))) (:unsigned-byte32 - (let ((address-var (gensym "memref-int-address-"))) - `(let ((,address-var ,address)) - (with-inline-assembly (:returns :untagged-fixnum-ecx) - (:compile-two-forms (:eax :ecx) ,offset ,index) - (:load-lexical (:lexical-binding ,address-var) :ebx) - (:shll 2 :ecx) - (:addl :ebx :eax) - (:into) - (:addl :eax :ecx) - (:shrl ,movitz::+movitz-fixnum-shift+ :ecx) ; scale down address - (,prefixes :movl (:ecx) :ecx))))) + (cond + ((integerp index) + (let ((address-var (gensym "memref-int-address-"))) + `(let ((,address-var (+ ,address ,offset))) + (with-inline-assembly (:returns :untagged-fixnum-ecx) + (:compile-form (:result-mode :untagged-fixnum-ecx) ,address-var) + (,prefixes :movl (:ecx ,index) :ecx))))) + (t (let ((address-var (gensym "memref-int-address-")) + (index-var (gensym "memref-int-index-"))) + `(let ((,address-var (+ ,address ,offset)) + (,index-var ,index)) + (with-inline-assembly (:returns :untagged-fixnum-ecx) + (:compile-two-forms (:eax :untagged-fixnum-ecx) ,index-var ,address-var) + (:testb ,movitz:+movitz-fixnum-zmask+ :al) + (:jnz '(:sub-program () (:int 64))) + (,prefixes :movl (:ecx :eax) :ecx))))))) (:unsigned-byte8 (cond ((and (eq 0 offset) (eq 0 index)) @@ -1026,7 +1046,7 @@ (:pushl :ecx) ; an untagged integer (zerop (mod x 4)) is still GC-safe. (:compile-form (:result-mode :untagged-fixnum-ecx) ,value-var) (:popl :eax) - (:movl :ecx (:eax ,offset)))))) + (,prefixes :movl :ecx (:eax ,offset)))))) (t (let ((offset-var (gensym "memref-int-offset-")) (addr-var (gensym "memref-int-address-")) (value-var (gensym "memref-int-value-"))) @@ -1044,7 +1064,7 @@ (:compile-form (:result-mode :edx) ,offset-var) (:std) (:shrl ,movitz:+movitz-fixnum-shift+ :edx) - (:movl :ecx (:eax :edx)) + (,prefixes :movl :ecx (:eax :edx)) (:movl :edi :edx) ; make EDX GC-safe (:cld))))))) (:lisp

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

movitz-cvs January 2008