September 2004 - movitz-cvs@common-lisp.net

[movitz-cvs] CVS update: movitz/special-operators-cl.lisp
by Frode Vatvedt Fjeld 02 Sep '04

02 Sep '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv19093 Modified Files: special-operators-cl.lisp Log Message: Implement the new stack-discipline-obeyant push/pop-current-values scheme. Date: Thu Sep 2 11:27:32 2004 Author: ffjeld Index: movitz/special-operators-cl.lisp diff -u movitz/special-operators-cl.lisp:1.21 movitz/special-operators-cl.lisp:1.22 --- movitz/special-operators-cl.lisp:1.21 Thu Aug 12 19:26:49 2004 +++ movitz/special-operators-cl.lisp Thu Sep 2 11:27:32 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Nov 24 16:31:11 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: special-operators-cl.lisp,v 1.21 2004/08/12 17:26:49 ffjeld Exp $ +;;;; $Id: special-operators-cl.lisp,v 1.22 2004/09/02 09:27:32 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -389,7 +389,8 @@ (numargs-binding (movitz-env-add-binding local-env (make-instance 'located-binding :name (gensym "m-v-numargs-")))) - (arg-code (loop for subform in subforms collecting + (arg-code (loop for subform in subforms + collecting (compiler-values-bind (&code subform-code &returns subform-returns) (compiler-call #'compile-form-unprotected :defaults all @@ -400,10 +401,10 @@ (:multiple-values `(:multiple ,@subform-code - (:globally (:call (:edi (:edi-offset push-current-values)))) + ,@(make-compiled-push-current-values) (:load-lexical ,numargs-binding :eax) - (:leal ((:ecx ,+movitz-fixnum-factor+) :eax) :eax) - (:store-lexical ,numargs-binding :eax :type t))) + (:addl :ecx :eax) + (:store-lexical ,numargs-binding :eax :type fixnum))) (t (list :single ; marker, used below subform)))))) (number-of-multiple-value-subforms (count :multiple arg-code :key #'car)) @@ -416,7 +417,7 @@ (t (compiler-values () :returns :multiple-values :code (append `((:load-constant ,(1+ number-of-single-value-subforms) :eax) - (:store-lexical ,numargs-binding :eax :type t)) + (:store-lexical ,numargs-binding :eax :type fixnum)) (compiler-call #'compile-form :defaults all :env local-env @@ -433,16 +434,17 @@ (:multiple (cdr ac)))) `((:load-lexical ,numargs-binding :ecx) + ;; (:store-lexical ,numargs-binding :ecx :type t) + (:movl (:esp (:ecx 1) -4) :eax) + (:movl (:esp (:ecx 1) -8) :ebx) (:shrl ,+movitz-fixnum-shift+ :ecx) - (:store-lexical ,numargs-binding :ecx :type t) - (:movl (:esp (:ecx 4) -4) :eax) - (:movl (:esp (:ecx 4) -8) :ebx) (:load-constant muerte.cl::funcall :edx) (:movl (:edx ,(slot-offset 'movitz-symbol 'function-value)) :esi) ; load new funobj from symbol into ESI (:call (:esi ,(slot-offset 'movitz-funobj 'code-vector))) (:load-lexical ,numargs-binding :edx) - (:leal (:esp (:edx 4)) :esp))))))))) + ;; Use LEA so as not to modify CF + (:leal (:esp :edx) :esp)))))))))

1 0

[movitz-cvs] CVS update: movitz/packages.lisp
by Frode Vatvedt Fjeld 02 Sep '04

02 Sep '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv18965 Modified Files: packages.lisp Log Message: *** empty log message *** Date: Thu Sep 2 11:25:36 2004 Author: ffjeld Index: movitz/packages.lisp diff -u movitz/packages.lisp:1.36 movitz/packages.lisp:1.37 --- movitz/packages.lisp:1.36 Tue Aug 10 15:03:06 2004 +++ movitz/packages.lisp Thu Sep 2 11:25:35 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sat Nov 15 21:39:55 2003 ;;;; -;;;; $Id: packages.lisp,v 1.36 2004/08/10 13:03:06 ffjeld Exp $ +;;;; $Id: packages.lisp,v 1.37 2004/09/02 09:25:35 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1269,6 +1269,7 @@ #:%io-port-write-succession #:with-io-register-syntax #:with-register-syntax + #:without-interrupts #:cpu-id #:cpu-486-class-p #:cpu-586-class-p

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/primitive-functions.lisp
by Frode Vatvedt Fjeld 02 Sep '04

02 Sep '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv17335 Modified Files: primitive-functions.lisp Log Message: Removed PF push-current-values, because it's incompatible with the stack discipline. Also, changed the semantics of PF pop-current-values quite a bit. Date: Thu Sep 2 11:21:31 2004 Author: ffjeld Index: movitz/losp/muerte/primitive-functions.lisp diff -u movitz/losp/muerte/primitive-functions.lisp:1.40 movitz/losp/muerte/primitive-functions.lisp:1.41 --- movitz/losp/muerte/primitive-functions.lisp:1.40 Mon Aug 23 15:51:57 2004 +++ movitz/losp/muerte/primitive-functions.lisp Thu Sep 2 11:21:31 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Oct 2 21:02:18 2001 ;;;; -;;;; $Id: primitive-functions.lisp,v 1.40 2004/08/23 13:51:57 ffjeld Exp $ +;;;; $Id: primitive-functions.lisp,v 1.41 2004/09/02 09:21:31 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -122,7 +122,7 @@ (with-inline-assembly (:returns :push) (:pushl :ebp) (:movl :esp :ebp) ; set up a pseudo stack-frame - (:pushl 4) + (:pushl :edi) (:globally (:movl (:edi (:edi-offset unwind-protect-tag)) :edx)) (:locally (:movl (:edi (:edi-offset dynamic-env)) :ecx)) @@ -637,77 +637,45 @@ (find-class 'basic-restart)) (t (find-class 'illegal-object)))) -(define-primitive-function push-current-values () - "Push all current return-values on the stack. And, return number -of values in ECX." - (with-inline-assembly (:returns :multiple-values) - (:jc 'maybe-not-exactly-one-value) - (:popl :edx) - (:movl 1 :ecx) - (:pushl :eax) - (:jmp :edx) ; return - maybe-not-exactly-one-value - ;; Set ECX=1 if CF=0 - (:popl :edx) ; return address - (:jecxz 'done) - (:pushl :eax) - (:cmpl 1 :ecx) - (:jbe 'done) - (:pushl :ebx) - (:cmpl 2 :ecx) - (:jbe 'done) - (:subl 2 :ecx) - (:leal (:edi #.(movitz::global-constant-offset 'values)) :eax) - (:cmpl 127 :ecx) - (:ja '(:sub-program () - (:int 62))) - push-loop - (:locally (:pushl (:eax))) - (:addl 4 :eax) - (:subl 1 :ecx) - (:jnz 'push-loop) - push-done - (:locally (:movl (:edi (:edi-offset num-values)) :ecx)) - (:testb 3 :cl) - (:jnz '(:sub-program () (:int 62))) - (:shrl #.movitz:+movitz-fixnum-shift+ :ecx) - (:addl 2 :ecx) - done - (:jmp :edx))) - (define-primitive-function pop-current-values () - "Input: ECX is number of values. Pop values into the standard -location for the current multiple values (i.e. eax, ebx, and the values thread-wide array)." - (with-inline-assembly (:returns :multiple-values) - (:cmpl 1 :ecx) + "Input: ECX is (fixnum) number of values. Pop values into the standard location +for the current multiple values (i.e. eax, ebx, CF, and the values run-time-context array). +However, ESP is *NOT* reset, this must be done by the caller. +The number of values (untagged) is returned in ECX, even if CF=0." + (with-inline-assembly (:returns :multiple-values) + (:testb #.movitz:+movitz-fixnum-zmask+ :cl) + (:jnz '(:sub-program () (:int 63))) + (:cmpl 4 :ecx) (:jb '(:sub-program (zero-values) (:stc) (:ret))) - (:popl :edx) (:je '(:sub-program (one-value) - (:popl :eax) + (:movl (:esp 4) :eax) + (:shrl #.movitz:+movitz-fixnum-shift+ :ecx) (:clc) - (:jmp :edx))) - (:cmpl 2 :ecx) + (:ret))) + (:cmpl 8 :ecx) (:je '(:sub-program (two-values) - (:popl :ebx) - (:popl :eax) + (:movl (:esp 8) :eax) + (:movl (:esp 4) :ebx) + (:shrl #.movitz:+movitz-fixnum-shift+ :ecx) (:stc) - (:jmp :edx))) + (:ret))) ;; three or more values - (:subl 2 :ecx) - (:shll #.movitz:+movitz-fixnum-shift+ :ecx) + (:subl 8 :ecx) (:locally (:movl :ecx (:edi (:edi-offset num-values)))) - (:subl #.movitz:+movitz-fixnum-factor+ :ecx) + (:subl 4 :ecx) + (:xorl :edx :edx) ; pointer into stack pop-loop - (:locally (:popl (:edi (:ecx 1) (:edi-offset values)))) - (:subl #.movitz:+movitz-fixnum-factor+ :ecx) + (:movl (:esp :edx 4) :eax) + (:locally (:movl :eax (:edi :ecx (:edi-offset values)))) + (:addl 4 :edx) + (:subl 4 :ecx) (:jnc 'pop-loop) - (:locally (:movl (:edi (:edi-offset num-values)) :ecx)) + (:leal (:edx 8) :ecx) + (:movl (:esp :edx 4) :ebx) + (:movl (:esp :edx 8) :eax) (:shrl #.movitz:+movitz-fixnum-shift+ :ecx) - (:popl :ebx) - (:popl :eax) - (:addl 2 :ecx) (:stc) - (:jmp :edx))) + (:ret))) (define-primitive-function assert-1arg () "1 argument there must be."

1 0

[movitz-cvs] CVS update: movitz/image.lisp
by Frode Vatvedt Fjeld 02 Sep '04

02 Sep '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv17309 Modified Files: image.lisp Log Message: Removed PF push-current-values, because it's incompatible with the stack discipline. Also, changed the semantics of PF pop-current-values quite a bit. Date: Thu Sep 2 11:21:14 2004 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.65 movitz/image.lisp:1.66 --- movitz/image.lisp:1.65 Wed Aug 18 11:15:14 2004 +++ movitz/image.lisp Thu Sep 2 11:21:14 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: image.lisp,v 1.65 2004/08/18 09:15:14 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.66 2004/09/02 09:21:14 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -105,25 +105,6 @@ :map-binary-write 'movitz-intern-code-vector :map-binary-read-delayed 'movitz-word-code-vector :binary-tag :primitive-function) - ;; various constants - (push-current-values - :binary-type code-vector-word - :initform nil - :map-binary-write 'movitz-intern-code-vector - :map-binary-read-delayed 'movitz-word-code-vector - :binary-tag :primitive-function) - (pop-current-values - :binary-type code-vector-word - :initform nil - :map-binary-write 'movitz-intern-code-vector - :map-binary-read-delayed 'movitz-word-code-vector - :binary-tag :primitive-function) - ;; function global constants -;;; (unbound-function -;;; :binary-type word -;;; :binary-tag :global-function -;;; :map-binary-read-delayed 'movitz-word -;;; :map-binary-write 'movitz-intern) ;; per thread parameters (dynamic-env :binary-type lu32 @@ -174,6 +155,12 @@ :map-binary-write 'movitz-read-and-intern :initform 'muerte::unbound) ;; primitive functions global constants + (pop-current-values + :binary-type code-vector-word + :initform nil + :map-binary-write 'movitz-intern-code-vector + :map-binary-read-delayed 'movitz-word-code-vector + :binary-tag :primitive-function) (dynamic-find-binding :map-binary-write 'movitz-intern-code-vector :binary-tag :primitive-function

1 0

[movitz-cvs] CVS update: movitz/compiler.lisp
by Frode Vatvedt Fjeld 02 Sep '04

02 Sep '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv17081 Modified Files: compiler.lisp Log Message: Added code to align calls such that return-addresses are distinguisable from immediate values. Date: Thu Sep 2 11:16:43 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.97 movitz/compiler.lisp:1.98 --- movitz/compiler.lisp:1.97 Thu Aug 19 02:22:02 2004 +++ movitz/compiler.lisp Thu Sep 2 11:16:42 2004 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.97 2004/08/19 00:22:02 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.98 2004/09/02 09:16:42 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -98,6 +98,28 @@ (or (member (car list) (cdr list)) (duplicatesp (cdr list))))) +(defun compute-call-extra-prefix (instr env size) + (let* ((return-pointer-tag (ldb (byte 3 0) + (+ (ia-x86::assemble-env-current-pc env) + size)))) + (cond + ((not (and (ia-x86::instruction-operands instr) + (typep (car (ia-x86::instruction-operands instr)) + 'ia-x86::operand-indirect-register) + (eq 'ia-x86::esi + (ia-x86::operand-register (car (ia-x86::instruction-operands instr)))))) + nil) + ((or (= (tag :even-fixnum) return-pointer-tag) + (= (tag :odd-fixnum) return-pointer-tag)) + ;; Insert a NOP + '(#x90)) + ((= 3 return-pointer-tag) + ;; Insert two NOPs, 3 -> 5 + '(#x90 #x90)) + ((= (tag :character) return-pointer-tag) + ;; Insert three NOPs, 2 -> 5 + '(#x90 #x90 #x90))))) + (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." @@ -113,14 +135,16 @@ (resolved-code (finalize-code body-code nil nil)) (function-code (ia-x86:read-proglist resolved-code))) (multiple-value-bind (code-vector symtab) - (ia-x86:proglist-encode :octet-vector - :32-bit - #x00000000 - function-code - :symtab-lookup - #'(lambda (label) - (case label - (:nil-value (image-nil-word *image*))))) + (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*)))))) (values (make-movitz-vector (length code-vector) :element-type 'code :initial-contents code-vector) @@ -888,27 +912,29 @@ (defun assemble-funobj (funobj combined-code) (multiple-value-bind (code-vector code-symtab) - (ia-x86:proglist-encode :octet-vector :32-bit #x00000000 - (ia-x86:read-proglist (append combined-code - `((% bytes 8 0 0 0)))) - :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 ((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 (append combined-code + #+ignore `((% bytes 8 0 0 0)))) + :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))))))))) (setf (movitz-funobj-symtab funobj) code-symtab) - (let ((code-length (- (length code-vector) 3))) - (assert (not (mismatch #(0 0 0) code-vector :start2 code-length)) () - "No space in code-vector was allocated for entry-points.") + (let ((code-length (- (length code-vector) 3 -3))) +;;; (assert (not (mismatch #(0 0 0) code-vector :start2 code-length)) () +;;; "No space in code-vector was allocated for entry-points.") (setf (fill-pointer code-vector) code-length) ;; debug info (setf (ldb (byte 1 5) (slot-value funobj 'debug-info)) @@ -921,16 +947,17 @@ (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))))) - (loop for ((entry-label slot-name) . rest) on '((entry%1op code-vector%1op) - (entry%2op code-vector%2op) - (entry%3op code-vector%3op)) + (loop for ((entry-label slot-name)) on '((entry%1op code-vector%1op) + (entry%2op code-vector%2op) + (entry%3op code-vector%3op)) do (cond ((assoc entry-label code-symtab) (let ((offset (cdr (assoc entry-label code-symtab)))) (setf (slot-value funobj slot-name) (cons offset funobj)) - (when (< offset #x100) - (vector-push offset code-vector)))) + #+ignore (when (< offset #x100) + (vector-push offset code-vector)))) + #+ignore ((some (lambda (label) (assoc label code-symtab)) (mapcar #'car rest)) (vector-push 0 code-vector)))) @@ -4394,14 +4421,16 @@ (not last-optional-p)) `((:pushl :ebx))) ; protect ebx ,@(if (optional-function-argument-init-form binding) - (append '((:pushl :ecx)) + (append `((:shll ,+movitz-fixnum-shift+ :ecx) + (:pushl :ecx)) (when (= 0 (function-argument-argnum binding)) `((:pushl :ebx))) init-code-edx `((:store-lexical ,binding :edx :type t)) (when (= 0 (function-argument-argnum binding)) `((:popl :ebx))) - `((:popl :ecx))) + `((:popl :ecx) + (:shrl ,+movitz-fixnum-shift+ :ecx))) (progn (error "Unsupported situation.") #+ignore `((:store-lexical ,binding :edi :type null)))) ,@(when (and (= 0 (function-argument-argnum binding)) @@ -5511,13 +5540,7 @@ ((:function :multiple-values :eax) :eax) (:lexical-binding - ;; We can use ECX as temporary storage, - ;; because this value will be reachable - ;; from at least one variable. - ;; XXXX But, probably we shouldn't decide - ;; on this here, rather use binding - ;; as result-mode in :load-lexical. - result-mode #+ignore :ecx) + result-mode) ((:ebx :ecx :edx :esi :push :untagged-fixnum-eax :untagged-fixnum-ecx @@ -5619,13 +5642,18 @@ :type `(eql ,movitz-obj) :final-form binding :functional-p t) - (if (eq :ignore (operator result-mode)) - (compiler-values (self-eval) - :returns :nothing - :type nil) - (compiler-values (self-eval) - :code `((:load-lexical ,binding ,result-mode)) - :returns result-mode))))) + (case (operator result-mode) + (:ignore + (compiler-values (self-eval) + :returns :nothing + :type nil)) + ((:eax :single-value :multiple-values :function) + (compiler-values (self-eval) + :code `((:load-lexical ,binding :eax)) + :returns :eax)) + (t (compiler-values (self-eval) + :code `((:load-lexical ,binding ,result-mode)) + :returns result-mode)))))) (define-compiler compile-implicit-progn (&all all &form forms &top-level-p top-level-p &result-mode result-mode) @@ -5731,6 +5759,39 @@ return-mode) `((:jmp ',to-label))))) (t (error "unknown!"))))) + +(defun make-compiled-push-current-values () + "Return code that pushes the current values onto the stack, and returns +in ECX the number of values (as fixnum)." + (let ((not-single-value (gensym "not-single-value-")) + (push-values-done (gensym "push-values-done-")) + (push-values-loop (gensym "push-values-loop-"))) + `((:jc ',not-single-value) + (:movl 4 :ecx) + (:pushl :eax) + (:jmp ',push-values-done) + ,not-single-value + (:shll ,+movitz-fixnum-shift+ :ecx) + (:jz ',push-values-done) + (:xorl :edx :edx) + (:pushl :eax) + (:addl 4 :edx) + (:cmpl :edx :ecx) + (:je ',push-values-done) + (:pushl :ebx) + (:addl 4 :edx) + (:cmpl :edx :ecx) + (:je ',push-values-done) + ,push-values-loop + (:locally (:pushl (:edi (:edi-offset values) :edx -8))) + (:addl 4 :edx) + (:cmpl :edx :ecx) + (:jne ',push-values-loop) + ,push-values-done))) + +;;;(:load-lexical ,numargs-binding :eax) +;;; (:addl :ecx :eax) +;;; (:store-lexical ,numargs-binding :eax :type fixnum)))) (defun stack-delta (inner-env outer-env) "Calculate the amount of stack-space used (in 32-bit stack slots) at the time

1 0

[movitz-cvs] CVS update: ia-x86/read.lisp
by Frode Vatvedt Fjeld 02 Sep '04

02 Sep '04

Update of /project/movitz/cvsroot/ia-x86 In directory common-lisp.net:/tmp/cvs-serv12514 Modified Files: read.lisp Log Message: Added a protocol for adding "extra" prefixes (such as NOPs) to instructions as they are inserted in a code-stream. This is needed for Movitz to be able to align call instructions such that return-addresses are distinguisable from immediate values, which is required by stack discipline. Date: Thu Sep 2 11:02:59 2004 Author: ffjeld Index: ia-x86/read.lisp diff -u ia-x86/read.lisp:1.6 ia-x86/read.lisp:1.7 --- ia-x86/read.lisp:1.6 Tue Aug 10 12:12:57 2004 +++ ia-x86/read.lisp Thu Sep 2 11:02:58 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Mon Jul 31 13:54:27 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: read.lisp,v 1.6 2004/08/10 10:12:57 ffjeld Exp $ +;;;; $Id: read.lisp,v 1.7 2004/09/02 09:02:58 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -44,6 +44,8 @@ ;;; absexpr ::= <label> | <number> | append-prg ;;; append-prg ::= program ;;; +;;; prefix ::= <segment-override> | (:size <size>) +;;; ;;; ;;; Instructions are recognized by symbol-name, so there should be no ;;; need to worry about packages etc. @@ -206,25 +208,34 @@ (t (error "Can't read operand ~S" spec)))) (defun read-prefixes (prefix-spec) - (loop for p in prefix-spec - with user-size = nil + (loop with user-size = nil with user-finalizer = nil + for p in prefix-spec if (symbolp p) collect (let ((ps (find-symbol (symbol-name p) '#:ia-x86))) (if (decode-set +prefix-opcode-map+ ps :errorp nil) ps (error "No such prefix: ~A" p))) into prefixes - else if (integerp p) - do (setf user-size p) - finally (return (values prefixes user-size)))) + else do + (check-type p list) + (ecase (car p) + (:size + (let ((size (second p))) + (check-type size integer) + (setf user-size size))) + (:finalize ; XXX + (let ((finalizer (second p))) + (check-type finalizer symbol "a function name") + (setf user-finalizer finalizer)))) + finally (return (values prefixes user-size user-finalizer)))) (defvar *find-instruction-cache* (make-hash-table :test #'eq)) (defun read-instruction (sexpr) "Parse a list into an assembly instruction." - (let (prefix-list user-size instr-name operand-list) + (let (prefix-list user-size user-finalizer instr-name operand-list) (if (listp (first sexpr)) - (setf (values prefix-list user-size) (read-prefixes (first sexpr)) + (setf (values prefix-list user-size user-finalizer) (read-prefixes (first sexpr)) instr-name (second sexpr) operand-list (nthcdr 2 sexpr)) (setf prefix-list nil @@ -244,9 +255,10 @@ (unless instr-symbol-status (error "No instruction named ~A." (string instr-name))) instr-symbol))) - 'prefixes prefix-list - 'user-size user-size - 'operands (mapcar #'read-operand operand-list)))))) + :prefixes prefix-list + :user-size user-size + :user-finalizer user-finalizer + :operands (mapcar #'read-operand operand-list)))))) (defun inline-data-p (expr) @@ -303,4 +315,4 @@ (defmacro asm (&rest spec) - `(instruction-encode (read-instruction ',spec))) + `(instruction-encode (read-instruction ',spec) nil))

1 0

[movitz-cvs] CVS update: ia-x86/proglist.lisp
by Frode Vatvedt Fjeld 02 Sep '04

02 Sep '04

Update of /project/movitz/cvsroot/ia-x86 In directory common-lisp.net:/tmp/cvs-serv12439 Modified Files: proglist.lisp Log Message: Added a protocol for adding "extra" prefixes (such as NOPs) to instructions as they are inserted in a code-stream. This is needed for Movitz to be able to align call instructions such that return-addresses are distinguisable from immediate values, which is required by stack discipline. Date: Thu Sep 2 11:02:41 2004 Author: ffjeld Index: ia-x86/proglist.lisp diff -u ia-x86/proglist.lisp:1.4 ia-x86/proglist.lisp:1.5 --- ia-x86/proglist.lisp:1.4 Tue Aug 10 12:12:52 2004 +++ ia-x86/proglist.lisp Thu Sep 2 11:02:40 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Mon May 15 13:43:55 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: proglist.lisp,v 1.4 2004/08/10 10:12:52 ffjeld Exp $ +;;;; $Id: proglist.lisp,v 1.5 2004/09/02 09:02:40 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -100,19 +100,21 @@ (make-assemble-env :symtab (assemble-env-symtab env) :current-pc referring-pc) optimize-teo))) - #+ignore (when (< (imagpart cdatum) assumed-length) + (warn "Assumption ~D bigger than actual ~D" assumed-length (imagpart cdatum)) (setf cdatum (instruction-encode instruction (make-assemble-env :symtab (assemble-env-symtab env) :current-pc referring-pc) - #'(lambda (teo-list instr) - (find-if #'(lambda (teo) + #'(lambda (teo-list instr env) + (or (find-if #'(lambda (teo) (= assumed-length (template-instr-and-prefix-length (teo-template teo) - instr))) - teo-list))))) + instr env))) + teo-list) + (error "Unable to find encoding matching size ~D for ~S" + assumed-length instr)))))) (unless (= (imagpart cdatum) assumed-length) (error 'assumption-failed 'forward-reference fwd-to-resolve @@ -144,7 +146,7 @@ (cdr placeholder-cons) (cdr cdatums))))) -(defun guess-next-instruction-length (expr missing-labels program-rest) +(defun guess-next-instruction-length (expr missing-labels program-rest env) (declare (special *proglist-minimum-expr-size*)) ;; (let ((minimum-size (max previous-length (gethash expr *proglist-minimum-expr-size*)))) (or (instruction-user-size expr) @@ -169,7 +171,7 @@ (t (loop with guesses = nil for template in (templates-lookup-by-class-name (type-of expr)) when (template-match-by-operand-classes template (instruction-operands expr)) - do (let ((l (template-instr-and-prefix-length template expr))) + do (let ((l (template-instr-and-prefix-length template expr env))) (unless (member l guesses) (setf guesses (merge 'list guesses (list l) #'<)))) @@ -190,9 +192,8 @@ (loop for fwd in forward-references when (try-resolve-forward-reference fwd env optimize-teo) collect fwd into resolved-forwards - finally (unless (null resolved-forwards) - (setf forward-references - (set-difference forward-references resolved-forwards))))) + finally (setf forward-references + (set-difference forward-references resolved-forwards)))) (ALIGNMENT (loop for cbyte in (create-alignment expr (assemble-env-current-pc env)) do (push cbyte encoded-proglist-reverse) @@ -252,7 +253,8 @@ (loop for assumed-instr-length = (guess-next-instruction-length expr (unresolved-labels-labels ul-condition) - (rest expr-rest)) + (rest expr-rest) + env) do #+ignore (warn "Trying for ~A at ~D with ~A octets.." expr (assemble-env-current-pc env) assumed-instr-length) @@ -277,7 +279,7 @@ (assumption-failed (af-condition) (unless (eq fwd (assumption-failed-forward-reference af-condition)) (error af-condition)) ; decline - #+ignore (warn "~A" af-condition) + ;; (warn "~A" af-condition) ;; pop this length off the list of instr-length guesses (assert (gethash expr *proglist-minimum-expr-size*) (expr) "Unable to encode ~A. Is the label too far away?" expr)

1 0

[movitz-cvs] CVS update: ia-x86/packages.lisp
by Frode Vatvedt Fjeld 02 Sep '04

02 Sep '04

Update of /project/movitz/cvsroot/ia-x86 In directory common-lisp.net:/tmp/cvs-serv12346 Modified Files: packages.lisp Log Message: Added a protocol for adding "extra" prefixes (such as NOPs) to instructions as they are inserted in a code-stream. This is needed for Movitz to be able to align call instructions such that return-addresses are distinguisable from immediate values, which is required by stack discipline. Date: Thu Sep 2 11:02:11 2004 Author: ffjeld Index: ia-x86/packages.lisp diff -u ia-x86/packages.lisp:1.3 ia-x86/packages.lisp:1.4 --- ia-x86/packages.lisp:1.3 Tue Feb 10 01:03:47 2004 +++ ia-x86/packages.lisp Thu Sep 2 11:02:10 2004 @@ -1,6 +1,6 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 20012000, 2002-2004, +;;;; Copyright (C) 2000-2004, ;;;; Department of Computer Science, University of Tromso, Norway ;;;; ;;;; Filename: packages.lisp @@ -9,7 +9,7 @@ ;;;; Created at: Wed Feb 16 14:02:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: packages.lisp,v 1.3 2004/02/10 00:03:47 ffjeld Exp $ +;;;; $Id: packages.lisp,v 1.4 2004/09/02 09:02:10 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -20,6 +20,7 @@ (:export #:init-instruction-tables #:*cpu-mode* + #:*instruction-compute-extra-prefix-map* #:decode-sub-stream #:decode-read-octet #:decode

1 0

[movitz-cvs] CVS update: ia-x86/operands.lisp
by Frode Vatvedt Fjeld 02 Sep '04

02 Sep '04

Update of /project/movitz/cvsroot/ia-x86 In directory common-lisp.net:/tmp/cvs-serv12279 Modified Files: operands.lisp Log Message: Added a protocol for adding "extra" prefixes (such as NOPs) to instructions as they are inserted in a code-stream. This is needed for Movitz to be able to align call instructions such that return-addresses are distinguisable from immediate values, which is required by stack discipline. Date: Thu Sep 2 11:01:49 2004 Author: ffjeld Index: ia-x86/operands.lisp diff -u ia-x86/operands.lisp:1.4 ia-x86/operands.lisp:1.5 --- ia-x86/operands.lisp:1.4 Tue Feb 10 01:03:42 2004 +++ ia-x86/operands.lisp Thu Sep 2 11:01:44 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Feb 16 14:02:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: operands.lisp,v 1.4 2004/02/10 00:03:42 ffjeld Exp $ +;;;; $Id: operands.lisp,v 1.5 2004/09/02 09:01:44 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -137,7 +137,7 @@ (defun abstract-operand-to-offset (operand template instr env) (sign-extend (mod (- (operand-resolve-to-number operand env) (assemble-env-current-pc env) - (template-instr-and-prefix-length template instr)) + (template-instr-and-prefix-length template instr env)) #x100000000) 4))

1 0

[movitz-cvs] CVS update: ia-x86/ia-x86.lisp
by Frode Vatvedt Fjeld 02 Sep '04

02 Sep '04

Update of /project/movitz/cvsroot/ia-x86 In directory common-lisp.net:/tmp/cvs-serv12217 Modified Files: ia-x86.lisp Log Message: Added a protocol for adding "extra" prefixes (such as NOPs) to instructions as they are inserted in a code-stream. This is needed for Movitz to be able to align call instructions such that return-addresses are distinguisable from immediate values, which is required by stack discipline. Date: Thu Sep 2 11:01:29 2004 Author: ffjeld Index: ia-x86/ia-x86.lisp diff -u ia-x86/ia-x86.lisp:1.3 ia-x86/ia-x86.lisp:1.4 --- ia-x86/ia-x86.lisp:1.3 Tue Feb 10 01:03:23 2004 +++ ia-x86/ia-x86.lisp Thu Sep 2 11:01:29 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 17 18:01:26 1999 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: ia-x86.lisp,v 1.3 2004/02/10 00:03:23 ffjeld Exp $ +;;;; $Id: ia-x86.lisp,v 1.4 2004/09/02 09:01:29 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -23,18 +23,22 @@ ((operands :type list :initform '() - :initarg operands + :initarg :operands :accessor instruction-operands) (prefixes :type list - :initarg prefixes + :initarg :prefixes :initform '() :accessor instruction-prefixes) (user-size - :initarg user-size + :initarg :user-size :reader instruction-user-size) + (user-finalizer + :initarg :user-finalizer + :initform nil + :reader instruction-finalizer) (original-datum - :initarg datum + :initarg :datum :accessor instruction-original-datum))) (defmethod print-object ((obj instruction) stream)

1 0