Update of /project/movitz/cvsroot/movitz
In directory common-lisp.net:/tmp/cvs-serv26043
Modified Files:
compiler.lisp
Log Message:
Improved add compiler some more.
Date: Thu Sep 1 00:30:57 2005
Author: ffjeld
Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.161 movitz/compiler.lisp:1.162
--- movitz/compiler.lisp:1.161 Sun Aug 28 23:03:41 2005
+++ movitz/compiler.lisp Thu Sep 1 00:30:55 2005
@@ -8,7 +8,7 @@
;;;; Created at: Wed Oct 25 12:30:49 2000
;;;; Distribution: See the accompanying file COPYING.
;;;;
-;;;; $Id: compiler.lisp,v 1.161 2005/08/28 21:03:41 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.162 2005/08/31 22:30:55 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
@@ -2428,8 +2428,8 @@
(when (and (binding-target object)
(not (eq object (binding-target object))))
(binding-name (forwarding-binding-target object)))
- (when (and #+ignore (slot-exists-p object 'store-type)
- #+ignore (slot-boundp object 'store-type)
+ (when (and (slot-exists-p object 'store-type)
+ (slot-boundp object 'store-type)
(binding-store-type object))
(or (apply #'encoded-type-decode
(binding-store-type object))
@@ -3759,128 +3759,129 @@
(defun make-store-lexical (binding source shared-reference-p funobj frame-map
&key protect-registers)
- (assert (not (and shared-reference-p
- (not (binding-lended-p binding))))
- (binding)
- "funny binding: ~W" binding)
- (if (and nil (typep source 'constant-object-binding))
- (make-load-constant (constant-object source) binding funobj frame-map)
- (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 funobj frame-map
- :protect-registers protect-registers))))
- ((typep binding 'borrowed-binding)
- (let ((slot (borrowed-binding-reference-slot binding)))
- (if (not shared-reference-p)
- (let ((tmp-reg (chose-free-register protect-registers)
- #+ignore(if (eq source :eax) :ebx :eax)))
- (when (eq :ecx source)
- (break "loading a word from ECX?"))
- `((:movl (:esi ,(+ (slot-offset 'movitz-funobj 'constant0) (* 4 slot)))
- ,tmp-reg)
- (:movl ,source (-1 ,tmp-reg))))
- `((:movl ,source (:esi ,(+ (slot-offset 'movitz-funobj 'constant0) (* 4 slot))))))))
- ((typep binding 'forwarding-binding)
- (assert (not (binding-lended-p binding)) (binding))
- (make-store-lexical (forwarding-binding-target binding)
- source shared-reference-p funobj frame-map))
- ((not (new-binding-located-p binding frame-map))
- ;; (warn "Can't store to unlocated binding ~S." binding)
- nil)
- ((and (binding-lended-p binding)
- (not shared-reference-p))
- (let ((tmp-reg (chose-free-register protect-registers)
- #+ignore (if (eq source :eax) :ebx :eax))
- (location (new-binding-location binding frame-map)))
- (if (integerp location)
- `((:movl (:ebp ,(stack-frame-offset location)) ,tmp-reg)
- (:movl ,source (,tmp-reg -1)))
- (ecase (operator location)
- (:argument-stack
- (assert (<= 2 (function-argument-argnum binding)) ()
- "store-lexical argnum can't be ~A." (function-argument-argnum binding))
- `((:movl (:ebp ,(argument-stack-offset binding)) ,tmp-reg)
- (:movl ,source (,tmp-reg -1))))))))
- (t (let ((location (new-binding-location binding frame-map)))
- (cond
- ((member source '(:eax :ebx :ecx :edx :edi :esp))
- (if (integerp location)
- `((:movl ,source (:ebp ,(stack-frame-offset location))))
- (ecase (operator location)
- ((:push)
- `((:pushl ,source)))
- ((:eax :ebx :ecx :edx)
- (unless (eq source location)
- `((:movl ,source ,location))))
- (: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)))))
- (:untagged-fixnum-ecx
- (assert (not (eq source :edi)))
- (cond
- ((eq source :untagged-fixnum-ecx)
- nil)
- ((eq source :eax)
- `((,*compiler-global-segment-prefix*
- :call (:edi ,(global-constant-offset 'unbox-u32)))))
- (t `((:movl ,source :eax)
- (,*compiler-global-segment-prefix*
- :call (:edi ,(global-constant-offset 'unbox-u32))))))))))
- ((member source +boolean-modes+)
- (let ((tmp (chose-free-register protect-registers))
- (label (gensym "store-lexical-bool-")))
- (append `((:movl :edi ,tmp))
- (list (make-branch-on-boolean source label))
- (list label)
- (make-store-lexical binding tmp shared-reference-p funobj frame-map
- :protect-registers protect-registers))))
- ((not (bindingp source))
- (error "Unknown source for store-lexical: ~S" source))
- ((binding-singleton source)
- (assert (not shared-reference-p))
- (let ((value (car (binding-singleton source))))
- (etypecase value
- (movitz-fixnum
- (let ((immediate (movitz-immediate-value value)))
- (if (integerp location)
- (let ((tmp (chose-free-register protect-registers)))
- (append (make-immediate-move immediate tmp)
- `((:movl ,tmp (:ebp ,(stack-frame-offset location))))))
- #+ignore (if (= 0 immediate)
+ (let ((binding (ensure-local-binding binding funobj)))
+ (assert (not (and shared-reference-p
+ (not (binding-lended-p binding))))
+ (binding)
+ "funny binding: ~W" binding)
+ (if (and nil (typep source 'constant-object-binding))
+ (make-load-constant (constant-object source) binding funobj frame-map)
+ (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 funobj frame-map
+ :protect-registers protect-registers))))
+ ((typep binding 'borrowed-binding)
+ (let ((slot (borrowed-binding-reference-slot binding)))
+ (if (not shared-reference-p)
+ (let ((tmp-reg (chose-free-register protect-registers)
+ #+ignore(if (eq source :eax) :ebx :eax)))
+ (when (eq :ecx source)
+ (break "loading a word from ECX?"))
+ `((:movl (:esi ,(+ (slot-offset 'movitz-funobj 'constant0) (* 4 slot)))
+ ,tmp-reg)
+ (:movl ,source (-1 ,tmp-reg))))
+ `((:movl ,source (:esi ,(+ (slot-offset 'movitz-funobj 'constant0) (* 4 slot))))))))
+ ((typep binding 'forwarding-binding)
+ (assert (not (binding-lended-p binding)) (binding))
+ (make-store-lexical (forwarding-binding-target binding)
+ source shared-reference-p funobj frame-map))
+ ((not (new-binding-located-p binding frame-map))
+ ;; (warn "Can't store to unlocated binding ~S." binding)
+ nil)
+ ((and (binding-lended-p binding)
+ (not shared-reference-p))
+ (let ((tmp-reg (chose-free-register protect-registers)
+ #+ignore (if (eq source :eax) :ebx :eax))
+ (location (new-binding-location binding frame-map)))
+ (if (integerp location)
+ `((:movl (:ebp ,(stack-frame-offset location)) ,tmp-reg)
+ (:movl ,source (,tmp-reg -1)))
+ (ecase (operator location)
+ (:argument-stack
+ (assert (<= 2 (function-argument-argnum binding)) ()
+ "store-lexical argnum can't be ~A." (function-argument-argnum binding))
+ `((:movl (:ebp ,(argument-stack-offset binding)) ,tmp-reg)
+ (:movl ,source (,tmp-reg -1))))))))
+ (t (let ((location (new-binding-location binding frame-map)))
+ (cond
+ ((member source '(:eax :ebx :ecx :edx :edi :esp))
+ (if (integerp location)
+ `((:movl ,source (:ebp ,(stack-frame-offset location))))
+ (ecase (operator location)
+ ((:push)
+ `((:pushl ,source)))
+ ((:eax :ebx :ecx :edx)
+ (unless (eq source location)
+ `((:movl ,source ,location))))
+ (: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)))))
+ (:untagged-fixnum-ecx
+ (assert (not (eq source :edi)))
+ (cond
+ ((eq source :untagged-fixnum-ecx)
+ nil)
+ ((eq source :eax)
+ `((,*compiler-global-segment-prefix*
+ :call (:edi ,(global-constant-offset 'unbox-u32)))))
+ (t `((:movl ,source :eax)
+ (,*compiler-global-segment-prefix*
+ :call (:edi ,(global-constant-offset 'unbox-u32))))))))))
+ ((member source +boolean-modes+)
+ (let ((tmp (chose-free-register protect-registers))
+ (label (gensym "store-lexical-bool-")))
+ (append `((:movl :edi ,tmp))
+ (list (make-branch-on-boolean source label))
+ (list label)
+ (make-store-lexical binding tmp shared-reference-p funobj frame-map
+ :protect-registers protect-registers))))
+ ((not (bindingp source))
+ (error "Unknown source for store-lexical: ~S" source))
+ ((binding-singleton source)
+ (assert (not shared-reference-p))
+ (let ((value (car (binding-singleton source))))
+ (etypecase value
+ (movitz-fixnum
+ (let ((immediate (movitz-immediate-value value)))
+ (if (integerp location)
+ (let ((tmp (chose-free-register protect-registers)))
+ (append (make-immediate-move immediate tmp)
+ `((:movl ,tmp (:ebp ,(stack-frame-offset location))))))
+ #+ignore (if (= 0 immediate)
(let ((tmp (chose-free-register protect-registers)))
`((:xorl ,tmp ,tmp)
(:movl ,tmp (:ebp ,(stack-frame-offset location)))))
`((:movl ,immediate (:ebp ,(stack-frame-offset location)))))
- (ecase (operator location)
- ((:argument-stack)
- `((:movl ,immediate (:ebp ,(argument-stack-offset binding)))))
- ((:eax :ebx :edx)
- (make-immediate-move immediate location))
- ((:untagged-fixnum-ecx)
- (make-immediate-move (movitz-fixnum-value value) :ecx))))))
- (movitz-heap-object
- (etypecase location
- ((member :eax :ebx :edx)
- (make-load-constant value location funobj frame-map))
- (integer
- (let ((tmp (chose-free-register protect-registers)))
- (append (make-load-constant value tmp funobj frame-map)
- (make-store-lexical binding tmp shared-reference-p
- funobj frame-map
- :protect-registers protect-registers))))
- ((eql :untagged-fixnum-ecx)
- (check-type value movitz-bignum)
- (let ((immediate (movitz-bignum-value value)))
- (check-type immediate (unsigned-byte 32))
- (make-immediate-move immediate :ecx)))
- )))))
- (t (error "Generalized lexb source for store-lexical not implemented: ~S" source)))))))))
+ (ecase (operator location)
+ ((:argument-stack)
+ `((:movl ,immediate (:ebp ,(argument-stack-offset binding)))))
+ ((:eax :ebx :edx)
+ (make-immediate-move immediate location))
+ ((:untagged-fixnum-ecx)
+ (make-immediate-move (movitz-fixnum-value value) :ecx))))))
+ (movitz-heap-object
+ (etypecase location
+ ((member :eax :ebx :edx)
+ (make-load-constant value location funobj frame-map))
+ (integer
+ (let ((tmp (chose-free-register protect-registers)))
+ (append (make-load-constant value tmp funobj frame-map)
+ (make-store-lexical binding tmp shared-reference-p
+ funobj frame-map
+ :protect-registers protect-registers))))
+ ((eql :untagged-fixnum-ecx)
+ (check-type value movitz-bignum)
+ (let ((immediate (movitz-bignum-value value)))
+ (check-type immediate (unsigned-byte 32))
+ (make-immediate-move immediate :ecx)))
+ )))))
+ (t (error "Generalized lexb source for store-lexical not implemented: ~S" source))))))))))
(defun finalize-code (code funobj frame-map)
;; (print-code 'to-be-finalized code)
@@ -7057,6 +7058,15 @@
(append (make-load-lexical term0 :eax funobj nil frame-map)
`((:addl :eax :eax))
(make-store :eax destination)))
+ ((and (integerp loc0)
+ (integerp loc1)
+ (integerp destination-location)
+ (/= loc0 loc1 destination-location))
+ `((:movl (:ebp ,(stack-frame-offset loc0))
+ :ecx)
+ (:addl (:ebp ,(stack-frame-offset loc1))
+ :ecx)
+ (:movl :ecx (:ebp ,(stack-frame-offset destination-location)))))
(t (warn "Unknown fixnum ADD: ~A/~S = ~A/~S + ~A/~S"
destination-location
destination
