From ffjeld at common-lisp.net Sat Feb 2 00:33:04 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Fri, 1 Feb 2008 19:33:04 -0500 (EST) Subject: [movitz-cvs] CVS movitz Message-ID: <20080202003304.C04007C057@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv25422 Modified Files: asm.lisp Log Message: Add asm:*instruction-compute-extra-prefix-map* feature to assembler. --- /project/movitz/cvsroot/movitz/asm.lisp 2008/01/31 21:11:24 1.4 +++ /project/movitz/cvsroot/movitz/asm.lisp 2008/02/02 00:33:04 1.5 @@ -6,7 +6,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: asm.lisp,v 1.4 2008/01/31 21:11:24 ffjeld Exp $ +;;;; $Id: asm.lisp,v 1.5 2008/02/02 00:33:04 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -25,12 +25,14 @@ #:pc-relative-operand #:proglist-encode #:*pc* - #:*symtab*)) + #:*symtab* + #:*instruction-compute-extra-prefix-map*)) (in-package asm) (defvar *pc* nil "Current program counter.") (defvar *symtab* nil "Current symbol table.") +(defvar *instruction-compute-extra-prefix-map* nil) (deftype symbol-reference () '(cons (eql quote) (cons symbol null))) From ffjeld at common-lisp.net Sat Feb 2 00:33:06 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Fri, 1 Feb 2008 19:33:06 -0500 (EST) Subject: [movitz-cvs] CVS movitz Message-ID: <20080202003306.53B897C058@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv25445 Modified Files: asm-x86.lisp Log Message: Add asm:*instruction-compute-extra-prefix-map* feature to assembler. --- /project/movitz/cvsroot/movitz/asm-x86.lisp 2008/01/31 21:11:28 1.11 +++ /project/movitz/cvsroot/movitz/asm-x86.lisp 2008/02/02 00:33:06 1.12 @@ -6,7 +6,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: asm-x86.lisp,v 1.11 2008/01/31 21:11:28 ffjeld Exp $ +;;;; $Id: asm-x86.lisp,v 1.12 2008/02/02 00:33:06 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -72,7 +72,7 @@ (loop for b from 0 below (* 8 n) by 8 collect (ldb (byte 8 b) i))) -(defun encode-values-fun (prefixes rexes opcode mod reg rm scale index base displacement immediate operand-size address-size) +(defun encode-values-fun (operator legacy-prefixes 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)) @@ -92,40 +92,43 @@ (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)) + (let ((code (append legacy-prefixes + (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))) + (append (compute-extra-prefixes operator *pc* (length code)) + code))) (defmacro encode (values-form) - `(multiple-value-call #'encode-values-fun ,values-form)) + `(multiple-value-call #'encode-values-fun operator legacy-prefixes ,values-form)) (defmacro merge-encodings (form1 form2) @@ -184,44 +187,19 @@ 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))))) + (apply (or (gethash operator *instruction-encoders*) + (error "Unknown instruction operator ~S in ~S." operator instruction)) + operator + (mapcar #'prefix-lookup legacy-prefixes) + operands)))) -(defun encode-to-parts (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 - (multiple-value-bind (prefixes prefix rex opcode mod reg rm scale index base displacement immediate operand-size address-size) - (apply (or (gethash operator *instruction-encoders*) - (error "Unknown instruction operator ~S in ~S." operator instruction)) - operands) - (values (append legacy-prefixes prefixes) - prefix - rex - opcode - mod - reg - rm - scale - index - base - displacement - immediate - operand-size - address-size))))) (defmacro define-operator (operator lambda-list &body body) (check-type operator keyword) (let ((defun-name (intern (format nil "~A-~A" 'instruction-encoder operator)))) `(progn - (defun ,defun-name ,lambda-list + (defun ,defun-name (operator legacy-prefixes , at lambda-list) + (declare (ignorable operator)) (let ((operator-mode nil) (default-rex nil)) (declare (ignorable operator-mode default-rex)) @@ -669,34 +647,47 @@ :immediate (encode-integer immediate ',type)) (encode-reg/mem ,op-modrm operator-mode))))))) -(defun encode-pc-rel (opcode operand type &rest extras) + +(defun compute-extra-prefixes (operator pc size) + (let ((ff (assoc operator *instruction-compute-extra-prefix-map*))) + (when ff + (funcall (cdr ff) pc size)))) + +(defun encode-pc-rel (operator legacy-prefixes 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))) + (let* ((estimated-code-size-no-extras (+ (length legacy-prefixes) + (type-octet-size type) + (opcode-octet-size opcode))) + (estimated-extra-prefixes (compute-extra-prefixes operator *pc* estimated-code-size-no-extras)) + (estimated-code-size (+ estimated-code-size-no-extras + (length estimated-extra-prefixes))) (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)))) + (let ((code (let ((*instruction-compute-extra-prefix-map* nil)) + (encode (apply #'encoded-values + :opcode opcode + :displacement (encode-integer offset type) + extras))))) (if (= (length code) - estimated-code-size) - code + estimated-code-size-no-extras) + (append estimated-extra-prefixes code) (let* ((code-size (length code)) - (offset (let ((*pc* (+ *pc* code-size))) + (extra-prefixes (compute-extra-prefixes operator *pc* code-size)) + (offset (let ((*pc* (+ *pc* code-size (length extra-prefixes)))) (resolve-pc-relative operand)))) (when (typep offset type) - (let ((code (encode (apply #'encoded-values - :opcode opcode - :displacement (encode-integer offset type) - extras)))) + (let ((code (let ((*instruction-compute-extra-prefix-map* nil)) + (encode (apply #'encoded-values + :opcode opcode + :displacement (encode-integer offset type) + extras))))) (assert (= code-size (length code))) - code))))))))) + (append extra-prefixes code)))))))))) (defmacro pc-rel (opcode operand type &rest extras) - `(return-when (encode-pc-rel ,opcode ,operand ',type , at extras))) + `(return-when (encode-pc-rel operator legacy-prefixes ,opcode ,operand ',type , at extras))) (defmacro modrm (operand opcode digit) `(when (typep ,operand '(or register-operand indirect-operand)) @@ -707,7 +698,7 @@ :rex default-rex) (encode-reg/mem ,operand operator-mode))))) -(defun encode-reg-modrm (op-reg op-modrm opcode operator-mode default-rex &rest extras) +(defun encode-reg-modrm (operator legacy-prefixes 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)) @@ -726,10 +717,10 @@ (encode-reg/mem op-modrm operator-mode)))))) (defmacro reg-modrm (op-reg op-modrm opcode &rest extras) - `(return-when (encode-reg-modrm ,op-reg ,op-modrm ,opcode operator-mode default-rex , at extras))) + `(return-when (encode-reg-modrm operator legacy-prefixes ,op-reg ,op-modrm ,opcode operator-mode default-rex , at extras))) -(defun encode-reg-cr (op-reg op-cr opcode operator-mode default-rex &rest extras) +(defun encode-reg-cr (operator legacy-prefixes 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)))) @@ -747,7 +738,7 @@ extras))))) (defmacro reg-cr (op-reg op-cr opcode &rest extras) - `(return-when (encode-reg-cr ,op-reg ,op-cr ,opcode operator-mode default-rex , at extras))) + `(return-when (encode-reg-cr operator legacy-prefixes ,op-reg ,op-cr ,opcode operator-mode default-rex , at extras))) (defmacro sreg-modrm (op-sreg op-modrm opcode) `(let* ((reg-map '(:es :cs :ss :ds :fs :gs)) @@ -782,7 +773,7 @@ (encoded-values :opcode ,opcode , at extras))) -(defun encode-opcode-reg (opcode op-reg operator-mode default-rex) +(defun encode-opcode-reg (operator legacy-prefixes opcode op-reg operator-mode default-rex) (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)) @@ -802,9 +793,9 @@ (defmacro opcode-reg (opcode op-reg) `(return-when - (encode-opcode-reg ,opcode ,op-reg operator-mode default-rex))) + (encode-opcode-reg operator legacy-prefixes ,opcode ,op-reg operator-mode default-rex))) -(defun encode-opcode-reg-imm (opcode op-reg op-imm type operator-mode default-rex) +(defun encode-opcode-reg-imm (operator legacy-prefixes opcode op-reg op-imm type operator-mode default-rex) (when (immediate-p op-imm) (let ((immediate (resolve op-imm))) (when (typep immediate type) @@ -828,7 +819,7 @@ (defmacro opcode-reg-imm (opcode op-reg op-imm type) `(return-when - (encode-opcode-reg-imm ,opcode ,op-reg ,op-imm ',type operator-mode default-rex))) + (encode-opcode-reg-imm operator legacy-prefixes ,opcode ,op-reg ,op-imm ',type operator-mode default-rex))) ;;;;;;;;;;;;;;;; From ffjeld at common-lisp.net Sun Feb 3 10:23:05 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sun, 3 Feb 2008 05:23:05 -0500 (EST) Subject: [movitz-cvs] CVS movitz Message-ID: <20080203102305.9B09D1F00C@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv15361 Modified Files: asm.lisp Log Message: Add support for *instruction-compute-extra-prefix-map* etc. --- /project/movitz/cvsroot/movitz/asm.lisp 2008/02/02 00:33:04 1.5 +++ /project/movitz/cvsroot/movitz/asm.lisp 2008/02/03 10:23:05 1.6 @@ -6,7 +6,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: asm.lisp,v 1.5 2008/02/02 00:33:04 ffjeld Exp $ +;;;; $Id: asm.lisp,v 1.6 2008/02/03 10:23:05 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -26,13 +26,15 @@ #:proglist-encode #:*pc* #:*symtab* - #:*instruction-compute-extra-prefix-map*)) + #:*instruction-compute-extra-prefix-map* + #:*position-independent-p*)) (in-package asm) (defvar *pc* nil "Current program counter.") (defvar *symtab* nil "Current symbol table.") (defvar *instruction-compute-extra-prefix-map* nil) +(defvar *position-independent-p* t) (deftype symbol-reference () '(cons (eql quote) (cons symbol null))) @@ -106,13 +108,26 @@ ((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)) - (error "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" instruction (cdr previous-definition) @@ -121,7 +136,8 @@ (cons (let ((code (handler-bind ((unresolved-symbol (lambda (c) - (let ((a (cons (unresolved-symbol c) 0))) + (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))))) @@ -138,5 +154,5 @@ (return (proglist-encode proglist :start-pc start-pc :cpu-package cpu-package - :corrections new-corrections))))) + :corrections (nconc new-corrections corrections)))))) *symtab*))) From ffjeld at common-lisp.net Sun Feb 3 10:23:07 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sun, 3 Feb 2008 05:23:07 -0500 (EST) Subject: [movitz-cvs] CVS movitz Message-ID: <20080203102307.AEB9F1F0FC@common-lisp.net> 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 ;;;; 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 From ffjeld at common-lisp.net Mon Feb 4 07:45:09 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Mon, 4 Feb 2008 02:45:09 -0500 (EST) Subject: [movitz-cvs] CVS movitz Message-ID: <20080204074509.1292B2E1CA@common-lisp.net> 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 ;;;; 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*)))) From ffjeld at common-lisp.net Mon Feb 4 07:45:19 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Mon, 4 Feb 2008 02:45:19 -0500 (EST) Subject: [movitz-cvs] CVS movitz Message-ID: <20080204074519.52455450B4@common-lisp.net> 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 ;;;; 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 - , at body))) + , at 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))) From ffjeld at common-lisp.net Mon Feb 4 08:33:41 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Mon, 4 Feb 2008 03:33:41 -0500 (EST) Subject: [movitz-cvs] CVS movitz Message-ID: <20080204083341.AC2EF5B069@common-lisp.net> 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 ;;;; 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)))))) From ffjeld at common-lisp.net Mon Feb 4 10:08:25 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Mon, 4 Feb 2008 05:08:25 -0500 (EST) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080204100825.749E11C003@common-lisp.net> 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. From ffjeld at common-lisp.net Mon Feb 4 11:48:28 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Mon, 4 Feb 2008 06:48:28 -0500 (EST) Subject: [movitz-cvs] CVS movitz Message-ID: <20080204114828.2A5C84083@common-lisp.net> 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 ;;;; 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) From ffjeld at common-lisp.net Mon Feb 4 12:00:37 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Mon, 4 Feb 2008 07:00:37 -0500 (EST) Subject: [movitz-cvs] CVS movitz Message-ID: <20080204120037.0AE5B2E1CA@common-lisp.net> 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 ;;;; 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)) From ffjeld at common-lisp.net Mon Feb 4 12:11:00 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Mon, 4 Feb 2008 07:11:00 -0500 (EST) Subject: [movitz-cvs] CVS movitz Message-ID: <20080204121100.59CFE3C076@common-lisp.net> 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 ;;;; 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) From ffjeld at common-lisp.net Mon Feb 4 15:11:17 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Mon, 4 Feb 2008 10:11:17 -0500 (EST) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080204151117.3267E3002F@common-lisp.net> 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 ;;;; 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) From ffjeld at common-lisp.net Mon Feb 4 21:03:33 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Mon, 4 Feb 2008 16:03:33 -0500 (EST) Subject: [movitz-cvs] CVS movitz Message-ID: <20080204210333.3A37C2E1D2@common-lisp.net> 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 ;;;; 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))))) From ffjeld at common-lisp.net Mon Feb 4 21:03:40 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Mon, 4 Feb 2008 16:03:40 -0500 (EST) Subject: [movitz-cvs] CVS movitz Message-ID: <20080204210340.0AA6D49032@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv32467 Modified Files: asm-x86.lisp Log Message: Various bits and pieces, movitz now compiles (but won't boot). --- /project/movitz/cvsroot/movitz/asm-x86.lisp 2008/02/04 12:11:00 1.16 +++ /project/movitz/cvsroot/movitz/asm-x86.lisp 2008/02/04 21:03:35 1.17 @@ -6,7 +6,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: asm-x86.lisp,v 1.16 2008/02/04 12:11:00 ffjeld Exp $ +;;;; $Id: asm-x86.lisp,v 1.17 2008/02/04 21:03:35 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -182,19 +182,28 @@ address-size)) (defun encode-instruction (instruction) - (multiple-value-bind (legacy-prefixes instruction) + (multiple-value-bind (instruction legacy-prefixes options) (if (listp (car instruction)) - (values (car instruction) - (cdr instruction)) - (values nil - instruction)) + (values (cdr instruction) + (remove-if #'listp (car instruction)) + (remove-if #'keywordp (car instruction))) + (values instruction + nil + nil)) (destructuring-bind (operator &rest operands) instruction - (apply (or (gethash operator *instruction-encoders*) - (error "Unknown instruction operator ~S in ~S." operator instruction)) - operator - (mapcar #'prefix-lookup legacy-prefixes) - operands)))) + (let ((code (apply (or (gethash operator *instruction-encoders*) + (error "Unknown instruction operator ~S in ~S." operator instruction)) + operator + (mapcar #'prefix-lookup legacy-prefixes) + operands))) + (cond + ((null options) + code) + ((assoc :size options) + (assert (= (second (assoc :size options)) + (length code))) + code)))))) (defmacro define-operator (operator lambda-list &body body) @@ -202,7 +211,7 @@ (let ((defun-name (intern (format nil "~A-~A" 'instruction-encoder operator)))) `(progn (defun ,defun-name (operator legacy-prefixes , at lambda-list) - (declare (ignorable operator)) + (declare (ignorable operator legacy-prefixes)) (let ((operator-mode nil) (default-rex nil)) (declare (ignorable operator-mode default-rex)) @@ -281,16 +290,6 @@ ,(when |64| `(define-operator/64 ,|64| ,args , at body64))))) -(defun resolve (x) - (etypecase x - (integer - x) - (symbol-reference - (let ((s (symbol-reference-symbol x))) - (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 @@ -309,9 +308,9 @@ (etypecase operand ((cons (eql :pc+)) (reduce #'+ (cdr operand) - :key #'resolve)) + :key #'resolve-operand)) (symbol-reference - (- (resolve operand) + (- (resolve-operand operand) *pc*)))) (defun encode-integer (i type) @@ -382,7 +381,7 @@ (assert (or (not reg-scale) (and reg reg-scale))) (let ((offset (reduce #'+ offsets - :key #'resolve))) + :key #'resolve-operand))) (cond ((and (not reg) (eq mode :16-bit) @@ -631,7 +630,7 @@ (defmacro imm (imm-operand opcode imm-type &rest extras) `(when (immediate-p ,imm-operand) - (let ((immediate (resolve ,imm-operand))) + (let ((immediate (resolve-operand ,imm-operand))) (when (typep immediate ',imm-type) (return-values-when (encoded-values :opcode ,opcode @@ -642,7 +641,7 @@ (defmacro imm-modrm (op-imm op-modrm opcode digit type) `(when (immediate-p ,op-imm) - (let ((immediate (resolve ,op-imm))) + (let ((immediate (resolve-operand ,op-imm))) (when (typep immediate ',type) (return-values-when (merge-encodings (encoded-values :opcode ,opcode @@ -764,7 +763,7 @@ (return-values-when (encoded-values :opcode ,opcode :displacement (encode-integer (reduce #'+ offsets - :key #'resolve) + :key #'resolve-operand) ',type))))))) (defmacro opcode (opcode &rest extras) @@ -802,7 +801,7 @@ (defun encode-opcode-reg-imm (operator legacy-prefixes opcode op-reg op-imm type operator-mode default-rex) (when (immediate-p op-imm) - (let ((immediate (resolve op-imm))) + (let ((immediate (resolve-operand op-imm))) (when (typep immediate type) (let* ((reg-map (ecase operator-mode (:8-bit '(:al :cl :dl :bl :ah :ch :dh :bh)) @@ -827,10 +826,20 @@ (encode-opcode-reg-imm operator legacy-prefixes ,opcode ,op-reg ,op-imm ',type operator-mode default-rex))) -;;;;;;;;;;;;;;;; +;;;;;;;;;;; + +;;;;;;;;;;;;;;;; NOP + +(define-operator :% (op &rest data) + (case op + (:bytes + (let ((byte-size (pop data))) + (return-from operator + (loop for datum in data + append (loop for b from 0 below byte-size by 8 + collect (ldb (byte 8 b) + datum)))))))) -(define-operator :nop () - (opcode #x90)) ;;;;;;;;;;; ADC @@ -928,6 +937,9 @@ (define-operator/32 :callr (dest) (modrm dest #xff 2)) +(define-operator :call-segment (dest) + (modrm dest #xff 3)) + ;;;;;;;;;;; CLC, CLD, CLI, CLTS, CMC (define-operator :clc () (opcode #xf8)) @@ -1254,6 +1266,9 @@ (indirect-operand-p dst)) (modrm dst #xff 4))) +(define-operator* (:16 :jmpw-segment :32 :jmp-segment :64 :jmpr-segment) (addr) + (modrm addr #xff 5)) + ;;;;;;;;;;; LAHF, LAR (define-operator :lahf () @@ -1267,6 +1282,9 @@ ;;;;;;;;;;; LEA (define-operator* (:16 :leaw :32 :leal :64 :lear) (addr dst) + (when (and (equal addr '(:esp :edx)) ; REMOVEME: ia-x86 compat. hack!! + (eq dst :esp)) + (return-from operator '(#x8D #x64 #x14 #x00))) (reg-modrm dst addr #x8d)) ;;;;;;;;;;; LEAVE @@ -1276,10 +1294,10 @@ ;;;;;;;;;;; LGDT, LIDT -(define-operator* (:16 :lgdtw :32 :lgdtl :64 :lgdtr) (addr) +(define-operator* (:16 :lgdtw :32 :lgdt :64 :lgdtr) (addr) (modrm addr #x0f01 2)) -(define-operator* (:16 :lidtw :32 :lidtl :64 :lidtr) (addr) +(define-operator* (:16 :lidtw :32 :lidt :64 :lidtr) (addr) (modrm addr #x0f01 3)) ;;;;;;;;;;; LFENCE @@ -1373,6 +1391,11 @@ (define-operator* (:16 :negw :32 :negl :64 :negr) (dst) (modrm dst #xf7 3)) +;;;;;;;;;;;;;;;; NOP + +(define-operator :nop () + (opcode #x90)) + ;;;;;;;;;;; NOT (define-operator/8 :notb (dst) @@ -1527,6 +1550,11 @@ (reg-modrm dst subtrahend #x1b) (reg-modrm subtrahend dst #x19)) +;;;;;;;;;;; SGDT + +(define-operator/8 :sgdt (addr) + (modrm addr #x0f01 0)) + ;;;;;;;;;;; SHL (define-operator/8 :shlb (count dst) @@ -1547,7 +1575,7 @@ (when (eq :cl count) (reg-modrm dst1 dst2 #x0fa5)) (when (immediate-p count) - (let ((immediate (resolve count))) + (let ((immediate (resolve-operand count))) (when (typep immediate '(uint #x8)) (reg-modrm dst1 dst2 #x0fa4 :immediate (encode-integer count '(uint 8))))))) @@ -1572,7 +1600,7 @@ (when (eq :cl count) (reg-modrm dst1 dst2 #x0fad)) (when (immediate-p count) - (let ((immediate (resolve count))) + (let ((immediate (resolve-operand count))) (when (typep immediate '(uint #x8)) (reg-modrm dst1 dst2 #x0fac :immediate (encode-integer count '(uint 8))))))) @@ -1620,6 +1648,10 @@ (imm-modrm mask dst #xf7 0 :int-16-32-64) (reg-modrm mask dst #x85)) +;;;;;;;;;;; XCHG + +(define-operator :wrmsr () + (opcode #x0f30)) ;;;;;;;;;;; XCHG From ffjeld at common-lisp.net Mon Feb 4 21:04:51 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Mon, 4 Feb 2008 16:04:51 -0500 (EST) Subject: [movitz-cvs] CVS movitz/losp Message-ID: <20080204210451.E045F7213E@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp In directory clnet:/tmp/cvs-serv32704 Modified Files: scratch.lisp Log Message: scratch. --- /project/movitz/cvsroot/movitz/losp/scratch.lisp 2007/04/09 17:30:21 1.1 +++ /project/movitz/cvsroot/movitz/losp/scratch.lisp 2008/02/04 21:04:51 1.2 @@ -7,7 +7,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: scratch.lisp,v 1.1 2007/04/09 17:30:21 ffjeld Exp $ +;;;; $Id: scratch.lisp,v 1.2 2008/02/04 21:04:51 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -77,6 +77,21 @@ (warn "X: ~S" (memref-int bios32)) (warn "X: ~S" (= (memref-int bios32) #x5f32335f))) +(defun setfint (x o) + (setf (memref x o :type :unsigned-byte32) 0)) + +(defun fint (x) + (memref-int x :type :unsigned-byte32 :physicalp t)) + +(defun good () + (with-inline-assembly (:returns :untagged-fixnum-ecx) + ((:gs-override) :movl (#x1000000) :ecx))) + +(defun (setf good) (x) + (with-inline-assembly (:returns :untagged-fixnum-ecx) + (:compile-form (:result-mode :untagged-fixnum-ecx) x) + ((:gs-override) :movl :ecx (#x1000000)))) + (defun test2 () (funcall (compile @@ -862,8 +877,8 @@ Can be used to measure the overhead of primitive function." (with-inline-assembly (:returns :eax) (:load-lexical (:lexical-binding x) :eax) - (% bytes 8 #xff #x97) ; (:call-local-pf ret-trampoline) - (% bytes 32 #.(bt:slot-offset 'movitz::movitz-run-time-context 'movitz::ret-trampoline)))) + (:% :bytes 8 #xff #x97) ; (:call-local-pf ret-trampoline) + (:% :bytes 32 #.(bt:slot-offset 'movitz::movitz-run-time-context 'movitz::ret-trampoline)))) (defun my-test-labels (x) (labels (#+ignore (p () (print x)) From ffjeld at common-lisp.net Mon Feb 4 21:05:23 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Mon, 4 Feb 2008 16:05:23 -0500 (EST) Subject: [movitz-cvs] CVS movitz Message-ID: <20080204210523.90CEA4908B@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv480 Modified Files: load.lisp Log Message: add asm. --- /project/movitz/cvsroot/movitz/load.lisp 2004/12/09 14:05:52 1.11 +++ /project/movitz/cvsroot/movitz/load.lisp 2008/02/04 21:05:23 1.12 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Thu Jan 15 18:40:58 2004 ;;;; -;;;; $Id: load.lisp,v 1.11 2004/12/09 14:05:52 ffjeld Exp $ +;;;; $Id: load.lisp,v 1.12 2008/02/04 21:05:23 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -28,6 +28,10 @@ (load (compile-file #p"../binary-types/binary-types")) +(load (compile-file #p"asm")) ; these are here for now, because +(load (compile-file #p"asm-x86")) ; ia-x86 needs them while testing/migrating. + + (let ((*default-pathname-defaults* (merge-pathnames #p"../ia-x86/"))) #+(or cmu) (let ((pwd (ext:default-directory))) (progn From ffjeld at common-lisp.net Mon Feb 4 23:01:13 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Mon, 4 Feb 2008 18:01:13 -0500 (EST) Subject: [movitz-cvs] CVS movitz Message-ID: <20080204230113.ED20B5832E@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv32559 Modified Files: asm.lisp Log Message: Fixed a bug in proglist-encode: When assumptions were corrected via a recursive call, we didn't return the symtab from the recursive call, just the code. --- /project/movitz/cvsroot/movitz/asm.lisp 2008/02/04 21:03:32 1.10 +++ /project/movitz/cvsroot/movitz/asm.lisp 2008/02/04 23:01:11 1.11 @@ -6,7 +6,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: asm.lisp,v 1.10 2008/02/04 21:03:32 ffjeld Exp $ +;;;; $Id: asm.lisp,v 1.11 2008/02/04 23:01:11 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -154,7 +154,7 @@ (sub-programs nil)) (flet ((process-instruction (instruction) (etypecase instruction - ((or symbol integer) + ((or symbol integer) ; a label? (let ((previous-definition (assoc instruction *symtab*))) (cond ((null previous-definition) @@ -172,24 +172,14 @@ ((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*) + ;; (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" @@ -197,45 +187,43 @@ (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)))) + (cons ; a bona fide instruction? + (let ((code (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)) - (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)))))) - *symtab*)))) + (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))))) + (let ((code (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))))) + (cond + ((not (null assumptions)) + (error "Undefined symbol~P: ~{~S~^, ~}" + (length assumptions) + (mapcar #'car assumptions))) + ((not (null new-corrections)) + (proglist-encode proglist + :symtab incoming-symtab + :start-pc start-pc + :cpu-package cpu-package + :corrections (nconc new-corrections corrections))) + (t (values code *symtab*)))))))) From ffjeld at common-lisp.net Mon Feb 4 23:08:07 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Mon, 4 Feb 2008 18:08:07 -0500 (EST) Subject: [movitz-cvs] CVS movitz Message-ID: <20080204230807.04FF77914E@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv3222 Modified Files: compiler.lisp Log Message: Use new assembler. --- /project/movitz/cvsroot/movitz/compiler.lisp 2007/04/05 21:10:39 1.186 +++ /project/movitz/cvsroot/movitz/compiler.lisp 2008/02/04 23:08:07 1.187 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.186 2007/04/05 21:10:39 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.187 2008/02/04 23:08:07 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -131,6 +131,22 @@ '(#x90 #x90 #x90) '(#x90))))) +(defun new-compute-call-extra-prefix (pc size) + (let* ((return-pointer-tag (ldb (byte 3 0) + (+ pc size)))) + (cond + ((or (= (tag :even-fixnum) return-pointer-tag) + (= (tag :odd-fixnum) return-pointer-tag)) + ;; Insert a NOP + '(#x90)) +;;; ((= 3 return-pointer-tag) +;;; ;; Insert two NOPs, 3 -> 5 +;;; '(#x90 #x90)) + ((= (tag :character) return-pointer-tag) + ;; Insert three NOPs, 2 -> 5 + '(#x90 #x90 #x90) + '(#x90))))) + (defun make-compiled-primitive (form environment top-level-p docstring) "Primitive functions have no funobj, no stack-frame, and no implied parameter/return value passing conventions." @@ -143,19 +159,24 @@ :top-level-p nil :result-mode :ignore)) ;; (ignmore (format t "~{~S~%~}" body-code)) - (resolved-code (finalize-code body-code nil nil)) - (function-code (ia-x86:read-proglist resolved-code))) + (resolved-code (finalize-code body-code nil nil))) + (multiple-value-bind (code-vector symtab) - (let ((ia-x86:*instruction-compute-extra-prefix-map* - '((:call . compute-call-extra-prefix)))) - (ia-x86:proglist-encode :octet-vector - :32-bit - #x00000000 - function-code - :symtab-lookup - #'(lambda (label) - (case label - (:nil-value (image-nil-word *image*)))))) + #+use-old-ia-x86 + (let ((ia-x86:*instruction-compute-extra-prefix-map* + '((:call . compute-call-extra-prefix)))) + (ia-x86:proglist-encode :octet-vector + :32-bit + #x00000000 + (ia-x86:read-proglist resolved-code) + :symtab-lookup (lambda (label) + (case label + (:nil-value (image-nil-word *image*)))))) + (let ((asm:*instruction-compute-extra-prefix-map* + '((:call . new-compute-call-extra-prefix)))) + (asm:proglist-encode (translate-program resolved-code :muerte.cl :cl) + :symtab (list (cons :nil-value (image-nil-word *image*))))) + (values (make-movitz-vector (length code-vector) :element-type 'code :initial-contents code-vector) @@ -1001,40 +1022,72 @@ funobj) +(defun diss (code) + (format nil "~&;; Diss: +~:{~4D: ~16<~{ ~2,'0X~}~;~> ~A~@[ ;~{ ~A~}~]~%~}" + (loop with code-position = 0 + for pc = 0 then code-position + for instruction = (ia-x86:decode-read-octet + #'(lambda () + (incf code-position) + (pop code))) + for cbyte = (and instruction + (ia-x86::instruction-original-datum instruction)) + until (null instruction) + collect (list pc + (ia-x86::cbyte-to-octet-list cbyte) + instruction + (comment-instruction instruction nil pc))))) + + (defun assemble-funobj (funobj combined-code) (multiple-value-bind (code-vector code-symtab) - (let ((ia-x86:*instruction-compute-extra-prefix-map* - '((:call . compute-call-extra-prefix)))) - (ia-x86:proglist-encode :octet-vector :32-bit #x00000000 - (ia-x86:read-proglist combined-code) - :symtab-lookup - (lambda (label) - (case label - (:nil-value (image-nil-word *image*)) - (t (let ((set (cdr (assoc label - (movitz-funobj-jumpers-map funobj))))) - (when set - (let ((pos (search set (movitz-funobj-const-list funobj) - :end2 (movitz-funobj-num-jumpers funobj)))) - (assert pos () - "Couldn't find for ~s set ~S in ~S." - label set (subseq (movitz-funobj-const-list funobj) - 0 (movitz-funobj-num-jumpers funobj))) - (* 4 pos))))))))) + #+use-old-ia-x86 + (let ((ia-x86:*instruction-compute-extra-prefix-map* + '((:call . compute-call-extra-prefix)))) + (ia-x86:proglist-encode :octet-vector :32-bit #x00000000 + (ia-x86:read-proglist combined-code) + :symtab-lookup + (lambda (label) + (case label + (:nil-value (image-nil-word *image*)) + (t (let ((set (cdr (assoc label + (movitz-funobj-jumpers-map funobj))))) + (when set + (let ((pos (search set (movitz-funobj-const-list funobj) + :end2 (movitz-funobj-num-jumpers funobj)))) + (assert pos () + "Couldn't find for ~s set ~S in ~S." + label set (subseq (movitz-funobj-const-list funobj) + 0 (movitz-funobj-num-jumpers funobj))) + (* 4 pos))))))))) + (let ((asm:*instruction-compute-extra-prefix-map* + '((:call . new-compute-call-extra-prefix)))) + (asm:proglist-encode combined-code + :symtab (list* (cons :nil-value (image-nil-word *image*)) + (loop for (label . set) in (movitz-funobj-jumpers-map funobj) + collect (cons label + (* 4 (or (search set (movitz-funobj-const-list funobj) + :end2 (movitz-funobj-num-jumpers funobj)) + (error "Jumper for ~S missing." label)))))))) + (setf (movitz-funobj-symtab funobj) code-symtab) - (let ((code-length (- (length code-vector) 3 -3))) + (let* ((code-length (- (length code-vector) 3 -3)) + (code-vector (make-array code-length + :initial-contents code-vector + :fill-pointer t))) (setf (fill-pointer code-vector) code-length) ;; debug info (setf (ldb (byte 1 5) (slot-value funobj 'debug-info)) - 1 #+ignore (if use-stack-frame-p 1 0)) + 1 #+ignore (if use-stack-frame-p 1 0)) (let ((x (cdr (assoc 'start-stack-frame-setup code-symtab)))) (cond - ((not x) - #+ignore (warn "No start-stack-frame-setup label for ~S." name)) - ((<= 0 x 30) - (setf (ldb (byte 5 0) (slot-value funobj 'debug-info)) x)) - (t (warn "Can't encode start-stack-frame-setup label ~D into debug-info for ~S." - x (movitz-funobj-name funobj))))) + ((not x) + #+ignore (warn "No start-stack-frame-setup label for ~S." name)) + ((<= 0 x 30) + (setf (ldb (byte 5 0) (slot-value funobj 'debug-info)) x)) + (t (warn "Can't encode start-stack-frame-setup label ~D into debug-info for ~S." + x (movitz-funobj-name funobj))))) (let* ((a (or (cdr (assoc 'entry%1op code-symtab)) 0)) (b (or (cdr (assoc 'entry%2op code-symtab)) a)) (c (or (cdr (assoc 'entry%3op code-symtab)) b))) @@ -1049,11 +1102,11 @@ (loop for ((entry-label slot-name)) on '((entry%1op code-vector%1op) (entry%2op code-vector%2op) (entry%3op code-vector%3op)) - do (cond + do (cond ((assoc entry-label code-symtab) (let ((offset (cdr (assoc entry-label code-symtab)))) (setf (slot-value funobj slot-name) - (cons offset funobj)) + (cons offset funobj)) #+ignore (when (< offset #x100) (vector-push offset code-vector)))) #+ignore @@ -1065,24 +1118,24 @@ (make-movitz-vector (length code-vector) :fill-pointer code-length :element-type 'code - :initial-contents code-vector)))) + :initial-contents code-vector))))) funobj) (defun check-locate-concistency (code-vector) (loop for x from 0 below (length code-vector) by 8 - do (when (and (= (tag :basic-vector) (aref code-vector x)) - (= (enum-value 'movitz-vector-element-type :code) (aref code-vector (1+ x))) - (or (<= #x4000 (length code-vector)) - (and (= (ldb (byte 8 0) (length code-vector)) - (aref code-vector (+ x 2))) - (= (ldb (byte 8 8) (length code-vector)) - (aref code-vector (+ x 3)))))) - (break "Code-vector (length #x~X) can break %find-code-vector at ~D: #x~2,'0X~2,'0X ~2,'0X~2,'0X." - (length code-vector) x - (aref code-vector (+ x 0)) - (aref code-vector (+ x 1)) - (aref code-vector (+ x 2)) - (aref code-vector (+ x 3))))) + do (when (and (= (tag :basic-vector) (aref code-vector x)) + (= (enum-value 'movitz-vector-element-type :code) (aref code-vector (1+ x))) + (or (<= #x4000 (length code-vector)) + (and (= (ldb (byte 8 0) (length code-vector)) + (aref code-vector (+ x 2))) + (= (ldb (byte 8 8) (length code-vector)) + (aref code-vector (+ x 3)))))) + (break "Code-vector (length #x~X) can break %find-code-vector at ~D: #x~2,'0X~2,'0X ~2,'0X~2,'0X." + (length code-vector) x + (aref code-vector (+ x 0)) + (aref code-vector (+ x 1)) + (aref code-vector (+ x 2)) + (aref code-vector (+ x 3))))) (values)) #+ignore From ffjeld at common-lisp.net Tue Feb 5 22:40:54 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Tue, 5 Feb 2008 17:40:54 -0500 (EST) Subject: [movitz-cvs] CVS movitz Message-ID: <20080205224054.D97B73C048@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv11463 Modified Files: asm-x86.lisp Log Message: Improve misc. instruction support. --- /project/movitz/cvsroot/movitz/asm-x86.lisp 2008/02/04 21:03:35 1.17 +++ /project/movitz/cvsroot/movitz/asm-x86.lisp 2008/02/05 22:40:54 1.18 @@ -6,12 +6,15 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: asm-x86.lisp,v 1.17 2008/02/04 21:03:35 ffjeld Exp $ +;;;; $Id: asm-x86.lisp,v 1.18 2008/02/05 22:40:54 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ (defpackage asm-x86 - (:use :common-lisp :asm)) + (:use :common-lisp :asm) + (:export #:encode-instruction + #:*cpu-mode* + #:*position-independent-p*)) (in-package asm-x86) @@ -133,7 +136,6 @@ (defmacro encode (values-form) `(multiple-value-call #'encode-values-fun operator legacy-prefixes ,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) ,form1 @@ -372,7 +374,7 @@ (:64-bit '(:rax :rcx :rdx :rbx :rsp :rbp :rsi :rdi :r8 :r9 :r10 :r11 :r12 :13 :r14 :r15)) (:mm '(:mm0 :mm1 :mm2 :mm3 :mm4 :mm5 :mm6 :mm7)) (:xmm '(:xmm0 :xmm1 :xmm2 :xmm3 :xmm4 :xmm5 :xmm6 :xmm7)))) - (error "Unknown ~D-bit register ~S." mode operand))) + (error "Unknown ~(~D~) register ~S." mode operand))) (multiple-value-bind (reg offsets reg2 reg-scale) (parse-indirect-operand operand) (check-type reg-scale (member nil 1 2 4 8)) @@ -702,7 +704,7 @@ :rex default-rex) (encode-reg/mem ,operand operator-mode))))) -(defun encode-reg-modrm (operator legacy-prefixes op-reg op-modrm opcode operator-mode default-rex &rest extras) +(defun encode-reg-modrm (operator legacy-prefixes op-reg op-modrm opcode operator-mode default-rex &optional reg/mem-mode &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)) @@ -718,11 +720,10 @@ :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) - `(return-when (encode-reg-modrm operator legacy-prefixes ,op-reg ,op-modrm ,opcode operator-mode default-rex , at extras))) + (encode-reg/mem op-modrm (or reg/mem-mode operator-mode))))))) +(defmacro reg-modrm (op-reg op-modrm opcode &optional reg/mem-mode &rest extras) + `(return-when (encode-reg-modrm operator legacy-prefixes ,op-reg ,op-modrm ,opcode operator-mode default-rex ,reg/mem-mode , at extras))) (defun encode-reg-cr (operator legacy-prefixes op-reg op-cr opcode operator-mode default-rex &rest extras) (let* ((reg-map (ecase operator-mode @@ -1140,10 +1141,12 @@ (typecase factor ((sint 8) (reg-modrm product1 product2 #x6b - :displacement (encode-integer factor '(sint 8)))) + nil + :displacement (encode-integer factor '(sint 8)))) ((sint 32) (reg-modrm product1 product2 #x69 - :displacement (encode-integer factor '(sint 32)))))) + nil + :displacement (encode-integer factor '(sint 32)))))) ;;;;;;;;;;; IN @@ -1264,7 +1267,8 @@ (pc-rel #xe9 dst (sint 32)) (when (or (not *position-independent-p*) (indirect-operand-p dst)) - (modrm dst #xff 4))) + (let ((operator-mode :32-bit)) + (modrm dst #xff 4)))) (define-operator* (:16 :jmpw-segment :32 :jmp-segment :64 :jmpr-segment) (addr) (modrm addr #xff 5)) @@ -1292,6 +1296,11 @@ (define-operator :leave () (opcode #xc9)) +;;;;;;;;;;; LFENCE + +(define-operator :lfence () + (opcode #x0faee8)) + ;;;;;;;;;;; LGDT, LIDT (define-operator* (:16 :lgdtw :32 :lgdt :64 :lgdtr) (addr) @@ -1300,10 +1309,10 @@ (define-operator* (:16 :lidtw :32 :lidt :64 :lidtr) (addr) (modrm addr #x0f01 3)) -;;;;;;;;;;; LFENCE +;;;;;;;;;;; LMSW -(define-operator :lfence () - (opcode #x0faee8)) +(define-operator/16 :lmsw (src) + (modrm src #x0f01 6)) ;;;;;;;;;;; LOOP, LOOPE, LOOPNE @@ -1360,6 +1369,17 @@ (reg-cr src dst #x0f22) (reg-cr dst src #x0f20)) +;;;;;;;;;;; MOVS + +(define-operator/8 :movsb () + (opcode #xa4)) + +(define-operator/16 :movsw () + (opcode #xa5)) + +(define-operator/32 :movsl () + (opcode #xa5)) + ;;;;;;;;;;; MOVSX (define-operator* (:32 :movsxb) (src dst) @@ -1371,7 +1391,7 @@ ;;;;;;;;;;; MOVZX (define-operator* (:32 :movzxb) (src dst) - (reg-modrm dst src #x0fb6)) + (reg-modrm dst src #x0fb6 :8-bit)) (define-operator* (:32 :movzxw) (src dst) (reg-modrm dst src #x0fb7)) @@ -1578,6 +1598,7 @@ (let ((immediate (resolve-operand count))) (when (typep immediate '(uint #x8)) (reg-modrm dst1 dst2 #x0fa4 + nil :immediate (encode-integer count '(uint 8))))))) ;;;;;;;;;;; SHR @@ -1603,6 +1624,7 @@ (let ((immediate (resolve-operand count))) (when (typep immediate '(uint #x8)) (reg-modrm dst1 dst2 #x0fac + nil :immediate (encode-integer count '(uint 8))))))) @@ -1648,7 +1670,10 @@ (imm-modrm mask dst #xf7 0 :int-16-32-64) (reg-modrm mask dst #x85)) -;;;;;;;;;;; XCHG +;;;;;;;;;;; WBINVD, WSRMSR + +(define-operator :wbinvd () + (opcode #x0f09)) (define-operator :wrmsr () (opcode #x0f30)) From ffjeld at common-lisp.net Sat Feb 9 09:50:46 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sat, 9 Feb 2008 04:50:46 -0500 (EST) Subject: [movitz-cvs] CVS movitz Message-ID: <20080209095046.0F4E455355@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv27398 Modified Files: asm.lisp Log Message: Finishing touches on the assembler. --- /project/movitz/cvsroot/movitz/asm.lisp 2008/02/04 23:01:11 1.11 +++ /project/movitz/cvsroot/movitz/asm.lisp 2008/02/09 09:50:46 1.12 @@ -6,7 +6,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: asm.lisp,v 1.11 2008/02/04 23:01:11 ffjeld Exp $ +;;;; $Id: asm.lisp,v 1.12 2008/02/09 09:50:46 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -127,7 +127,7 @@ (defun resolve-operand (operand) - (etypecase operand + (typecase operand (integer operand) (symbol-reference @@ -139,7 +139,8 @@ (funcall-operand (apply (funcall-operand-operator operand) (mapcar #'resolve-operand - (funcall-operand-operands operand)))))) + (funcall-operand-operands operand)))) + (t operand))) ;;;;;;;;;;;; From ffjeld at common-lisp.net Sat Feb 9 09:50:48 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sat, 9 Feb 2008 04:50:48 -0500 (EST) Subject: [movitz-cvs] CVS movitz Message-ID: <20080209095048.77CEE55355@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv27415 Modified Files: asm-x86.lisp Log Message: Finishing touches on the assembler. --- /project/movitz/cvsroot/movitz/asm-x86.lisp 2008/02/05 22:40:54 1.18 +++ /project/movitz/cvsroot/movitz/asm-x86.lisp 2008/02/09 09:50:48 1.19 @@ -6,7 +6,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: asm-x86.lisp,v 1.18 2008/02/05 22:40:54 ffjeld Exp $ +;;;; $Id: asm-x86.lisp,v 1.19 2008/02/09 09:50:48 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -194,12 +194,15 @@ nil)) (destructuring-bind (operator &rest operands) instruction - (let ((code (apply (or (gethash operator *instruction-encoders*) - (error "Unknown instruction operator ~S in ~S." operator instruction)) - operator - (mapcar #'prefix-lookup legacy-prefixes) - operands))) + (multiple-value-bind (code failp) + (apply (or (gethash operator *instruction-encoders*) + (error "Unknown instruction operator ~S in ~S." operator instruction)) + operator + (mapcar #'prefix-lookup legacy-prefixes) + operands) (cond + (failp + (error "Unable to encode ~S." instruction)) ((null options) code) ((assoc :size options) @@ -219,8 +222,7 @@ (declare (ignorable operator-mode default-rex)) (block operator , at body - (error "Unable to encode ~S." (list operator ,@(remove #\& lambda-list - :key (lambda (x) (char (string x) 0)))))))) + (values nil 'fail)))) (setf (gethash ',operator *instruction-encoders*) ',defun-name) ',operator))) @@ -274,7 +276,7 @@ (declare (ignorable operator-mode)) , at body))) -(defmacro define-operator* ((&key |16| |32| |64|) args &body body) +(defmacro define-operator* ((&key |16| |32| |64| dispatch) args &body body) (let ((body16 (subst '(xint 16) :int-16-32-64 (subst :dx :dx-edx-rdx (subst :ax :ax-eax-rax body)))) @@ -290,8 +292,21 @@ ,(when |32| `(define-operator/32 ,|32| ,args , at body32)) ,(when |64| - `(define-operator/64 ,|64| ,args , at body64))))) - + `(define-operator/64 ,|64| ,args , at body64)) + ,(when dispatch + (let ((dispatch-name (intern (format nil "~A-~A" 'instruction-dispatcher dispatch)))) + `(progn + (defun ,dispatch-name (&rest args) + (declare (dynamic-extent args)) + (loop for encoder in (ecase *cpu-mode* + (:32-bit ',(remove nil (list |32| |16| |64|))) + (:64-bit ',(remove nil (list |64| |32| |16|))) + (:16-bit ',(remove nil (list |16| |32| |64|)))) + thereis (apply (gethash encoder *instruction-encoders*) args) + finally (return (values nil 'fail)))) + (setf (gethash ',dispatch *instruction-encoders*) + ',dispatch-name)))) + nil))) (defun resolve-and-encode (x type &key size) (encode-integer (cond @@ -738,7 +753,9 @@ :mod #b11 :rm reg-index :reg cr-index - :operand-size operator-mode + :operand-size (if (not (eq *cpu-mode* :64-bit)) + nil + operator-mode) :rex default-rex extras))))) @@ -826,21 +843,62 @@ `(return-when (encode-opcode-reg-imm operator legacy-prefixes ,opcode ,op-reg ,op-imm ',type operator-mode default-rex))) +(defmacro far-pointer (opcode segment offset offset-type &rest extra) + `(when (and (immediate-p ,segment) + (indirect-operand-p ,offset)); FIXME: should be immediate-p, change in bootblock.lisp. + (let ((segment (resolve-operand ,segment)) + (offset (resolve-operand (car ,offset)))) + (when (and (typep segment '(uint 16)) + (typep offset ',offset-type)) + (return-when (encode (encoded-values :opcode ,opcode + :immediate (append (encode-integer offset ',offset-type) + (encode-integer segment '(uint 16))) + , at extra))))))) -;;;;;;;;;;; -;;;;;;;;;;;;;;;; NOP +;;;;;;;;;;; Pseudo-instructions -(define-operator :% (op &rest data) +(define-operator :% (op &rest form) (case op (:bytes - (let ((byte-size (pop data))) - (return-from operator + (return-from operator + (destructuring-bind (byte-size &rest data) + form (loop for datum in data append (loop for b from 0 below byte-size by 8 collect (ldb (byte 8 b) - datum)))))))) - + (resolve-operand datum))))))) + (:funcall + (return-from operator + (destructuring-bind (function &rest args) + form + (apply function (mapcar #'resolve-operand args))))) + (:fun + (return-from operator + (destructuring-bind (function &rest args) + (car form) + (loop for cbyte in (apply function (mapcar #'resolve-operand args)) + append (loop for octet from 0 below (imagpart cbyte) + collect (ldb (byte 8 (* 8 octet)) + (realpart cbyte))))))) + (:format + (return-from operator + (destructuring-bind (byte-size format-control &rest format-args) + form + (ecase byte-size + (8 (let ((data (map 'list #'char-code + (apply #'format nil format-control + (mapcar #'resolve-operand format-args))))) + (cons (length data) + data))))))) + (:align + (return-from operator + (destructuring-bind (alignment) + form + (let* ((offset (mod *pc* alignment))) + (when (plusp offset) + (make-list (- alignment offset) + :initial-element 0)))))))) ;;;;;;;;;;; ADC @@ -927,16 +985,14 @@ ;;;;;;;;;;; CALL -(define-operator/16 :callw (dest) - (pc-rel #xe8 dest (sint 16)) - (modrm dest #xff 2)) - -(define-operator/32 :call (dest) - (pc-rel #xe8 dest (sint 32)) - (modrm dest #xff 2)) - -(define-operator/32 :callr (dest) - (modrm dest #xff 2)) +(define-operator* (:16 :callw :32 :calll :64 :callr :dispatch :call) (dest) + (case *cpu-mode* + (:16-bit + (pc-rel #xe8 dest (sint 16))) + (:32-bit + (pc-rel #xe8 dest (sint 32)))) + (when (eq operator-mode *cpu-mode*) + (modrm dest #xff 2))) (define-operator :call-segment (dest) (modrm dest #xff 3)) @@ -1262,13 +1318,24 @@ ;;;;;;;;;;; JMP -(define-operator :jmp (dst) - (pc-rel #xeb dst (sint 8)) - (pc-rel #xe9 dst (sint 32)) - (when (or (not *position-independent-p*) - (indirect-operand-p dst)) - (let ((operator-mode :32-bit)) - (modrm dst #xff 4)))) +(define-operator :jmp (seg-dst &optional dst) + (cond + (dst + (when (eq *cpu-mode* :16-bit) + (far-pointer #xea seg-dst dst (uint 16))) + (when (eq *cpu-mode* :32-bit) + (far-pointer #xea seg-dst dst (xint 32)))) + (t (let ((dst seg-dst)) + (pc-rel #xeb dst (sint 8)) + (when (or (and (eq *cpu-mode* :32-bit) + *use-jcc-16-bit-p*) + (eq *cpu-mode* :16-bit)) + (pc-rel #xe9 dst (sint 16))) + (pc-rel #xe9 dst (sint 32)) + (when (or (not *position-independent-p*) + (indirect-operand-p dst)) + (let ((operator-mode :32-bit)) + (modrm dst #xff 4))))))) (define-operator* (:16 :jmpw-segment :32 :jmp-segment :64 :jmpr-segment) (addr) (modrm addr #xff 5)) @@ -1303,8 +1370,9 @@ ;;;;;;;;;;; LGDT, LIDT -(define-operator* (:16 :lgdtw :32 :lgdt :64 :lgdtr) (addr) - (modrm addr #x0f01 2)) +(define-operator* (:16 :lgdtw :32 :lgdtl :64 :lgdtr :dispatch :lgdt) (addr) + (when (eq operator-mode *cpu-mode*) + (modrm addr #x0f01 2))) (define-operator* (:16 :lidtw :32 :lidt :64 :lidtr) (addr) (modrm addr #x0f01 3)) @@ -1314,6 +1382,14 @@ (define-operator/16 :lmsw (src) (modrm src #x0f01 6)) +;;;;;;;;;;; LODS + +(define-operator/8 :lodsb () + (opcode #xac)) + +(define-operator* (:16 :lodsw :32 :lodsl :64 :lodsr) () + (opcode #xad)) + ;;;;;;;;;;; LOOP, LOOPE, LOOPNE (define-operator :loop (dst) @@ -1361,13 +1437,17 @@ ;;;;;;;;;;; MOVCR -(define-operator/32 :movcr (src dst) +(define-operator* (:32 :movcrl :64 :movcrr :dispatch :movcr) (src dst) (when (eq src :cr8) - (reg-cr dst :cr0 #xf00f20)) + (reg-cr dst :cr0 #xf00f20 + :operand-size nil)) (when (eq dst :cr8) - (reg-cr src :cr0 #xf00f22)) - (reg-cr src dst #x0f22) - (reg-cr dst src #x0f20)) + (reg-cr src :cr0 #xf00f22 + :operand-size nil)) + (reg-cr src dst #x0f22 + :operand-size nil) + (reg-cr dst src #x0f20 + :operand-size nil)) ;;;;;;;;;;; MOVS @@ -1390,7 +1470,7 @@ ;;;;;;;;;;; MOVZX -(define-operator* (:32 :movzxb) (src dst) +(define-operator* (:16 :movzxbw :32 :movzxbl :dispatch :movzxb) (src dst) (reg-modrm dst src #x0fb6 :8-bit)) (define-operator* (:32 :movzxw) (src dst) From ffjeld at common-lisp.net Sat Feb 9 18:42:00 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sat, 9 Feb 2008 13:42:00 -0500 (EST) Subject: [movitz-cvs] CVS movitz Message-ID: <20080209184200.8C78F340A8@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv21024 Modified Files: image.lisp Log Message: Buglet in disassembler comment generator, wrt. recognizing characters. --- /project/movitz/cvsroot/movitz/image.lisp 2007/04/01 18:18:26 1.113 +++ /project/movitz/cvsroot/movitz/image.lisp 2008/02/09 18:42:00 1.114 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: image.lisp,v 1.113 2007/04/01 18:18:26 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.114 2008/02/09 18:42:00 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1313,7 +1313,7 @@ (format nil "branch to ~S at ~D" label x) (format nil "branch to ~D" x))) when (and (typep operand 'ia-x86::operand-immediate) - (<= 256 (ia-x86::operand-value operand)) + (<= #x100 (ia-x86::operand-value operand) #x10000) (= (tag :character) (mod (ia-x86::operand-value operand) 256))) collect (format nil "#\\~C" (code-char (truncate (ia-x86::operand-value operand) 256))) when (and (typep operand 'ia-x86::operand-immediate) From ffjeld at common-lisp.net Sat Feb 9 18:42:26 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sat, 9 Feb 2008 13:42:26 -0500 (EST) Subject: [movitz-cvs] CVS movitz Message-ID: <20080209184226.2EB7A691A4@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv21135 Modified Files: bootblock.lisp Log Message: Use new assembler. Compile twice as fast. --- /project/movitz/cvsroot/movitz/bootblock.lisp 2007/03/16 17:39:27 1.13 +++ /project/movitz/cvsroot/movitz/bootblock.lisp 2008/02/09 18:42:26 1.14 @@ -9,7 +9,7 @@ ;;;; Created at: Mon Oct 9 20:47:19 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: bootblock.lisp,v 1.13 2007/03/16 17:39:27 ffjeld Exp $ +;;;; $Id: bootblock.lisp,v 1.14 2008/02/09 18:42:26 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -83,245 +83,239 @@ (let* ((first-sector (1+ skip-sectors)) (last-sector (+ first-sector (ceiling image-size +sector-size+))) (read-buffer-segment (floor +read-buffer+ #x10))) - (ia-x86:read-proglist - `( - (:jmp (:pc+ 0)) ; some BIOSes might check for this. - - ;; - ;; We are running at address #x7c00. - ;; - - (:xorw :ax :ax) - (:movw :ax :ds) - (:movw :ax :es) - - (:movw #x9000 :ax) - (:movw :ax :ss) - (:movw #xfffc :bp) - (:leaw (:bp ,(- +stack-frame-size+)) :sp) - (:movw 'welcome :si) ; Print welcome message) - (:call 'print) - - ;; - ;; Enable the A20 gate - ;; - (:call 'empty-8042) - (:movb #xd1 :al) - (:outb :al #x64) - - (:call 'empty-8042) - (:movb #xdf :al) - (:outb :al #x60) - (:call 'empty-8042) - - ;; Poll the floppy's sectors per track - - (:movw 5 (:bp ,+sectors-per-track+)) - check-geometry - (:incb (:bp ,+sectors-per-track+)) - (:jz 'read-error) - (:movw (:bp ,+sectors-per-track+) :cx ) - (:movw #x0201 :ax) - (:xorw :dx :dx) - (:movw ,read-buffer-segment :bx) - (:movw :bx :es) - (:xorw :bx :bx) - (:int #x13) ; Call BIOS routine - (:testb :ah :ah) - (:jz 'check-geometry) - (:decb (:bp ,+sectors-per-track+)) - - ;; - ;; Read sectors into memory - ;; + `((:jmp (:pc+ 0)) ; some BIOSes might check for this. + ;; + ;; We are running at address #x7c00. + ;; + (:xorw :ax :ax) + (:movw :ax :ds) + (:movw :ax :es) + + (:movw #x9000 :ax) + (:movw :ax :ss) + (:movw #xfffc :bp) + (:leaw (:bp ,(- +stack-frame-size+)) :sp) + (:movw 'welcome :si) ; Print welcome message) + (:call 'print) + + ;; + ;; Enable the A20 gate + ;; + (:call 'empty-8042) + (:movb #xd1 :al) + (:outb :al #x64) + + (:call 'empty-8042) + (:movb #xdf :al) + (:outb :al #x60) + (:call 'empty-8042) + + ;; Poll the floppy's sectors per track + + (:movw 5 (:bp ,+sectors-per-track+)) + check-geometry + (:incb (:bp ,+sectors-per-track+)) + (:jz 'read-error) + (:movw (:bp ,+sectors-per-track+) :cx ) + (:movw #x0201 :ax) + (:xorw :dx :dx) + (:movw ,read-buffer-segment :bx) + (:movw :bx :es) + (:xorw :bx :bx) + (:int #x13) ; Call BIOS routine + (:testb :ah :ah) + (:jz 'check-geometry) + (:decb (:bp ,+sectors-per-track+)) + + ;; + ;; Read sectors into memory + ;; - (:movw ,first-sector (:bp ,+linear-sector+)) - (:movl ,load-address (:bp ,+destination+)) + (:movw ,first-sector (:bp ,+linear-sector+)) + (:movl ,load-address (:bp ,+destination+)) - read-loop + read-loop - (:cmpw ,last-sector (:bp ,+linear-sector+)) - (:jg 'read-done) + (:cmpw ,last-sector (:bp ,+linear-sector+)) + (:jg 'read-done) - (:movw 'track-start-msg :si) ; Print '(' to screen for each track - (:call 'print) + (:movw 'track-start-msg :si) ; Print '(' to screen for each track + (:call 'print) - (:movw (:bp ,+linear-sector+) :ax) - (:movb (:bp ,+sectors-per-track+) :cl) - (:divb :cl :ax) ; al=quotient, ah=remainder of :ax/:cl - - (:movb :ah :cl) ; sector - 1 - (:movb :al :dh) - (:andb 1 :dh) ; head - (:movb :al :ch) - (:shrb 1 :ch) ; track - (:xorb :dl :dl) ; drive = 0 - (:movw (:bp ,+sectors-per-track+) :ax) - (:subb :cl :al) ; number of sectors (rest of track) - (:incb :cl) - (:addw :ax (:bp ,+linear-sector+)) ; update read pointer - (:movw (:bp ,+linear-sector+) :bx) ; subtract some if it's the last track. - (:subw ,last-sector :bx) - (:jc 'subtract-zero-sectors) - (:subw :bx :ax) - (:jz 'read-done) - subtract-zero-sectors - (:movb 2 :ah) - - (:movw ,read-buffer-segment :bx) - (:movw :bx :es) - (:xorw :bx :bx) - (:int #x13) ; Call BIOS routine - - (:jc 'read-error) - (:movzxb :al :ecx) - - ;; - ;; Install GS as 4GB segment - ;; http://www.faqs.org/faqs/assembly-language/x86/general/part2/ - ;; - (:cli) - (:lgdt ('gdt-addr)) ; load gdt - (:movcr :cr0 :eax) - (:orb 1 :al) - (:movcr :eax :cr0) - (:jmp (:pc+ 0)) - (:movw 16 :bx) - (:movw :bx :gs) - (:andb #xfe :al) - (:movcr :eax :cr0) - (:jmp (:pc+ 0)) - (:sti) - ;; Completed install GS as 4GB segment. - - ;; Copy data to destination - (:shll ,(+ 9 -2) :ecx) ; 512/4 = sector-size/word-size - (:movl ,+read-buffer+ :ebx) - (:movl (:bp ,+destination+) :esi) - (:leal (:esi (:ecx 4)) :edx) - - (:movl :edx (:bp ,+destination+)) - - copy-loop - (:decl :ecx) - ((:gs-override) :movl (:ebx (:ecx 4)) :edx) - ((:gs-override) :movl :edx (:esi (:ecx 4))) - (:jnz 'copy-loop) - - (:movw 'track-end-msg :si) ; Print ')' to screen after each track - (:call 'print) - - (:jmp 'read-loop) - - read-done - - motor-loop ; Wait for floppy motor - (:btw 8 (#x43e)) - (:jc 'motor-loop) - - (movw 'entering :si) ; Print welcome message - (call 'print) - - ;; Read the cursor position into DH (row) and DL (column). - (:movb 3 :ah) - (:movb 0 :bh) - (:int #x10) - - (:cli) ; Disable interrupts - (:lgdt ('gdt-addr)) ; load gdt - - (:xorw :ax :ax) - (:movw :ax :es) ; reset es - - ;; - ;; Turn off the cursor - ;; + (:movw (:bp ,+linear-sector+) :ax) + (:movb (:bp ,+sectors-per-track+) :cl) + (:divb :cl :ax) ; al=quotient, ah=remainder of :ax/:cl + + (:movb :ah :cl) ; sector - 1 + (:movb :al :dh) + (:andb 1 :dh) ; head + (:movb :al :ch) + (:shrb 1 :ch) ; track + (:xorb :dl :dl) ; drive = 0 + (:movw (:bp ,+sectors-per-track+) :ax) + (:subb :cl :al) ; number of sectors (rest of track) + (:incb :cl) + (:addw :ax (:bp ,+linear-sector+)) ; update read pointer + (:movw (:bp ,+linear-sector+) :bx) ; subtract some if it's the last track. + (:subw ,last-sector :bx) + (:jc 'subtract-zero-sectors) + (:subw :bx :ax) + (:jz 'read-done) + subtract-zero-sectors + (:movb 2 :ah) + + (:movw ,read-buffer-segment :bx) + (:movw :bx :es) + (:xorw :bx :bx) + (:int #x13) ; Call BIOS routine + + (:jc 'read-error) + (:movzxb :al :ecx) + + ;; + ;; Install GS as 4GB segment + ;; http://www.faqs.org/faqs/assembly-language/x86/general/part2/ + ;; + (:cli) + (:lgdt ('gdt-addr)) ; load gdt + (:movcr :cr0 :eax) + (:orb 1 :al) + (:movcr :eax :cr0) + (:jmp (:pc+ 0)) + (:movw 16 :bx) + (:movw :bx :gs) + (:andb #xfe :al) + (:movcr :eax :cr0) + (:jmp (:pc+ 0)) + (:sti) + ;; Completed install GS as 4GB segment. + + ;; Copy data to destination + (:shll ,(+ 9 -2) :ecx) ; 512/4 = sector-size/word-size + (:movl ,+read-buffer+ :ebx) + (:movl (:bp ,+destination+) :esi) + (:leal (:esi (:ecx 4)) :edx) + + (:movl :edx (:bp ,+destination+)) + + copy-loop + (:decl :ecx) + ((:gs-override) :movl (:ebx (:ecx 4)) :edx) + ((:gs-override) :movl :edx (:esi (:ecx 4))) + (:jnz 'copy-loop) + + (:movw 'track-end-msg :si) ; Print ')' to screen after each track + (:call 'print) + + (:jmp 'read-loop) + + read-done + + motor-loop ; Wait for floppy motor + (:btw 8 (#x43e)) + (:jc 'motor-loop) + + (:movw 'entering :si) ; Print welcome message + (:call 'print) + + ;; Read the cursor position into DH (row) and DL (column). + (:movb 3 :ah) + (:movb 0 :bh) + (:int #x10) + + (:cli) ; Disable interrupts + (:lgdt ('gdt-addr)) ; load gdt + + (:xorw :ax :ax) + (:movw :ax :es) ; reset es + + ;; + ;; Turn off the cursor + ;; ;;; (movb #x01 :ah) ;;; (movw #x0100 :cx) ;;; (int #x10) - ;; - ;; Load machine status word. This will enable - ;; protected mode. The subsequent instruction MUST - ;; reload the code segment register with a selector for - ;; the protected mode code segment descriptor (see - ;; GDT specification). - ;; - (:movw 1 :ax) - (:lmsw :ax) ; load word 0 of cr0 - - ;; - ;; Do a longjump to new-world. This will cause the CS to - ;; be loaded with the correct descriptor, and the processor - ;; will now run in 32 bit mode. - ;; - - (:jmp 8 ('new-world)) - - ;; - ;; Display error message and hang - ;; - read-error - (:movw 'error :si) ; Print error message - (:call 'print) - halt-cpu - (:halt) - (:jmp 'halt-cpu) ; Infinite loop - - ;; - ;; Empty the 8042 Keyboard controller - ;; - empty-8042 - (:call 'delay) - (:inb #x64 :al) ; 8042 status port - (:testb 1 :al) ; if ( no information available ) - (:jz 'no-output) ; goto no_output - (:call 'delay) - (:inb #x60 :al) ; read it - (:jmp 'empty-8042) - no-output - (:testb 2 :al) ; if ( input buffer is full ) - (:jnz 'empty-8042) ; goto empty_8042 - (:ret) - - delay - (:xorw :cx :cx) - delay-loop - (:loop 'delay-loop) - (:ret) - - print ,@(mkasm16-bios-print) - - ;; Data - welcome (% format 8 "Loading Movitz ~D..~% " - ,(incf *bootblock-build*)) - entering (% format 8 "~% Enter..") - error (% format 8 "Failed!)") - track-start-msg (% format 8 "(") - track-end-msg (% format 8 ")") - sector-msg (% format 8 "-") + ;; + ;; Load machine status word. This will enable + ;; protected mode. The subsequent instruction MUST + ;; reload the code segment register with a selector for + ;; the protected mode code segment descriptor (see + ;; GDT specification). + ;; + (:movw 1 :ax) + (:lmsw :ax) ; load word 0 of cr0 + + ;; + ;; Do a longjump to new-world. This will cause the CS to + ;; be loaded with the correct descriptor, and the processor + ;; will now run in 32 bit mode. + ;; + + (:jmp 8 ('new-world)) + + ;; + ;; Display error message and hang + ;; + read-error [234 lines skipped] From ffjeld at common-lisp.net Sat Feb 9 18:42:40 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sat, 9 Feb 2008 13:42:40 -0500 (EST) Subject: [movitz-cvs] CVS movitz Message-ID: <20080209184240.144D068322@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv21152 Modified Files: compiler.lisp Log Message: Use new assembler. Compile twice as fast. --- /project/movitz/cvsroot/movitz/compiler.lisp 2008/02/04 23:08:07 1.187 +++ /project/movitz/cvsroot/movitz/compiler.lisp 2008/02/09 18:42:29 1.188 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.187 2008/02/04 23:08:07 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.188 2008/02/09 18:42:29 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -112,7 +112,7 @@ (or (member (car list) (cdr list)) (duplicatesp (cdr list))))) -(defun compute-call-extra-prefix (instr env size) +(defun old-compute-call-extra-prefix (instr env size) (let* ((return-pointer-tag (ldb (byte 3 0) (+ (ia-x86::assemble-env-current-pc env) size)))) @@ -131,7 +131,7 @@ '(#x90 #x90 #x90) '(#x90))))) -(defun new-compute-call-extra-prefix (pc size) +(defun compute-call-extra-prefix (pc size) (let* ((return-pointer-tag (ldb (byte 3 0) (+ pc size)))) (cond @@ -162,21 +162,19 @@ (resolved-code (finalize-code body-code nil nil))) (multiple-value-bind (code-vector symtab) - #+use-old-ia-x86 - (let ((ia-x86:*instruction-compute-extra-prefix-map* - '((:call . compute-call-extra-prefix)))) - (ia-x86:proglist-encode :octet-vector - :32-bit - #x00000000 - (ia-x86:read-proglist resolved-code) - :symtab-lookup (lambda (label) - (case label - (:nil-value (image-nil-word *image*)))))) - (let ((asm:*instruction-compute-extra-prefix-map* - '((:call . new-compute-call-extra-prefix)))) - (asm:proglist-encode (translate-program resolved-code :muerte.cl :cl) - :symtab (list (cons :nil-value (image-nil-word *image*))))) - +;; (let ((ia-x86:*instruction-compute-extra-prefix-map* +;; '((:call . old-compute-call-extra-prefix)))) +;; (ia-x86:proglist-encode :octet-vector +;; :32-bit +;; #x00000000 +;; (ia-x86:read-proglist resolved-code) +;; :symtab-lookup (lambda (label) +;; (case label +;; (:nil-value (image-nil-word *image*)))))) + (let ((asm:*instruction-compute-extra-prefix-map* + '((:call . compute-call-extra-prefix)))) + (asm:proglist-encode (translate-program resolved-code :muerte.cl :cl) + :symtab (list (cons :nil-value (image-nil-word *image*))))) (values (make-movitz-vector (length code-vector) :element-type 'code :initial-contents code-vector) @@ -1025,52 +1023,58 @@ (defun diss (code) (format nil "~&;; Diss: ~:{~4D: ~16<~{ ~2,'0X~}~;~> ~A~@[ ;~{ ~A~}~]~%~}" - (loop with code-position = 0 + (loop with code-position = 0 and instruction-octets = nil for pc = 0 then code-position - for instruction = (ia-x86:decode-read-octet - #'(lambda () - (incf code-position) - (pop code))) - for cbyte = (and instruction - (ia-x86::instruction-original-datum instruction)) - until (null instruction) - collect (list pc - (ia-x86::cbyte-to-octet-list cbyte) - instruction - (comment-instruction instruction nil pc))))) + for instruction = (progn + (setf instruction-octets nil) + (ia-x86:decode-read-octet (lambda () + (incf code-position) + (loop while (and code (not (typep (car code) '(unsigned-byte 8)))) + do (warn "diss bad byte at ~D: ~S" code-position (pop code)) + (incf code-position)) + (let ((x (pop code))) + (when x (push x instruction-octets)) + x)))) + collect (if (not instruction) + (list pc (nreverse instruction-octets) nil '("???")) + (list pc + (nreverse instruction-octets) + ;;(ia-x86::cbyte-to-octet-list (ia-x86::instruction-original-datum instruction)) + instruction + (comment-instruction instruction nil pc))) + while code))) (defun assemble-funobj (funobj combined-code) +;; (multiple-value-bind (code-vector code-symtab) +;; (let ((ia-x86:*instruction-compute-extra-prefix-map* +;; '((:call . old-compute-call-extra-prefix)))) +;; (ia-x86:proglist-encode :octet-vector :32-bit #x00000000 +;; (ia-x86:read-proglist combined-code) +;; :symtab-lookup +;; (lambda (label) +;; (case label +;; (:nil-value (image-nil-word *image*)) +;; (t (let ((set (cdr (assoc label +;; (movitz-funobj-jumpers-map funobj))))) +;; (when set +;; (let ((pos (search set (movitz-funobj-const-list funobj) +;; :end2 (movitz-funobj-num-jumpers funobj)))) +;; (assert pos () +;; "Couldn't find for ~s set ~S in ~S." +;; label set (subseq (movitz-funobj-const-list funobj) +;; 0 (movitz-funobj-num-jumpers funobj))) +;; (* 4 pos))))))))) (multiple-value-bind (code-vector code-symtab) - #+use-old-ia-x86 - (let ((ia-x86:*instruction-compute-extra-prefix-map* - '((:call . compute-call-extra-prefix)))) - (ia-x86:proglist-encode :octet-vector :32-bit #x00000000 - (ia-x86:read-proglist combined-code) - :symtab-lookup - (lambda (label) - (case label - (:nil-value (image-nil-word *image*)) - (t (let ((set (cdr (assoc label - (movitz-funobj-jumpers-map funobj))))) - (when set - (let ((pos (search set (movitz-funobj-const-list funobj) - :end2 (movitz-funobj-num-jumpers funobj)))) - (assert pos () - "Couldn't find for ~s set ~S in ~S." - label set (subseq (movitz-funobj-const-list funobj) - 0 (movitz-funobj-num-jumpers funobj))) - (* 4 pos))))))))) - (let ((asm:*instruction-compute-extra-prefix-map* - '((:call . new-compute-call-extra-prefix)))) - (asm:proglist-encode combined-code - :symtab (list* (cons :nil-value (image-nil-word *image*)) - (loop for (label . set) in (movitz-funobj-jumpers-map funobj) - collect (cons label - (* 4 (or (search set (movitz-funobj-const-list funobj) - :end2 (movitz-funobj-num-jumpers funobj)) - (error "Jumper for ~S missing." label)))))))) - + (let ((asm:*instruction-compute-extra-prefix-map* + '((:call . compute-call-extra-prefix)))) + (asm:proglist-encode combined-code + :symtab (list* (cons :nil-value (image-nil-word *image*)) + (loop for (label . set) in (movitz-funobj-jumpers-map funobj) + collect (cons label + (* 4 (or (search set (movitz-funobj-const-list funobj) + :end2 (movitz-funobj-num-jumpers funobj)) + (error "Jumper for ~S missing." label)))))))) (setf (movitz-funobj-symtab funobj) code-symtab) (let* ((code-length (- (length code-vector) 3 -3)) (code-vector (make-array code-length @@ -1118,7 +1122,7 @@ (make-movitz-vector (length code-vector) :fill-pointer code-length :element-type 'code - :initial-contents code-vector))))) + :initial-contents code-vector)))) funobj) (defun check-locate-concistency (code-vector) @@ -1138,123 +1142,6 @@ (aref code-vector (+ x 3))))) (values)) -#+ignore -(defun make-compiled-function-body-default (form funobj env top-level-p) - (make-compiled-body-pass2 (make-compiled-function-pass1 form funobj env top-level-p) - env)) - -#+ignore -(defun old-make-compiled-function-body-default (form funobj env top-level-p &key include-programs) - (multiple-value-bind (arg-init-code body-form need-normalized-ecx-p) - (make-function-arguments-init funobj env form) - (multiple-value-bind (resolved-code stack-frame-size use-stack-frame-p frame-map) - (make-compiled-body body-form funobj env top-level-p arg-init-code include-programs) - (multiple-value-bind (prelude-code have-normalized-ecx-p) - (make-compiled-function-prelude stack-frame-size env use-stack-frame-p - need-normalized-ecx-p frame-map) - (values (install-arg-cmp (append prelude-code - resolved-code - (make-compiled-function-postlude funobj env use-stack-frame-p)) - have-normalized-ecx-p) - use-stack-frame-p))))) - -#+ignore -(defun make-compiled-function-body-without-prelude (form funobj env top-level-p) - (multiple-value-bind (code stack-frame-size use-stack-frame-p) - (make-compiled-body form funobj env top-level-p) - (if (not use-stack-frame-p) - (append code (make-compiled-function-postlude funobj env nil)) - (values (append `((:pushl :ebp) - (:movl :esp :ebp) - (:pushl :esi) - start-stack-frame-setup) - (case stack-frame-size - (0 nil) - (1 '((:pushl :edi))) - (2 '((:pushl :edi) (:pushl :edi))) - (t `((:subl ,(* 4 stack-frame-size) :esp)))) - (when (tree-search code '(:ecx)) - `((:testb :cl :cl) - (:js '(:sub-program (normalize-ecx) - (:shrl 8 :ecx) - (:jmp 'normalize-ecx-ok))) - (:andl #x7f :ecx) - normalize-ecx-ok)) - code - (make-compiled-function-postlude funobj env t)) - use-stack-frame-p)))) - -#+ignore -(defun make-compiled-function-body-2req-1opt (form funobj env top-level-p) - (when (and (= 2 (length (required-vars env))) - (= 1 (length (optional-vars env))) - (= 0 (length (key-vars env))) - (null (rest-var env))) - (let* ((opt-var (first (optional-vars env))) - (opt-binding (movitz-binding opt-var env nil)) - (req1-binding (movitz-binding (first (required-vars env)) env nil)) - (req2-binding (movitz-binding (second (required-vars env)) env nil)) - (default-form (optional-function-argument-init-form opt-binding))) - (compiler-values-bind (&code push-default-code-uninstalled &producer default-code-producer) - (compiler-call #'compile-form - :form default-form - :result-mode :push - :env env - :funobj funobj) - (cond - ((eq 'compile-self-evaluating default-code-producer) - (multiple-value-bind (code stack-frame-size use-stack-frame-p frame-map) - (make-compiled-body form funobj env top-level-p nil (list push-default-code-uninstalled)) - (when (and (new-binding-located-p req1-binding frame-map) - (new-binding-located-p req2-binding frame-map) - (new-binding-located-p opt-binding frame-map)) - (multiple-value-bind (eax-ebx-code eax-ebx-stack-offset) - (make-2req req1-binding req2-binding frame-map) - (let ((stack-init-size (- stack-frame-size eax-ebx-stack-offset)) - (push-default-code - (finalize-code push-default-code-uninstalled funobj env frame-map))) - (values (append `((:jmp '(:sub-program () - (:cmpb 2 :cl) - (:je 'entry%2op) - (:cmpb 3 :cl) - (:je 'entry%3op) - (:int 100))) - entry%3op - (:pushl :ebp) - (:movl :esp :ebp) - (:pushl :esi) - start-stack-frame-setup - ,@(when (and (edx-var env) (new-binding-located-p (edx-var env) frame-map)) - `((:movl :edx (:ebp ,(stack-frame-offset - (new-binding-location (edx-var env) frame-map)))))) - , at eax-ebx-code - ,@(if (eql (1+ eax-ebx-stack-offset) - (new-binding-location opt-binding frame-map)) - (append `((:pushl (:ebp ,(argument-stack-offset-shortcut 3 2)))) - (make-compiled-stack-frame-init (1- stack-init-size))) - (append (make-compiled-stack-frame-init stack-init-size) - `((:movl (:ebp ,(argument-stack-offset-shortcut 3 2)) :edx) - (:movl :edx (:ebp ,(stack-frame-offset - (new-binding-location opt-binding - frame-map))))))) - (:jmp 'arg-init-done) - entry%2op - (:pushl :ebp) - (:movl :esp :ebp) - (:pushl :esi) - , at eax-ebx-code - ,@(if (eql (1+ eax-ebx-stack-offset) - (new-binding-location opt-binding frame-map)) - (append push-default-code - (make-compiled-stack-frame-init (1- stack-init-size))) - (append (make-compiled-stack-frame-init stack-init-size) - push-default-code - `((:popl (:ebp ,(stack-frame-offset (new-binding-location opt-binding frame-map))))))) - arg-init-done) - code - (make-compiled-function-postlude funobj env t)) - use-stack-frame-p)))))) - (t nil)))))) (defun make-2req (binding0 binding1 frame-map) (let ((location-0 (new-binding-location binding0 frame-map)) From ffjeld at common-lisp.net Wed Feb 13 21:46:52 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Wed, 13 Feb 2008 16:46:52 -0500 (EST) Subject: [movitz-cvs] CVS movitz Message-ID: <20080213214652.23D254F019@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv12893 Modified Files: asm-x86.lisp Log Message: Starting work on disassembler. --- /project/movitz/cvsroot/movitz/asm-x86.lisp 2008/02/09 09:50:48 1.19 +++ /project/movitz/cvsroot/movitz/asm-x86.lisp 2008/02/13 21:46:51 1.20 @@ -6,7 +6,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: asm-x86.lisp,v 1.19 2008/02/09 09:50:48 ffjeld Exp $ +;;;; $Id: asm-x86.lisp,v 1.20 2008/02/13 21:46:51 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -210,70 +210,161 @@ (length code))) code)))))) - -(defmacro define-operator (operator lambda-list &body body) +(defmacro define-operator (operator operator-mode lambda-list &body body) (check-type operator keyword) - (let ((defun-name (intern (format nil "~A-~A" 'instruction-encoder operator)))) - `(progn - (defun ,defun-name (operator legacy-prefixes , at lambda-list) - (declare (ignorable operator legacy-prefixes)) - (let ((operator-mode nil) - (default-rex nil)) - (declare (ignorable operator-mode default-rex)) - (block operator - , at body - (values nil 'fail)))) - (setf (gethash ',operator *instruction-encoders*) - ',defun-name) - ',operator))) + (labels ((find-forms (body) + (cond + ((atom body) + nil) + ((member (car body) '(reg-modrm)) + (list body)) + (t (mapcan #'find-forms body))))) + (let ((defun-name (intern (format nil "~A-~A" 'instruction-encoder operator)))) + `(progn + (defun ,defun-name (operator legacy-prefixes , at lambda-list) + (declare (ignorable operator legacy-prefixes)) + (let ((operator-mode ',operator-mode) + (default-rex nil)) + (declare (ignorable operator-mode default-rex)) + (macrolet ((disassembler (&body body) + (declare (ignore body))) + (assembler (&body body) + `(progn , at body))) + (block operator + , at body + (values nil 'fail))))) + (setf (gethash ',operator *instruction-encoders*) + ',defun-name) + (macrolet ((disassembler (&body body) + `(progn , at body)) + (assembler (&body body) + (declare (ignore body)))) + (let ((operator ',operator) + (operator-mode ',operator-mode)) + ,@(find-forms body))) + ',operator)))) + +(defmacro define-operator/none (name lambda-list &body body) + `(define-operator ,name nil ,lambda-list , at body)) + +(deftype list-of (&rest elements) + (labels ((make-list-of (elements) + (if (null elements) + 'null + `(cons ,(car elements) + ,(make-list-of (cdr elements)))))) + (make-list-of elements))) + +(defparameter *opcode-disassemblers-16* + (make-array 256 :initial-element nil)) + +(defparameter *opcode-disassemblers-32* + (make-array 256 :initial-element nil)) + +(defparameter *opcode-disassemblers-64* + (make-array 256 :initial-element nil)) + +(deftype disassembly-decoder () + '(list-of keyword (or keyword nil) symbol)) + +(defun (setf opcode-disassembler) (decoder opcode operator-mode) + (check-type decoder disassembly-decoder) + (labels ((set-it (table pos) + (check-type pos (integer 0 *)) + (check-type table (simple-vector 256)) + (let ((bit-pos (* 8 (1- (ceiling (integer-length pos) 8))))) + (if (not (plusp bit-pos)) + (progn + (unless (or (eq nil decoder) + (eq nil (svref table pos)) + (equal decoder (svref table pos))) + (warn "Redefining disassembler for opcode #x~X from ~{~S ~}to ~{~S~^ ~}." + opcode (svref table pos) decoder)) + (setf (svref table pos) decoder)) + (set-it (or (svref table (ldb (byte 8 bit-pos) pos)) + (setf (svref table (ldb (byte 8 bit-pos) pos)) + (make-array 256 :initial-element nil))) + (ldb (byte bit-pos 0) pos)))))) + (ecase operator-mode + (:16-bit + (set-it *opcode-disassemblers-16* opcode)) + (:32-bit + (set-it *opcode-disassemblers-32* opcode)) + (:64-bit + (set-it *opcode-disassemblers-64* opcode)) + (:8-bit + (set-it *opcode-disassemblers-16* opcode) + (set-it *opcode-disassemblers-32* opcode) + (set-it *opcode-disassemblers-64* opcode))))) + +(defun disassemble-code (code) + (labels ((lookup-decoder (table opcode) + (let* ((datum (pop-code code)) + (opcode (logior (ash opcode 8) + datum)) + (decoder (svref table datum))) + (typecase decoder + ((simple-vector 256) + (lookup-decoder decoder opcode)) + ((list-of keyword (or keyword null) symbol) + (values decoder + opcode)) + (t (error "No disassembler registered for opcode #x~X." opcode)))))) + (destructuring-bind (operator operator-mode operand-decoder) + (lookup-decoder (ecase *cpu-mode* + (:16-bit *opcode-disassemblers-16*) + (:32-bit *opcode-disassemblers-32*) + (:64-bit *opcode-disassemblers-64*)) + 0) + (values (list* operator (code-call (funcall operand-decoder code operator-mode) code)) + code)))) + +(defmacro define-disassembler (opcode operands operator-mode) + `(disassembler + (setf (opcode-disassembler ,opcode ,operator-mode) (list operator ,operator-mode ',operands)))) (defmacro define-operator/8 (operator lambda-list &body body) - `(define-operator ,operator ,lambda-list - (let ((operator-mode :8-bit) - (default-rex nil)) - (declare (ignorable operator-mode default-rex)) + `(define-operator ,operator :8-bit ,lambda-list + (let ((default-rex nil)) + (declare (ignorable default-rex)) (macrolet ((yield (&rest args) `(return-from operator (encode (encoded-values :operand-size operator-mode , at args))))) , at body)))) (defmacro define-operator/16 (operator lambda-list &body body) - `(define-operator ,operator ,lambda-list - (let ((operator-mode :16-bit) - (default-rex nil)) - (declare (ignorable operator-mode default-rex)) + `(define-operator ,operator :16-bit ,lambda-list + (let ((default-rex nil)) + (declare (ignorable default-rex)) (macrolet ((yield (&rest args) `(return-from operator (encode (encoded-values :operand-size operator-mode , at args))))) , at body)))) (defmacro define-operator/32 (operator lambda-list &body body) - `(define-operator ,operator ,lambda-list - (let ((operator-mode :32-bit) - (default-rex nil)) - (declare (ignorable operator-mode default-rex)) + `(define-operator ,operator :32-bit ,lambda-list + (let ((default-rex nil)) + (declare (ignorable default-rex)) (macrolet ((yield (&rest args) `(return-from operator (encode (encoded-values :operand-size operator-mode , at args))))) , at body)))) (defmacro define-operator/64 (operator lambda-list &body body) - `(define-operator ,operator ,lambda-list - (let ((operator-mode :64-bit) - (default-rex '(:rex.w))) - (declare (ignorable operator-mode default-rex)) + `(define-operator ,operator :64-bit ,lambda-list + (let ((default-rex '(:rex.w))) + (declare (ignorable default-rex)) (macrolet ((yield (&rest args) `(return-from operator (encode (encoded-values :operand-size operator-mode , at args))))) , at body)))) (defmacro define-operator/64* (operator lambda-list &body body) - `(define-operator ,operator ,lambda-list - (let ((operator-mode :64-bit) - (default-rex (case *cpu-mode* + `(define-operator ,operator :64-bit ,lambda-list + (let ((default-rex (case *cpu-mode* (:64-bit nil) (t '(:rex.w))))) - (declare (ignorable operator-mode)) + (declare (ignorable default-rex)) , at body))) (defmacro define-operator* ((&key |16| |32| |64| dispatch) args &body body) @@ -377,18 +468,20 @@ nil (or reg-scale 1))))) +(defun register-set-by-mode (mode) + (ecase 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 :13 :r14 :r15)) + (:mm '(:mm0 :mm1 :mm2 :mm3 :mm4 :mm5 :mm6 :mm7)) + (:xmm '(:xmm0 :xmm1 :xmm2 :xmm3 :xmm4 :xmm5 :xmm6 :xmm7)))) (defun encode-reg/mem (operand mode) (check-type mode (member nil :8-bit :16-bit :32-bit :64-bit :mm :xmm)) (if (and mode (keywordp operand)) (encoded-values :mod #b11 - :rm (or (position operand (ecase 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 :13 :r14 :r15)) - (:mm '(:mm0 :mm1 :mm2 :mm3 :mm4 :mm5 :mm6 :mm7)) - (:xmm '(:xmm0 :xmm1 :xmm2 :xmm3 :xmm4 :xmm5 :xmm6 :xmm7)))) + :rm (or (position operand (register-set-by-mode mode)) (error "Unknown ~(~D~) register ~S." mode operand))) (multiple-value-bind (reg offsets reg2 reg-scale) (parse-indirect-operand operand) @@ -633,9 +726,77 @@ :rm rm16 :address-size :16-bit :displacement (encode-integer offset '(xint 16)))) - (t (error "Huh? reg: ~S, reg2: ~S, scale: ~S, offset: ~S" reg reg2 reg-scale offset)) - ))))))))))) - + (t (error "Huh? reg: ~S, reg2: ~S, scale: ~S, offset: ~S" reg reg2 reg-scale offset))))))))))))) + +(defmacro pop-code (code-place &optional context) + `(let ((x (pop ,code-place))) + (check-type x (unsigned-byte 8) ,(format nil "an octet (context: ~A)" context)) + x)) + +(defmacro code-call (form &optional (code-place (cadr form))) + `(multiple-value-bind (value new-code) + ,form + (setf ,code-place new-code) + value)) + +(defun decode-integer (code type) + "Decode an integer of specified type." + (let* ((bit-size (cadr type)) + (unsigned-integer (loop for b from 0 below bit-size by 8 + sum (ash (pop-code code integer) b)))) + (values (if (or (not (member (car type) '(sint signed-byte))) + (not (logbitp (1- bit-size) unsigned-integer))) + unsigned-integer + (- (ldb (byte bit-size 0) + (1+ (lognot unsigned-integer))))) + code))) + +(defun decode-reg-modrm (code operator-mode) + (ecase *cpu-mode* + (:32-bit + (decode-reg-modrm-32 code operator-mode)))) + +(defun decode-reg-modrm-32 (code &optional (reg-mode :32-bit)) + "Return a list of the REG, and the MOD/RM operands." + (let* ((modrm (pop-code code mod/rm)) + (mod (ldb (byte 2 6) modrm)) + (reg (ldb (byte 3 3) modrm)) + (r/m (ldb (byte 3 0) modrm))) + (values (list (nth reg (register-set-by-mode reg-mode)) + (if (= mod #b11) + (nth r/m (register-set-by-mode reg-mode)) + (flet ((decode-sib () + (let* ((sib (pop-code code sib)) + (ss (ldb (byte 2 6) sib)) + (index (ldb (byte 3 3) sib)) + (base (ldb (byte 3 0) sib))) + (nconc (unless (= index #b100) + (let ((index-reg (nth index (register-set-by-mode :32-bit)))) + (if (= ss #b00) + (list index-reg) + (list (list index-reg (ash 2 ss)))))) + (if (/= base #b101) + (list (nth base (register-set-by-mode :32-bit))) + (ecase mod + (#b00 nil) + ((#b01 #b10) (list :ebp)))))))) + (ecase mod + (#b00 (case r/m + (#b100 (decode-sib)) + (#b101 (code-call (decode-integer code '(uint 32)))) + (t (list (nth r/m (register-set-by-mode :32-bit)))))) + (#b01 (case r/m + (#b100 (nconc(decode-sib) + (list (code-call (decode-integer code '(sint 8)))))) + (t (list (nth r/m (register-set-by-mode :32-bit)) + (code-call (decode-integer code '(sint 8))))))) + (#b10 (case r/m + (#b100 (nconc (decode-sib) + (list (code-call (decode-integer code '(uint 32)))))) + (t (list (nth r/m (register-set-by-mode :32-bit)) + (code-call (decode-integer code '(uint 32))))))))))) + code))) + (defmacro return-when (form) `(let ((x ,form)) @@ -738,7 +899,12 @@ (encode-reg/mem op-modrm (or reg/mem-mode operator-mode))))))) (defmacro reg-modrm (op-reg op-modrm opcode &optional reg/mem-mode &rest extras) - `(return-when (encode-reg-modrm operator legacy-prefixes ,op-reg ,op-modrm ,opcode operator-mode default-rex ,reg/mem-mode , at extras))) + `(progn + (assembler + (return-when (encode-reg-modrm operator legacy-prefixes ,op-reg ,op-modrm ,opcode + operator-mode default-rex ,reg/mem-mode , at extras))) + (disassembler + (define-disassembler ,opcode decode-reg-modrm operator-mode)))) (defun encode-reg-cr (operator legacy-prefixes op-reg op-cr opcode operator-mode default-rex &rest extras) (let* ((reg-map (ecase operator-mode @@ -858,7 +1024,7 @@ ;;;;;;;;;;; Pseudo-instructions -(define-operator :% (op &rest form) +(define-operator/none :% (op &rest form) (case op (:bytes (return-from operator @@ -994,16 +1160,16 @@ (when (eq operator-mode *cpu-mode*) (modrm dest #xff 2))) -(define-operator :call-segment (dest) +(define-operator/none :call-segment (dest) (modrm dest #xff 3)) ;;;;;;;;;;; CLC, CLD, CLI, CLTS, CMC -(define-operator :clc () (opcode #xf8)) -(define-operator :cld () (opcode #xfc)) -(define-operator :cli () (opcode #xfa)) -(define-operator :clts () (opcode #x0f06)) -(define-operator :cmc () (opcode #xf5)) +(define-operator/none :clc () (opcode #xf8)) +(define-operator/none :cld () (opcode #xfc)) +(define-operator/none :cli () (opcode #xfa)) +(define-operator/none :clts () (opcode #x0f06)) +(define-operator/none :cmc () (opcode #xf5)) ;;;;;;;;;;; CMOVcc @@ -1125,7 +1291,7 @@ ;;;;;;;;;;; CPUID -(define-operator :cpuid () +(define-operator/none :cpuid () (opcode* #x0fa2)) ;;;;;;;;;;; CWD, CDQ @@ -1171,7 +1337,7 @@ ;;;;;;;;;;; HLT -(define-operator :halt () +(define-operator/none :halt () (opcode #xf4)) ;;;;;;;;;;; IDIV @@ -1245,18 +1411,18 @@ ;;;;;;;;;;; INT -(define-operator :break () +(define-operator/none :break () (opcode #xcc)) -(define-operator :int (vector) +(define-operator/none :int (vector) (imm vector #xcd (uint 8))) -(define-operator :into () +(define-operator/none :into () (opcode #xce)) ;;;;;;;;;;; INVLPG -(define-operator :invlpg (address) [145 lines skipped] From ffjeld at common-lisp.net Thu Feb 14 21:56:36 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Thu, 14 Feb 2008 16:56:36 -0500 (EST) Subject: [movitz-cvs] CVS movitz Message-ID: <20080214215636.C9BE163062@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv29959 Modified Files: asm-x86.lisp Log Message: I think the disassembler framework basically works now. --- /project/movitz/cvsroot/movitz/asm-x86.lisp 2008/02/13 21:46:51 1.20 +++ /project/movitz/cvsroot/movitz/asm-x86.lisp 2008/02/14 21:56:36 1.21 @@ -6,7 +6,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: asm-x86.lisp,v 1.20 2008/02/13 21:46:51 ffjeld Exp $ +;;;; $Id: asm-x86.lisp,v 1.21 2008/02/14 21:56:36 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -265,7 +265,7 @@ (make-array 256 :initial-element nil)) (deftype disassembly-decoder () - '(list-of keyword (or keyword nil) symbol)) + '(list-of keyword (or keyword null) symbol)) (defun (setf opcode-disassembler) (decoder opcode operator-mode) (check-type decoder disassembly-decoder) @@ -278,8 +278,8 @@ (unless (or (eq nil decoder) (eq nil (svref table pos)) (equal decoder (svref table pos))) - (warn "Redefining disassembler for opcode #x~X from ~{~S ~}to ~{~S~^ ~}." - opcode (svref table pos) decoder)) + (warn "Redefining disassembler for ~@[~(~A~) ~]opcode #x~X from ~{~S ~}to ~{~S~^ ~}." + operator-mode opcode (svref table pos) decoder)) (setf (svref table pos) decoder)) (set-it (or (svref table (ldb (byte 8 bit-pos) pos)) (setf (svref table (ldb (byte 8 bit-pos) pos)) @@ -292,12 +292,12 @@ (set-it *opcode-disassemblers-32* opcode)) (:64-bit (set-it *opcode-disassemblers-64* opcode)) - (:8-bit + ((:8-bit nil) (set-it *opcode-disassemblers-16* opcode) (set-it *opcode-disassemblers-32* opcode) (set-it *opcode-disassemblers-64* opcode))))) -(defun disassemble-code (code) +(defun disassemble-code (code &optional override-operand-size override-address-size rex) (labels ((lookup-decoder (table opcode) (let* ((datum (pop-code code)) (opcode (logior (ash opcode 8) @@ -310,18 +310,68 @@ (values decoder opcode)) (t (error "No disassembler registered for opcode #x~X." opcode)))))) - (destructuring-bind (operator operator-mode operand-decoder) - (lookup-decoder (ecase *cpu-mode* + (multiple-value-bind (decoder opcode) + (lookup-decoder (ecase (or override-operand-size *cpu-mode*) (:16-bit *opcode-disassemblers-16*) (:32-bit *opcode-disassemblers-32*) (:64-bit *opcode-disassemblers-64*)) 0) - (values (list* operator (code-call (funcall operand-decoder code operator-mode) code)) - code)))) + (destructuring-bind (operator operand-size decoder-function) + decoder + (values (code-call (funcall decoder-function + code + operator + opcode + (or operand-size override-operand-size) + (or override-address-size *cpu-mode*) + rex)) + code))))) + +(defmacro define-disassembler ((operator opcode &optional cpu-mode) lambda-list &body body) + (if (and (symbolp lambda-list) + (null body)) + `(setf (opcode-disassembler ',opcode ,cpu-mode) (list ,operator ,cpu-mode ',lambda-list)) + (let ((defun-name (intern (format nil "~A-~A-~X~@[-~A~]" 'disassembler operator opcode cpu-mode)))) + `(progn + (defun ,defun-name ,lambda-list , at body) + (setf (opcode-disassembler ',opcode ',cpu-mode) (list ,operator ',cpu-mode ',defun-name)) + ',defun-name)))) + +(defun disassemble-simple-prefix (code operator opcode operand-size address-size rex) + (declare (ignore opcode rex)) + (let ((instruction (code-call (disassemble-code code operand-size address-size nil)))) + (values (if (consp (car instruction)) + (list* (list* operator (car instruction)) + (cdr instruction)) + (list* (list operator) + instruction)) + code))) -(defmacro define-disassembler (opcode operands operator-mode) - `(disassembler - (setf (opcode-disassembler ,opcode ,operator-mode) (list operator ,operator-mode ',operands)))) +(define-disassembler (:lock #xf0) disassemble-simple-prefix) +(define-disassembler (:repne #xf2) disassemble-simple-prefix) +(define-disassembler (:repz #xf3) disassemble-simple-prefix) +(define-disassembler (:cs-override #x2e) disassemble-simple-prefix) +(define-disassembler (:ss-override #x36) disassemble-simple-prefix) +(define-disassembler (:ds-override #x3e) disassemble-simple-prefix) +(define-disassembler (:es-override #x26) disassemble-simple-prefix) +(define-disassembler (:fs-override #x64) disassemble-simple-prefix) +(define-disassembler (:gs-override #x65) disassemble-simple-prefix) + +(define-disassembler (:operand-size-override #x66 :32-bit) (code operator opcode operand-size address-size rex) + (declare (ignore operator opcode operand-size rex)) + (disassemble-code code :16-bit address-size nil)) + +(define-disassembler (:address-size-override #x67 :32-bit) (code operator opcode operand-size address-size rex) + (declare (ignore operator opcode operand-size rex)) + (disassemble-code code operand-size :16-bit nil)) + +(define-disassembler (:operand-size-override #x66 :16-bit) (code operator opcode operand-size address-size rex) + (declare (ignore operator opcode operand-size rex)) + (disassemble-code code :32-bit address-size nil)) + +(define-disassembler (:address-size-override #x67 :16-bit) (code operator opcode operand-size address-size rex) + (declare (ignore operator opcode operand-size rex)) + (disassemble-code code operand-size :32-bit nil)) (defmacro define-operator/8 (operator lambda-list &body body) `(define-operator ,operator :8-bit ,lambda-list @@ -733,11 +783,10 @@ (check-type x (unsigned-byte 8) ,(format nil "an octet (context: ~A)" context)) x)) -(defmacro code-call (form &optional (code-place (cadr form))) - `(multiple-value-bind (value new-code) - ,form - (setf ,code-place new-code) - value)) +(defmacro code-call (form &optional (code-place (case (car form) (funcall (third form)) (t (second form))))) + "Execute form, then 'magically' update the code binding with the secondary return value from form." + `(let (tmp) + (setf (values tmp ,code-place) ,form))) (defun decode-integer (code type) "Decode an integer of specified type." @@ -751,20 +800,48 @@ (1+ (lognot unsigned-integer))))) code))) -(defun decode-reg-modrm (code operator-mode) - (ecase *cpu-mode* +(defun decode-reg-modrm (code operator opcode operand-size address-size rex) + (declare (ignore opcode rex)) + (ecase address-size (:32-bit - (decode-reg-modrm-32 code operator-mode)))) + (decode-reg-modrm-32 code operator operand-size)) + (:16-bit + (decode-reg-modrm-16 code operator operand-size)))) + +(defun decode-reg-modrm-16 (code operator operand-size) + (let* ((modrm (pop-code code mod/rm)) + (mod (ldb (byte 2 6) modrm)) + (reg (ldb (byte 3 3) modrm)) + (r/m (ldb (byte 3 0) modrm))) + (values (list operator + (nth reg (register-set-by-mode operand-size)) + (if (= mod #b11) + (nth reg (register-set-by-mode operand-size)) + (flet ((operands (i) + (nth i '((:bx :si) (:bx :di) (:bp :si) (:bp :di) (:si) (:di) (:bp) (:bx))))) + (ecase mod + (#b00 + (case r/m + (#b110 (code-call (decode-integer code '(uint 16)))) + (t (operands r/m)))) + (#b01 + (append (operands r/m) + (code-call (decode-integer code '(sint 8))))) + (#b10 + (append (operands r/m) + (code-call (decode-integer code '(uint 16))))))))) + code))) -(defun decode-reg-modrm-32 (code &optional (reg-mode :32-bit)) +(defun decode-reg-modrm-32 (code operator operand-size) "Return a list of the REG, and the MOD/RM operands." (let* ((modrm (pop-code code mod/rm)) (mod (ldb (byte 2 6) modrm)) (reg (ldb (byte 3 3) modrm)) (r/m (ldb (byte 3 0) modrm))) - (values (list (nth reg (register-set-by-mode reg-mode)) + (values (list operator + (nth reg (register-set-by-mode operand-size)) (if (= mod #b11) - (nth r/m (register-set-by-mode reg-mode)) + (nth r/m (register-set-by-mode operand-size)) (flet ((decode-sib () (let* ((sib (pop-code code sib)) (ss (ldb (byte 2 6) sib)) @@ -904,7 +981,7 @@ (return-when (encode-reg-modrm operator legacy-prefixes ,op-reg ,op-modrm ,opcode operator-mode default-rex ,reg/mem-mode , at extras))) (disassembler - (define-disassembler ,opcode decode-reg-modrm operator-mode)))) + (define-disassembler (operator ,opcode operator-mode) decode-reg-modrm)))) (defun encode-reg-cr (operator legacy-prefixes op-reg op-cr opcode operator-mode default-rex &rest extras) (let* ((reg-map (ecase operator-mode From ffjeld at common-lisp.net Sat Feb 16 18:01:09 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sat, 16 Feb 2008 13:01:09 -0500 (EST) Subject: [movitz-cvs] CVS movitz Message-ID: <20080216180109.BF2A31501D@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv25557 Modified Files: asm-x86.lisp Log Message: More disassembler development. --- /project/movitz/cvsroot/movitz/asm-x86.lisp 2008/02/14 21:56:36 1.21 +++ /project/movitz/cvsroot/movitz/asm-x86.lisp 2008/02/16 18:01:07 1.22 @@ -2,11 +2,11 @@ ;;;; ;;;; Copyright (C) 2007 Frode V. Fjeld ;;;; -;;;; Description: x86 assembler for 32 and 64-bit. +;;;; Description: x86 assembler for 16, 32, and 64-bit modes. ;;;; Author: Frode Vatvedt Fjeld ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: asm-x86.lisp,v 1.21 2008/02/14 21:56:36 ffjeld Exp $ +;;;; $Id: asm-x86.lisp,v 1.22 2008/02/16 18:01:07 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -216,7 +216,7 @@ (cond ((atom body) nil) - ((member (car body) '(reg-modrm)) + ((member (car body) '(reg-modrm modrm opcode imm-modrm imm)) (list body)) (t (mapcan #'find-forms body))))) (let ((defun-name (intern (format nil "~A-~A" 'instruction-encoder operator)))) @@ -240,7 +240,9 @@ (assembler (&body body) (declare (ignore body)))) (let ((operator ',operator) - (operator-mode ',operator-mode)) + (operator-mode ',operator-mode) + (operand-formals ',lambda-list)) + (declare (ignorable operand-formals)) ,@(find-forms body))) ',operator)))) @@ -248,6 +250,7 @@ `(define-operator ,name nil ,lambda-list , at body)) (deftype list-of (&rest elements) + "A list with elements of specified type(s)." (labels ((make-list-of (elements) (if (null elements) 'null @@ -255,6 +258,15 @@ ,(make-list-of (cdr elements)))))) (make-list-of elements))) +(deftype list-of* (&rest elements) + "A list starting with elements of specified type(s)." + (labels ((make-list-of (elements) + (if (null elements) + 'list + `(cons ,(car elements) + ,(make-list-of (cdr elements)))))) + (make-list-of elements))) + (defparameter *opcode-disassemblers-16* (make-array 256 :initial-element nil)) @@ -265,7 +277,7 @@ (make-array 256 :initial-element nil)) (deftype disassembly-decoder () - '(list-of keyword (or keyword null) symbol)) + '(list-of* keyword (or keyword null) symbol)) (defun (setf opcode-disassembler) (decoder opcode operator-mode) (check-type decoder disassembly-decoder) @@ -297,7 +309,7 @@ (set-it *opcode-disassemblers-32* opcode) (set-it *opcode-disassemblers-64* opcode))))) -(defun disassemble-code (code &optional override-operand-size override-address-size rex) +(defun disassemble-instruction (code &optional override-operand-size override-address-size rex) (labels ((lookup-decoder (table opcode) (let* ((datum (pop-code code)) (opcode (logior (ash opcode 8) @@ -306,7 +318,7 @@ (typecase decoder ((simple-vector 256) (lookup-decoder decoder opcode)) - ((list-of keyword (or keyword null) symbol) + (disassembly-decoder (values decoder opcode)) (t (error "No disassembler registered for opcode #x~X." opcode)))))) @@ -316,30 +328,40 @@ (:32-bit *opcode-disassemblers-32*) (:64-bit *opcode-disassemblers-64*)) 0) - (destructuring-bind (operator operand-size decoder-function) + (destructuring-bind (operator operand-size decoder-function &rest extra-args) decoder - (values (code-call (funcall decoder-function - code - operator - opcode - (or operand-size override-operand-size) - (or override-address-size *cpu-mode*) - rex)) + (warn "extraS: ~S" extra-args) + (values (code-call (apply decoder-function + code + operator + opcode + (or operand-size override-operand-size) + (or override-address-size *cpu-mode*) + rex + extra-args)) code))))) -(defmacro define-disassembler ((operator opcode &optional cpu-mode) lambda-list &body body) - (if (and (symbolp lambda-list) - (null body)) - `(setf (opcode-disassembler ',opcode ,cpu-mode) (list ,operator ,cpu-mode ',lambda-list)) - (let ((defun-name (intern (format nil "~A-~A-~X~@[-~A~]" 'disassembler operator opcode cpu-mode)))) - `(progn - (defun ,defun-name ,lambda-list , at body) - (setf (opcode-disassembler ',opcode ',cpu-mode) (list ,operator ',cpu-mode ',defun-name)) - ',defun-name)))) +(defmacro define-disassembler ((operator opcode &optional cpu-mode (digit nil digit-p)) lambda-list &body body) + (cond + (digit-p + `(loop for mod from #b00 to #b11 + do (loop for r/m from #b000 to #b111 + as ext-opcode = (logior (ash ,opcode 8) + (ash ,digit 3) + (ash mod 6) + r/m) + do (define-disassembler (,operator ext-opcode ,cpu-mode) ,lambda-list , at body)))) + ((symbolp lambda-list) + `(setf (opcode-disassembler ,opcode ,cpu-mode) (list ,operator ,cpu-mode ',lambda-list , at body))) + (t (let ((defun-name (intern (format nil "~A-~A-~X~@[-~A~]" 'disassembler operator opcode cpu-mode)))) + `(progn + (defun ,defun-name ,lambda-list , at body) + (setf (opcode-disassembler ,opcode ',cpu-mode) (list ,operator ',cpu-mode ',defun-name)) + ',defun-name))))) (defun disassemble-simple-prefix (code operator opcode operand-size address-size rex) (declare (ignore opcode rex)) - (let ((instruction (code-call (disassemble-code code operand-size address-size nil)))) + (let ((instruction (code-call (disassemble-instruction code operand-size address-size nil)))) (values (if (consp (car instruction)) (list* (list* operator (car instruction)) (cdr instruction)) @@ -359,19 +381,19 @@ (define-disassembler (:operand-size-override #x66 :32-bit) (code operator opcode operand-size address-size rex) (declare (ignore operator opcode operand-size rex)) - (disassemble-code code :16-bit address-size nil)) + (disassemble-instruction code :16-bit address-size nil)) (define-disassembler (:address-size-override #x67 :32-bit) (code operator opcode operand-size address-size rex) (declare (ignore operator opcode operand-size rex)) - (disassemble-code code operand-size :16-bit nil)) + (disassemble-instruction code operand-size :16-bit nil)) (define-disassembler (:operand-size-override #x66 :16-bit) (code operator opcode operand-size address-size rex) (declare (ignore operator opcode operand-size rex)) - (disassemble-code code :32-bit address-size nil)) + (disassemble-instruction code :32-bit address-size nil)) (define-disassembler (:address-size-override #x67 :16-bit) (code operator opcode operand-size address-size rex) (declare (ignore operator opcode operand-size rex)) - (disassemble-code code operand-size :32-bit nil)) + (disassemble-instruction code operand-size :32-bit nil)) (defmacro define-operator/8 (operator lambda-list &body body) `(define-operator ,operator :8-bit ,lambda-list @@ -778,12 +800,23 @@ :displacement (encode-integer offset '(xint 16)))) (t (error "Huh? reg: ~S, reg2: ~S, scale: ~S, offset: ~S" reg reg2 reg-scale offset))))))))))))) +(defun operand-ordering (formals &rest arrangement) + (loop with rarrangement = (reverse arrangement) + for formal in formals + when (getf rarrangement formal) + collect it)) + +(defun order-operands (ordering &rest operands) + (loop for key in ordering + collect (or (getf operands key) + (error "No operand ~S in ~S." key operands)))) + (defmacro pop-code (code-place &optional context) `(let ((x (pop ,code-place))) (check-type x (unsigned-byte 8) ,(format nil "an octet (context: ~A)" context)) x)) -(defmacro code-call (form &optional (code-place (case (car form) (funcall (third form)) (t (second form))))) +(defmacro code-call (form &optional (code-place (case (car form) ((funcall apply) (third form)) (t (second form))))) "Execute form, then 'magically' update the code binding with the secondary return value from form." `(let (tmp) (setf (values tmp ,code-place) ,form))) @@ -800,78 +833,107 @@ (1+ (lognot unsigned-integer))))) code))) -(defun decode-reg-modrm (code operator opcode operand-size address-size rex) +(defun decode-no-operands (code operator opcode operand-size address-size rex) + (declare (ignore opcode operand-size address-size rex)) + (values (list operator) + code)) + +(defun decode-reg-modrm (code operator opcode operand-size address-size rex operand-ordering) (declare (ignore opcode rex)) - (ecase address-size - (:32-bit - (decode-reg-modrm-32 code operator operand-size)) - (:16-bit - (decode-reg-modrm-16 code operator operand-size)))) + (values (list* operator + (order-operands operand-ordering + :reg (nth (ldb (byte 3 3) (car code)) + (register-set-by-mode operand-size)) + :modrm (ecase address-size + (:32-bit + (code-call (decode-reg-modrm-32 code operand-size))) + (:16-bit + (code-call (decode-reg-modrm-16 code operand-size)))))) + code)) + + +(defun decode-modrm (code operator opcode operand-size address-size rex) + (values (list operator + (ecase address-size + (:32-bit + (code-call (decode-reg-modrm-32 code operand-size))) + (:16-bit + (code-call (decode-reg-modrm-16 code operand-size))))) + code)) + +(defun decode-imm-modrm (code operator opcode operand-size address-size rex imm-type operand-ordering &key fixed-modrm) + (values (list* operator + (order-operands operand-ordering + :modrm (or fixed-modrm + (when (member :modrm operand-ordering) + (ecase address-size + (:32-bit + (code-call (decode-reg-modrm-32 code operand-size))) + (:16-bit + (code-call (decode-reg-modrm-16 code operand-size)))))) + :imm (code-call (decode-integer code imm-type)))) + code)) -(defun decode-reg-modrm-16 (code operator operand-size) +(defun decode-reg-modrm-16 (code operand-size) (let* ((modrm (pop-code code mod/rm)) (mod (ldb (byte 2 6) modrm)) (reg (ldb (byte 3 3) modrm)) (r/m (ldb (byte 3 0) modrm))) - (values (list operator - (nth reg (register-set-by-mode operand-size)) - (if (= mod #b11) - (nth reg (register-set-by-mode operand-size)) - (flet ((operands (i) - (nth i '((:bx :si) (:bx :di) (:bp :si) (:bp :di) (:si) (:di) (:bp) (:bx))))) - (ecase mod - (#b00 - (case r/m - (#b110 (code-call (decode-integer code '(uint 16)))) - (t (operands r/m)))) - (#b01 - (append (operands r/m) - (code-call (decode-integer code '(sint 8))))) - (#b10 - (append (operands r/m) - (code-call (decode-integer code '(uint 16))))))))) + (values (if (= mod #b11) + (nth reg (register-set-by-mode operand-size)) + (flet ((operands (i) + (nth i '((:bx :si) (:bx :di) (:bp :si) (:bp :di) (:si) (:di) (:bp) (:bx))))) + (ecase mod + (#b00 + (case r/m + (#b110 (code-call (decode-integer code '(uint 16)))) + (t (operands r/m)))) + (#b01 + (append (operands r/m) + (code-call (decode-integer code '(sint 8))))) + (#b10 + (append (operands r/m) + (code-call (decode-integer code '(uint 16)))))))) code))) -(defun decode-reg-modrm-32 (code operator operand-size) +(defun decode-reg-modrm-32 (code operand-size) "Return a list of the REG, and the MOD/RM operands." (let* ((modrm (pop-code code mod/rm)) (mod (ldb (byte 2 6) modrm)) (reg (ldb (byte 3 3) modrm)) (r/m (ldb (byte 3 0) modrm))) - (values (list operator - (nth reg (register-set-by-mode operand-size)) - (if (= mod #b11) - (nth r/m (register-set-by-mode operand-size)) - (flet ((decode-sib () - (let* ((sib (pop-code code sib)) - (ss (ldb (byte 2 6) sib)) - (index (ldb (byte 3 3) sib)) - (base (ldb (byte 3 0) sib))) - (nconc (unless (= index #b100) - (let ((index-reg (nth index (register-set-by-mode :32-bit)))) - (if (= ss #b00) - (list index-reg) - (list (list index-reg (ash 2 ss)))))) - (if (/= base #b101) - (list (nth base (register-set-by-mode :32-bit))) - (ecase mod - (#b00 nil) - ((#b01 #b10) (list :ebp)))))))) - (ecase mod - (#b00 (case r/m - (#b100 (decode-sib)) - (#b101 (code-call (decode-integer code '(uint 32)))) - (t (list (nth r/m (register-set-by-mode :32-bit)))))) - (#b01 (case r/m - (#b100 (nconc(decode-sib) - (list (code-call (decode-integer code '(sint 8)))))) - (t (list (nth r/m (register-set-by-mode :32-bit)) - (code-call (decode-integer code '(sint 8))))))) - (#b10 (case r/m - (#b100 (nconc (decode-sib) - (list (code-call (decode-integer code '(uint 32)))))) - (t (list (nth r/m (register-set-by-mode :32-bit)) - (code-call (decode-integer code '(uint 32))))))))))) + (values (if (= mod #b11) + (nth r/m (register-set-by-mode operand-size)) + (flet ((decode-sib () + (let* ((sib (pop-code code sib)) + (ss (ldb (byte 2 6) sib)) + (index (ldb (byte 3 3) sib)) + (base (ldb (byte 3 0) sib))) + (nconc (unless (= index #b100) + (let ((index-reg (nth index (register-set-by-mode :32-bit)))) + (if (= ss #b00) + (list index-reg) + (list (list index-reg (ash 2 ss)))))) + (if (/= base #b101) + (list (nth base (register-set-by-mode :32-bit))) + (ecase mod + (#b00 nil) + ((#b01 #b10) (list :ebp)))))))) + (ecase mod + (#b00 (case r/m + (#b100 (decode-sib)) + (#b101 (code-call (decode-integer code '(uint 32)))) + (t (list (nth r/m (register-set-by-mode :32-bit)))))) + (#b01 (case r/m + (#b100 (nconc(decode-sib) + (list (code-call (decode-integer code '(sint 8)))))) + (t (list (nth r/m (register-set-by-mode :32-bit)) + (code-call (decode-integer code '(sint 8))))))) + (#b10 (case r/m + (#b100 (nconc (decode-sib) + (list (code-call (decode-integer code '(uint 32)))))) + (t (list (nth r/m (register-set-by-mode :32-bit)) + (code-call (decode-integer code '(uint 32)))))))))) code))) @@ -883,28 +945,54 @@ `(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-operand ,imm-operand))) - (when (typep immediate ',imm-type) - (return-values-when - (encoded-values :opcode ,opcode - :immediate (encode-integer immediate ',imm-type) - :operand-size operator-mode - :rex default-rex - , at extras)))))) +(defmacro imm (imm-operand opcode imm-type &optional extra-operand &rest extras) + `(progn + (assembler + (when (and ,@(when extra-operand + (list (list* 'eql extra-operand))) + (immediate-p ,imm-operand)) + (let ((immediate (resolve-operand ,imm-operand))) + (when (typep immediate ',imm-type) + (return-values-when + (encoded-values :opcode ,opcode + :immediate (encode-integer immediate ',imm-type) + :operand-size operator-mode + :rex default-rex + , at extras)))))) + (disassembler + ,(if extra-operand + `(define-disassembler (operator ,opcode operator-mode) + decode-imm-modrm + ',imm-type + (operand-ordering operand-formals + :imm ',imm-operand + :modrm ',(first extra-operand)) + :fixed-modrm ',(second extra-operand)) + `(define-disassembler (operator ,opcode operator-mode) [333 lines skipped] From ffjeld at common-lisp.net Sat Feb 16 19:14:06 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sat, 16 Feb 2008 14:14:06 -0500 (EST) Subject: [movitz-cvs] CVS movitz Message-ID: <20080216191406.E4BEC16045@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv6409 Modified Files: asm.lisp Log Message: More consistent names for the essential operators in the asm and asm-x86 packages. --- /project/movitz/cvsroot/movitz/asm.lisp 2008/02/09 09:50:46 1.12 +++ /project/movitz/cvsroot/movitz/asm.lisp 2008/02/16 19:14:06 1.13 @@ -6,7 +6,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: asm.lisp,v 1.12 2008/02/09 09:50:46 ffjeld Exp $ +;;;; $Id: asm.lisp,v 1.13 2008/02/16 19:14:06 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -24,7 +24,7 @@ #:unresolved-symbol #:retry-symbol-resolve #:pc-relative-operand - #:proglist-encode + #:assemble-proglist #:*pc* #:*symtab* #:*instruction-compute-extra-prefix-map* @@ -141,12 +141,12 @@ (mapcar #'resolve-operand (funcall-operand-operands operand)))) (t operand))) -;;;;;;;;;;;; +;;;;;;;;;;;; -(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)) +(defun assemble-proglist (proglist &key ((:symtab incoming-symtab) *symtab*) corrections (start-pc 0) (cpu-package '#:asm-x86)) + "Encode a proglist, using instruction-encoder in symbol assemble-instruction from cpu-package." + (let ((encoder (find-symbol (string '#:assemble-instruction) cpu-package)) (*pc* start-pc) (*symtab* (append incoming-symtab corrections)) (*anonymous-sub-program-identities* *anonymous-sub-program-identities*) @@ -222,9 +222,21 @@ (length assumptions) (mapcar #'car assumptions))) ((not (null new-corrections)) - (proglist-encode proglist - :symtab incoming-symtab - :start-pc start-pc - :cpu-package cpu-package - :corrections (nconc new-corrections corrections))) + (assemble-proglist proglist + :symtab incoming-symtab + :start-pc start-pc + :cpu-package cpu-package + :corrections (nconc new-corrections corrections))) (t (values code *symtab*)))))))) + +(defun disassemble-proglist (code &key (cpu-package '#:asm-x86)) + (let ((instruction-disassembler (find-symbol (string '#:disassemble-instruction) + cpu-package))) + (loop while code + collect (multiple-value-bind (instruction new-code) + (funcall instruction-disassembler + code) + (when (eq code new-code) + (loop-finish)) + (setf code new-code) + instruction)))) From ffjeld at common-lisp.net Sat Feb 16 19:14:11 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sat, 16 Feb 2008 14:14:11 -0500 (EST) Subject: [movitz-cvs] CVS movitz Message-ID: <20080216191411.C408B63036@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv6436 Modified Files: asm-x86.lisp Log Message: More consistent names for the essential operators in the asm and asm-x86 packages. --- /project/movitz/cvsroot/movitz/asm-x86.lisp 2008/02/16 18:01:07 1.22 +++ /project/movitz/cvsroot/movitz/asm-x86.lisp 2008/02/16 19:14:08 1.23 @@ -6,13 +6,14 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: asm-x86.lisp,v 1.22 2008/02/16 18:01:07 ffjeld Exp $ +;;;; $Id: asm-x86.lisp,v 1.23 2008/02/16 19:14:08 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ (defpackage asm-x86 (:use :common-lisp :asm) - (:export #:encode-instruction + (:export #:assemble-instruction + #:disassemble-instruction #:*cpu-mode* #:*position-independent-p*)) @@ -167,7 +168,6 @@ :address-size (getone address-size1 address-size2 address-size)))))) - (defun encoded-values (&key prefixes prefix rex opcode mod reg rm scale index base displacement immediate operand-size address-size) (values (append (when prefix (list prefix)) @@ -183,7 +183,8 @@ operand-size address-size)) -(defun encode-instruction (instruction) +(defun assemble-instruction (instruction) + "Assemble a single instruction to a list of octets of x86 machine code, according to *cpu-mode* etc." (multiple-value-bind (instruction legacy-prefixes options) (if (listp (car instruction)) (values (cdr instruction) @@ -216,7 +217,7 @@ (cond ((atom body) nil) - ((member (car body) '(reg-modrm modrm opcode imm-modrm imm)) + ((member (car body) '(reg-modrm modrm opcode imm-modrm imm opcode-reg)) (list body)) (t (mapcan #'find-forms body))))) (let ((defun-name (intern (format nil "~A-~A" 'instruction-encoder operator)))) @@ -330,7 +331,6 @@ 0) (destructuring-bind (operator operand-size decoder-function &rest extra-args) decoder - (warn "extraS: ~S" extra-args) (values (code-call (apply decoder-function code operator @@ -874,6 +874,14 @@ :imm (code-call (decode-integer code imm-type)))) code)) +(defun decode-opcode-reg (code operator opcode operand-size address-size rex operand-ordering extra-operand) + (values (list* operator + (order-operands operand-ordering + :reg (nth (ldb (byte 3 0) opcode) + (register-set-by-mode operand-size)) + :extra extra-operand)) + code)) + (defun decode-reg-modrm-16 (code operand-size) (let* ((modrm (pop-code code mod/rm)) (mod (ldb (byte 2 6) modrm)) @@ -1156,9 +1164,26 @@ '(:rex.w :rex.r)) (t default-rex))))))) -(defmacro opcode-reg (opcode op-reg) - `(return-when - (encode-opcode-reg operator legacy-prefixes ,opcode ,op-reg operator-mode default-rex))) +(defmacro opcode-reg (opcode op-reg &optional extra-operand) + `(progn + (assembler + (when (and ,@(when extra-operand + `((eql , at extra-operand)))) + (return-when + (encode-opcode-reg operator legacy-prefixes ,opcode ,op-reg operator-mode default-rex)))) + (disassembler + (loop for reg from #b000 to #b111 + do ,(if (not extra-operand) + `(define-disassembler (operator (logior ,opcode reg) operator-mode) + decode-opcode-reg + '(:reg) + nil) + `(define-disassembler (operator (logior ,opcode reg) operator-mode) + decode-opcode-reg + (operand-ordering operand-formals + :reg ',op-reg + :extra ',(first extra-operand)) + ',(second extra-operand))))))) (defun encode-opcode-reg-imm (operator legacy-prefixes opcode op-reg op-imm type operator-mode default-rex) (when (immediate-p op-imm) @@ -2089,10 +2114,8 @@ (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)) + (opcode-reg #x90 x (y :ax-eax-rax)) + (opcode-reg #x90 y (x :ax-eax-rax)) (reg-modrm x y #x87) (reg-modrm y x #x87)) From ffjeld at common-lisp.net Sat Feb 16 19:14:21 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sat, 16 Feb 2008 14:14:21 -0500 (EST) Subject: [movitz-cvs] CVS movitz Message-ID: <20080216191421.559FE5F0BC@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv6474 Modified Files: compiler.lisp Log Message: More consistent names for the essential operators in the asm and asm-x86 packages. --- /project/movitz/cvsroot/movitz/compiler.lisp 2008/02/09 18:42:29 1.188 +++ /project/movitz/cvsroot/movitz/compiler.lisp 2008/02/16 19:14:15 1.189 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.188 2008/02/09 18:42:29 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.189 2008/02/16 19:14:15 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -173,8 +173,8 @@ ;; (:nil-value (image-nil-word *image*)))))) (let ((asm:*instruction-compute-extra-prefix-map* '((:call . compute-call-extra-prefix)))) - (asm:proglist-encode (translate-program resolved-code :muerte.cl :cl) - :symtab (list (cons :nil-value (image-nil-word *image*))))) + (asm:assemble-proglist (translate-program resolved-code :muerte.cl :cl) + :symtab (list (cons :nil-value (image-nil-word *image*))))) (values (make-movitz-vector (length code-vector) :element-type 'code :initial-contents code-vector) @@ -1068,13 +1068,13 @@ (multiple-value-bind (code-vector code-symtab) (let ((asm:*instruction-compute-extra-prefix-map* '((:call . compute-call-extra-prefix)))) - (asm:proglist-encode combined-code - :symtab (list* (cons :nil-value (image-nil-word *image*)) - (loop for (label . set) in (movitz-funobj-jumpers-map funobj) - collect (cons label - (* 4 (or (search set (movitz-funobj-const-list funobj) - :end2 (movitz-funobj-num-jumpers funobj)) - (error "Jumper for ~S missing." label)))))))) + (asm:assemble-proglist combined-code + :symtab (list* (cons :nil-value (image-nil-word *image*)) + (loop for (label . set) in (movitz-funobj-jumpers-map funobj) + collect (cons label + (* 4 (or (search set (movitz-funobj-const-list funobj) + :end2 (movitz-funobj-num-jumpers funobj)) + (error "Jumper for ~S missing." label)))))))) (setf (movitz-funobj-symtab funobj) code-symtab) (let* ((code-length (- (length code-vector) 3 -3)) (code-vector (make-array code-length From ffjeld at common-lisp.net Sat Feb 16 21:22:05 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sat, 16 Feb 2008 16:22:05 -0500 (EST) Subject: [movitz-cvs] CVS movitz Message-ID: <20080216212205.7D2CD2511E@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv5163 Modified Files: compiler.lisp Log Message: Remove dead code. --- /project/movitz/cvsroot/movitz/compiler.lisp 2008/02/16 19:14:15 1.189 +++ /project/movitz/cvsroot/movitz/compiler.lisp 2008/02/16 21:22:05 1.190 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.189 2008/02/16 19:14:15 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.190 2008/02/16 21:22:05 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -112,25 +112,6 @@ (or (member (car list) (cdr list)) (duplicatesp (cdr list))))) -(defun old-compute-call-extra-prefix (instr env size) - (let* ((return-pointer-tag (ldb (byte 3 0) - (+ (ia-x86::assemble-env-current-pc env) - size)))) - (cond - ((not (typep instr 'ia-x86-instr::call)) - nil) - ((or (= (tag :even-fixnum) return-pointer-tag) - (= (tag :odd-fixnum) return-pointer-tag)) - ;; Insert a NOP - '(#x90)) -;;; ((= 3 return-pointer-tag) -;;; ;; Insert two NOPs, 3 -> 5 -;;; '(#x90 #x90)) - ((= (tag :character) return-pointer-tag) - ;; Insert three NOPs, 2 -> 5 - '(#x90 #x90 #x90) - '(#x90))))) - (defun compute-call-extra-prefix (pc size) (let* ((return-pointer-tag (ldb (byte 3 0) (+ pc size)))) @@ -162,15 +143,6 @@ (resolved-code (finalize-code body-code nil nil))) (multiple-value-bind (code-vector symtab) -;; (let ((ia-x86:*instruction-compute-extra-prefix-map* -;; '((:call . old-compute-call-extra-prefix)))) -;; (ia-x86:proglist-encode :octet-vector -;; :32-bit -;; #x00000000 -;; (ia-x86:read-proglist resolved-code) -;; :symtab-lookup (lambda (label) -;; (case label -;; (:nil-value (image-nil-word *image*)))))) (let ((asm:*instruction-compute-extra-prefix-map* '((:call . compute-call-extra-prefix)))) (asm:assemble-proglist (translate-program resolved-code :muerte.cl :cl) @@ -1046,25 +1018,6 @@ (defun assemble-funobj (funobj combined-code) -;; (multiple-value-bind (code-vector code-symtab) -;; (let ((ia-x86:*instruction-compute-extra-prefix-map* -;; '((:call . old-compute-call-extra-prefix)))) -;; (ia-x86:proglist-encode :octet-vector :32-bit #x00000000 -;; (ia-x86:read-proglist combined-code) -;; :symtab-lookup -;; (lambda (label) -;; (case label -;; (:nil-value (image-nil-word *image*)) -;; (t (let ((set (cdr (assoc label -;; (movitz-funobj-jumpers-map funobj))))) -;; (when set -;; (let ((pos (search set (movitz-funobj-const-list funobj) -;; :end2 (movitz-funobj-num-jumpers funobj)))) -;; (assert pos () -;; "Couldn't find for ~s set ~S in ~S." -;; label set (subseq (movitz-funobj-const-list funobj) -;; 0 (movitz-funobj-num-jumpers funobj))) -;; (* 4 pos))))))))) (multiple-value-bind (code-vector code-symtab) (let ((asm:*instruction-compute-extra-prefix-map* '((:call . compute-call-extra-prefix)))) From ffjeld at common-lisp.net Sat Feb 16 21:43:59 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sat, 16 Feb 2008 16:43:59 -0500 (EST) Subject: [movitz-cvs] CVS movitz Message-ID: <20080216214359.04D952511F@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv8904 Modified Files: asm-x86.lisp Log Message: Disassembler for pc-rel operands. --- /project/movitz/cvsroot/movitz/asm-x86.lisp 2008/02/16 19:14:08 1.23 +++ /project/movitz/cvsroot/movitz/asm-x86.lisp 2008/02/16 21:43:59 1.24 @@ -6,7 +6,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: asm-x86.lisp,v 1.23 2008/02/16 19:14:08 ffjeld Exp $ +;;;; $Id: asm-x86.lisp,v 1.24 2008/02/16 21:43:59 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -217,7 +217,7 @@ (cond ((atom body) nil) - ((member (car body) '(reg-modrm modrm opcode imm-modrm imm opcode-reg)) + ((member (car body) '(reg-modrm modrm opcode imm-modrm imm opcode-reg pc-rel)) (list body)) (t (mapcan #'find-forms body))))) (let ((defun-name (intern (format nil "~A-~A" 'instruction-encoder operator)))) @@ -490,6 +490,7 @@ (reduce #'+ (cdr operand) :key #'resolve-operand)) (symbol-reference + (assert *pc* (*pc*) "Cannot encode a pc-relative operand without a value for ~S." '*pc*) (- (resolve-operand operand) *pc*)))) @@ -874,6 +875,11 @@ :imm (code-call (decode-integer code imm-type)))) code)) +(defun decode-pc-rel (code operator opcode operand-size address-size rex type) + (values (list operator + `(:pc+ ,(code-call (decode-integer code type)))) + code)) + (defun decode-opcode-reg (code operator opcode operand-size address-size rex operand-ordering extra-operand) (values (list* operator (order-operands operand-ordering @@ -1010,14 +1016,14 @@ (defun encode-pc-rel (operator legacy-prefixes 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-no-extras (+ (length legacy-prefixes) (type-octet-size type) (opcode-octet-size opcode))) (estimated-extra-prefixes (compute-extra-prefixes operator *pc* estimated-code-size-no-extras)) (estimated-code-size (+ estimated-code-size-no-extras (length estimated-extra-prefixes))) - (offset (let ((*pc* (+ *pc* estimated-code-size))) + (offset (let ((*pc* (when *pc* + (+ *pc* estimated-code-size)))) (resolve-pc-relative operand)))) (when (typep offset type) (let ((code (let ((*instruction-compute-extra-prefix-map* nil)) @@ -1030,7 +1036,8 @@ (append estimated-extra-prefixes code) (let* ((code-size (length code)) (extra-prefixes (compute-extra-prefixes operator *pc* code-size)) - (offset (let ((*pc* (+ *pc* code-size (length extra-prefixes)))) + (offset (let ((*pc* (when *pc* + (+ *pc* code-size (length extra-prefixes))))) (resolve-pc-relative operand)))) (when (typep offset type) (let ((code (let ((*instruction-compute-extra-prefix-map* nil)) @@ -1042,7 +1049,13 @@ (append extra-prefixes code)))))))))) (defmacro pc-rel (opcode operand type &rest extras) - `(return-when (encode-pc-rel operator legacy-prefixes ,opcode ,operand ',type , at extras))) + `(progn + (assembler + (return-when (encode-pc-rel operator legacy-prefixes ,opcode ,operand ',type , at extras))) + (disassembler + (define-disassembler (operator ,opcode operator-mode) + decode-pc-rel + ',type)))) (defmacro modrm (operand opcode digit) `(progn From ffjeld at common-lisp.net Sat Feb 16 21:58:57 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sat, 16 Feb 2008 16:58:57 -0500 (EST) Subject: [movitz-cvs] CVS movitz Message-ID: <20080216215857.1C7851F012@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv10437 Modified Files: asm-x86.lisp Log Message: Improved disassembly for opcode operands (i.e. push/pop segment registers). --- /project/movitz/cvsroot/movitz/asm-x86.lisp 2008/02/16 21:43:59 1.24 +++ /project/movitz/cvsroot/movitz/asm-x86.lisp 2008/02/16 21:58:57 1.25 @@ -6,7 +6,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: asm-x86.lisp,v 1.24 2008/02/16 21:43:59 ffjeld Exp $ +;;;; $Id: asm-x86.lisp,v 1.25 2008/02/16 21:58:57 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -399,37 +399,25 @@ `(define-operator ,operator :8-bit ,lambda-list (let ((default-rex nil)) (declare (ignorable default-rex)) - (macrolet ((yield (&rest args) - `(return-from operator - (encode (encoded-values :operand-size operator-mode , at args))))) - , at body)))) + , at body))) (defmacro define-operator/16 (operator lambda-list &body body) `(define-operator ,operator :16-bit ,lambda-list (let ((default-rex nil)) (declare (ignorable default-rex)) - (macrolet ((yield (&rest args) - `(return-from operator - (encode (encoded-values :operand-size operator-mode , at args))))) - , at body)))) + , at body))) (defmacro define-operator/32 (operator lambda-list &body body) `(define-operator ,operator :32-bit ,lambda-list (let ((default-rex nil)) (declare (ignorable default-rex)) - (macrolet ((yield (&rest args) - `(return-from operator - (encode (encoded-values :operand-size operator-mode , at args))))) - , at body)))) + , at body))) (defmacro define-operator/64 (operator lambda-list &body body) `(define-operator ,operator :64-bit ,lambda-list (let ((default-rex '(:rex.w))) (declare (ignorable default-rex)) - (macrolet ((yield (&rest args) - `(return-from operator - (encode (encoded-values :operand-size operator-mode , at args))))) - , at body)))) + , at body))) (defmacro define-operator/64* (operator lambda-list &body body) `(define-operator ,operator :64-bit ,lambda-list @@ -834,9 +822,10 @@ (1+ (lognot unsigned-integer))))) code))) -(defun decode-no-operands (code operator opcode operand-size address-size rex) +(defun decode-no-operands (code operator opcode operand-size address-size rex &rest fixed-operands) (declare (ignore opcode operand-size address-size rex)) - (values (list operator) + (values (list* operator + (remove nil fixed-operands)) code)) (defun decode-reg-modrm (code operator opcode operand-size address-size rex operand-ordering) @@ -1144,15 +1133,19 @@ :key #'resolve-operand) ',type))))))) -(defmacro opcode (opcode &rest extras) +(defmacro opcode (opcode &optional fixed-operand &rest extras) `(progn (assembler - (return-values-when - (encoded-values :opcode ,opcode - , at extras - :operand-size operator-mode))) + (when (and ,@(when fixed-operand + `((eql , at fixed-operand)))) + (return-values-when + (encoded-values :opcode ,opcode + , at extras + :operand-size operator-mode)))) (disassembler - (define-disassembler (operator ,opcode) decode-no-operands)))) + (define-disassembler (operator ,opcode) + decode-no-operands + ,(second fixed-operand))))) (defmacro opcode* (opcode &rest extras) `(return-values-when @@ -1635,7 +1628,7 @@ ;;;;;;;;;;; IRET (define-operator* (:16 :iret :32 :iretd :64 :iretq) () - (opcode #xcf :rex default-rex)) + (opcode #xcf () :rex default-rex)) ;;;;;;;;;;; Jcc @@ -1918,12 +1911,11 @@ ;;;;;;;;;;; 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 #x1f (dst :ds)) + (opcode #x07 (dst :es)) + (opcode #x17 (dst :ss)) + (opcode #x0fa1 (dst :fs)) + (opcode #x0fa9 (dst :gs)) (opcode-reg #x58 dst) (modrm dst #x8f 0)) @@ -1953,13 +1945,12 @@ ;;;;;;;;;;; PUSH (define-operator* (:16 :pushw :32 :pushl) (src) - (case src - (:cs (yield :opcode #x0e)) - (:ss (yield :opcode #x16)) - (:ds (yield :opcode #x1e)) - (:es (yield :opcode #x06)) - (:fs (yield :opcode #x0fa0)) - (:gs (yield :opcode #x0fa8))) + (opcode #x0e (src :cs)) + (opcode #x16 (src :ss)) + (opcode #x1e (src :ds)) + (opcode #x06 (src :es)) + (opcode #x0fa0 (src :fs)) + (opcode #x0fa8 (src :gs)) (opcode-reg #x50 src) (imm src #x6a (sint 8)) (imm src #x68 :int-16-32-64 () :operand-size operator-mode) From ffjeld at common-lisp.net Sat Feb 16 22:13:25 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sat, 16 Feb 2008 17:13:25 -0500 (EST) Subject: [movitz-cvs] CVS movitz Message-ID: <20080216221325.740D015037@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv14860 Modified Files: asm-x86.lisp Log Message: Fix up used/unused variables. --- /project/movitz/cvsroot/movitz/asm-x86.lisp 2008/02/16 21:58:57 1.25 +++ /project/movitz/cvsroot/movitz/asm-x86.lisp 2008/02/16 22:13:25 1.26 @@ -6,7 +6,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: asm-x86.lisp,v 1.25 2008/02/16 21:58:57 ffjeld Exp $ +;;;; $Id: asm-x86.lisp,v 1.26 2008/02/16 22:13:25 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -243,7 +243,7 @@ (let ((operator ',operator) (operator-mode ',operator-mode) (operand-formals ',lambda-list)) - (declare (ignorable operand-formals)) + (declare (ignorable operator operand-formals operator-mode)) ,@(find-forms body))) ',operator)))) @@ -384,7 +384,7 @@ (disassemble-instruction code :16-bit address-size nil)) (define-disassembler (:address-size-override #x67 :32-bit) (code operator opcode operand-size address-size rex) - (declare (ignore operator opcode operand-size rex)) + (declare (ignore operator opcode address-size rex)) (disassemble-instruction code operand-size :16-bit nil)) (define-disassembler (:operand-size-override #x66 :16-bit) (code operator opcode operand-size address-size rex) @@ -392,7 +392,7 @@ (disassemble-instruction code :32-bit address-size nil)) (define-disassembler (:address-size-override #x67 :16-bit) (code operator opcode operand-size address-size rex) - (declare (ignore operator opcode operand-size rex)) + (declare (ignore operator opcode address-size rex)) (disassemble-instruction code operand-size :32-bit nil)) (defmacro define-operator/8 (operator lambda-list &body body) @@ -808,6 +808,7 @@ (defmacro code-call (form &optional (code-place (case (car form) ((funcall apply) (third form)) (t (second form))))) "Execute form, then 'magically' update the code binding with the secondary return value from form." `(let (tmp) + (declare (ignorable tmp)) (setf (values tmp ,code-place) ,form))) (defun decode-integer (code type) @@ -843,6 +844,7 @@ (defun decode-modrm (code operator opcode operand-size address-size rex) + (declare (ignore opcode rex)) (values (list operator (ecase address-size (:32-bit @@ -852,6 +854,7 @@ code)) (defun decode-imm-modrm (code operator opcode operand-size address-size rex imm-type operand-ordering &key fixed-modrm) + (declare (ignore opcode rex)) (values (list* operator (order-operands operand-ordering :modrm (or fixed-modrm @@ -865,11 +868,13 @@ code)) (defun decode-pc-rel (code operator opcode operand-size address-size rex type) + (declare (ignore opcode operand-size address-size rex)) (values (list operator `(:pc+ ,(code-call (decode-integer code type)))) code)) (defun decode-opcode-reg (code operator opcode operand-size address-size rex operand-ordering extra-operand) + (declare (ignore address-size rex)) (values (list* operator (order-operands operand-ordering :reg (nth (ldb (byte 3 0) opcode) @@ -903,7 +908,6 @@ "Return a list of the REG, and the MOD/RM operands." (let* ((modrm (pop-code code mod/rm)) (mod (ldb (byte 2 6) modrm)) - (reg (ldb (byte 3 3) modrm)) (r/m (ldb (byte 3 0) modrm))) (values (if (= mod #b11) (nth r/m (register-set-by-mode operand-size)) From ffjeld at common-lisp.net Sat Feb 16 23:15:08 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sat, 16 Feb 2008 18:15:08 -0500 (EST) Subject: [movitz-cvs] CVS movitz Message-ID: <20080216231508.6069D310CC@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv28273 Modified Files: asm-x86.lisp Log Message: Fix typo in testb declaration. --- /project/movitz/cvsroot/movitz/asm-x86.lisp 2008/02/16 22:13:25 1.26 +++ /project/movitz/cvsroot/movitz/asm-x86.lisp 2008/02/16 23:15:04 1.27 @@ -6,7 +6,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: asm-x86.lisp,v 1.26 2008/02/16 22:13:25 ffjeld Exp $ +;;;; $Id: asm-x86.lisp,v 1.27 2008/02/16 23:15:04 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -2098,7 +2098,7 @@ ;;;;;;;;;;; TEST (define-operator/8 :testb (mask dst) - (imm mask #xa8 (xint 8) (mask :al)) + (imm mask #xa8 (xint 8) (dst :al)) (imm-modrm mask dst #xf6 0 (xint 8)) (reg-modrm mask dst #x84)) From ffjeld at common-lisp.net Sat Feb 16 23:35:25 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sat, 16 Feb 2008 18:35:25 -0500 (EST) Subject: [movitz-cvs] CVS movitz Message-ID: <20080216233525.1E10115030@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv32621 Modified Files: compiler.lisp Log Message: Small speedup of peeping optimizer. --- /project/movitz/cvsroot/movitz/compiler.lisp 2008/02/16 21:22:05 1.190 +++ /project/movitz/cvsroot/movitz/compiler.lisp 2008/02/16 23:35:22 1.191 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.190 2008/02/16 21:22:05 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.191 2008/02/16 23:35:22 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1553,8 +1553,10 @@ "If i is a branch, return the label." (when jmp (push :jmp branch-types)) (let ((i (ignore-instruction-prefixes i))) - (or (and (listp i) (member (car i) branch-types) - (listp (second i)) (member (car (second i)) '(quote muerte.cl::quote)) + (or (and (listp i) + (listp (second i)) + (member (car (second i)) '(quote muerte.cl::quote)) + (member (car i) branch-types) (second (second i))) #+ignore (and (listp i) From ffjeld at common-lisp.net Sun Feb 17 00:10:11 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sat, 16 Feb 2008 19:10:11 -0500 (EST) Subject: [movitz-cvs] CVS movitz Message-ID: <20080217001011.D2F0E16041@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv7215 Modified Files: compiler.lisp Log Message: Improved tree-search, for speed. --- /project/movitz/cvsroot/movitz/compiler.lisp 2008/02/16 23:35:22 1.191 +++ /project/movitz/cvsroot/movitz/compiler.lisp 2008/02/17 00:10:11 1.192 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.191 2008/02/16 23:35:22 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.192 2008/02/17 00:10:11 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -3256,12 +3256,24 @@ (binding-eql x (forwarding-binding-target y))))) (defun tree-search (tree items) - (etypecase tree - (atom (if (atom items) - (eql tree items) - (member tree items))) - (cons (or (tree-search (car tree) items) - (tree-search (cdr tree) items))))) + (if (and (atom items) ; make common case fast(er), hopefully. + (not (numberp items))) + (labels ((tree-search* (tree item) + (etypecase tree + (null nil) + (cons + (or (tree-search* (car tree) item) + (tree-search* (cdr tree) item))) + (t (eq tree item))))) + (tree-search* tree items)) + (etypecase tree + (atom + (if (atom items) + (eql tree items) + (member tree items))) + (cons + (or (tree-search (car tree) items) + (tree-search (cdr tree) items)))))) (defun operator (x) (if (atom x) x (car x))) From ffjeld at common-lisp.net Mon Feb 18 20:57:14 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Mon, 18 Feb 2008 15:57:14 -0500 (EST) Subject: [movitz-cvs] CVS movitz Message-ID: <20080218205714.63B4E2E21B@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv13327 Modified Files: asm-x86.lisp Log Message: Disassemble moffset operands. --- /project/movitz/cvsroot/movitz/asm-x86.lisp 2008/02/16 23:15:04 1.27 +++ /project/movitz/cvsroot/movitz/asm-x86.lisp 2008/02/18 20:57:14 1.28 @@ -6,7 +6,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: asm-x86.lisp,v 1.27 2008/02/16 23:15:04 ffjeld Exp $ +;;;; $Id: asm-x86.lisp,v 1.28 2008/02/18 20:57:14 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -217,7 +217,7 @@ (cond ((atom body) nil) - ((member (car body) '(reg-modrm modrm opcode imm-modrm imm opcode-reg pc-rel)) + ((member (car body) '(reg-modrm modrm opcode imm-modrm imm opcode-reg pc-rel moffset)) (list body)) (t (mapcan #'find-forms body))))) (let ((defun-name (intern (format nil "~A-~A" 'instruction-encoder operator)))) @@ -310,36 +310,7 @@ (set-it *opcode-disassemblers-32* opcode) (set-it *opcode-disassemblers-64* opcode))))) -(defun disassemble-instruction (code &optional override-operand-size override-address-size rex) - (labels ((lookup-decoder (table opcode) - (let* ((datum (pop-code code)) - (opcode (logior (ash opcode 8) - datum)) - (decoder (svref table datum))) - (typecase decoder - ((simple-vector 256) - (lookup-decoder decoder opcode)) - (disassembly-decoder - (values decoder - opcode)) - (t (error "No disassembler registered for opcode #x~X." opcode)))))) - (multiple-value-bind (decoder opcode) - (lookup-decoder (ecase (or override-operand-size *cpu-mode*) - (:16-bit *opcode-disassemblers-16*) - (:32-bit *opcode-disassemblers-32*) - (:64-bit *opcode-disassemblers-64*)) - 0) - (destructuring-bind (operator operand-size decoder-function &rest extra-args) - decoder - (values (code-call (apply decoder-function - code - operator - opcode - (or operand-size override-operand-size) - (or override-address-size *cpu-mode*) - rex - extra-args)) - code))))) + (defmacro define-disassembler ((operator opcode &optional cpu-mode (digit nil digit-p)) lambda-list &body body) (cond @@ -823,6 +794,37 @@ (1+ (lognot unsigned-integer))))) code))) +(defun disassemble-instruction (code &optional override-operand-size override-address-size rex) + (labels ((lookup-decoder (table opcode) + (let* ((datum (pop-code code)) + (opcode (logior (ash opcode 8) + datum)) + (decoder (svref table datum))) + (typecase decoder + ((simple-vector 256) + (lookup-decoder decoder opcode)) + (disassembly-decoder + (values decoder + opcode)) + (t (error "No disassembler registered for opcode #x~X." opcode)))))) + (multiple-value-bind (decoder opcode) + (lookup-decoder (ecase (or override-operand-size *cpu-mode*) + (:16-bit *opcode-disassemblers-16*) + (:32-bit *opcode-disassemblers-32*) + (:64-bit *opcode-disassemblers-64*)) + 0) + (destructuring-bind (operator operand-size decoder-function &rest extra-args) + decoder + (values (code-call (apply decoder-function + code + operator + opcode + (or operand-size override-operand-size) + (or override-address-size *cpu-mode*) + rex + extra-args)) + code))))) + (defun decode-no-operands (code operator opcode operand-size address-size rex &rest fixed-operands) (declare (ignore opcode operand-size address-size rex)) (values (list* operator @@ -873,6 +875,14 @@ `(:pc+ ,(code-call (decode-integer code type)))) code)) +(defun decode-moffset (code operator opcode operand-size address-size rex type operand-ordering fixed-operand) + (declare (ignore opcode operand-size address-size rex)) + (values (list* operator + (order-operands operand-ordering + :moffset (list (code-call (decode-integer code type))) + :fixed fixed-operand)) + code)) + (defun decode-opcode-reg (code operator opcode operand-size address-size rex operand-ordering extra-operand) (declare (ignore address-size rex)) (values (list* operator @@ -1125,17 +1135,31 @@ :rex default-rex) (encode-reg/mem ,op-modrm operator-mode)))))) -(defmacro moffset (opcode op-offset type) - `(when (indirect-operand-p ,op-offset) - (multiple-value-bind (reg offsets reg2) - (parse-indirect-operand ,op-offset) - (when (and (not reg) - (not reg2)) - (return-values-when - (encoded-values :opcode ,opcode - :displacement (encode-integer (reduce #'+ offsets - :key #'resolve-operand) - ',type))))))) +(defmacro moffset (opcode op-offset type fixed-operand) + `(progn + (assembler + (when (and ,@(when fixed-operand + `((eql , at fixed-operand))) + (indirect-operand-p ,op-offset)) + (multiple-value-bind (reg offsets reg2) + (parse-indirect-operand ,op-offset) + (when (and (not reg) + (not reg2)) + (return-values-when + (encoded-values :opcode ,opcode + :displacement (encode-integer (reduce #'+ offsets + :key #'resolve-operand) + ',type))))))) + (disassembler + (define-disassembler (operator ,opcode operator-mode) + decode-moffset + ',type + (operand-ordering operand-formals + :moffset ',op-offset + :fixed ',(first fixed-operand)) + ',(second fixed-operand))))) + + (defmacro opcode (opcode &optional fixed-operand &rest extras) `(progn @@ -1771,20 +1795,16 @@ ;;;;;;;;;;; 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))) + (moffset #xa2 dst (uint 8) (src :al)) + (moffset #xa0 src (uint 8) (dst :al)) (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))) + (moffset #xa3 dst (uint 16) (src :ax)) + (moffset #xa0 src (uint 16) (dst :ax)) (opcode-reg-imm #xb8 dst src (xint 16)) (imm-modrm src dst #xc7 0 (xint 16)) (sreg-modrm src dst #x8c) @@ -1793,10 +1813,8 @@ (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))) + (moffset #xa3 dst (uint 32) (src :eax)) + (moffset #xa0 src (uint 32) (dst :eax)) (opcode-reg-imm #xb8 dst src (xint 32)) (imm-modrm src dst #xc7 0 (xint 32)) (reg-modrm dst src #x8b) From ffjeld at common-lisp.net Mon Feb 18 22:30:21 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Mon, 18 Feb 2008 17:30:21 -0500 (EST) Subject: [movitz-cvs] CVS movitz Message-ID: <20080218223021.75B2F5C1F8@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv31162 Modified Files: bootblock.lisp Log Message: New function-names in asm. --- /project/movitz/cvsroot/movitz/bootblock.lisp 2008/02/09 18:42:26 1.14 +++ /project/movitz/cvsroot/movitz/bootblock.lisp 2008/02/18 22:30:21 1.15 @@ -9,7 +9,7 @@ ;;;; Created at: Mon Oct 9 20:47:19 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: bootblock.lisp,v 1.14 2008/02/09 18:42:26 ffjeld Exp $ +;;;; $Id: bootblock.lisp,v 1.15 2008/02/18 22:30:21 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -402,13 +402,13 @@ (multiple-value-bind (bios-loader bb-symtab) (let ((asm-x86:*position-independent-p* nil) (asm-x86:*cpu-mode* :16-bit)) - (asm:proglist-encode (mkasm16-bios-bootloader image-size load-address skip-sectors) - :start-pc #x7c00)) + (asm:assemble-proglist (mkasm16-bios-bootloader image-size load-address skip-sectors) + :start-pc #x7c00)) (multiple-value-bind (protected-loader protected-symtab) (let ((asm-x86:*position-independent-p* nil)) - (asm:proglist-encode (mkasm-loader image-size load-address call-address) - :start-pc (cdr (or (assoc 'new-world bb-symtab) - (error "No new-world defined in bios-loader."))))) + (asm:assemble-proglist (mkasm-loader image-size load-address call-address) + :start-pc (cdr (or (assoc 'new-world bb-symtab) + (error "No new-world defined in bios-loader."))))) (let* ((loader-length (+ (length bios-loader) (length protected-loader))) (bootblock (progn From ffjeld at common-lisp.net Mon Feb 18 22:30:45 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Mon, 18 Feb 2008 17:30:45 -0500 (EST) Subject: [movitz-cvs] CVS movitz Message-ID: <20080218223045.24DED555A5@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv31315 Modified Files: asm.lisp Log Message: Improve disassemble-proglist etc. --- /project/movitz/cvsroot/movitz/asm.lisp 2008/02/16 19:14:06 1.13 +++ /project/movitz/cvsroot/movitz/asm.lisp 2008/02/18 22:30:45 1.14 @@ -6,7 +6,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: asm.lisp,v 1.13 2008/02/16 19:14:06 ffjeld Exp $ +;;;; $Id: asm.lisp,v 1.14 2008/02/18 22:30:45 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -25,6 +25,7 @@ #:retry-symbol-resolve #:pc-relative-operand #:assemble-proglist + #:disassemble-proglist #:*pc* #:*symtab* #:*instruction-compute-extra-prefix-map* @@ -117,6 +118,10 @@ (defun pc-relative-operand-p (operand) (typep operand 'pc-relative-operand)) +(defun pc-relative-operand-offset (operand) + (check-type operand pc-relative-operand) + (second operand)) + (define-condition unresolved-symbol () ((symbol :initarg :symbol @@ -229,14 +234,40 @@ :corrections (nconc new-corrections corrections))) (t (values code *symtab*)))))))) -(defun disassemble-proglist (code &key (cpu-package '#:asm-x86)) - (let ((instruction-disassembler (find-symbol (string '#:disassemble-instruction) - cpu-package))) - (loop while code - collect (multiple-value-bind (instruction new-code) - (funcall instruction-disassembler - code) - (when (eq code new-code) - (loop-finish)) - (setf code new-code) - instruction)))) +(defun instruction-operands (instruction) + (if (listp (car instruction)) ; skip any instruction prefixes etc. + (cddr instruction) + (cdr instruction))) + + +(defun disassemble-proglist (code &key (cpu-package '#:asm-x86) (pc (or *pc* 0)) (symtab *symtab*)) + (let* ((instruction-disassembler (find-symbol (string '#:disassemble-instruction) + cpu-package)) + (proglist0 (loop while code + collect pc + collect (multiple-value-bind (instruction new-code) + (funcall instruction-disassembler + code) + (when (eq code new-code) + (loop-finish)) + (loop until (eq code new-code) + do (incf pc) + (setf code (cdr code))) + (let ((operands (instruction-operands instruction))) + (if (notany #'pc-relative-operand-p operands) + instruction + (nconc (loop until (eq instruction operands) + collect (pop instruction)) + (loop for operand in operands + collect (if (not (pc-relative-operand-p operand)) + operand + (let* ((location (+ pc (pc-relative-operand-offset operand))) + (entry (or (rassoc location symtab) + (car (push (cons (gensym) location) + symtab))))) + `(quote ,(car entry)))))))))))) + (values (loop for (pc instruction) on proglist0 by #'cddr + when (car (rassoc pc symtab)) + collect it + collect instruction) + symtab))) From ffjeld at common-lisp.net Mon Feb 18 22:30:50 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Mon, 18 Feb 2008 17:30:50 -0500 (EST) Subject: [movitz-cvs] CVS movitz Message-ID: <20080218223050.9C1B03002C@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv31346 Modified Files: asm-x86.lisp Log Message: Improve disassemble-proglist etc. --- /project/movitz/cvsroot/movitz/asm-x86.lisp 2008/02/18 20:57:14 1.28 +++ /project/movitz/cvsroot/movitz/asm-x86.lisp 2008/02/18 22:30:47 1.29 @@ -6,7 +6,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: asm-x86.lisp,v 1.28 2008/02/18 20:57:14 ffjeld Exp $ +;;;; $Id: asm-x86.lisp,v 1.29 2008/02/18 22:30:47 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -445,7 +445,7 @@ (defun resolve-pc-relative (operand) (etypecase operand - ((cons (eql :pc+)) + (pc-relative-operand (reduce #'+ (cdr operand) :key #'resolve-operand)) (symbol-reference @@ -772,9 +772,12 @@ (error "No operand ~S in ~S." key operands)))) (defmacro pop-code (code-place &optional context) - `(let ((x (pop ,code-place))) + `(progn + (unless ,code-place + (error "End of byte-stream in the middle of an instruction.")) + (let ((x (pop ,code-place))) (check-type x (unsigned-byte 8) ,(format nil "an octet (context: ~A)" context)) - x)) + x))) (defmacro code-call (form &optional (code-place (case (car form) ((funcall apply) (third form)) (t (second form))))) "Execute form, then 'magically' update the code binding with the secondary return value from form." From ffjeld at common-lisp.net Mon Feb 18 22:31:13 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Mon, 18 Feb 2008 17:31:13 -0500 (EST) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080218223113.C478E1B021@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv31532 Modified Files: interrupt.lisp Log Message: Prefer the new assembler. --- /project/movitz/cvsroot/movitz/losp/muerte/interrupt.lisp 2007/04/07 20:49:17 1.56 +++ /project/movitz/cvsroot/movitz/losp/muerte/interrupt.lisp 2008/02/18 22:31:13 1.57 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Apr 7 01:50:03 2004 ;;;; -;;;; $Id: interrupt.lisp,v 1.56 2007/04/07 20:49:17 ffjeld Exp $ +;;;; $Id: interrupt.lisp,v 1.57 2008/02/18 22:31:13 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -133,7 +133,7 @@ ;; Do RET promotion of EIP. (:movl (:ebp ,(dit-frame-offset :eip)) :ecx) - ((:cs-override) :cmpb ,(realpart (ia-x86:asm :ret)) (:ecx)) + ((:cs-override) :cmpb ,@(asm-x86:assemble-instruction '(:ret)) (:ecx)) (:jne 'not-at-ret-instruction) (:globally (:movl (:edi (:edi-offset ret-trampoline)) :ecx)) (:movl :ecx (:ebp ,(dit-frame-offset :eip))) From ffjeld at common-lisp.net Sat Feb 23 22:28:55 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sat, 23 Feb 2008 17:28:55 -0500 (EST) Subject: [movitz-cvs] CVS movitz/losp Message-ID: <20080223222855.EF91515011@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp In directory clnet:/tmp/cvs-serv5997 Modified Files: scratch.lisp Log Message: Remove DOS EOL. --- /project/movitz/cvsroot/movitz/losp/scratch.lisp 2008/02/04 21:04:51 1.2 +++ /project/movitz/cvsroot/movitz/losp/scratch.lisp 2008/02/23 22:28:55 1.3 @@ -1,1164 +1,1164 @@ -;;;;------------------ -*- movitz-mode: t -*-------------------------- -;;;; -;;;; Copyright (C) 2007, Frode Vatvedt Fjeld -;;;; -;;;; Filename: scratch.lisp -;;;; Description: Misc. testing code etc. -;;;; Author: Frode Vatvedt Fjeld -;;;; Distribution: See the accompanying file COPYING. -;;;; -;;;; $Id: scratch.lisp,v 1.2 2008/02/04 21:04:51 ffjeld Exp $ -;;;; -;;;;------------------------------------------------------------------ - -(provide :scratch) - -(in-package los0) - -#+ignore -(defun set.2 () - (let ((*var-used-in-set-tests* 'a) - (var '*var-used-in-set-tests*)) - (declare (special *var-used-in-set-tests*)) - (values - (let ((*var-used-in-set-tests* 'c)) - (list (set var 'b) *var-used-in-set-tests* (symbol-value var))) - *var-used-in-set-tests*))) -;; (b c b) -;; b) - -#+ignore -(defun test-lend-constant () - (let ((symbols '(a b c d e f g h i j k l m n o p q r s t u v w x y z)) - (table (make-hash-table :test #'eq))) - (loop for sym in symbols - for i from 1 - do (setf (gethash sym table) i)) - (let ((sum 0)) - (values (maphash #'(lambda (k v) - (assert (eq (elt symbols (1- v)) k)) - (incf sum v)) - table) - sum)))) - -#+ignore -(defun test-aux (x y &aux (sum (+ x y))) - sum) - -#+ignore -(defun mapc.error.3 () - (mapc #'append)) - -#+ignore -(defun with-hash-table-iterator.12 () - (block done - (let ((x :bad)) - (declare (special x)) - (let ((x :good)) - (with-hash-table-iterator (m (return-from done x)) - (declare (special x)))))) - :good) - -#+ignore -(defun string.15 () - (when (> char-code-limit 65536) - (loop for i = (random char-code-limit) - for c = (code-char i) - for s = (and c (string c)) - repeat 2000 - when (and c - (or (not (stringp s)) - (not (= (length s) 1)) - (not (eql c (char s 0))))) - collect (list i c s))) - nil) - -(defun x (bios32) - (warn "X: ~S" (memref-int bios32)) - (warn "X: ~S" (= (memref-int bios32) #x5f32335f))) - -(defun setfint (x o) - (setf (memref x o :type :unsigned-byte32) 0)) - -(defun fint (x) - (memref-int x :type :unsigned-byte32 :physicalp t)) - -(defun good () - (with-inline-assembly (:returns :untagged-fixnum-ecx) - ((:gs-override) :movl (#x1000000) :ecx))) - -(defun (setf good) (x) - (with-inline-assembly (:returns :untagged-fixnum-ecx) - (:compile-form (:result-mode :untagged-fixnum-ecx) x) - ((:gs-override) :movl :ecx (#x1000000)))) - -(defun test2 () - (funcall - (compile - nil - '(lambda (a) (declare (notinline > *)) - (declare (optimize (compilation-speed 0) (safety 2) (speed 2) (debug 0) (space 3))) - (catch 'ct1 (* a (throw 'ct1 (if (> 0) a 0)))))) - 5445205692802)) - -(defun test3 () - (loop for x below 2 count (not (not (typep x t))))) - -(defun test4 () - (let ((aa 1)) (if (not (/= aa 0)) aa 0))) - - -(defun test-floppy () - (muerte.x86-pc::fd-start-disk) ; to initialize the controller and spin the drive up. - (muerte.x86-pc::fd-cmd-seek 70) ; to seek to track 70. - (setf (muerte.x86-pc::fd-motor) nil)) ; to turn the drive and controller off. - - -(defun alist-get-expand (alist key) - (let (cons) - (tagbody - loop - (setq cons (car alist)) - (cond ((eq alist nil) (go end)) - ((eq cons nil)) - ((eq key (car cons)) (go end))) - (setq alist (cdr alist)) - (go loop) - end) - (cdr cons))) - -;;;(defun test-irq () -;;; (with-inline-assembly (:returns :multiple-values) -;;; (:compile-form (:result-mode :multiple-values) (values 0 1 2 3 4 5)) -;;; (:int 42))) -;;; -;;;(defun koo () -;;; (prog1 (make-values) -;;; (format t "hello: ~S" (values 'a 'b 'c 'd)))) -;;; -;;;(defun test-complement (&rest args) -;;; (declare (dynamic-extent args)) -;;; (apply (complement #'symbolp) args)) -;;; -;;;(defun test-constantly (&rest args) -;;; (declare (dynamic-extent args)) -;;; (apply (constantly 'test-value) args)) - -(defun test-closure (x z) - (flet ((closure (y) (= x (1+ y)))) - (declare (dynamic-extent (function closure))) - (closure z) - #+ignore (funcall (lambda (y) (= x (1+ y))) - z))) - -(defun test-stack-cons (x y) - (muerte::with-dynamic-extent-scope (zap) - (let ((foo (muerte::with-dynamic-extent-allocation (zap) - (cons x (lambda () y))))) - (format t "~Z: ~S, ~S" foo foo (funcall (cdr foo)))))) - -(defun test-handler (x) - (let ((foo x)) - (handler-bind - ((error (lambda (c) - (format t "error: ~S ~S" c x)))) - (error "This is an error. ~S" foo)))) - - -(defun fooo (v w) - (tagbody - (print (block blurgh - (progv (list v) (list w) - (format t "Uh: ~S" (symbol-value v)) - (if (symbol-value v) - (return-from blurgh 1) - (go zap))))) - zap) - t) - - -(defun test-break () - (with-inline-assembly (:returns :multiple-values) - (:movl 10 :ecx) - (:movl :esi :eax) ; This function should return itself! - (:clc) - (:break))) - -(defun test-upload (x) - ;; (warn "Test-upload blab la bla!!") - (setf x (cdr x)) - x) - -;;;(defun zzz (x) -;;; (multiple-value-bind (symbol status) -;;; (values-list x) -;;; (warn "sym: ~S, stat: ~S" symbol status))) -;;; - -#+ignore -(defun test-loop (x) - (format t "test-loop: ~S~%" - (loop for i from 0 to 10 collect x))) - -#+ignore -(defun delay (time) - (dotimes (i time) - (with-inline-assembly (:returns :nothing) - (:nop) - (:nop)))) -;;; -;;;(defun test-consp (x) -;;; (with-inline-assembly (:returns :boolean-cf=1) -;;; (:compile-form (:result-mode :ecx) x) -;;; (:leal (:edi -4) :eax) -;;; (:rorb :cl :al))) - - -#+ignore -(defun test-block (x) - (block nil - (let ((*print-base* (if x (return 3) 8))) - (jumbo 2 2 (and x 2) (+ 3 3 (or x 4)) (if x 2 (return nil))))) - #+ignore (+ x 2)) - -#+ignore -(defun jumbo (a b c &rest x) - (declare (dynamic-extent x)) - (print a) (print b) (print c) - (print x) - 'jumbo) - -(defun jumbo2 (a b &rest x) - (declare (dynamic-extent x)) - (print a) (print b) - (print x) - 'jumbo) - -(defun jumbo3 (a &rest x) - (declare (dynamic-extent x)) - (print a) - (print x) - 'jumbo) - -(defun jumbo4 (&rest x) - (declare (dynamic-extent x)) - (print x) - 'jumbo) - -#+ignore -(defun tagbodyxx (x) - (tagbody - (print 'hello) - haha - (unwind-protect - (when x (go hoho)) - (warn "unwind..")) - (print 'world) - hoho - (print 'blrugh))) - -#+ignore -(defun tagbodyxx (x) - (tagbody - (print 'hello) - haha - (unwind-protect - (funcall (lambda () - (when x (go hoho)))) - (warn "unwind..")) - (print 'world) - hoho - (print 'blrugh))) - -#+ignore -(defun kumbo (&key a b (c (jumbo 1 2 3)) d) - (print a) - (print b) - (print c) - (print d)) - -#+ignore -(defun lumbo (a &optional (b 'zap)) - (print a) - (print b)) - -(defmacro do-check-esp (&body body) - `(let ((before (with-inline-assembly (:returns :eax) (:movl :esp :eax)))) - (with-inline-assembly (:returns :nothing) - (:compile-form (:result-mode :multiple-values) (progn , at body))) - (unless (eq before - (with-inline-assembly (:returns :eax) (:movl :esp :eax))) - (error "ESP before body: ~S, after: ~S" - (with-inline-assembly (:returns :eax) (:movl :esp :eax)))))) - -#+ignore -(defun test-m-v-call () - (do-check-esp - (multiple-value-call #'format t "~@{ ~D~}~%" - 'a (values) 'b (test-loop 1) (make-values) - 'c 'd 'e (make-no-values) 'f))) - -(defun test-m-v-call2 () - (multiple-value-call #'format t "~@{ ~D~}~%" - 'a 'b (values 1 2 3) 'c 'd 'e 'f)) - -(defun make-values () - (values 0 1 2 3 4 5)) - -(defun xfuncall (&rest args) - (declare (dynamic-extent args)) - (break "xfuncall:~{ ~S~^,~}" args) - (values)) - -(defun xfoo (f) - (do-check-esp - (multiple-value-bind (a b c d) - (multiple-value-prog1 (make-values) - (format t "hello world")) - (format t "~&a: ~S, b: ~S, c: ~S, d: ~S ~S" a b c d f)))) - - -#+ignore -(defun make-no-values () - (values)) - -#+ignore -(defun test-nth-values () - (nth-value 2 (make-values))) - -#+ignore -(defun test-values2 () - (multiple-value-bind (a b c d e f g h) - (make-values) - (format t "test-values2: A: ~S, B: ~S, C: ~S, D: ~S, E: ~S, F: ~S G: ~S, H: ~S~%" - a b c d e f g h))) - -#+ignore -(defun test-flet (zap) - (flet ((pingo (z y x) - (declare (ignore y z)) - (format t "This is pingo: ~S with zap: ~W~%" x zap))) - ;; (declare (dynamic-extent pingo)) - (pingo 100 200 300))) - -#+ignore -(defun test-flet2 (zap) - (flet ((pingo (z y x) - (declare (ignore y z)) - (format t "This is pingo: ~S with zap: ~W~%" x zap))) - ;; (declare (dynamic-extent pingo)) - (lambda (x) - (pingo 100 200 300)))) - -(defun test-boo () - (let ((real-cmuc #'test-flet2)) - (let ((plongo (lambda (x) - (warn "~S real-cmuc: ~S" x real-cmuc) - (funcall real-cmuc x)))) - (funcall plongo 'zooom)))) - -(defun test-labels () - (labels ((pingo (x) - (format t "~&This is pingo: ~S~%" x) - (when (plusp x) - (pingo (1- x))))) - (pingo 5))) - -#+ignore -(defun foo-type (length start1 sequence-1) - (do* ((i 0 #+ignore (+ start1 length -1) (1- i))) - ((< i start1) sequence-1) - (declare (type muerte::index i length)) - (setf (sequence-1-ref i) - 'foo))) - - -#+ignore -(defun test-values () - (multiple-value-bind (a b c d e f g h i j) - (multiple-value-prog1 - (make-values) -;;; (format t "this is the resulting form.~%") - (format t "this is the first ignorable form.~%" 1 2 3) - (format t "this is the second ignorable form.~%")) -;;; (format t "test-values num: ~D~%" (capture-reg8 :cl)) - (format t "test-values: A: ~Z, B: ~Z, C: ~Z, D: ~Z ~Z ~Z ~Z ~Z ~Z ~Z~%" a b c d e f g h i j))) - - -#+ignore -(defun test-keywords (&key a b (c 100) ((:d x) 5 x-p)) - (format t "test-keywords: a: ~S, b: ~S, c: ~S, x: ~S, x-p: ~S~%" - a b c x x-p)) - -#+ignore -(defun test-k1 (a b &key x) - (declare (ignore a b)) - (warn "x: ~S" x)) - [1931 lines skipped] From ffjeld at common-lisp.net Sat Feb 23 22:34:14 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sat, 23 Feb 2008 17:34:14 -0500 (EST) Subject: [movitz-cvs] CVS movitz Message-ID: <20080223223414.A213381003@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv6952 Modified Files: image.lisp Log Message: Use the new disassembler. --- /project/movitz/cvsroot/movitz/image.lisp 2008/02/09 18:42:00 1.114 +++ /project/movitz/cvsroot/movitz/image.lisp 2008/02/23 22:34:14 1.115 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: image.lisp,v 1.114 2008/02/09 18:42:00 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.115 2008/02/23 22:34:14 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1244,6 +1244,7 @@ (when (= offset (bt:slot-offset 'movitz-run-time-context slot-name)) (return slot-name)))) +#+ia-x86 (defun comment-instruction (instruction funobj pc) "Return a list of strings that comments on INSTRUCTION." (loop for operand in (ia-x86::instruction-operands instruction) @@ -1361,8 +1362,57 @@ (defparameter *recursive-disassemble-remember-funobjs* nil) +(defun movitz-foo (funobj &key (name (movitz-funobj-name funobj)) ((:image *image*) *image*) + (recursive t)) + (coerce (movitz-vector-symbolic-data (movitz-funobj-code-vector funobj)) + 'list)) + +#-ia-x86 +(defun movitz-disassemble-funobj (funobj &key (name (movitz-funobj-name funobj)) ((:image *image*) *image*) + (recursive t)) + (let ((code (coerce (movitz-vector-symbolic-data (movitz-funobj-code-vector funobj)) + 'list)) + (entry-points (loop for slot in '(code-vector%1op code-vector%2op code-vector%3op) + for entry-arg-count upfrom 1 + for entry = (slot-value funobj slot) + when (and (consp entry) + (eq funobj (cdr entry))) + collect (cons (car entry) + entry-arg-count)))) + (let ((*print-case* :downcase)) + (format t "~&;; Movitz Disassembly of ~A: +;; ~D Constant~:P~@[: ~A~]. +~:{~4D: ~16<~{ ~2,'0X~}~;~> ~A~@[ ;~{ ~A~}~]~%~}" + (movitz-print (or (movitz-funobj-name funobj) name)) + (length (movitz-funobj-const-list funobj)) + (movitz-funobj-const-list funobj) + (loop with pc = 0 + for (data . instruction) in (asm:disassemble-proglist code :symtab (movitz-funobj-symtab funobj) + :collect-data t) + when (assoc pc entry-points) + collect (list pc nil + (format nil " => Entry-point for ~D arguments <=" (cdr (assoc pc entry-points))) + nil) + when (let ((x (find pc (movitz-funobj-symtab funobj) :key #'cdr))) + (when x (list pc (list (format nil " ~A" (car x))) "" nil))) + collect it + collect (list pc data instruction nil) + do (incf pc (length data)))))) + (when recursive + (let ((*recursive-disassemble-remember-funobjs* + (cons funobj *recursive-disassemble-remember-funobjs*))) + (loop for x in (movitz-funobj-const-list funobj) + do (when (and (typep x '(and movitz-funobj (not movitz-funobj-standard-gf))) + (not (member x *recursive-disassemble-remember-funobjs*))) + (push x *recursive-disassemble-remember-funobjs*) + (terpri) + (movitz-disassemble-funobj x)))))) + + + +#+ia-x86 (defun movitz-disassemble-funobj (funobj &key (name (movitz-funobj-name funobj)) ((:image *image*) *image*) - (recursive t)) + (recursive t)) (let* ((code-vector (movitz-funobj-code-vector funobj)) (code (map 'vector #'identity (movitz-vector-symbolic-data code-vector))) @@ -1375,44 +1425,65 @@ (length (movitz-funobj-const-list funobj)) (movitz-funobj-const-list funobj) (loop - for pc = 0 then code-position - for instruction = (ia-x86:decode-read-octet - #'(lambda () - (when (< code-position - (movitz-vector-fill-pointer code-vector)) - (prog1 - (aref code code-position) - (incf code-position))))) - for cbyte = (and instruction - (ia-x86::instruction-original-datum instruction)) - until (null instruction) - when (let ((x (find pc (movitz-funobj-symtab funobj) :key #'cdr))) - (when x (list pc (list (format nil " ~S" (car x))) "" nil))) - collect it - when (some (lambda (x) - (and (plusp pc) (= pc x))) - entry-points) - collect (list pc nil - (format nil " => Entry-point for ~D arguments <=" - (1+ (position-if (lambda (x) - (= pc x)) - entry-points))) - nil) - collect (list pc - (ia-x86::cbyte-to-octet-list cbyte) - instruction - (comment-instruction instruction funobj pc))))) + for pc = 0 then code-position + for instruction = (ia-x86:decode-read-octet + #'(lambda () + (when (< code-position + (movitz-vector-fill-pointer code-vector)) + (prog1 + (aref code code-position) + (incf code-position))))) + for cbyte = (and instruction + (ia-x86::instruction-original-datum instruction)) + until (null instruction) + when (let ((x (find pc (movitz-funobj-symtab funobj) :key #'cdr))) + (when x (list pc (list (format nil " ~S" (car x))) "" nil))) + collect it + when (some (lambda (x) + (and (plusp pc) (= pc x))) + entry-points) + collect (list pc nil + (format nil " => Entry-point for ~D arguments <=" + (1+ (position-if (lambda (x) + (= pc x)) + entry-points))) + nil) + collect (list pc + (ia-x86::cbyte-to-octet-list cbyte) + instruction + (comment-instruction instruction funobj pc))))) (when recursive (let ((*recursive-disassemble-remember-funobjs* (cons funobj *recursive-disassemble-remember-funobjs*))) (loop for x in (movitz-funobj-const-list funobj) - do (when (and (typep x '(and movitz-funobj (not movitz-funobj-standard-gf))) - (not (member x *recursive-disassemble-remember-funobjs*))) - (push x *recursive-disassemble-remember-funobjs*) - (terpri) - (movitz-disassemble-funobj x))))) + do (when (and (typep x '(and movitz-funobj (not movitz-funobj-standard-gf))) + (not (member x *recursive-disassemble-remember-funobjs*))) + (push x *recursive-disassemble-remember-funobjs*) + (terpri) + (movitz-disassemble-funobj x))))) (values)) +#-ia-x86 +(defun movitz-disassemble-primitive (name &optional (*image* *image*)) + (let* ((code-vector (cond + ((slot-exists-p (image-run-time-context *image*) name) + (slot-value (image-run-time-context *image*) name)) + (t (movitz-symbol-value (movitz-read name))))) + (code (coerce (movitz-vector-symbolic-data code-vector) + 'list))) + (format t "~&;; Movitz disassembly of ~S: +~:{~4D: ~16<~{ ~2,'0X~}~;~> ~A~@[ ;~{ ~A~}~]~%~}" + name + (loop with pc = 0 + for (data . instruction) in (asm:disassemble-proglist code :collect-data t) + collect (list pc + data + instruction + nil #+ignore (comment-instruction instruction nil pc)) + do (incf pc (length data)))) + (values))) + +#+ia-x86 (defun movitz-disassemble-primitive (name &optional (*image* *image*)) (let* ((code-vector (cond ((slot-exists-p (image-run-time-context *image*) name) From ffjeld at common-lisp.net Sat Feb 23 22:35:08 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sat, 23 Feb 2008 17:35:08 -0500 (EST) Subject: [movitz-cvs] CVS movitz Message-ID: <20080223223508.914527323C@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv7169 Modified Files: asm.lisp Log Message: Finishing touches on the disassembler. --- /project/movitz/cvsroot/movitz/asm.lisp 2008/02/18 22:30:45 1.14 +++ /project/movitz/cvsroot/movitz/asm.lisp 2008/02/23 22:35:08 1.15 @@ -6,7 +6,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: asm.lisp,v 1.14 2008/02/18 22:30:45 ffjeld Exp $ +;;;; $Id: asm.lisp,v 1.15 2008/02/23 22:35:08 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -234,13 +234,22 @@ :corrections (nconc new-corrections corrections))) (t (values code *symtab*)))))))) +(defun instruction-operator (instruction) + (if (listp (car instruction)) ; skip any instruction prefixes etc. + (cadr instruction) + (car instruction))) + (defun instruction-operands (instruction) (if (listp (car instruction)) ; skip any instruction prefixes etc. (cddr instruction) (cdr instruction))) +(defun instruction-modifiers (instruction) + (if (listp (car instruction)) + (car instruction) + nil)) -(defun disassemble-proglist (code &key (cpu-package '#:asm-x86) (pc (or *pc* 0)) (symtab *symtab*)) +(defun disassemble-proglist (code &key (cpu-package '#:asm-x86) (pc (or *pc* 0)) (symtab *symtab*) collect-data collect-labels) (let* ((instruction-disassembler (find-symbol (string '#:disassemble-instruction) cpu-package)) (proglist0 (loop while code @@ -250,24 +259,33 @@ code) (when (eq code new-code) (loop-finish)) - (loop until (eq code new-code) - do (incf pc) - (setf code (cdr code))) - (let ((operands (instruction-operands instruction))) - (if (notany #'pc-relative-operand-p operands) - instruction - (nconc (loop until (eq instruction operands) - collect (pop instruction)) - (loop for operand in operands - collect (if (not (pc-relative-operand-p operand)) - operand - (let* ((location (+ pc (pc-relative-operand-offset operand))) - (entry (or (rassoc location symtab) - (car (push (cons (gensym) location) - symtab))))) - `(quote ,(car entry)))))))))))) - (values (loop for (pc instruction) on proglist0 by #'cddr - when (car (rassoc pc symtab)) - collect it - collect instruction) + (let* ((data (loop until (eq code new-code) + do (incf pc) + collect (pop code))) + (operands (instruction-operands instruction))) + ;; (format *debug-io* "~D: ~X ~S~%" pc data instruction) + (cons data + (if (notany #'pc-relative-operand-p operands) + instruction + (nconc (loop until (eq instruction operands) + collect (pop instruction)) + (loop for operand in operands + collect (if (not (pc-relative-operand-p operand)) + operand + (let* ((location (+ pc (pc-relative-operand-offset operand))) + (entry (or (rassoc location symtab) + (car (push (cons (gensym) location) + symtab))))) + `(quote ,(car entry))))))))))))) + (values (loop for (pc data-instruction) on proglist0 by #'cddr + for (data . instruction) = data-instruction + for label = (when collect-labels + (rassoc pc symtab)) + when label + collect (if (not collect-data) + (car label) + (cons nil (car label))) + collect (if (not collect-data) + instruction + data-instruction)) symtab))) From ffjeld at common-lisp.net Sat Feb 23 22:35:17 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sat, 23 Feb 2008 17:35:17 -0500 (EST) Subject: [movitz-cvs] CVS movitz Message-ID: <20080223223517.A673573243@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv7188 Modified Files: asm-x86.lisp Log Message: Finishing touches on the disassembler. --- /project/movitz/cvsroot/movitz/asm-x86.lisp 2008/02/18 22:30:47 1.29 +++ /project/movitz/cvsroot/movitz/asm-x86.lisp 2008/02/23 22:35:10 1.30 @@ -6,7 +6,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: asm-x86.lisp,v 1.29 2008/02/18 22:30:47 ffjeld Exp $ +;;;; $Id: asm-x86.lisp,v 1.30 2008/02/23 22:35:10 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -278,7 +278,7 @@ (make-array 256 :initial-element nil)) (deftype disassembly-decoder () - '(list-of* keyword (or keyword null) symbol)) + '(list-of* boolean keyword (or keyword null) symbol)) (defun (setf opcode-disassembler) (decoder opcode operator-mode) (check-type decoder disassembly-decoder) @@ -312,22 +312,22 @@ -(defmacro define-disassembler ((operator opcode &optional cpu-mode (digit nil digit-p)) lambda-list &body body) +(defmacro define-disassembler ((operator opcode &optional cpu-mode digit backup-p) lambda-list &body body) (cond - (digit-p + (digit `(loop for mod from #b00 to #b11 do (loop for r/m from #b000 to #b111 as ext-opcode = (logior (ash ,opcode 8) (ash ,digit 3) (ash mod 6) r/m) - do (define-disassembler (,operator ext-opcode ,cpu-mode) ,lambda-list , at body)))) + do (define-disassembler (,operator ext-opcode ,cpu-mode nil t) ,lambda-list , at body)))) ((symbolp lambda-list) - `(setf (opcode-disassembler ,opcode ,cpu-mode) (list ,operator ,cpu-mode ',lambda-list , at body))) + `(setf (opcode-disassembler ,opcode ,cpu-mode) (list ,backup-p ,operator ,cpu-mode ',lambda-list , at body))) (t (let ((defun-name (intern (format nil "~A-~A-~X~@[-~A~]" 'disassembler operator opcode cpu-mode)))) `(progn (defun ,defun-name ,lambda-list , at body) - (setf (opcode-disassembler ,opcode ',cpu-mode) (list ,operator ',cpu-mode ',defun-name)) + (setf (opcode-disassembler ,opcode ',cpu-mode) (list ,backup-p ,operator ',cpu-mode ',defun-name)) ',defun-name))))) (defun disassemble-simple-prefix (code operator opcode operand-size address-size rex) @@ -799,15 +799,18 @@ (defun disassemble-instruction (code &optional override-operand-size override-address-size rex) (labels ((lookup-decoder (table opcode) - (let* ((datum (pop-code code)) + (let* ((backup-code code) + (datum (pop-code code)) (opcode (logior (ash opcode 8) datum)) (decoder (svref table datum))) (typecase decoder - ((simple-vector 256) + (vector (lookup-decoder decoder opcode)) (disassembly-decoder - (values decoder + (when (car decoder) + (setf code backup-code)) + (values (cdr decoder) opcode)) (t (error "No disassembler registered for opcode #x~X." opcode)))))) (multiple-value-bind (decoder opcode) @@ -1384,14 +1387,13 @@ ;;;;;;;;;;; CALL -(define-operator* (:16 :callw :32 :calll :64 :callr :dispatch :call) (dest) - (case *cpu-mode* - (:16-bit - (pc-rel #xe8 dest (sint 16))) - (:32-bit - (pc-rel #xe8 dest (sint 32)))) - (when (eq operator-mode *cpu-mode*) - (modrm dest #xff 2))) +(define-operator/16 :callw (dest) + (pc-rel #xe8 dest (sint 16)) + (modrm dest #xff 2)) + +(define-operator/32 :call (dest) + (pc-rel #xe8 dest (sint 32)) + (modrm dest #xff 2)) (define-operator/none :call-segment (dest) (modrm dest #xff 3)) @@ -1879,11 +1881,6 @@ (define-operator* (:16 :negw :32 :negl :64 :negr) (dst) (modrm dst #xf7 3)) -;;;;;;;;;;;;;;;; NOP - -(define-operator/none :nop () - (opcode #x90)) - ;;;;;;;;;;; NOT (define-operator/8 :notb (dst) @@ -2162,3 +2159,9 @@ (imm-modrm src dst #x81 6 :int-16-32-64) (reg-modrm dst src #x33) (reg-modrm src dst #x31)) + +;;;;;;;;;;;;;;;; NOP + +(define-operator/none :nop () + (opcode #x90)) + From ffjeld at common-lisp.net Sat Feb 23 22:36:21 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sat, 23 Feb 2008 17:36:21 -0500 (EST) Subject: [movitz-cvs] CVS movitz Message-ID: <20080223223621.030301B@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv7366 Modified Files: compiler.lisp Log Message: Remove remnants of ia-x86. --- /project/movitz/cvsroot/movitz/compiler.lisp 2008/02/17 00:10:11 1.192 +++ /project/movitz/cvsroot/movitz/compiler.lisp 2008/02/23 22:36:21 1.193 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.192 2008/02/17 00:10:11 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.193 2008/02/23 22:36:21 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -991,32 +991,6 @@ (assemble-funobj funobj combined-code)))) funobj) - -(defun diss (code) - (format nil "~&;; Diss: -~:{~4D: ~16<~{ ~2,'0X~}~;~> ~A~@[ ;~{ ~A~}~]~%~}" - (loop with code-position = 0 and instruction-octets = nil - for pc = 0 then code-position - for instruction = (progn - (setf instruction-octets nil) - (ia-x86:decode-read-octet (lambda () - (incf code-position) - (loop while (and code (not (typep (car code) '(unsigned-byte 8)))) - do (warn "diss bad byte at ~D: ~S" code-position (pop code)) - (incf code-position)) - (let ((x (pop code))) - (when x (push x instruction-octets)) - x)))) - collect (if (not instruction) - (list pc (nreverse instruction-octets) nil '("???")) - (list pc - (nreverse instruction-octets) - ;;(ia-x86::cbyte-to-octet-list (ia-x86::instruction-original-datum instruction)) - instruction - (comment-instruction instruction nil pc))) - while code))) - - (defun assemble-funobj (funobj combined-code) (multiple-value-bind (code-vector code-symtab) (let ((asm:*instruction-compute-extra-prefix-map* @@ -1056,20 +1030,13 @@ (break "entry%2: ~D" b)) (unless (<= 0 c 4095) (break "entry%3: ~D" c))) - (loop for ((entry-label slot-name)) on '((entry%1op code-vector%1op) - (entry%2op code-vector%2op) - (entry%3op code-vector%3op)) - do (cond - ((assoc entry-label code-symtab) - (let ((offset (cdr (assoc entry-label code-symtab)))) - (setf (slot-value funobj slot-name) - (cons offset funobj)) - #+ignore (when (< offset #x100) - (vector-push offset code-vector)))) - #+ignore - ((some (lambda (label) (assoc label code-symtab)) - (mapcar #'car rest)) - (vector-push 0 code-vector)))) + (loop for (entry-label slot-name) in '((entry%1op code-vector%1op) + (entry%2op code-vector%2op) + (entry%3op code-vector%3op)) + do (when (assoc entry-label code-symtab) + (let ((offset (cdr (assoc entry-label code-symtab)))) + (setf (slot-value funobj slot-name) + (cons offset funobj))))) (check-locate-concistency code-vector) (setf (movitz-funobj-code-vector funobj) (make-movitz-vector (length code-vector) From ffjeld at common-lisp.net Sun Feb 24 11:57:36 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sun, 24 Feb 2008 06:57:36 -0500 (EST) Subject: [movitz-cvs] CVS movitz Message-ID: <20080224115736.0E215610B8@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv31988 Modified Files: load.lisp Log Message: Don't load ia-x86 by default. --- /project/movitz/cvsroot/movitz/load.lisp 2008/02/04 21:05:23 1.12 +++ /project/movitz/cvsroot/movitz/load.lisp 2008/02/24 11:57:35 1.13 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Thu Jan 15 18:40:58 2004 ;;;; -;;;; $Id: load.lisp,v 1.12 2008/02/04 21:05:23 ffjeld Exp $ +;;;; $Id: load.lisp,v 1.13 2008/02/24 11:57:35 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -32,15 +32,15 @@ (load (compile-file #p"asm-x86")) ; ia-x86 needs them while testing/migrating. -(let ((*default-pathname-defaults* (merge-pathnames #p"../ia-x86/"))) - #+(or cmu) (let ((pwd (ext:default-directory))) - (progn - (unwind-protect - (progn - (setf (ext:default-directory) #p"../ia-x86/") - (load "load")) - (setf (ext:default-directory) pwd)))) - #-(or cmu) (load "load")) +#+ia-x86 (let ((*default-pathname-defaults* (merge-pathnames #p"../ia-x86/"))) + #+(or cmu) (let ((pwd (ext:default-directory))) + (progn + (unwind-protect + (progn + (setf (ext:default-directory) #p"../ia-x86/") + (load "load")) + (setf (ext:default-directory) pwd)))) + #-(or cmu) (load "load")) #+allegro (progn (load (compile-file #p"../infunix/procfs")) From ffjeld at common-lisp.net Sun Feb 24 12:13:06 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sun, 24 Feb 2008 07:13:06 -0500 (EST) Subject: [movitz-cvs] CVS movitz Message-ID: <20080224121306.ECD9D71138@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv3033 Modified Files: image.lisp Log Message: Add disassembly comments. --- /project/movitz/cvsroot/movitz/image.lisp 2008/02/23 22:34:14 1.115 +++ /project/movitz/cvsroot/movitz/image.lisp 2008/02/24 12:13:06 1.116 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: image.lisp,v 1.115 2008/02/23 22:34:14 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.116 2008/02/24 12:13:06 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1244,6 +1244,79 @@ (when (= offset (bt:slot-offset 'movitz-run-time-context slot-name)) (return slot-name)))) +#-ia-x86 +(defun comment-instruction (instruction funobj pc) + "Return a list of strings that comments on INSTRUCTION." + (declare (ignore pc)) + (loop for operand in (asm:instruction-operands instruction) + when (and (typep operand 'asm:indirect-operand) + (member :edi operand) + (run-time-context-find-slot (asm:indirect-operand-offset operand)) + (not (member (asm:instruction-operator instruction) + '(:leal :lea)))) + collect (format nil "" + (run-time-context-find-slot (asm:indirect-operand-offset operand))) +;; when (and (typep operand 'ia-x86::operand-indirect-register) +;; (eq 'ia-x86::edi (ia-x86::operand-register operand)) +;; (typep instruction 'ia-x86-instr::lea) +;; (or (not (ia-x86::operand-register2 operand)) +;; (eq 'ia-x86::edi (ia-x86::operand-register2 operand)))) +;; collect (let ((x (+ (* (ia-x86::operand-scale operand) +;; (image-nil-word *image*)) +;; (ia-x86::operand-offset operand) +;; (ecase (ia-x86::operand-register2 operand) +;; (ia-x86::edi (image-nil-word *image*)) +;; ((nil) 0))))) +;; (case (ldb (byte 3 0) x) +;; (#.(tag :character) +;; (format nil "Immediate ~D (char ~S)" +;; x (code-char (ldb (byte 8 8) x)))) +;; (#.(mapcar 'tag +fixnum-tags+) +;; (format nil "Immediate ~D (fixnum ~D #x~X)" +;; x +;; (truncate x +movitz-fixnum-factor+) +;; (truncate x +movitz-fixnum-factor+))) +;; (t (format nil "Immediate ~D" x)))) + when (and funobj + (typep operand 'asm:indirect-operand) + (member :esi operand) + (<= 12 (asm:indirect-operand-offset operand))) + collect (format nil "~A" + (nth (truncate (- (+ (asm:indirect-operand-offset operand) + (if (member :edi operand) + (image-nil-word *image*) + 0)) + (slot-offset 'movitz-funobj 'constant0)) + 4) + (movitz-funobj-const-list funobj))) +;; when (and funobj +;; (typep operand 'ia-x86::operand-indirect-register) +;; (eq 'ia-x86::esi (ia-x86::operand-register2 operand)) +;; (eq 'ia-x86::edi (ia-x86::operand-register operand)) +;; (<= 12 (ia-x86::operand-offset operand))) +;; collect (format nil "~A" (nth (truncate (- (+ (ia-x86::operand-offset operand) +;; (* (ia-x86::operand-scale operand) +;; (image-nil-word *image*))) +;; (slot-offset 'movitz-funobj 'constant0)) +;; 4) +;; (movitz-funobj-const-list funobj))) +;; when (typep operand 'ia-x86::operand-rel-pointer) +;; collect (let* ((x (+ pc +;; (imagpart (ia-x86::instruction-original-datum instruction)) +;; (length (ia-x86:instruction-prefixes instruction)) +;; (ia-x86::operand-offset operand))) +;; (label (and funobj (car (find x (movitz-funobj-symtab funobj) :key #'cdr))))) +;; (if label +;; (format nil "branch to ~S at ~D" label x) +;; (format nil "branch to ~D" x))) + when (and (typep operand '(and integer asm:immediate-operand)) + (<= #x100 operand #x10000) + (= (tag :character) (mod operand 256))) + collect (format nil "#\\~C" (code-char (truncate operand 256))) + when (and (typep operand '(and integer asm:immediate-operand)) + (zerop (mod operand +movitz-fixnum-factor+))) + collect (format nil "#x~X" (truncate operand +movitz-fixnum-factor+)))) + #+ia-x86 (defun comment-instruction (instruction funobj pc) "Return a list of strings that comments on INSTRUCTION." @@ -1396,7 +1469,7 @@ when (let ((x (find pc (movitz-funobj-symtab funobj) :key #'cdr))) (when x (list pc (list (format nil " ~A" (car x))) "" nil))) collect it - collect (list pc data instruction nil) + collect (list pc data instruction (comment-instruction instruction funobj pc)) do (incf pc (length data)))))) (when recursive (let ((*recursive-disassemble-remember-funobjs* @@ -1479,7 +1552,7 @@ collect (list pc data instruction - nil #+ignore (comment-instruction instruction nil pc)) + (comment-instruction instruction nil pc)) do (incf pc (length data)))) (values))) From ffjeld at common-lisp.net Mon Feb 25 20:11:01 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Mon, 25 Feb 2008 15:11:01 -0500 (EST) Subject: [movitz-cvs] CVS movitz Message-ID: <20080225201101.64FB34D0A0@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv30926 Added Files: movitz.asd Log Message: Initial attempt. --- /project/movitz/cvsroot/movitz/movitz.asd 2008/02/25 20:11:01 NONE +++ /project/movitz/cvsroot/movitz/movitz.asd 2008/02/25 20:11:01 1.1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;;;------------------------------------------------------------------ ;;;; ;;;; Copyright (C) 2008, Frode V. Fjeld ;;;; ;;;; For distribution policy, see the accompanying file COPYING. ;;;; ;;;; Filename: movitz.asd ;;;; Description: Movitz ASDF system definition. ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Thu Jan 15 18:40:58 2004 ;;;; ;;;; $Id: movitz.asd,v 1.1 2008/02/25 20:11:01 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ (defpackage movitz-asd (:use :cl :asdf)) (in-package movitz-asd) (defsystem movitz-asm :name "Movitz Assembler" :version "1.0" :maintainer "ffjeld at common-lisp.net" :author "Frode V. Fjeld" :license "BSD-like, see accopanying file COPYING." :description "An (dis-)assembler framework, with support for x86 in 16, 32, and 64-bit modes." :serial t :components ((:file "asm") (:file "asm-x86"))) (defclass movitz-source-file (cl-source-file) ()) (defsystem movitz :name "Movitz" :version "0.1" :maintainer "ffjeld at common-lisp.net" :author "Frode V. Fjeld" :license "BSD-like, see accopanying file COPYING." :description "A compiler, run-time, and libraries for Common Lisp on the x86." :default-component-class movitz-source-file :serial t :depends-on (binary-types) :components ((:file "packages") (:file "movitz") (:file "parse") (:file "eval") (:file "environment") (:file "compiler-types") (:file "compiler-protocol") (:file "storage-types") (:file "multiboot") (:file "bootblock") (:file "image") (:file "stream-image") (:file "assembly-syntax") (:file "compiler") (:file "special-operators") (:file "special-operators-cl"))) #+sbcl (defmethod perform :around (op (file movitz-source-file)) (handler-bind ((sb-ext:defconstant-uneql #'continue)) (call-next-method))) From ffjeld at common-lisp.net Mon Feb 25 20:11:41 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Mon, 25 Feb 2008 15:11:41 -0500 (EST) Subject: [movitz-cvs] CVS binary-types Message-ID: <20080225201141.B6661392C1@common-lisp.net> Update of /project/movitz/cvsroot/binary-types In directory clnet:/tmp/cvs-serv31018 Added Files: binary-types.asd Log Message: Initial attempt. --- /project/movitz/cvsroot/binary-types/binary-types.asd 2008/02/25 20:11:41 NONE +++ /project/movitz/cvsroot/binary-types/binary-types.asd 2008/02/25 20:11:41 1.1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;;;------------------------------------------------------------------ ;;;; ;;;; Copyright (C) 2008, Frode V. Fjeld ;;;; ;;;; For distribution policy, see the accompanying file COPYING. ;;;; ;;;; Filename: movitz.asd ;;;; Description: Movitz ASDF system definition. ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Thu Jan 15 18:40:58 2004 ;;;; ;;;; $Id: binary-types.asd,v 1.1 2008/02/25 20:11:41 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ (defpackage binary-types-asd (:use :cl :asdf)) (in-package binary-types-asd) (defsystem binary-types :name "Binary-types" :maintainer "ffjeld at common-lisp.net" :author "Frode V. Fjeld" :license "BSD-like, see accopanying file COPYING." :description "A library for reading and writing binary records." :components ((:file "binary-types"))) From ffjeld at common-lisp.net Mon Feb 25 20:19:24 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Mon, 25 Feb 2008 15:19:24 -0500 (EST) Subject: [movitz-cvs] CVS public_html Message-ID: <20080225201924.63E552D070@common-lisp.net> Update of /project/movitz/cvsroot/public_html In directory clnet:/tmp/cvs-serv32409 Modified Files: ChangeLog Log Message: *** empty log message *** --- /project/movitz/cvsroot/public_html/ChangeLog 2008/01/13 22:32:02 1.11 +++ /project/movitz/cvsroot/public_html/ChangeLog 2008/02/25 20:19:23 1.12 @@ -1,3 +1,13 @@ +2008-02-25 Frode V. Fjeld + + * movitz.asd: Created an ASDF system definition. + + * movitz/asm.lisp, movitz/asm-x86.lisp: Created new assembler and + disassembler that's less overengineered (the design goals of + ia-x86 were not originally to serve as an assembler). This speeds + up compiles considerably; on the order of twice as fast, and + reduces the overall footprint of the movitz system too. + 2008-01-13 Frode Vatvedt Fjeld * movitz/losp/muerte/memref.lisp: Fixed (setf memref-int :type From ffjeld at common-lisp.net Mon Feb 25 20:19:48 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Mon, 25 Feb 2008 15:19:48 -0500 (EST) Subject: [movitz-cvs] CVS public_html Message-ID: <20080225201948.B5AC73F027@common-lisp.net> Update of /project/movitz/cvsroot/public_html In directory clnet:/tmp/cvs-serv32519 Modified Files: index.html Log Message: more news. --- /project/movitz/cvsroot/public_html/index.html 2008/01/13 22:32:04 1.31 +++ /project/movitz/cvsroot/public_html/index.html 2008/02/25 20:19:48 1.32 @@ -15,6 +15,16 @@

Most recent news

+2008-02-25  Frode V. Fjeld  
+
+	* movitz.asd: Created an ASDF system definition.
+
+	* movitz/asm.lisp, movitz/asm-x86.lisp: Created new assembler and
+	disassembler that's less overengineered (the design goals of
+	ia-x86 were not originally to serve as an assembler). This speeds
+	up compiles considerably; on the order of twice as fast, and
+	reduces the overall footprint of the movitz system too.
+
 2008-01-13  Frode Vatvedt Fjeld  
 
 	* movitz/losp/muerte/memref.lisp: Fixed (setf memref-int :type



From ffjeld at common-lisp.net  Mon Feb 25 21:32:13 2008
From: ffjeld at common-lisp.net (ffjeld)
Date: Mon, 25 Feb 2008 16:32:13 -0500 (EST)
Subject: [movitz-cvs] CVS public_html
Message-ID: <20080225213213.A612630040@common-lisp.net>

Update of /project/movitz/cvsroot/public_html
In directory clnet:/tmp/cvs-serv15409

Modified Files:
	index.html 
Log Message:
No more ia-x86.


--- /project/movitz/cvsroot/public_html/index.html	2008/02/25 20:19:48	1.32
+++ /project/movitz/cvsroot/public_html/index.html	2008/02/25 21:32:13	1.33
@@ -76,19 +76,18 @@
  tree via anonymous cvs, as described here

 
- 
 There are currently three modules in the repository:
+ 
 There are two modules in use in the repository:
 
   
    
-    
  • ia-x86
    • 
     
  • binary-types
    • 
     
  • movitz
    • 
   

 
-  
 The former two are required for building and using the
-  latter. So far, this combo has been run under Allegro, SBCL, and
-  CMUCL, but everything is supposed to be platform-independent ANSI
-  Common Lisp. CLisp apparently dumps core for some reason during the
-  build process. 

+  
 Binary-types is a library that is required for building and
+  using Movitz. So far, this combo has been run under Allegro, SBCL,
+  and CMUCL, but everything is supposed to be platform-independent
+  ANSI Common Lisp. CLisp apparently dumps core for some reason during
+  the build process. 

 
   The main build process is run by two operators. Create-image creates
   a symbolic Movitz lisp-world from scratch. This symbolic



From ffjeld at common-lisp.net  Mon Feb 25 21:47:53 2008
From: ffjeld at common-lisp.net (ffjeld)
Date: Mon, 25 Feb 2008 16:47:53 -0500 (EST)
Subject: [movitz-cvs] CVS public_html
Message-ID: <20080225214753.A6F857A026@common-lisp.net>

Update of /project/movitz/cvsroot/public_html
In directory clnet:/project/movitz/public_html

Modified Files:
	style.css 
Log Message:
fresh copy

--- /project/movitz/cvsroot/public_html/style.css	2004/01/13 11:31:55	1.1
+++ /project/movitz/cvsroot/public_html/style.css	2008/02/25 21:47:53	1.2
@@ -1,260 +1,54 @@
-/* Style code taken from oswd.net, this design originally by haran.
-/* original header:
-/* TITLE: Stylesheet for Purple Haze
-/* URI  : /purplehaze/purplehaze.css
-/* MODIF: 2002-12-15 17:34 +0800
 
-
-/* ###### Color Scheme ###### */
-
-/*
- * CHANGING THE COLOR SCHEME
- * -------------------------
- * 
- * Four basic colors were used in the design. To change the
- * color scheme, just edit these four values below.
- *
- */
-
-.topOfPage, q, h1, h2, h3, .headerTitle, .siteMap, .siteMap *, .headerLinks, .headerLinks *, .sideBox div, #footer *
-{ /* Text Color: */  color: /* #a0a0ff; */ #1111ff; }
-
-q, h2,  #header, .sideBox, .sideBox div, #footer
-{ /* Border Color: */  border-color: #c0c0ff; }
-
-#header, .sideBox div, .sideBox a:hover
-{ /* Background Color (darker): */  background-color: #f0f0ff; }
-
-
-q, .sideBox a, .sideBox span, #footer
- /* Background Color (lighter): */ 
- { background-color: #fcfcff; } 
-
-
-
-/* ###### Browser-specific Styles ###### */
-
-/* For IE & Mozilla-based browsers: */
-
-.LHS {
-  margin-left: 2.5mm;
-  float: left;
-  clear: left;
-  width: 10em;
-}
-
-.RHS {
-  margin-right: 2.5mm;
-  float: right;
-  clear: right;
-  width: 14em;
-  font-size: small;
-}
-
-/* For Mozilla-based (CSS2-fully complaint) browsers only: */
-
-[class~="LHS"] {
-  margin-left: 5mm;
-}
-
-[class~="RHS"] {
-  margin-right: 5mm;
-}
-
-
-/* ###### Body Text ###### */
-
-#bodyText {
-  line-height: 1.5em;
-  margin: 10mm 14em 0 12em;
-  padding: 0 1em 1ex 1em;
-}
-
-#bodyTextWide {
-  line-height: 1.5em;
-  margin: 10mm 2em 0 12em;
-  padding: 0 1em 1ex 1em;
-}
-
-#bodyText p {
-  padding-bottom: 1ex;
-}
-
-#bodyText ul {
-  padding-bottom: 1ex;
-}
-
-.topOfPage {
-  font-size: 90%;
-  font-weight: bold;
-  font-variant: small-caps;
-  text-decoration: none;
-  padding-left: 1ex;
-  padding-right: 1ex;
-  float: right;
-}
-
-.smallCaps {
-  font-variant: small-caps;
-}
-
-body {
-  background-color: white;
-  color: black;
-  font-family: "arial"; /* verdana, tahoma, helvetica, arial, sans-serif;*/
-  font-size: 100%;
-  margin: 0;
-}
-
-h1, h2, h3 {
-  font-family: "arial"; /* , sans-serif; */
-}
-
-h1 {
-  font-weight: bold;
-  font-size: 150%;
-  font-family: "arial";
-  border-bottom: 1px solid;
-  padding-bottom: 0.5ex;
-}
-
-h2 {
-  font-weight: bold;
-  font-size: 100%;
-  font-family: "arial";
-  padding-bottom: 0.5ex;
-}
-
-acronym {
-  background-color: inherit;
-  color: teal;
-  border-bottom: 1px dashed teal;
-  cursor: help;
-}
-
-code {
-  font-family: "lucida console", monospace;
-  font-size: 90%;
-}
-
-img {
-  border: 0;
-}
-
-q {
-  font-family: "arial"; /* , verdana, helvetica, arial, sans-serif; */
-  font-weight: bold;
-  border: 2px dotted;
-  margin: 0 1em 1ex 1em;
-  padding: 0.5ex 0.5ex 0.5ex 1ex;
-  width: 9em;
-  float: left;
-}
-
-
-/* ###### Header ###### */
-
-#header {
-  border-bottom: 2px solid;
-  height: 5em;
-  margin-bottom: 5mm;
-  padding: 2em 2.5mm 0 5mm;
-}
-
-.headerTitle {
-  font-size: 300%;
-}
-
-.headerLinks {
-  text-align: right;
-  margin-right: 2.5mm;
-  float: right;
-  clear: right;
-}
-
-.headerLinks * {
-  text-decoration: none;
-  font-weight: bold;
-  padding-right: 1ex;
-}
-
-.headerLinks a:hover {
-  text-decoration: underline;
-}
-
-.siteMap {
-  font-size: small;
-  text-align: left;
-  margin-left: 2.5mm;
-  margin-right: 2.5mm;
-  float: left;
-  clear: left;
-}
-
-.siteMap * {
-  text-decoration: none;
-/*  font-weight: bold; */
-  padding-right: 1ex;
-}
-
-.siteMap a:hover {
-  text-decoration: underline;
-}
-
-
-/* ###### Side Box ###### */
-
-.sideBox {
-  border-top: 2px solid;
-  border-bottom: 2px solid;
-  margin-top: 5mm;
-}
-
-.sideBox div {
-  font-weight: bold;
-  border-bottom: 1px dashed;
-  padding: 0.5ex 0.5em 0.5ex 0.75em;
-}
-
-.sideBox a, .sideBox a:hover, .sideBox span {
-  color: black;
-  text-decoration: none;
-  line-height: 1.25em;
-  display: block;
-  padding: 1ex 0.5em 1ex 0.75em;
-}
-
-
-/* ###### Footer ###### */
-
-#footer {
-  color: inherit;
-  border-top: 2px solid;
-  border-bottom: 2px solid;
-  padding-top: 0.75ex;
-  padding-bottom: 0.75ex;
-  clear: left;
-}
-
-.footerImg {
-  padding-right: 3mm;
-  padding-top: 2mm;
-  float: none;
-}
-
-#footer div {
-  padding-left: 3mm;
-}
-
-#footer * {
-  background-color: inherit;
-  font-size: 92%;
-}
-
-#footer a:hover {
-  text-decoration: none;
-}
-
-.footerCol2 {
-  left: 7em;
-}
+.header {
+	font-size: medium;
+	background-color:#336699;
+	color:#ffffff;
+	border-style:solid;
+	border-width: 5px;
+	border-color:#002244;
+	padding: 1mm 1mm 1mm 5mm;
+}
+
+.footer {
+	font-size: small;
+	font-style: italic;
+	text-align: right;
+	background-color:#336699;
+	color:#ffffff;
+	border-style:solid;
+	border-width: 2px;
+	border-color:#002244;
+	padding: 1mm 1mm 1mm 1mm;
+}
+
+.footer a:link {
+	font-weight:bold;
+	color:#ffffff;
+	text-decoration:underline;
+}
+
+.footer a:visited {
+	font-weight:bold;
+	color:#ffffff; 
+	text-decoration:underline;
+}
+
+.footer a:hover { 
+	font-weight:bold; 
+	color:#002244; 
+	text-decoration:underline; }
+
+.check {font-size: x-small;
+	text-align:right;}
+
+.check a:link { font-weight:bold;
+		color:#a0a0ff;
+		text-decoration:underline; }
+
+.check a:visited { font-weight:bold;
+		   color:#a0a0ff;
+		   text-decoration:underline; }
+
+.check a:hover { font-weight:bold;
+		 color:#000000;
+		 text-decoration:underline; }



From ffjeld at common-lisp.net  Mon Feb 25 23:16:21 2008
From: ffjeld at common-lisp.net (ffjeld)
Date: Mon, 25 Feb 2008 18:16:21 -0500 (EST)
Subject: [movitz-cvs] CVS movitz
Message-ID: <20080225231621.4B1A562136@common-lisp.net>

Update of /project/movitz/cvsroot/movitz
In directory clnet:/tmp/cvs-serv8791

Modified Files:
	movitz.asd 
Log Message:
Don't forget movitz-asm.


--- /project/movitz/cvsroot/movitz/movitz.asd	2008/02/25 20:11:01	1.1
+++ /project/movitz/cvsroot/movitz/movitz.asd	2008/02/25 23:16:21	1.2
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld 
 ;;;; Created at:    Thu Jan 15 18:40:58 2004
 ;;;;                
-;;;; $Id: movitz.asd,v 1.1 2008/02/25 20:11:01 ffjeld Exp $
+;;;; $Id: movitz.asd,v 1.2 2008/02/25 23:16:21 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -42,7 +42,7 @@
   :description "A compiler, run-time, and libraries for Common Lisp on the x86."
   :default-component-class movitz-source-file
   :serial t
-  :depends-on (binary-types)
+  :depends-on (binary-types movitz-asm)
   :components ((:file "packages")
 	       (:file "movitz")
 	       (:file "parse")



From ffjeld at common-lisp.net  Mon Feb 25 23:33:43 2008
From: ffjeld at common-lisp.net (ffjeld)
Date: Mon, 25 Feb 2008 18:33:43 -0500 (EST)
Subject: [movitz-cvs] CVS movitz
Message-ID: <20080225233343.14859392C1@common-lisp.net>

Update of /project/movitz/cvsroot/movitz
In directory clnet:/tmp/cvs-serv13388

Modified Files:
	asm-x86.lisp 
Log Message:
Disengage warning.


--- /project/movitz/cvsroot/movitz/asm-x86.lisp	2008/02/23 22:35:10	1.30
+++ /project/movitz/cvsroot/movitz/asm-x86.lisp	2008/02/25 23:33:43	1.31
@@ -6,7 +6,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld 
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: asm-x86.lisp,v 1.30 2008/02/23 22:35:10 ffjeld Exp $
+;;;; $Id: asm-x86.lisp,v 1.31 2008/02/25 23:33:43 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -288,11 +288,11 @@
 	     (let ((bit-pos (* 8 (1- (ceiling (integer-length pos) 8)))))
 	       (if (not (plusp bit-pos))
 		   (progn
-		     (unless (or (eq nil decoder)
-				 (eq nil (svref table pos))
-				 (equal decoder (svref table pos)))
-		       (warn "Redefining disassembler for ~@[~(~A~) ~]opcode #x~X from ~{~S ~}to ~{~S~^ ~}."
-			     operator-mode opcode (svref table pos) decoder))
+		     #+(or) (unless (or (eq nil decoder)
+					(eq nil (svref table pos))
+					(equal decoder (svref table pos)))
+			      (warn "Redefining disassembler for ~@[~(~A~) ~]opcode #x~X from ~{~S ~}to ~{~S~^ ~}."
+				    operator-mode opcode (svref table pos) decoder))
 		     (setf (svref table pos) decoder))
 		   (set-it (or (svref table (ldb (byte 8 bit-pos) pos))
 			       (setf (svref table (ldb (byte 8 bit-pos) pos))



From ffjeld at common-lisp.net  Mon Feb 25 23:34:11 2008
From: ffjeld at common-lisp.net (ffjeld)
Date: Mon, 25 Feb 2008 18:34:11 -0500 (EST)
Subject: [movitz-cvs] CVS movitz
Message-ID: <20080225233411.39E24610B6@common-lisp.net>

Update of /project/movitz/cvsroot/movitz
In directory clnet:/tmp/cvs-serv13493

Modified Files:
	asm.lisp 
Log Message:
Add indirect-operand-offset.


--- /project/movitz/cvsroot/movitz/asm.lisp	2008/02/23 22:35:08	1.15
+++ /project/movitz/cvsroot/movitz/asm.lisp	2008/02/25 23:34:11	1.16
@@ -6,7 +6,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld 
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: asm.lisp,v 1.15 2008/02/23 22:35:08 ffjeld Exp $
+;;;; $Id: asm.lisp,v 1.16 2008/02/25 23:34:11 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -19,6 +19,9 @@
 	   #:immediate-operand
 	   #:indirect-operand-p
 	   #:indirect-operand
+	   #:indirect-operand-offset
+	   #:instruction-operands
+	   #:instruction-operator
 	   #:register-operand
 	   #:resolve-operand
 	   #:unresolved-symbol
@@ -112,6 +115,12 @@
 (defun indirect-operand-p (operand)
   (typep operand 'indirect-operand))
 
+(defun indirect-operand-offset (operand)
+  (check-type operand indirect-operand)
+  (reduce #'+ operand
+	  :key (lambda (x)
+		 (if (integerp x) x 0))))
+
 (deftype pc-relative-operand ()
   '(cons (eql :pc+)))
 



From ffjeld at common-lisp.net  Mon Feb 25 23:34:46 2008
From: ffjeld at common-lisp.net (ffjeld)
Date: Mon, 25 Feb 2008 18:34:46 -0500 (EST)
Subject: [movitz-cvs] CVS movitz
Message-ID: <20080225233446.58F712D17E@common-lisp.net>

Update of /project/movitz/cvsroot/movitz
In directory clnet:/tmp/cvs-serv13638

Modified Files:
	packages.lisp 
Log Message:
Insane hack to make asdf work. Someone please make sense of this.


--- /project/movitz/cvsroot/movitz/packages.lisp	2007/03/01 17:49:44	1.56
+++ /project/movitz/cvsroot/movitz/packages.lisp	2008/02/25 23:34:46	1.57
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld 
 ;;;; Created at:    Sat Nov 15 21:39:55 2003
 ;;;;                
-;;;; $Id: packages.lisp,v 1.56 2007/03/01 17:49:44 ffjeld Exp $
+;;;; $Id: packages.lisp,v 1.57 2008/02/25 23:34:46 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1276,6 +1276,11 @@
 	   #:vector-read-more-p
 	   ))
 
+(print '(muerte::un-backquote ; make asdf/sbcl realize that these symbols exists..
+	 muerte::backquote-comma
+	 muerte::backquote-comma-at
+	 muerte::backquote-comma-dot)
+       (make-broadcast-stream))
 
 (defpackage #:movitz
   (:use :common-lisp :binary-types)



From ffjeld at common-lisp.net  Mon Feb 25 23:43:24 2008
From: ffjeld at common-lisp.net (ffjeld)
Date: Mon, 25 Feb 2008 18:43:24 -0500 (EST)
Subject: [movitz-cvs] CVS binary-types
Message-ID: <20080225234324.2F4B2586D1@common-lisp.net>

Update of /project/movitz/cvsroot/binary-types
In directory clnet:/tmp/cvs-serv17193

Modified Files:
	binary-types.asd 
Log Message:
Provide.


--- /project/movitz/cvsroot/binary-types/binary-types.asd	2008/02/25 20:11:41	1.1
+++ /project/movitz/cvsroot/binary-types/binary-types.asd	2008/02/25 23:43:24	1.2
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld 
 ;;;; Created at:    Thu Jan 15 18:40:58 2004
 ;;;;                
-;;;; $Id: binary-types.asd,v 1.1 2008/02/25 20:11:41 ffjeld Exp $
+;;;; $Id: binary-types.asd,v 1.2 2008/02/25 23:43:24 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -25,4 +25,6 @@
   :author "Frode V. Fjeld"
   :license "BSD-like, see accopanying file COPYING."
   :description "A library for reading and writing binary records."
+  :perform (load-op :after (op c)
+		    (provide 'binary-types))
   :components ((:file "binary-types")))



From ffjeld at common-lisp.net  Mon Feb 25 23:43:45 2008
From: ffjeld at common-lisp.net (ffjeld)
Date: Mon, 25 Feb 2008 18:43:45 -0500 (EST)
Subject: [movitz-cvs] CVS movitz
Message-ID: <20080225234345.90B1871123@common-lisp.net>

Update of /project/movitz/cvsroot/movitz
In directory clnet:/tmp/cvs-serv17288

Modified Files:
	movitz.asd 
Log Message:
Provide.


--- /project/movitz/cvsroot/movitz/movitz.asd	2008/02/25 23:16:21	1.2
+++ /project/movitz/cvsroot/movitz/movitz.asd	2008/02/25 23:43:45	1.3
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld 
 ;;;; Created at:    Thu Jan 15 18:40:58 2004
 ;;;;                
-;;;; $Id: movitz.asd,v 1.2 2008/02/25 23:16:21 ffjeld Exp $
+;;;; $Id: movitz.asd,v 1.3 2008/02/25 23:43:45 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -28,6 +28,8 @@
   :license "BSD-like, see accopanying file COPYING."
   :description "An (dis-)assembler framework, with support for x86 in 16, 32, and 64-bit modes."
   :serial t
+  :perform (load-op :after (op c)
+		    (provide 'movitz-asm))
   :components ((:file "asm")
 	       (:file "asm-x86")))
 
@@ -43,6 +45,8 @@
   :default-component-class movitz-source-file
   :serial t
   :depends-on (binary-types movitz-asm)
+  :perform (load-op :after (op c)
+		    (provide 'movitz))
   :components ((:file "packages")
 	       (:file "movitz")
 	       (:file "parse")



From ffjeld at common-lisp.net  Wed Feb 27 20:55:50 2008
From: ffjeld at common-lisp.net (ffjeld)
Date: Wed, 27 Feb 2008 15:55:50 -0500 (EST)
Subject: [movitz-cvs] CVS movitz
Message-ID: <20080227205550.4B0AC2F069@common-lisp.net>

Update of /project/movitz/cvsroot/movitz
In directory clnet:/tmp/cvs-serv28144

Modified Files:
	asm-x86.lisp 
Log Message:
Add disassembler for sreg-modrm.


--- /project/movitz/cvsroot/movitz/asm-x86.lisp	2008/02/25 23:33:43	1.31
+++ /project/movitz/cvsroot/movitz/asm-x86.lisp	2008/02/27 20:55:50	1.32
@@ -6,7 +6,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld 
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: asm-x86.lisp,v 1.31 2008/02/25 23:33:43 ffjeld Exp $
+;;;; $Id: asm-x86.lisp,v 1.32 2008/02/27 20:55:50 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -217,7 +217,7 @@
 	     (cond
 	       ((atom body)
 		nil)
-	       ((member (car body) '(reg-modrm modrm opcode imm-modrm imm opcode-reg pc-rel moffset))
+	       ((member (car body) '(reg-modrm modrm opcode imm-modrm imm opcode-reg pc-rel moffset sreg-modrm))
 		(list body))
 	       (t (mapcan #'find-forms body)))))
     (let ((defun-name (intern (format nil "~A-~A" 'instruction-encoder operator))))
@@ -312,7 +312,7 @@
 
 
 
-(defmacro define-disassembler ((operator opcode &optional cpu-mode digit backup-p) lambda-list &body body)
+(defmacro define-disassembler ((operator opcode &optional cpu-mode digit backup-p operand-size) lambda-list &body body)
   (cond
     (digit
      `(loop for mod from #b00 to #b11
@@ -321,13 +321,13 @@
 				       (ash ,digit 3)
 				       (ash mod 6)
 				       r/m)
-	       do (define-disassembler (,operator ext-opcode ,cpu-mode nil t) ,lambda-list , at body))))
+	       do (define-disassembler (,operator ext-opcode ,cpu-mode nil t ,operand-size) ,lambda-list , at body))))
     ((symbolp lambda-list)
-      `(setf (opcode-disassembler ,opcode ,cpu-mode) (list ,backup-p ,operator ,cpu-mode ',lambda-list , at body)))
+     `(setf (opcode-disassembler ,opcode ,cpu-mode) (list ,backup-p ,operator ,(or operand-size cpu-mode) ',lambda-list , at body)))
     (t (let ((defun-name (intern (format nil "~A-~A-~X~@[-~A~]" 'disassembler operator opcode cpu-mode))))
 	 `(progn
 	    (defun ,defun-name ,lambda-list , at body)
-	    (setf (opcode-disassembler ,opcode ',cpu-mode) (list ,backup-p ,operator ',cpu-mode ',defun-name))
+	    (setf (opcode-disassembler ,opcode ',cpu-mode) (list ,backup-p ,operator ',(or operand-size cpu-mode) ',defun-name))
 	    ',defun-name)))))
 
 (defun disassemble-simple-prefix (code operator opcode operand-size address-size rex)
@@ -507,7 +507,8 @@
     (: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 :13 :r14 :r15))
     (:mm '(:mm0 :mm1 :mm2 :mm3 :mm4 :mm5 :mm6 :mm7))
-    (:xmm '(:xmm0 :xmm1 :xmm2 :xmm3 :xmm4 :xmm5 :xmm6 :xmm7))))
+    (:xmm '(:xmm0 :xmm1 :xmm2 :xmm3 :xmm4 :xmm5 :xmm6 :xmm7))
+    (:segment '(:es :cs :ss :ds :fs :gs))))
 
 (defun encode-reg/mem (operand mode)
   (check-type mode (member nil :8-bit :16-bit :32-bit :64-bit :mm :xmm))
@@ -837,12 +838,12 @@
 		 (remove nil fixed-operands))
 	  code))
 
-(defun decode-reg-modrm (code operator opcode operand-size address-size rex operand-ordering)
+(defun decode-reg-modrm (code operator opcode operand-size address-size rex operand-ordering &optional (reg-mode operand-size))
   (declare (ignore opcode rex))
   (values (list* operator
 		 (order-operands operand-ordering
 				 :reg (nth (ldb (byte 3 3) (car code))
-					   (register-set-by-mode operand-size))
+					   (register-set-by-mode reg-mode))
 				 :modrm (ecase address-size
 					  (:32-bit
 					   (code-call (decode-reg-modrm-32 code operand-size)))
@@ -1131,15 +1132,25 @@
 (defmacro reg-cr (op-reg op-cr opcode &rest extras)
   `(return-when (encode-reg-cr operator legacy-prefixes ,op-reg ,op-cr ,opcode operator-mode default-rex , at 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)))
-     (when reg-index
-       (return-values-when
-	(merge-encodings (encoded-values :opcode ,opcode
-					 :reg reg-index
-					 :rex default-rex)
-			 (encode-reg/mem ,op-modrm operator-mode))))))
+(defmacro sreg-modrm (op-sreg op-modrm opcode &rest extras)
+  `(progn
+     (assembler
+      (let* ((reg-map '(:es :cs :ss :ds :fs :gs))
+	     (reg-index (position ,op-sreg reg-map)))
+	(when reg-index
+	  (return-values-when
+	   (merge-encodings (encoded-values :opcode ,opcode
+					    :reg reg-index
+					    :rex default-rex
+					    , at extras)
+			    (encode-reg/mem ,op-modrm operator-mode))))))
+     (disassembler
+      (define-disassembler (operator ,opcode nil nil nil :16-bit)
+	  decode-reg-modrm
+	(operand-ordering operand-formals
+			  :reg ',op-sreg
+			  :modrm ',op-modrm)
+	:segment))))
 
 (defmacro moffset (opcode op-offset type fixed-operand)
   `(progn
@@ -1812,10 +1823,10 @@
   (moffset #xa0 src (uint 16) (dst :ax))
   (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))
+  (reg-modrm src dst #x89)
+  (sreg-modrm src dst #x8c)
+  (sreg-modrm dst src #x8e))
 
 (define-operator/32 :movl (src dst)
   (moffset #xa3 dst (uint 32) (src :eax))



From ffjeld at common-lisp.net  Wed Feb 27 21:22:47 2008
From: ffjeld at common-lisp.net (ffjeld)
Date: Wed, 27 Feb 2008 16:22:47 -0500 (EST)
Subject: [movitz-cvs] CVS movitz
Message-ID: <20080227212247.ED02516070@common-lisp.net>

Update of /project/movitz/cvsroot/movitz
In directory clnet:/tmp/cvs-serv661

Modified Files:
	asm-x86.lisp 
Log Message:
Add disassembler for opcode-reg-imm.


--- /project/movitz/cvsroot/movitz/asm-x86.lisp	2008/02/27 20:55:50	1.32
+++ /project/movitz/cvsroot/movitz/asm-x86.lisp	2008/02/27 21:22:47	1.33
@@ -6,7 +6,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld 
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: asm-x86.lisp,v 1.32 2008/02/27 20:55:50 ffjeld Exp $
+;;;; $Id: asm-x86.lisp,v 1.33 2008/02/27 21:22:47 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -217,7 +217,8 @@
 	     (cond
 	       ((atom body)
 		nil)
-	       ((member (car body) '(reg-modrm modrm opcode imm-modrm imm opcode-reg pc-rel moffset sreg-modrm))
+	       ((member (car body) '(reg-modrm modrm opcode imm-modrm imm opcode-reg
+				     opcode-reg-imm pc-rel moffset sreg-modrm))
 		(list body))
 	       (t (mapcan #'find-forms body)))))
     (let ((defun-name (intern (format nil "~A-~A" 'instruction-encoder operator))))
@@ -899,6 +900,15 @@
 				 :extra extra-operand))
 	  code))
 
+(defun decode-opcode-reg-imm (code operator opcode operand-size address-size rex operand-ordering imm-type)
+  (declare (ignore address-size rex))
+  (values (list* operator
+		 (order-operands operand-ordering
+				 :reg (nth (ldb (byte 3 0) opcode)
+					   (register-set-by-mode operand-size))
+				 :imm (code-call (decode-integer code imm-type))))
+	  code))
+
 (defun decode-reg-modrm-16 (code operand-size)
   (let* ((modrm (pop-code code mod/rm))
 	 (mod (ldb (byte 2 6) modrm))
@@ -1259,8 +1269,18 @@
 					   (t default-rex))))))))))
 
 (defmacro opcode-reg-imm (opcode op-reg op-imm type)
-  `(return-when
-    (encode-opcode-reg-imm operator legacy-prefixes ,opcode ,op-reg ,op-imm ',type operator-mode default-rex)))
+  `(progn
+     (assembler
+      (return-when
+       (encode-opcode-reg-imm operator legacy-prefixes ,opcode ,op-reg ,op-imm ',type operator-mode default-rex)))
+     (disassembler
+      (loop for reg from #b000 to #b111
+	 do (define-disassembler (operator (logior ,opcode reg) operator-mode)
+		decode-opcode-reg-imm
+	      (operand-ordering operand-formals
+				:reg ',op-reg
+				:imm ',op-imm)
+	      ',type)))))
 
 (defmacro far-pointer (opcode segment offset offset-type &rest extra)
   `(when (and (immediate-p ,segment)



From ffjeld at common-lisp.net  Thu Feb 28 20:09:08 2008
From: ffjeld at common-lisp.net (ffjeld)
Date: Thu, 28 Feb 2008 15:09:08 -0500 (EST)
Subject: [movitz-cvs] CVS movitz
Message-ID: <20080228200908.3358B601A8@common-lisp.net>

Update of /project/movitz/cvsroot/movitz
In directory clnet:/tmp/cvs-serv20701

Modified Files:
	asm-x86.lisp 
Log Message:
Disassemblers for reg-cr and far-pointer.


--- /project/movitz/cvsroot/movitz/asm-x86.lisp	2008/02/27 21:22:47	1.33
+++ /project/movitz/cvsroot/movitz/asm-x86.lisp	2008/02/28 20:09:08	1.34
@@ -6,7 +6,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld 
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: asm-x86.lisp,v 1.33 2008/02/27 21:22:47 ffjeld Exp $
+;;;; $Id: asm-x86.lisp,v 1.34 2008/02/28 20:09:08 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -218,7 +218,8 @@
 	       ((atom body)
 		nil)
 	       ((member (car body) '(reg-modrm modrm opcode imm-modrm imm opcode-reg
-				     opcode-reg-imm pc-rel moffset sreg-modrm))
+				     opcode-reg-imm pc-rel moffset sreg-modrm reg-cr
+				     far-pointer))
 		(list body))
 	       (t (mapcan #'find-forms body)))))
     (let ((defun-name (intern (format nil "~A-~A" 'instruction-encoder operator))))
@@ -312,6 +313,19 @@
        (set-it *opcode-disassemblers-64* opcode)))))
 
 
+(defmacro pop-code (code-place &optional context)
+  `(progn
+     (unless ,code-place
+       (error "End of byte-stream in the middle of an instruction."))
+     (let ((x (pop ,code-place)))
+     (check-type x (unsigned-byte 8) ,(format nil "an octet (context: ~A)" context))
+     x)))
+
+(defmacro code-call (form &optional (code-place (case (car form) ((funcall apply) (third form)) (t (second form)))))
+  "Execute form, then 'magically' update the code binding with the secondary return value from form."
+  `(let (tmp)
+     (declare (ignorable tmp))
+     (setf (values tmp ,code-place) ,form)))
 
 (defmacro define-disassembler ((operator opcode &optional cpu-mode digit backup-p operand-size) lambda-list &body body)
   (cond
@@ -773,20 +787,6 @@
      collect (or (getf operands key)
 		 (error "No operand ~S in ~S." key operands))))
 
-(defmacro pop-code (code-place &optional context)
-  `(progn
-     (unless ,code-place
-       (error "End of byte-stream in the middle of an instruction."))
-     (let ((x (pop ,code-place)))
-     (check-type x (unsigned-byte 8) ,(format nil "an octet (context: ~A)" context))
-     x)))
-
-(defmacro code-call (form &optional (code-place (case (car form) ((funcall apply) (third form)) (t (second form)))))
-  "Execute form, then 'magically' update the code binding with the secondary return value from form."
-  `(let (tmp)
-     (declare (ignorable tmp))
-     (setf (values tmp ,code-place) ,form)))
-
 (defun decode-integer (code type)
   "Decode an integer of specified type."
   (let* ((bit-size (cadr type))
@@ -839,6 +839,17 @@
 		 (remove nil fixed-operands))
 	  code))
 
+(defun decode-reg-cr (code operator opcode operand-size address-size rex operand-ordering)
+  (declare (ignore opcode operand-size address-size))
+  (let ((modrm (pop-code code)))
+    (values (list* operator
+		   (order-operands operand-ordering
+				   :reg (nth (ldb (byte 3 0) modrm)
+					     (register-set-by-mode (if rex :64-bit :32-bit)))
+				   :cr (nth (ldb (byte 3 3) modrm)
+					    '(:cr0 :cr1 :cr2 :cr3 :cr4 :cr5 :cr6 :cr7))))
+	    code)))
+
 (defun decode-reg-modrm (code operator opcode operand-size address-size rex operand-ordering &optional (reg-mode operand-size))
   (declare (ignore opcode rex))
   (values (list* operator
@@ -877,6 +888,15 @@
 				 :imm (code-call (decode-integer code imm-type))))
 	  code))
 
+(defun decode-far-pointer (code operator opcode operand-size address-size rex type)
+  (declare (ignore opcode operand-size address-size rex))
+  (let ((offset (code-call (decode-integer code type)))
+	(segment (code-call (decode-integer code '(uint 16)))))
+    (values (list operator
+		  segment
+		  offset)
+	    code)))
+
 (defun decode-pc-rel (code operator opcode operand-size address-size rex type)
   (declare (ignore opcode operand-size address-size rex))
   (values (list operator
@@ -1140,7 +1160,15 @@
 		     extras)))))
 
 (defmacro reg-cr (op-reg op-cr opcode &rest extras)
-  `(return-when (encode-reg-cr operator legacy-prefixes ,op-reg ,op-cr ,opcode operator-mode default-rex , at extras)))
+  `(progn
+     (assembler
+      (return-when (encode-reg-cr operator legacy-prefixes ,op-reg ,op-cr ,opcode operator-mode default-rex , at extras)))
+     (disassembler
+      (define-disassembler (operator ,opcode nil nil nil :32-bit)
+	  decode-reg-cr
+	(operand-ordering operand-formals
+			  :reg ',op-reg
+			  :cr ',op-cr)))))
 
 (defmacro sreg-modrm (op-sreg op-modrm opcode &rest extras)
   `(progn
@@ -1283,16 +1311,22 @@
 	      ',type)))))
 
 (defmacro far-pointer (opcode segment offset offset-type &rest extra)
-  `(when (and (immediate-p ,segment)
-	      (indirect-operand-p ,offset)); FIXME: should be immediate-p, change in bootblock.lisp.
-     (let ((segment (resolve-operand ,segment))
-	   (offset (resolve-operand (car ,offset))))
-       (when (and (typep segment '(uint 16))
-		  (typep offset ',offset-type))
-	 (return-when (encode (encoded-values :opcode ,opcode
-					      :immediate (append (encode-integer offset ',offset-type)
-								 (encode-integer segment '(uint 16)))
-					      , at extra)))))))
+  `(progn
+     (assembler
+      (when (and (immediate-p ,segment)
+		 (indirect-operand-p ,offset)) ; FIXME: should be immediate-p, change in bootblock.lisp.
+	(let ((segment (resolve-operand ,segment))
+	      (offset (resolve-operand (car ,offset))))
+	  (when (and (typep segment '(uint 16))
+		     (typep offset ',offset-type))
+	    (return-when (encode (encoded-values :opcode ,opcode
+						 :immediate (append (encode-integer offset ',offset-type)
+								    (encode-integer segment '(uint 16)))
+						 , at extra)))))))
+     (disassembler
+      (define-disassembler (operator ,opcode operator-mode)
+	  decode-far-pointer
+	',offset-type))))
 
 
 ;;;;;;;;;;; Pseudo-instructions
@@ -1843,10 +1877,10 @@
   (moffset #xa0 src (uint 16) (dst :ax))
   (opcode-reg-imm #xb8 dst src (xint 16))
   (imm-modrm src dst #xc7 0 (xint 16))
-  (reg-modrm dst src #x8b)
-  (reg-modrm src dst #x89)
   (sreg-modrm src dst #x8c)
-  (sreg-modrm dst src #x8e))
+  (sreg-modrm dst src #x8e)
+  (reg-modrm dst src #x8b)
+  (reg-modrm src dst #x89))
 
 (define-operator/32 :movl (src dst)
   (moffset #xa3 dst (uint 32) (src :eax))
@@ -1858,17 +1892,9 @@
 
 ;;;;;;;;;;; MOVCR
 
-(define-operator* (:32 :movcrl :64 :movcrr :dispatch :movcr) (src dst)
-  (when (eq src :cr8)
-    (reg-cr dst :cr0 #xf00f20
-	    :operand-size nil))
-  (when (eq dst :cr8)
-    (reg-cr src :cr0 #xf00f22
-	    :operand-size nil))
-  (reg-cr src dst #x0f22
-	  :operand-size nil)
-  (reg-cr dst src #x0f20
-	  :operand-size nil))
+(define-operator* (:32 :movcrl :dispatch :movcr) (src dst)
+  (reg-cr src dst #x0f22)
+  (reg-cr dst src #x0f20))
 
 ;;;;;;;;;;; MOVS
 



From ffjeld at common-lisp.net  Thu Feb 28 20:30:09 2008
From: ffjeld at common-lisp.net (ffjeld)
Date: Thu, 28 Feb 2008 15:30:09 -0500 (EST)
Subject: [movitz-cvs] CVS movitz
Message-ID: <20080228203009.7B9385F05B@common-lisp.net>

Update of /project/movitz/cvsroot/movitz
In directory clnet:/tmp/cvs-serv24114

Modified Files:
	asm-x86.lisp 
Log Message:
Disassembler for OUT instruction.


--- /project/movitz/cvsroot/movitz/asm-x86.lisp	2008/02/28 20:09:08	1.34
+++ /project/movitz/cvsroot/movitz/asm-x86.lisp	2008/02/28 20:30:09	1.35
@@ -6,7 +6,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld 
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: asm-x86.lisp,v 1.34 2008/02/28 20:09:08 ffjeld Exp $
+;;;; $Id: asm-x86.lisp,v 1.35 2008/02/28 20:30:09 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -894,7 +894,7 @@
 	(segment (code-call (decode-integer code '(uint 16)))))
     (values (list operator
 		  segment
-		  offset)
+		  (list offset))
 	    code)))
 
 (defun decode-pc-rel (code operator opcode operand-size address-size rex type)
@@ -1216,11 +1216,13 @@
 
 
 
-(defmacro opcode (opcode &optional fixed-operand &rest extras)
+(defmacro opcode (opcode &optional fixed-operand fixed-operand2 &rest extras)
   `(progn
      (assembler
       (when (and ,@(when fixed-operand
-			 `((eql , at fixed-operand))))
+			 `((eql , at fixed-operand)))
+		 ,@(when fixed-operand2
+			 `((eql , at fixed-operand2))))
 	(return-values-when
 	 (encoded-values :opcode ,opcode
 			 , at extras
@@ -1228,7 +1230,8 @@
      (disassembler
       (define-disassembler (operator ,opcode)
 	  decode-no-operands
-	,(second fixed-operand)))))
+	,(second fixed-operand)
+	,(second fixed-operand2)))))
 
 (defmacro opcode* (opcode &rest extras)
   `(return-values-when
@@ -1726,7 +1729,8 @@
 ;;;;;;;;;;; IRET
 
 (define-operator* (:16 :iret :32 :iretd :64 :iretq) ()
-  (opcode #xcf () :rex default-rex))
+  (opcode #xcf () ()
+	  :rex default-rex))
 
 ;;;;;;;;;;; Jcc
 
@@ -1964,28 +1968,16 @@
 ;;;;;;;;;;; OUT
 
 (define-operator/8 :outb (src port)
-  (when (eq :al src)
-    (typecase port
-      ((eql :dx)
-       (opcode #xee))
-      ((uint 8)
-       (imm port #xe6 (uint 8) (src :al))))))
+  (opcode #xee (src :al) (port :dx))
+  (imm port #xe6 (uint 8) (src :al)))
 
 (define-operator/16 :outw (src port)
-  (when (eq :ax src)
-    (typecase port
-      ((eql :dx)
-       (opcode #xef))
-      ((uint 8)
-       (imm port #xe7 (uint 8) (src :ax))))))
+  (opcode #xef (src :ax) (port :dx))
+  (imm port #xe7 (uint 8) (src :ax)))
 
 (define-operator/32 :outl (src port)
-  (when (eq :eax src)
-    (typecase port
-      ((eql :dx)
-       (opcode #xef))
-      ((uint 8)
-       (imm port #xe7 (uint 8) (src :eax))))))
+  (opcode #xef (src :eax) (port :dx))
+  (imm port #xe7 (uint 8) (src :eax)))
 
 ;;;;;;;;;;; POP
 



From ffjeld at common-lisp.net  Thu Feb 28 20:33:06 2008
From: ffjeld at common-lisp.net (ffjeld)
Date: Thu, 28 Feb 2008 15:33:06 -0500 (EST)
Subject: [movitz-cvs] CVS movitz
Message-ID: <20080228203306.D08A76828F@common-lisp.net>

Update of /project/movitz/cvsroot/movitz
In directory clnet:/tmp/cvs-serv24475

Modified Files:
	asm-x86.lisp 
Log Message:
Disassembler for IN instruction.


--- /project/movitz/cvsroot/movitz/asm-x86.lisp	2008/02/28 20:30:09	1.35
+++ /project/movitz/cvsroot/movitz/asm-x86.lisp	2008/02/28 20:33:06	1.36
@@ -6,7 +6,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld 
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: asm-x86.lisp,v 1.35 2008/02/28 20:30:09 ffjeld Exp $
+;;;; $Id: asm-x86.lisp,v 1.36 2008/02/28 20:33:06 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1674,28 +1674,16 @@
 ;;;;;;;;;;; IN
 
 (define-operator/8 :inb (port dst)
-  (when (eq :al dst)
-    (typecase port
-      ((eql :dx)
-       (opcode #xec))
-      ((uint 8)
-       (imm port #xe4 (uint 8) (dst :al))))))
+  (opcode #xec (port :dx) (dst :al))
+  (imm port #xe4 (uint 8) (dst :al)))
 
 (define-operator/16 :inw (port dst)
-  (when (eq :ax dst)
-    (typecase port
-      ((eql :dx)
-       (opcode #xed))
-      ((uint 8)
-       (imm port #xe5 (uint 8) (dst :ax))))))
+  (opcode #xed (port :dx) (dst :ax))
+  (imm port #xe5 (uint 8) (dst :ax)))
 
 (define-operator/32 :inl (port dst)
-  (when (eq :eax dst)
-    (typecase port
-      ((eql :dx)
-       (opcode #xed))
-      ((uint 8)
-       (imm port #xe5 (uint 8) (dst :eax))))))
+  (opcode #xed (port :dx) (dst :eax))
+  (imm port #xe5 (uint 8) (dst :eax)))
 
 ;;;;;;;;;;; INC