[movitz-cvs] CVS update: movitz/compiler.lisp
Frode Vatvedt Fjeld
ffjeld at common-lisp.net
Thu Sep 2 09:16:44 UTC 2004
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
More information about the Movitz-cvs
mailing list