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