[movitz-cvs] CVS update: movitz/compiler.lisp
Frode Vatvedt Fjeld
ffjeld at common-lisp.net
Thu Apr 1 02:09:27 UTC 2004
Update of /project/movitz/cvsroot/movitz
In directory common-lisp.net:/tmp/cvs-serv20779
Modified Files:
compiler.lisp
Log Message:
These changes are mostly about being more consistent about using ECX
as a scratch (non-GC-root) register.
Date: Wed Mar 31 21:09:26 2004
Author: ffjeld
Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.39 movitz/compiler.lisp:1.40
--- movitz/compiler.lisp:1.39 Wed Mar 31 10:55:31 2004
+++ movitz/compiler.lisp Wed Mar 31 21:09:26 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.39 2004/03/31 15:55:31 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.40 2004/04/01 02:09:26 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
@@ -2095,8 +2095,8 @@
(binding-name object)
(unless (eq object (binding-target object))
(binding-name (binding-target object)))
- (when (and (slot-exists-p object 'store-type)
- (slot-boundp object 'store-type)
+ (when (and #+ignore (slot-exists-p object 'store-type)
+ #+ignore (slot-boundp object 'store-type)
(binding-store-type object))
(apply #'encoded-type-decode
(binding-store-type object)))))))
@@ -2107,6 +2107,9 @@
:reader constant-object)))
(defmethod binding-lended-p ((binding constant-object-binding)) nil)
+(defmethod binding-store-type ((binding constant-object-binding))
+ (multiple-value-list (type-specifier-encode `(eql ,(constant-object binding)))))
+
(defclass operator-binding (binding) ())
@@ -2430,7 +2433,7 @@
pos)))))
(defun compute-free-registers (pc distance funobj frame-map
- &key (free-registers '(:eax :ebx :edx)))
+ &key (free-registers '(:eax :ebx :ecx :edx)))
"Return set of free register, and whether there may be more registers
free later, with a more specified frame-map."
(loop with free-so-far = free-registers
@@ -2515,16 +2518,22 @@
(distance (position load-instruction (cdr init-pc))))
(multiple-value-bind (free-registers more-later-p)
(and distance (compute-free-registers (cdr init-pc) distance funobj frame-map))
- (cond
- ((member binding-destination free-registers)
- binding-destination)
- ((member init-with-register free-registers)
- init-with-register)
- ((not (null free-registers))
- (first free-registers))
- (more-later-p
- (values nil :not-now))
- (t (values nil :never)))))))
+ (if (and (member :ecx free-registers)
+ (not (typep binding 'function-argument))
+ (or (eq :untagged-fixnum-ecx binding-destination)
+ (eq :untagged-fixnum-ecx init-with-register)))
+ :untagged-fixnum-ecx
+ (let ((free-registers (remove :ecx free-registers)))
+ (cond
+ ((member binding-destination free-registers)
+ binding-destination)
+ ((member init-with-register free-registers)
+ init-with-register)
+ ((not (null free-registers))
+ (first free-registers))
+ (more-later-p
+ (values nil :not-now))
+ (t (values nil :never)))))))))
(t (values nil :never)))))
(defun discover-variables (code function-env)
@@ -3000,6 +3009,14 @@
&key tmp-register protect-registers)
"When tmp-register is provided, use that for intermediate storage required when
loading borrowed bindings."
+ #+ignore
+ (when (eq :ecx result-mode)
+ ;; (warn "loading to ecx: ~S" binding)
+ (unless (or (null (binding-store-type binding))
+ (movitz-subtypep (apply #'encoded-type-decode
+ (binding-store-type binding))
+ 'integer))
+ (warn "ecx from ~S" binding)))
(when (movitz-env-get (binding-name binding) 'ignore nil (binding-env binding))
(warn "The variable ~S is used even if it was declared ignored."
(binding-name binding)))
@@ -3012,32 +3029,56 @@
protect-registers))
(error "Unable to chose a temporary register.")))
(install-for-single-value (lexb lexb-location result-mode indirect-p)
- (if (integerp lexb-location)
- (append `((:movl ,(make-indirect-reference :ebp (stack-frame-offset lexb-location))
- ,(single-value-register result-mode)))
- (when indirect-p
- `((:movl (-1 ,(single-value-register result-mode))
- ,(single-value-register result-mode)))))
- (ecase lexb-location
- (:eax
- (assert (not indirect-p))
- (ecase result-mode
- ((:ebx :ecx :edx :esi) `((:movl :eax ,result-mode)))
- ((:eax :single-value) nil)))
- ((:ebx :ecx :edx)
- (assert (not indirect-p))
- (unless (eq result-mode lexb-location)
+ (cond
+ ((and (eq result-mode :untagged-fixnum-ecx)
+ (integerp lexb-location))
+ (assert (not indirect-p))
+ `((:movl ,(make-indirect-reference :ebp (stack-frame-offset lexb-location))
+ :ecx)
+ (:sarl ,+movitz-fixnum-shift+ :ecx)))
+ ((integerp lexb-location)
+ (append `((:movl ,(make-indirect-reference :ebp (stack-frame-offset lexb-location))
+ ,(single-value-register result-mode)))
+ (when indirect-p
+ `((:movl (-1 ,(single-value-register result-mode))
+ ,(single-value-register result-mode))))))
+ (t (ecase lexb-location
+ (:eax
+ (assert (not indirect-p))
(ecase result-mode
- ((:eax :single-value) `((:movl ,lexb-location :eax)))
- ((:ebx :ecx :edx :esi) `((:movl ,lexb-location ,result-mode))))))
- (:argument-stack
- (assert (<= 2 (function-argument-argnum lexb)) ()
- "lexical :argument-stack argnum can't be ~A." (function-argument-argnum lexb))
- (append `((:movl (:ebp ,(argument-stack-offset lexb))
- ,(single-value-register result-mode)))
- (when indirect-p
- `((:movl (-1 ,(single-value-register result-mode))
- ,(single-value-register result-mode))))))))))
+ ((:ebx :ecx :edx :esi) `((:movl :eax ,result-mode)))
+ ((:eax :single-value) nil)
+ (:untagged-fixnum-ecx
+ `((:movl :eax :ecx)
+ (:sarl ,movitz:+movitz-fixnum-factor+ :ecx)))))
+ ((:ebx :ecx :edx)
+ (assert (not indirect-p))
+ (unless (eq result-mode lexb-location)
+ (ecase result-mode
+ ((:eax :single-value) `((:movl ,lexb-location :eax)))
+ ((:ebx :ecx :edx :esi) `((:movl ,lexb-location ,result-mode)))
+ (:untagged-fixnum-ecx
+ `((:movl ,lexb-location :ecx)
+ (:sarl ,movitz:+movitz-fixnum-factor+ :ecx))))))
+ (:argument-stack
+ (assert (<= 2 (function-argument-argnum lexb)) ()
+ "lexical :argument-stack argnum can't be ~A." (function-argument-argnum lexb))
+ (cond
+ ((eq result-mode :untagged-fixnum-ecx)
+ (assert (not indirect-p))
+ `((:movl (:ebp ,(argument-stack-offset lexb)) :ecx)
+ (:sarl ,+movitz-fixnum-shift+ :ecx)))
+ (t (append `((:movl (:ebp ,(argument-stack-offset lexb))
+ ,(single-value-register result-mode)))
+ (when indirect-p
+ `((:movl (-1 ,(single-value-register result-mode))
+ ,(single-value-register result-mode))))))))
+ (:untagged-fixnum-ecx
+ (ecase result-mode
+ ((:eax :ebx :ecx :edx)
+ `((:leal ((:ecx ,+movitz-fixnum-factor+)) ,result-mode)))
+ (:untagged-fixnum-ecx
+ nil))))))))
(etypecase binding
(forwarding-binding
(assert (not (binding-lended-p binding)) (binding)
@@ -3138,9 +3179,7 @@
`((:cmpl :edi (:ebp ,(argument-stack-offset binding)))
(:je ',(operands result-mode)))))))
(:untagged-fixnum-ecx
- (make-result-and-returns-glue
- result-mode :ecx
- (install-for-single-value binding binding-location :ecx nil)))
+ (install-for-single-value binding binding-location :untagged-fixnum-ecx nil))
(:lexical-binding
(let* ((destination result-mode)
(dest-location (new-binding-location destination frame-map :default nil)))
@@ -3174,6 +3213,13 @@
"funny binding: ~W" binding)
(let ((protect-registers (cons source protect-registers)))
(cond
+ ((eq :untagged-fixnum-ecx source)
+ (if (eq :untagged-fixnum-ecx
+ (new-binding-location binding frame-map))
+ nil
+ (append (make-result-and-returns-glue :ecx :untagged-fixnum-ecx)
+ (make-store-lexical binding :ecx shared-reference-p frame-map
+ :protect-registers protect-registers))))
((typep binding 'borrowed-binding)
(let ((slot (borrowed-binding-reference-slot binding)))
(if (not shared-reference-p)
@@ -3214,7 +3260,12 @@
(:argument-stack
(assert (<= 2 (function-argument-argnum binding)) ()
"store-lexical argnum can't be ~A." (function-argument-argnum binding))
- `((:movl ,source (:ebp ,(argument-stack-offset binding))))))))))))
+ `((:movl ,source (:ebp ,(argument-stack-offset binding)))))
+ (:untagged-fixnum-ecx
+ (append (unless (member source '(:ecx :untagged-fixnum-ecx))
+ `((:movl ,source :ecx)))
+ (unless (eq source :untagged-fixnum-ecx)
+ `((:sarl ,+movitz-fixnum-shift+ :ecx))))))))))))
(defun finalize-code (code funobj frame-map)
;; (print-code 'to-be-finalized code)
@@ -4631,7 +4682,10 @@
(:untagged-fixnum-ecx
(case (result-mode-type desired-result)
((:eax :ebx :ecx :edx)
- (values (append code `((:leal ((:ecx ,+movitz-fixnum-factor+) :edi ,(edi-offset))
+ (values (append code `((:cmpl ,+movitz-most-positive-fixnum+ :ecx)
+ (:ja '(:sub-program ()
+ (:int 4)))
+ (:leal ((:ecx ,+movitz-fixnum-factor+) :edi ,(edi-offset))
,desired-result)))
desired-result))
(t (make-result-and-returns-glue desired-result :eax
@@ -4695,7 +4749,7 @@
(compiler-call #'compile-form
:result-mode :ebx
:forward form-info))
- ((member form-returns '(:eax :ebx :ecx :edx :edi))
+ ((member form-returns '(:eax :ebx :ecx :edx :edi :untagged-fixnum-ecx))
(compiler-values (unprotected-values)))
(t (compiler-call #'compile-form
:result-mode :eax
More information about the Movitz-cvs
mailing list