movitz-cvs February 2008

movitz-cvs@common-lisp.net

1 participants
66 discussions

[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

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

04 Feb '08

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

1 0

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

04 Feb '08

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

1 0

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

04 Feb '08

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

1 0

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

04 Feb '08

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

1 0

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

04 Feb '08

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

1 0

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

04 Feb '08

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

1 0

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

04 Feb '08

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

1 0

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