movitz-cvs

movitz-cvs@common-lisp.net

2595 discussions

[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

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

04 Feb '08

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv480 Modified Files: load.lisp Log Message: add asm. --- /project/movitz/cvsroot/movitz/load.lisp 2004/12/09 14:05:52 1.11 +++ /project/movitz/cvsroot/movitz/load.lisp 2008/02/04 21:05:23 1.12 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Thu Jan 15 18:40:58 2004 ;;;; -;;;; $Id: load.lisp,v 1.11 2004/12/09 14:05:52 ffjeld Exp $ +;;;; $Id: load.lisp,v 1.12 2008/02/04 21:05:23 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -28,6 +28,10 @@ (load (compile-file #p"../binary-types/binary-types")) +(load (compile-file #p"asm")) ; these are here for now, because +(load (compile-file #p"asm-x86")) ; ia-x86 needs them while testing/migrating. + + (let ((*default-pathname-defaults* (merge-pathnames #p"../ia-x86/"))) #+(or cmu) (let ((pwd (ext:default-directory))) (progn

1 0

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

04 Feb '08

Update of /project/movitz/cvsroot/movitz/losp In directory clnet:/tmp/cvs-serv32704 Modified Files: scratch.lisp Log Message: scratch. --- /project/movitz/cvsroot/movitz/losp/scratch.lisp 2007/04/09 17:30:21 1.1 +++ /project/movitz/cvsroot/movitz/losp/scratch.lisp 2008/02/04 21:04:51 1.2 @@ -7,7 +7,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: scratch.lisp,v 1.1 2007/04/09 17:30:21 ffjeld Exp $ +;;;; $Id: scratch.lisp,v 1.2 2008/02/04 21:04:51 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -77,6 +77,21 @@ (warn "X: ~S" (memref-int bios32)) (warn "X: ~S" (= (memref-int bios32) #x5f32335f))) +(defun setfint (x o) + (setf (memref x o :type :unsigned-byte32) 0)) + +(defun fint (x) + (memref-int x :type :unsigned-byte32 :physicalp t)) + +(defun good () + (with-inline-assembly (:returns :untagged-fixnum-ecx) + ((:gs-override) :movl (#x1000000) :ecx))) + +(defun (setf good) (x) + (with-inline-assembly (:returns :untagged-fixnum-ecx) + (:compile-form (:result-mode :untagged-fixnum-ecx) x) + ((:gs-override) :movl :ecx (#x1000000)))) + (defun test2 () (funcall (compile @@ -862,8 +877,8 @@ Can be used to measure the overhead of primitive function." (with-inline-assembly (:returns :eax) (:load-lexical (:lexical-binding x) :eax) - (% bytes 8 #xff #x97) ; (:call-local-pf ret-trampoline) - (% bytes 32 #.(bt:slot-offset 'movitz::movitz-run-time-context 'movitz::ret-trampoline)))) + (:% :bytes 8 #xff #x97) ; (:call-local-pf ret-trampoline) + (:% :bytes 32 #.(bt:slot-offset 'movitz::movitz-run-time-context 'movitz::ret-trampoline)))) (defun my-test-labels (x) (labels (#+ignore (p () (print x))

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-serv32467 Modified Files: asm-x86.lisp Log Message: Various bits and pieces, movitz now compiles (but won't boot). --- /project/movitz/cvsroot/movitz/asm-x86.lisp 2008/02/04 12:11:00 1.16 +++ /project/movitz/cvsroot/movitz/asm-x86.lisp 2008/02/04 21:03:35 1.17 @@ -6,7 +6,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: asm-x86.lisp,v 1.16 2008/02/04 12:11:00 ffjeld Exp $ +;;;; $Id: asm-x86.lisp,v 1.17 2008/02/04 21:03:35 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -182,19 +182,28 @@ address-size)) (defun encode-instruction (instruction) - (multiple-value-bind (legacy-prefixes instruction) + (multiple-value-bind (instruction legacy-prefixes options) (if (listp (car instruction)) - (values (car instruction) - (cdr instruction)) - (values nil - instruction)) + (values (cdr instruction) + (remove-if #'listp (car instruction)) + (remove-if #'keywordp (car instruction))) + (values instruction + nil + nil)) (destructuring-bind (operator &rest operands) instruction - (apply (or (gethash operator *instruction-encoders*) - (error "Unknown instruction operator ~S in ~S." operator instruction)) - operator - (mapcar #'prefix-lookup legacy-prefixes) - operands)))) + (let ((code (apply (or (gethash operator *instruction-encoders*) + (error "Unknown instruction operator ~S in ~S." operator instruction)) + operator + (mapcar #'prefix-lookup legacy-prefixes) + operands))) + (cond + ((null options) + code) + ((assoc :size options) + (assert (= (second (assoc :size options)) + (length code))) + code)))))) (defmacro define-operator (operator lambda-list &body body) @@ -202,7 +211,7 @@ (let ((defun-name (intern (format nil "~A-~A" 'instruction-encoder operator)))) `(progn (defun ,defun-name (operator legacy-prefixes ,@lambda-list) - (declare (ignorable operator)) + (declare (ignorable operator legacy-prefixes)) (let ((operator-mode nil) (default-rex nil)) (declare (ignorable operator-mode default-rex)) @@ -281,16 +290,6 @@ ,(when |64| `(define-operator/64 ,|64| ,args ,@body64))))) -(defun resolve (x) - (etypecase x - (integer - x) - (symbol-reference - (let ((s (symbol-reference-symbol x))) - (loop (with-simple-restart (retry-symbol-resolve "Retry resolving ~S." s) - (return (cdr (or (assoc s *symtab*) - (error 'unresolved-symbol - :symbol s)))))))))) (defun resolve-and-encode (x type &key size) (encode-integer (cond @@ -309,9 +308,9 @@ (etypecase operand ((cons (eql :pc+)) (reduce #'+ (cdr operand) - :key #'resolve)) + :key #'resolve-operand)) (symbol-reference - (- (resolve operand) + (- (resolve-operand operand) *pc*)))) (defun encode-integer (i type) @@ -382,7 +381,7 @@ (assert (or (not reg-scale) (and reg reg-scale))) (let ((offset (reduce #'+ offsets - :key #'resolve))) + :key #'resolve-operand))) (cond ((and (not reg) (eq mode :16-bit) @@ -631,7 +630,7 @@ (defmacro imm (imm-operand opcode imm-type &rest extras) `(when (immediate-p ,imm-operand) - (let ((immediate (resolve ,imm-operand))) + (let ((immediate (resolve-operand ,imm-operand))) (when (typep immediate ',imm-type) (return-values-when (encoded-values :opcode ,opcode @@ -642,7 +641,7 @@ (defmacro imm-modrm (op-imm op-modrm opcode digit type) `(when (immediate-p ,op-imm) - (let ((immediate (resolve ,op-imm))) + (let ((immediate (resolve-operand ,op-imm))) (when (typep immediate ',type) (return-values-when (merge-encodings (encoded-values :opcode ,opcode @@ -764,7 +763,7 @@ (return-values-when (encoded-values :opcode ,opcode :displacement (encode-integer (reduce #'+ offsets - :key #'resolve) + :key #'resolve-operand) ',type))))))) (defmacro opcode (opcode &rest extras) @@ -802,7 +801,7 @@ (defun encode-opcode-reg-imm (operator legacy-prefixes opcode op-reg op-imm type operator-mode default-rex) (when (immediate-p op-imm) - (let ((immediate (resolve op-imm))) + (let ((immediate (resolve-operand op-imm))) (when (typep immediate type) (let* ((reg-map (ecase operator-mode (:8-bit '(:al :cl :dl :bl :ah :ch :dh :bh)) @@ -827,10 +826,20 @@ (encode-opcode-reg-imm operator legacy-prefixes ,opcode ,op-reg ,op-imm ',type operator-mode default-rex))) -;;;;;;;;;;;;;;;; +;;;;;;;;;;; + +;;;;;;;;;;;;;;;; NOP + +(define-operator :% (op &rest data) + (case op + (:bytes + (let ((byte-size (pop data))) + (return-from operator + (loop for datum in data + append (loop for b from 0 below byte-size by 8 + collect (ldb (byte 8 b) + datum)))))))) -(define-operator :nop () - (opcode #x90)) ;;;;;;;;;;; ADC @@ -928,6 +937,9 @@ (define-operator/32 :callr (dest) (modrm dest #xff 2)) +(define-operator :call-segment (dest) + (modrm dest #xff 3)) + ;;;;;;;;;;; CLC, CLD, CLI, CLTS, CMC (define-operator :clc () (opcode #xf8)) @@ -1254,6 +1266,9 @@ (indirect-operand-p dst)) (modrm dst #xff 4))) +(define-operator* (:16 :jmpw-segment :32 :jmp-segment :64 :jmpr-segment) (addr) + (modrm addr #xff 5)) + ;;;;;;;;;;; LAHF, LAR (define-operator :lahf () @@ -1267,6 +1282,9 @@ ;;;;;;;;;;; LEA (define-operator* (:16 :leaw :32 :leal :64 :lear) (addr dst) + (when (and (equal addr '(:esp :edx)) ; REMOVEME: ia-x86 compat. hack!! + (eq dst :esp)) + (return-from operator '(#x8D #x64 #x14 #x00))) (reg-modrm dst addr #x8d)) ;;;;;;;;;;; LEAVE @@ -1276,10 +1294,10 @@ ;;;;;;;;;;; LGDT, LIDT -(define-operator* (:16 :lgdtw :32 :lgdtl :64 :lgdtr) (addr) +(define-operator* (:16 :lgdtw :32 :lgdt :64 :lgdtr) (addr) (modrm addr #x0f01 2)) -(define-operator* (:16 :lidtw :32 :lidtl :64 :lidtr) (addr) +(define-operator* (:16 :lidtw :32 :lidt :64 :lidtr) (addr) (modrm addr #x0f01 3)) ;;;;;;;;;;; LFENCE @@ -1373,6 +1391,11 @@ (define-operator* (:16 :negw :32 :negl :64 :negr) (dst) (modrm dst #xf7 3)) +;;;;;;;;;;;;;;;; NOP + +(define-operator :nop () + (opcode #x90)) + ;;;;;;;;;;; NOT (define-operator/8 :notb (dst) @@ -1527,6 +1550,11 @@ (reg-modrm dst subtrahend #x1b) (reg-modrm subtrahend dst #x19)) +;;;;;;;;;;; SGDT + +(define-operator/8 :sgdt (addr) + (modrm addr #x0f01 0)) + ;;;;;;;;;;; SHL (define-operator/8 :shlb (count dst) @@ -1547,7 +1575,7 @@ (when (eq :cl count) (reg-modrm dst1 dst2 #x0fa5)) (when (immediate-p count) - (let ((immediate (resolve count))) + (let ((immediate (resolve-operand count))) (when (typep immediate '(uint #x8)) (reg-modrm dst1 dst2 #x0fa4 :immediate (encode-integer count '(uint 8))))))) @@ -1572,7 +1600,7 @@ (when (eq :cl count) (reg-modrm dst1 dst2 #x0fad)) (when (immediate-p count) - (let ((immediate (resolve count))) + (let ((immediate (resolve-operand count))) (when (typep immediate '(uint #x8)) (reg-modrm dst1 dst2 #x0fac :immediate (encode-integer count '(uint 8))))))) @@ -1620,6 +1648,10 @@ (imm-modrm mask dst #xf7 0 :int-16-32-64) (reg-modrm mask dst #x85)) +;;;;;;;;;;; XCHG + +(define-operator :wrmsr () + (opcode #x0f30)) ;;;;;;;;;;; XCHG

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