movitz-cvs February 2008

movitz-cvs@common-lisp.net

1 participants
66 discussions

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

14 Feb '08

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 <frodef(a)acm.org> ;;;; 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 ,@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 ,@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

1 0

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

13 Feb '08

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 <frodef(a)acm.org> ;;;; 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 ,@lambda-list) - (declare (ignorable operator legacy-prefixes)) - (let ((operator-mode nil) - (default-rex nil)) - (declare (ignorable operator-mode default-rex)) - (block operator - ,@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 ,@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 ,@body))) + (block operator + ,@body + (values nil 'fail))))) + (setf (gethash ',operator *instruction-encoders*) + ',defun-name) + (macrolet ((disassembler (&body body) + `(progn ,@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 ,@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 ,@args))))) ,@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 ,@args))))) ,@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 ,@args))))) ,@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 ,@args))))) ,@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)) ,@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 ,@extras))) + `(progn + (assembler + (return-when (encode-reg-modrm operator legacy-prefixes ,op-reg ,op-modrm ,opcode + operator-mode default-rex ,reg/mem-mode ,@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]

1 0

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

09 Feb '08

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)))))) - ,@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) - ,@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))

1 0

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

09 Feb '08

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]

1 0

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

09 Feb '08

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)

1 0

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

09 Feb '08

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 <frodef(a)acm.org> ;;;; 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 ,@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)) ,@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 ,@body32)) ,(when |64| - `(define-operator/64 ,|64| ,args ,@body64))))) - + `(define-operator/64 ,|64| ,args ,@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))) + ,@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)

1 0

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

09 Feb '08

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 <frodef(a)acm.org> ;;;; 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))) ;;;;;;;;;;;;

1 0

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

05 Feb '08

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 <frodef(a)acm.org> ;;;; 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 ,@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 ,@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))

1 0

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

04 Feb '08

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-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

1 0

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

04 Feb '08

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-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 <frodef(a)acm.org> ;;;; 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*))))))))

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

movitz-cvs February 2008