movitz-cvs

movitz-cvs@common-lisp.net

2595 discussions

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 07 Mar '08

07 Mar '08

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv13658 Modified Files: basic-functions.lisp Log Message: Implement macro destructuring-bind. --- /project/movitz/cvsroot/movitz/losp/muerte/basic-functions.lisp 2007/02/19 20:24:51 1.22 +++ /project/movitz/cvsroot/movitz/losp/muerte/basic-functions.lisp 2008/03/07 23:38:19 1.23 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Sep 4 18:41:57 2001 ;;;; -;;;; $Id: basic-functions.lisp,v 1.22 2007/02/19 20:24:51 ffjeld Exp $ +;;;; $Id: basic-functions.lisp,v 1.23 2008/03/07 23:38:19 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -48,6 +48,33 @@ (:movl :ecx :eax))) +(defun d-bind-veryfy-keys (args keys) + (do ((allow-allow-p t) + (mismatches nil)) + ((null args) + (when mismatches + (error "Unexpected destructuring keys ~{~S~^, ~}, expected ~{~S~^, ~}." + mismatches keys))) + (let ((a (pop args)) + (v (pop args))) + (cond + ((eq a :allow-other-keys) + (when (and v allow-allow-p) + (return)) + (setf allow-allow-p nil)) + ((not (member a keys)) + (pushnew a mismatches)))))) + +(defun d-bind-lookup-key (key list) + (do () + ((endp list) + nil) + (unless (cdr list) + (error "Odd number of keyword arguments.")) + (when (eq key (pop list)) + (return list)) + (setf list (cdr list)))) + (defmacro numargs () `(with-inline-assembly (:returns :ecx) (:movzxb :cl :ecx)

1 0

[movitz-cvs] CVS movitz/losp
by ffjeld 07 Mar '08

07 Mar '08

Update of /project/movitz/cvsroot/movitz/losp In directory clnet:/tmp/cvs-serv13632 Modified Files: scratch.lisp Log Message: Implement macro destructuring-bind. --- /project/movitz/cvsroot/movitz/losp/scratch.lisp 2008/02/23 22:28:55 1.3 +++ /project/movitz/cvsroot/movitz/losp/scratch.lisp 2008/03/07 23:38:16 1.4 @@ -7,7 +7,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: scratch.lisp,v 1.3 2008/02/23 22:28:55 ffjeld Exp $ +;;;; $Id: scratch.lisp,v 1.4 2008/03/07 23:38:16 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -15,6 +15,16 @@ (in-package los0) +(defun test-bq (x y) + `(+ ,x ,y)) + + +#+ignore +(defun d-bind (x) + (destructuring-bind (a (b &optional c) d &rest e &key f) + x + (values a b c d e f))) + #+ignore (defun set.2 () (let ((*var-used-in-set-tests* 'a)

1 0

[movitz-cvs] CVS movitz
by ffjeld 06 Mar '08

06 Mar '08

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv11934 Modified Files: compiler.lisp Log Message: Specify asm-x86:*cpu-mode* :32-bit. --- /project/movitz/cvsroot/movitz/compiler.lisp 2008/02/23 22:36:21 1.193 +++ /project/movitz/cvsroot/movitz/compiler.lisp 2008/03/06 21:14:22 1.194 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.193 2008/02/23 22:36:21 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.194 2008/03/06 21:14:22 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -143,7 +143,8 @@ (resolved-code (finalize-code body-code nil nil))) (multiple-value-bind (code-vector symtab) - (let ((asm:*instruction-compute-extra-prefix-map* + (let ((asm-x86:*cpu-mode* :32-bit) + (asm:*instruction-compute-extra-prefix-map* '((:call . compute-call-extra-prefix)))) (asm:assemble-proglist (translate-program resolved-code :muerte.cl :cl) :symtab (list (cons :nil-value (image-nil-word *image*))))) @@ -993,7 +994,8 @@ (defun assemble-funobj (funobj combined-code) (multiple-value-bind (code-vector code-symtab) - (let ((asm:*instruction-compute-extra-prefix-map* + (let ((asm-x86:*cpu-mode* :32-bit) + (asm:*instruction-compute-extra-prefix-map* '((:call . compute-call-extra-prefix)))) (asm:assemble-proglist combined-code :symtab (list* (cons :nil-value (image-nil-word *image*))

1 0

[movitz-cvs] CVS movitz
by ffjeld 06 Mar '08

06 Mar '08

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv14059 Modified Files: asm.lisp Log Message: Add disassemble-proglist*. --- /project/movitz/cvsroot/movitz/asm.lisp 2008/02/25 23:34:11 1.16 +++ /project/movitz/cvsroot/movitz/asm.lisp 2008/03/06 19:18:51 1.17 @@ -6,7 +6,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: asm.lisp,v 1.16 2008/02/25 23:34:11 ffjeld Exp $ +;;;; $Id: asm.lisp,v 1.17 2008/03/06 19:18:51 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -259,6 +259,9 @@ nil)) (defun disassemble-proglist (code &key (cpu-package '#:asm-x86) (pc (or *pc* 0)) (symtab *symtab*) collect-data collect-labels) + "Return a proglist (i.e. a list of instructions), or a list of (cons instruction data) if collect-data is true, +data being the octets corresponding to that instruction. Labels will be included in the proglist if collect-labels is true. +Secondarily, return the symtab." (let* ((instruction-disassembler (find-symbol (string '#:disassemble-instruction) cpu-package)) (proglist0 (loop while code @@ -272,7 +275,6 @@ 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 @@ -298,3 +300,18 @@ instruction data-instruction)) symtab))) + +(defun disassemble-proglist* (code &key (cpu-package '#:asm-x86) (pc 0)) + "Print a human-readable disassembly of code." + (multiple-value-bind (proglist symtab) + (disassemble-proglist code + :cpu-package cpu-package + :collect-data t) + (format t "~&~:{~4X: ~20<~{ ~2,'0X~}~;~> ~A~%~}" + (loop with pc = pc + for (data . instruction) in proglist + when (let ((x (find pc symtab :key #'cdr))) + (when x (list pc (list (format nil " ~A" (car x))) ""))) + collect it + collect (list pc data instruction) + do (incf pc (length data))))))

1 0

[movitz-cvs] CVS movitz
by ffjeld 06 Mar '08

06 Mar '08

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv13555 Modified Files: asm-x86.lisp Log Message: Fix disassembly of pc-rel and far-pointer. --- /project/movitz/cvsroot/movitz/asm-x86.lisp 2008/02/28 20:33:06 1.36 +++ /project/movitz/cvsroot/movitz/asm-x86.lisp 2008/03/06 19:14:39 1.37 @@ -6,7 +6,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: asm-x86.lisp,v 1.36 2008/02/28 20:33:06 ffjeld Exp $ +;;;; $Id: asm-x86.lisp,v 1.37 2008/03/06 19:14:39 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -941,14 +941,14 @@ (ecase mod (#b00 (case r/m - (#b110 (code-call (decode-integer code '(uint 16)))) + (#b110 (list (code-call (decode-integer code '(uint 16))))) (t (operands r/m)))) (#b01 (append (operands r/m) - (code-call (decode-integer code '(sint 8))))) + (list (code-call (decode-integer code '(sint 8)))))) (#b10 (append (operands r/m) - (code-call (decode-integer code '(uint 16)))))))) + (list (code-call (decode-integer code '(uint 16))))))))) code))) (defun decode-reg-modrm-32 (code operand-size) @@ -1088,12 +1088,12 @@ (assert (= code-size (length code))) (append extra-prefixes code)))))))))) -(defmacro pc-rel (opcode operand type &rest extras) +(defmacro pc-rel (opcode operand type &optional (mode 'operator-mode) &rest extras) `(progn (assembler (return-when (encode-pc-rel operator legacy-prefixes ,opcode ,operand ',type ,@extras))) (disassembler - (define-disassembler (operator ,opcode operator-mode) + (define-disassembler (operator ,opcode ,mode) decode-pc-rel ',type)))) @@ -1313,7 +1313,7 @@ :imm ',op-imm) ',type))))) -(defmacro far-pointer (opcode segment offset offset-type &rest extra) +(defmacro far-pointer (opcode segment offset offset-type &optional mode &rest extra) `(progn (assembler (when (and (immediate-p ,segment) @@ -1327,7 +1327,7 @@ (encode-integer segment '(uint 16))) ,@extra))))))) (disassembler - (define-disassembler (operator ,opcode operator-mode) + (define-disassembler (operator ,opcode ,(or mode 'operator-mode)) decode-far-pointer ',offset-type)))) @@ -1728,9 +1728,9 @@ (when (or (and (eq *cpu-mode* :32-bit) *use-jcc-16-bit-p*) (eq *cpu-mode* :16-bit)) - (pc-rel ,opcode2 dst (sint 16) + (pc-rel ,opcode2 dst (sint 16) nil :operand-size :16-bit)) - (pc-rel ,opcode2 dst (sint 32) + (pc-rel ,opcode2 dst (sint 32) nil :operand-size (case *cpu-mode* ((:16-bit :32-bit) :32-bit))))) @@ -1768,7 +1768,7 @@ (define-jcc :jz #x74) (define-operator* (:16 :jcxz :32 :jecxz :64 :jrcxz) (dst) - (pc-rel #xe3 dst (sint 8) + (pc-rel #xe3 dst (sint 8) nil :operand-size operator-mode :rex default-rex)) @@ -1778,16 +1778,16 @@ (cond (dst (when (eq *cpu-mode* :16-bit) - (far-pointer #xea seg-dst dst (uint 16))) + (far-pointer #xea seg-dst dst (uint 16) :16-bit)) (when (eq *cpu-mode* :32-bit) - (far-pointer #xea seg-dst dst (xint 32)))) + (far-pointer #xea seg-dst dst (xint 32) :32-bit))) (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)) + (pc-rel #xe9 dst (sint 16) :16-bit)) + (pc-rel #xe9 dst (sint 32) :32-bit) (when (or (not *position-independent-p*) (indirect-operand-p dst)) (let ((operator-mode :32-bit))

1 0

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

03 Mar '08

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv26370 Modified Files: bootblock.lisp Log Message: Make bootblock construction work: use 16-bit call targets in 16-bit mode (assembler problem). --- /project/movitz/cvsroot/movitz/bootblock.lisp 2008/02/18 22:30:21 1.15 +++ /project/movitz/cvsroot/movitz/bootblock.lisp 2008/03/03 22:40:55 1.16 @@ -9,7 +9,7 @@ ;;;; Created at: Mon Oct 9 20:47:19 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: bootblock.lisp,v 1.15 2008/02/18 22:30:21 ffjeld Exp $ +;;;; $Id: bootblock.lisp,v 1.16 2008/03/03 22:40:55 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -96,19 +96,19 @@ (:movw #xfffc :bp) (:leaw (:bp ,(- +stack-frame-size+)) :sp) (:movw 'welcome :si) ; Print welcome message) - (:call 'print) + (:callw 'print) ;; ;; Enable the A20 gate ;; - (:call 'empty-8042) + (:callw 'empty-8042) (:movb #xd1 :al) (:outb :al #x64) - (:call 'empty-8042) + (:callw 'empty-8042) (:movb #xdf :al) (:outb :al #x60) - (:call 'empty-8042) + (:callw 'empty-8042) ;; Poll the floppy's sectors per track @@ -140,7 +140,7 @@ (:jg 'read-done) (:movw 'track-start-msg :si) ; Print '(' to screen for each track - (:call 'print) + (:callw 'print) (:movw (:bp ,+linear-sector+) :ax) (:movb (:bp ,+sectors-per-track+) :cl) @@ -205,7 +205,7 @@ (:jnz 'copy-loop) (:movw 'track-end-msg :si) ; Print ')' to screen after each track - (:call 'print) + (:callw 'print) (:jmp 'read-loop) @@ -216,7 +216,7 @@ (:jc 'motor-loop) (:movw 'entering :si) ; Print welcome message - (:call 'print) + (:callw 'print) ;; Read the cursor position into DH (row) and DL (column). (:movb 3 :ah) @@ -261,7 +261,7 @@ ;; read-error (:movw 'error :si) ; Print error message - (:call 'print) + (:callw 'print) halt-cpu (:halt) (:jmp 'halt-cpu) ; Infinite loop @@ -270,11 +270,11 @@ ;; Empty the 8042 Keyboard controller ;; empty-8042 - (:call 'delay) + (:callw 'delay) (:inb #x64 :al) ; 8042 status port (:testb 1 :al) ; if ( no information available ) (:jz 'no-output) ; goto no_output - (:call 'delay) + (:callw 'delay) (:inb #x60 :al) ; read it (:jmp 'empty-8042) no-output @@ -405,7 +405,8 @@ (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)) + (let ((asm-x86:*position-independent-p* nil) + (asm-x86:*cpu-mode* :32-bit)) (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.")))))

1 0

[movitz-cvs] CVS ia-x86
by ffjeld 03 Mar '08

03 Mar '08

Update of /project/movitz/cvsroot/ia-x86 In directory clnet:/tmp/cvs-serv22419 Modified Files: instr-shift.lisp Log Message: Add instruction RCR. --- /project/movitz/cvsroot/ia-x86/instr-shift.lisp 2004/01/16 11:54:14 1.2 +++ /project/movitz/cvsroot/ia-x86/instr-shift.lisp 2008/03/03 22:22:17 1.3 @@ -1,6 +1,6 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 20012000, 2002, +;;;; Copyright (C) 20012000, 2002, 2005, ;;;; Department of Computer Science, University of Tromso, Norway ;;;; ;;;; Filename: instr-shift.lisp @@ -9,7 +9,7 @@ ;;;; Created at: Tue May 2 10:56:33 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: instr-shift.lisp,v 1.2 2004/01/16 11:54:14 ffjeld Exp $ +;;;; $Id: instr-shift.lisp,v 1.3 2008/03/03 22:22:17 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -138,6 +138,25 @@ (:digit (#xd3 0) 0 (cl r/m32) :operand-mode :32-bit) (:digit (#xc1 0) 1 (imm8 r/m32) :operand-mode :32-bit)) +;;; Rotate right with CF + +(def-instr rcr (instruction)) + +(def-instr rcrb (shl) + (:digit (#xd0 2) 0 (1 r/m8)) + (:digit (#xd2 2) 0 (cl r/m8)) + (:digit (#xc0 2) 1 (imm8 r/m8))) + +(def-instr rcrw (rcr) + (:digit (#xd1 3) 0 (1 r/m16) :operand-mode :16-bit) + (:digit (#xd3 3) 0 (cl r/m16) :operand-mode :16-bit) + (:digit (#xc1 3) 1 (imm8 r/m16) :operand-mode :16-bit)) + +(def-instr rcrl (rcr) + (:digit (#xd1 3) 0 (1 r/m32) :operand-mode :32-bit) + (:digit (#xd3 3) 0 (cl r/m32) :operand-mode :32-bit) + (:digit (#xc1 3) 1 (imm8 r/m32) :operand-mode :32-bit)) + ;;; Rotate right without CF (def-instr ror (instruction))

1 0

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

28 Feb '08

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

1 0

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

28 Feb '08

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 <frodef(a)acm.org> ;;;; 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 ,@fixed-operand)))) + `((eql ,@fixed-operand))) + ,@(when fixed-operand2 + `((eql ,@fixed-operand2)))) (return-values-when (encoded-values :opcode ,opcode ,@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

1 0

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

28 Feb '08

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 <frodef(a)acm.org> ;;;; 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 ,@extras))) + `(progn + (assembler + (return-when (encode-reg-cr operator legacy-prefixes ,op-reg ,op-cr ,opcode operator-mode default-rex ,@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))) - ,@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))) + ,@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

1 0

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

movitz-cvs