movitz-cvs

movitz-cvs@common-lisp.net

2595 discussions

[movitz-cvs] CVS movitz
by ffjeld 04 Feb '08

04 Feb '08

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv32450 Modified Files: asm.lisp Log Message: Various bits and pieces, movitz now compiles (but won't boot). --- /project/movitz/cvsroot/movitz/asm.lisp 2008/02/04 12:00:36 1.9 +++ /project/movitz/cvsroot/movitz/asm.lisp 2008/02/04 21:03:32 1.10 @@ -6,7 +6,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: asm.lisp,v 1.9 2008/02/04 12:00:36 ffjeld Exp $ +;;;; $Id: asm.lisp,v 1.10 2008/02/04 21:03:32 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -20,6 +20,7 @@ #:indirect-operand-p #:indirect-operand #:register-operand + #:resolve-operand #:unresolved-symbol #:retry-symbol-resolve #:pc-relative-operand @@ -36,20 +37,32 @@ (defvar *symtab* nil "Current symbol table.") (defvar *instruction-compute-extra-prefix-map* nil) (defvar *position-independent-p* t) -(defvar *sub-program-instructions* '(:jmp :ret) +(defvar *sub-program-instructions* '(:jmp :ret :iretd) "Instruction operators after which to insert sub-programs.") (defvar *anonymous-sub-program-identities* nil) +(defun quotep (x) + "Is x a symbol (in any package) named 'quote'?" + ;; This is required because of Movitz package-fiddling. + (and (symbolp x) + (string= x 'quote))) + (deftype simple-symbol-reference () - '(cons (eql quote) (cons symbol null))) + '(cons (satisfies quotep) (cons symbol null))) (deftype sub-program-operand () - '(cons (eql quote) + '(cons (satisfies quotep) (cons (cons (eql :sub-program)) null))) +(deftype funcall-operand () + '(cons (satisfies quotep) + (cons + (cons (eql :funcall)) + null))) + (deftype symbol-reference () '(or simple-symbol-reference sub-program-operand)) @@ -64,7 +77,6 @@ (car (push (cons operand (gensym "sub-program-")) *anonymous-sub-program-identities*))))))) - (defun sub-program-program (operand) (cddadr operand)) @@ -75,8 +87,14 @@ (sub-program-operand (sub-program-label expr)))) +(defun funcall-operand-operator (operand) + (cadadr operand)) + +(defun funcall-operand-operands (operand) + (cddadr operand)) + (deftype immediate-operand () - '(or integer symbol-reference)) + '(or integer symbol-reference funcall-operand)) (defun immediate-p (expr) (typep expr 'immediate-operand)) @@ -88,7 +106,7 @@ (typep operand 'register-operand)) (deftype indirect-operand () - '(and cons (not (cons (eql quote))))) + '(and cons (not (cons (satisfies quotep))))) (defun indirect-operand-p (operand) (typep operand 'indirect-operand)) @@ -107,6 +125,21 @@ (format s "Unresolved symbol ~S." (unresolved-symbol c))))) + +(defun resolve-operand (operand) + (etypecase operand + (integer + operand) + (symbol-reference + (let ((s (symbol-reference-symbol operand))) + (loop (with-simple-restart (retry-symbol-resolve "Retry resolving ~S." s) + (return (cdr (or (assoc s *symtab*) + (error 'unresolved-symbol + :symbol s)))))))) + (funcall-operand + (apply (funcall-operand-operator operand) + (mapcar #'resolve-operand + (funcall-operand-operands operand)))))) ;;;;;;;;;;;; @@ -121,7 +154,7 @@ (sub-programs nil)) (flet ((process-instruction (instruction) (etypecase instruction - (symbol + ((or symbol integer) (let ((previous-definition (assoc instruction *symtab*))) (cond ((null previous-definition) @@ -139,24 +172,24 @@ ((member previous-definition corrections) (cond ((> *pc* (cdr previous-definition)) - ;; (warn "correcting ~S from ~D to ~D" instruction (cdr previous-definition) *pc*) +;; (warn "correcting ~S from ~D to ~D" instruction (cdr previous-definition) *pc*) (setf (cdr previous-definition) *pc*) (push previous-definition new-corrections)) ((< *pc* (cdr previous-definition)) - ;; (warn "Definition for ~S shrunk from ~S to ~S (corrections: ~{~D~}." - ;; instruction - ;; (cdr previous-definition) - ;; *pc* - ;; corrections) - ;; (warn "prg: ~{~%~A~}" proglist) - ;; (warn "Definition for ~S shrunk from ~S to ~S." - ;; instruction - ;; (cdr previous-definition) - ;; *pc*) - ;; (break "Definition for ~S shrunk from ~S to ~S." - ;; instruction - ;; (cdr previous-definition) - ;; *pc*) +;; (warn "Definition for ~S shrunk from ~S to ~S (corrections: ~{~D~}." +;; instruction +;; (cdr previous-definition) +;; *pc* +;; corrections) +;; (warn "prg: ~{~%~A~}" proglist) +;; (warn "Definition for ~S shrunk from ~S to ~S." +;; instruction +;; (cdr previous-definition) +;; *pc*) +;; (break "Definition for ~S shrunk from ~S to ~S." +;; instruction +;; (cdr previous-definition) +;; *pc*) (setf (cdr previous-definition) *pc*) (push previous-definition new-corrections)))) (t (error "Label ~S doubly defined. Old value: ~S, new value: ~S" @@ -168,7 +201,7 @@ (let ((code (handler-bind ((unresolved-symbol (lambda (c) (let ((a (cons (unresolved-symbol c) *pc*))) - ;; (warn "assuming ~S for ~S" (unresolved-symbol c) *pc*) +;; (warn "assuming ~S for ~S" (unresolved-symbol c) *pc*) (push a assumptions) (push a *symtab*) (invoke-restart 'retry-symbol-resolve)))))

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 04 Feb '08

04 Feb '08

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv26600 Modified Files: bignums.lisp Log Message: assembly instruction je should be keyword. --- /project/movitz/cvsroot/movitz/losp/muerte/bignums.lisp 2005/08/31 22:33:03 1.17 +++ /project/movitz/cvsroot/movitz/losp/muerte/bignums.lisp 2008/02/04 15:11:16 1.18 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sat Jul 17 19:42:57 2004 ;;;; -;;;; $Id: bignums.lisp,v 1.17 2005/08/31 22:33:03 ffjeld Exp $ +;;;; $Id: bignums.lisp,v 1.18 2008/02/04 15:11:16 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -392,7 +392,7 @@ :eax) (:xorl :edx :edx) (:shldl :cl :eax :edx) - (jnz 'overflow) + (:jnz 'overflow) shift-short-loop (:movl (:ebx :esi (:offset movitz-bignum bigit0 -4)) :eax)

1 0

[movitz-cvs] CVS movitz
by ffjeld 04 Feb '08

04 Feb '08

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv13579 Modified Files: asm-x86.lisp Log Message: Add PREFETCH instructions. --- /project/movitz/cvsroot/movitz/asm-x86.lisp 2008/02/04 11:48:27 1.15 +++ /project/movitz/cvsroot/movitz/asm-x86.lisp 2008/02/04 12:11:00 1.16 @@ -6,7 +6,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: asm-x86.lisp,v 1.15 2008/02/04 11:48:27 ffjeld Exp $ +;;;; $Id: asm-x86.lisp,v 1.16 2008/02/04 12:11:00 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1445,6 +1445,20 @@ (define-operator* (:16 :popfw :32 :popfl :64 :popfr) () (opcode #x9d)) +;;;;;;;;;;; PRFETCH + +(define-operator :prefetch-nta (m8) + (modrm m8 #x0f18 0)) + +(define-operator :prefetch-t0 (m8) + (modrm m8 #x0f18 1)) + +(define-operator :prefetch-t1 (m8) + (modrm m8 #x0f18 2)) + +(define-operator :prefetch-t2 (m8) + (modrm m8 #x0f18 3)) + ;;;;;;;;;;; PUSH (define-operator* (:16 :pushw :32 :pushl) (src)

1 0

[movitz-cvs] CVS movitz
by ffjeld 04 Feb '08

04 Feb '08

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv10217 Modified Files: asm.lisp Log Message: Support anonymous sub-programs. --- /project/movitz/cvsroot/movitz/asm.lisp 2008/02/04 08:33:39 1.8 +++ /project/movitz/cvsroot/movitz/asm.lisp 2008/02/04 12:00:36 1.9 @@ -6,7 +6,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: asm.lisp,v 1.8 2008/02/04 08:33:39 ffjeld Exp $ +;;;; $Id: asm.lisp,v 1.9 2008/02/04 12:00:36 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -39,6 +39,8 @@ (defvar *sub-program-instructions* '(:jmp :ret) "Instruction operators after which to insert sub-programs.") +(defvar *anonymous-sub-program-identities* nil) + (deftype simple-symbol-reference () '(cons (eql quote) (cons symbol null))) @@ -55,7 +57,13 @@ (typep expr 'sub-program-operand)) (defun sub-program-label (operand) - (car (cadadr operand))) + (let ((x (cadadr operand))) + (if (not (eq '() x)) + (car x) + (cdr (or (assoc operand *anonymous-sub-program-identities*) + (car (push (cons operand (gensym "sub-program-")) + *anonymous-sub-program-identities*))))))) + (defun sub-program-program (operand) (cddadr operand)) @@ -107,6 +115,7 @@ (let ((encoder (find-symbol (string '#:encode-instruction) cpu-package)) (*pc* start-pc) (*symtab* (append incoming-symtab corrections)) + (*anonymous-sub-program-identities* *anonymous-sub-program-identities*) (assumptions nil) (new-corrections nil) (sub-programs nil))

1 0

[movitz-cvs] CVS movitz
by ffjeld 04 Feb '08

04 Feb '08

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv8206 Modified Files: asm-x86.lisp Log Message: Add MULL instruction. --- /project/movitz/cvsroot/movitz/asm-x86.lisp 2008/02/04 07:45:12 1.14 +++ /project/movitz/cvsroot/movitz/asm-x86.lisp 2008/02/04 11:48:27 1.15 @@ -6,7 +6,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: asm-x86.lisp,v 1.14 2008/02/04 07:45:12 ffjeld Exp $ +;;;; $Id: asm-x86.lisp,v 1.15 2008/02/04 11:48:27 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1358,6 +1358,13 @@ (define-operator* (:32 :movzxw) (src dst) (reg-modrm dst src #x0fb7)) +;;;;;;;;;;; MUL + +(define-operator/32 :mull (factor product1 &optional product2) + (when (and (eq product1 :eax) + (eq product2 :edx)) + (modrm factor #xf7 4))) + ;;;;;;;;;;; NEG (define-operator/8 :negb (dst)

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 04 Feb '08

04 Feb '08

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv12581 Modified Files: integers.lisp Log Message: assembly instruction je should be keyword. --- /project/movitz/cvsroot/movitz/losp/muerte/integers.lisp 2007/04/07 07:56:45 1.123 +++ /project/movitz/cvsroot/movitz/losp/muerte/integers.lisp 2008/02/04 10:08:18 1.124 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: integers.lisp,v 1.123 2007/04/07 07:56:45 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.124 2008/02/04 10:08:18 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1899,26 +1899,26 @@ (:shrl 5 :ecx) ; compute msb bigit index/fixnum in ecx (:addl 4 :ecx) (:cmpw :cx (:ebx (:offset movitz-bignum length))) - (je '(:sub-program (equal-size-maybe-return-same) - (:testl :edx :edx) ; Can only return same if (zerop position). - (:jnz 'adjust-size) - (:movl :eax :ecx) ; size/fixnum - (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) - (:andl 31 :ecx) - (:jz 'yes-return-same) - (:std) ; <================ - ;; we know EDX=0, now generate mask in EDX - (:addl 1 :edx) - (:shll :cl :edx) - (:movzxw (:ebx (:offset movitz-bignum length)) - :ecx) - (:cmpl :edx (:ebx :ecx (:offset movitz-bignum bigit0 -4))) - (:movl 0 :edx) ; Safe value, and correct if we need to go to adjust-size. - (:cld) ; =================> - (:jnc 'adjust-size) ; nope, we have to generate a new bignum. - yes-return-same - (:movl :ebx :eax) ; yep, we can return same bignum. - (:jmp 'ldb-done))) + (:je '(:sub-program (equal-size-maybe-return-same) + (:testl :edx :edx) ; Can only return same if (zerop position). + (:jnz 'adjust-size) + (:movl :eax :ecx) ; size/fixnum + (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) + (:andl 31 :ecx) + (:jz 'yes-return-same) + (:std) ; <================ + ;; we know EDX=0, now generate mask in EDX + (:addl 1 :edx) + (:shll :cl :edx) + (:movzxw (:ebx (:offset movitz-bignum length)) + :ecx) + (:cmpl :edx (:ebx :ecx (:offset movitz-bignum bigit0 -4))) + (:movl 0 :edx) ; Safe value, and correct if we need to go to adjust-size. + (:cld) ; =================> + (:jnc 'adjust-size) ; nope, we have to generate a new bignum. + yes-return-same + (:movl :ebx :eax) ; yep, we can return same bignum. + (:jmp 'ldb-done))) (:jnc 'size-ok) ;; We now know that (+ size position) is beyond the size of the bignum. ;; So, if (zerop position), we can return the bignum as our result.

1 0

[movitz-cvs] CVS movitz
by ffjeld 04 Feb '08

04 Feb '08

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv24213 Modified Files: asm.lisp Log Message: Add support for incoming-symtab. --- /project/movitz/cvsroot/movitz/asm.lisp 2008/02/04 07:45:08 1.7 +++ /project/movitz/cvsroot/movitz/asm.lisp 2008/02/04 08:33:39 1.8 @@ -6,7 +6,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: asm.lisp,v 1.7 2008/02/04 07:45:08 ffjeld Exp $ +;;;; $Id: asm.lisp,v 1.8 2008/02/04 08:33:39 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -102,11 +102,11 @@ ;;;;;;;;;;;; -(defun proglist-encode (proglist &key corrections (start-pc 0) (cpu-package '#:asm-x86)) +(defun proglist-encode (proglist &key ((:symtab incoming-symtab) *symtab*) 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) + (*symtab* (append incoming-symtab corrections)) (assumptions nil) (new-corrections nil) (sub-programs nil)) @@ -186,11 +186,13 @@ finally (cond ((not (null assumptions)) + (warn "prg: ~{~%~A~}" proglist) (error "Undefined symbol~P: ~{~S~^, ~}" (length assumptions) (mapcar #'car assumptions))) ((not (null new-corrections)) (return (proglist-encode proglist + :symtab incoming-symtab :start-pc start-pc :cpu-package cpu-package :corrections (nconc new-corrections corrections))))))

1 0

[movitz-cvs] CVS movitz
by ffjeld 04 Feb '08

04 Feb '08

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv14852 Modified Files: asm-x86.lisp Log Message: Added support for sub-program operands. --- /project/movitz/cvsroot/movitz/asm-x86.lisp 2008/02/03 10:23:07 1.13 +++ /project/movitz/cvsroot/movitz/asm-x86.lisp 2008/02/04 07:45:12 1.14 @@ -6,7 +6,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: asm-x86.lisp,v 1.13 2008/02/03 10:23:07 ffjeld Exp $ +;;;; $Id: asm-x86.lisp,v 1.14 2008/02/04 07:45:12 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -207,7 +207,9 @@ (default-rex nil)) (declare (ignorable operator-mode default-rex)) (block operator - ,@body))) + ,@body + (error "Unable to encode ~S." (list operator ,@(remove #\& lambda-list + :key (lambda (x) (char (string x) 0)))))))) (setf (gethash ',operator *instruction-encoders*) ',defun-name) ',operator)))

1 0

[movitz-cvs] CVS movitz
by ffjeld 04 Feb '08

04 Feb '08

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv14780 Modified Files: asm.lisp Log Message: Added support for sub-program operands. --- /project/movitz/cvsroot/movitz/asm.lisp 2008/02/03 10:23:05 1.6 +++ /project/movitz/cvsroot/movitz/asm.lisp 2008/02/04 07:45:08 1.7 @@ -6,7 +6,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: asm.lisp,v 1.6 2008/02/03 10:23:05 ffjeld Exp $ +;;;; $Id: asm.lisp,v 1.7 2008/02/04 07:45:08 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -27,7 +27,8 @@ #:*pc* #:*symtab* #:*instruction-compute-extra-prefix-map* - #:*position-independent-p*)) + #:*position-independent-p* + #:*sub-program-instructions*)) (in-package asm) @@ -35,16 +36,36 @@ (defvar *symtab* nil "Current symbol table.") (defvar *instruction-compute-extra-prefix-map* nil) (defvar *position-independent-p* t) +(defvar *sub-program-instructions* '(:jmp :ret) + "Instruction operators after which to insert sub-programs.") -(deftype symbol-reference () +(deftype simple-symbol-reference () '(cons (eql quote) (cons symbol null))) -(defun symbol-reference-p (expr) - (typep expr 'symbol-reference)) +(deftype sub-program-operand () + '(cons (eql quote) + (cons + (cons (eql :sub-program)) + null))) + +(deftype symbol-reference () + '(or simple-symbol-reference sub-program-operand)) + +(defun sub-program-operand-p (expr) + (typep expr 'sub-program-operand)) + +(defun sub-program-label (operand) + (car (cadadr operand))) + +(defun sub-program-program (operand) + (cddadr operand)) (defun symbol-reference-symbol (expr) - (check-type expr symbol-reference) - (second expr)) + (etypecase expr + (simple-symbol-reference + (second expr)) + (sub-program-operand + (sub-program-label expr)))) (deftype immediate-operand () '(or integer symbol-reference)) @@ -87,72 +108,90 @@ (*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)) -;; (warn "correcting ~S from ~D to ~D" instruction (cdr previous-definition) *pc*) - (setf (cdr previous-definition) *pc*) - (push previous-definition new-corrections)) - ((< *pc* (cdr previous-definition)) -;; (warn "Definition for ~S shrunk from ~S to ~S (corrections: ~{~D~}." -;; instruction -;; (cdr previous-definition) -;; *pc* -;; corrections) -;; (warn "prg: ~{~%~A~}" proglist) -;; (warn "Definition for ~S shrunk from ~S to ~S." -;; instruction -;; (cdr previous-definition) -;; *pc*) -;; (break "Definition for ~S shrunk from ~S to ~S." -;; instruction -;; (cdr previous-definition) -;; *pc*) - (setf (cdr previous-definition) *pc*) - (push previous-definition new-corrections)))) - (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) *pc*))) -;; (warn "assuming ~S for ~S" (unresolved-symbol c) *pc*) - (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 (nconc new-corrections corrections)))))) - *symtab*))) + (new-corrections nil) + (sub-programs nil)) + (flet ((process-instruction (instruction) + (etypecase instruction + (symbol + (let ((previous-definition (assoc instruction *symtab*))) + (cond + ((null previous-definition) + (push (cons instruction *pc*) + *symtab*)) + ((assoc instruction new-corrections) + (break "prev-def ~S in new-corrections?? new: ~S, old: ~S" + instruction + *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)) + ;; (warn "correcting ~S from ~D to ~D" instruction (cdr previous-definition) *pc*) + (setf (cdr previous-definition) *pc*) + (push previous-definition new-corrections)) + ((< *pc* (cdr previous-definition)) + ;; (warn "Definition for ~S shrunk from ~S to ~S (corrections: ~{~D~}." + ;; instruction + ;; (cdr previous-definition) + ;; *pc* + ;; corrections) + ;; (warn "prg: ~{~%~A~}" proglist) + ;; (warn "Definition for ~S shrunk from ~S to ~S." + ;; instruction + ;; (cdr previous-definition) + ;; *pc*) + ;; (break "Definition for ~S shrunk from ~S to ~S." + ;; instruction + ;; (cdr previous-definition) + ;; *pc*) + (setf (cdr previous-definition) *pc*) + (push previous-definition new-corrections)))) + (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) *pc*))) + ;; (warn "assuming ~S for ~S" (unresolved-symbol c) *pc*) + (push a assumptions) + (push a *symtab*) + (invoke-restart 'retry-symbol-resolve))))) + (funcall encoder instruction)))) + (incf *pc* (length code)) + code))))) + (values (loop for instruction in proglist + for operands = (when (consp instruction) + instruction) + for operator = (when (consp instruction) + (let ((x (pop operands))) + (if (not (listp x)) x (pop operands)))) + append (process-instruction instruction) + do (loop for operand in operands + do (when (sub-program-operand-p operand) + (push (cons (sub-program-label operand) + (sub-program-program operand)) + sub-programs))) + when (and (not (null sub-programs)) + (member operator *sub-program-instructions*)) + append (loop for sub-program in (nreverse sub-programs) + append (mapcan #'process-instruction sub-program) + finally (setf sub-programs nil)) + 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 (nconc new-corrections corrections)))))) + *symtab*))))

1 0

[movitz-cvs] CVS movitz
by ffjeld 03 Feb '08

03 Feb '08

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv15379 Modified Files: asm-x86.lisp Log Message: Add support for *instruction-compute-extra-prefix-map* etc. --- /project/movitz/cvsroot/movitz/asm-x86.lisp 2008/02/02 00:33:06 1.12 +++ /project/movitz/cvsroot/movitz/asm-x86.lisp 2008/02/03 10:23:07 1.13 @@ -6,7 +6,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: asm-x86.lisp,v 1.12 2008/02/02 00:33:06 ffjeld Exp $ +;;;; $Id: asm-x86.lisp,v 1.13 2008/02/03 10:23:07 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -20,6 +20,9 @@ (defvar *instruction-encoders* (make-hash-table :test 'eq)) +(defvar *use-jcc-16-bit-p* nil + "Whether to use 16-bit JCC instructions in 32-bit mode.") + (defun prefix-lookup (prefix-name) (cdr (or (assoc prefix-name '((:operand-size-override . #x66) @@ -821,6 +824,7 @@ `(return-when (encode-opcode-reg-imm operator legacy-prefixes ,opcode ,op-reg ,op-imm ',type operator-mode default-rex))) + ;;;;;;;;;;;;;;;; (define-operator :nop () @@ -1057,17 +1061,17 @@ (define-operator/16 :cwd (reg1 reg2) (when (and (eq reg1 :ax) - (eq reg2 :dx)) + (eq reg2 :dx)) (opcode #x99))) (define-operator/32 :cdq (reg1 reg2) (when (and (eq reg1 :eax) - (eq reg2 :edx)) + (eq reg2 :edx)) (opcode #x99))) (define-operator/64 :cqo (reg1 reg2) (when (and (eq reg1 :rax) - (eq reg2 :rdx)) + (eq reg2 :rdx)) (opcode #x99))) ;;;;;;;;;;; DEC @@ -1091,7 +1095,7 @@ (define-operator* (:16 :divw :32 :divl :64 :divr) (divisor dividend1 dividend2) (when (and (eq dividend1 :ax-eax-rax) - (eq dividend2 :dx-edx-rdx)) + (eq dividend2 :dx-edx-rdx)) (modrm divisor #xf7 6))) ;;;;;;;;;;; HLT @@ -1103,12 +1107,12 @@ (define-operator/8 :idivb (divisor dividend1 dividend2) (when (and (eq dividend1 :al) - (eq dividend2 :ah)) + (eq dividend2 :ah)) (modrm divisor #xf6 7))) (define-operator* (:16 :idivw :32 :idivl :64 :idivr) (divisor dividend1 dividend2) (when (and (eq dividend1 :ax-eax-rax) - (eq dividend2 :dx-edx-rdx)) + (eq dividend2 :dx-edx-rdx)) (modrm divisor #xf7 7))) ;;;;;;;;;;; IMUL @@ -1117,7 +1121,7 @@ (when (not product2) (reg-modrm product1 factor #x0faf)) (when (and (eq product1 :eax) - (eq product2 :edx)) + (eq product2 :edx)) (modrm factor #xf7 5)) (typecase factor ((sint 8) @@ -1192,14 +1196,15 @@ (defmacro define-jcc (name opcode1 &optional (opcode2 (+ #x0f10 opcode1))) `(define-operator ,name (dst) (pc-rel ,opcode1 dst (sint 8)) - (case *cpu-mode* - ((:16-bit :32-bit) - (pc-rel ,opcode2 dst (sint 16) - :operand-size :16-bit))) + (when (or (and (eq *cpu-mode* :32-bit) + *use-jcc-16-bit-p*) + (eq *cpu-mode* :16-bit)) + (pc-rel ,opcode2 dst (sint 16) + :operand-size :16-bit)) (pc-rel ,opcode2 dst (sint 32) - :operand-size (case *cpu-mode* - ((:16-bit :32-bit) - :32-bit))))) + :operand-size (case *cpu-mode* + ((:16-bit :32-bit) + :32-bit))))) (define-jcc :ja #x77) (define-jcc :jae #x73) @@ -1243,7 +1248,9 @@ (define-operator :jmp (dst) (pc-rel #xeb dst (sint 8)) (pc-rel #xe9 dst (sint 32)) - (modrm dst #xff 4)) + (when (or (not *position-independent-p*) + (indirect-operand-p dst)) + (modrm dst #xff 4))) ;;;;;;;;;;; LAHF, LAR

1 0

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

movitz-cvs