Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv4314
Modified Files: compiler.lisp Log Message: More improvements to add.
Date: Tue Aug 23 01:05:37 2005 Author: ffjeld
Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.154 movitz/compiler.lisp:1.155 --- movitz/compiler.lisp:1.154 Mon Aug 22 01:30:04 2005 +++ movitz/compiler.lisp Tue Aug 23 01:05:35 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.154 2005/08/21 23:30:04 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.155 2005/08/22 23:05:35 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------
@@ -3464,7 +3464,7 @@ (t (list base-register offset))))))
(defun make-load-lexical (binding result-mode funobj shared-reference-p frame-map - &key tmp-register protect-registers) + &key tmp-register protect-registers override-binding-type) "When tmp-register is provided, use that for intermediate storage required when loading borrowed bindings." #+ignore @@ -3494,10 +3494,6 @@ ((and (eq result-mode :untagged-fixnum-ecx) (integerp lexb-location)) (cond -;;; ((and binding-type -;;; (not (movitz-subtypep decoded-type '(unsigned-byte 32)))) -;;; (error "Can't load a value of type ~S as ~S." -;;; :untagged-fixnum-ecx)) ((and binding-type (type-specifier-singleton decoded-type)) #+ignore (warn "Immloadlex: ~S" @@ -3505,6 +3501,12 @@ (make-immediate-move (movitz-immediate-value (car (type-specifier-singleton decoded-type))) :ecx)) + ((and binding-type + (movitz-subtypep decoded-type '(and fixnum (unsigned-byte 32)))) + (assert (not indirect-p)) + (append (install-for-single-value lexb lexb-location :ecx nil) + `((:shrl ,+movitz-fixnum-shift+ :ecx)))) + #+ignore ((warn "utecx ~S bt: ~S" lexb decoded-type)) (t (assert (not indirect-p)) (assert (not (member :eax protect-registers))) @@ -3571,7 +3573,8 @@ (assert (not (binding-lended-p binding)) (binding) "Can't lend a forwarding-binding ~S." binding) (make-load-lexical (forwarding-binding-target binding) - result-mode funobj shared-reference-p frame-map)) + result-mode funobj shared-reference-p frame-map + :override-binding-type (binding-store-type binding))) (constant-object-binding (assert (not (binding-lended-p binding)) (binding) "Can't lend a constant-reference-binding ~S." binding) @@ -3609,7 +3612,8 @@ ,tmp-register) (:movl (,tmp-register -1) ,tmp-register)))))))))) (located-binding - (let ((binding-type (binding-store-type binding)) + (let ((binding-type (or override-binding-type + (binding-store-type binding))) (binding-location (new-binding-location binding frame-map))) #+ignore (warn "~S type: ~S ~:[~;lended~]" binding @@ -6820,47 +6824,47 @@ `((:movl :eax ,destination)))) (binding (make-store-lexical destination :eax nil funobj frame-map)))))) - (cond - ((type-specifier-singleton result-type) - ;; (break "constant add: ~S" instruction) - (make-load-constant (car (type-specifier-singleton result-type)) - destination funobj frame-map)) - ((movitz-subtypep type0 '(integer 0 0)) + (let ((constant0 (let ((x (type-specifier-singleton type0))) + (when x (movitz-immediate-value (car x))))) + (constant1 (let ((x (type-specifier-singleton type1))) + (when x (movitz-immediate-value (car x)))))) (cond - ((eql destination loc1) - #+ignore (break "NOP add: ~S" instruction) - nil) - ((and (member destination-location '(:eax :ebx :ecx :edx)) - (member loc1 '(:eax :ebx :ecx :edx))) - `((:movl ,loc1 ,destination-location))) - ((integerp loc1) - (make-load-lexical term1 destination-location funobj nil frame-map)) - #+ignore - ((integerp destination-location) - (make-store-lexical destination-location loc1 nil funobj frame-map)) - (t (break "Unknown X zero-add: ~S" instruction)))) - ((movitz-subtypep type1 '(integer 0 0)) - ;; (warn "zero-add ~S => ~S [~S]" loc0 destination-location result-type) - (cond - ((eql destination loc0) - #+ignore (break "NOP add: ~S" instruction) - nil) - ((and (member destination-location '(:eax :ebx :ecx :edx)) - (member loc0 '(:eax :ebx :ecx :edx))) - `((:movl ,loc0 ,destination-location))) - ((integerp loc0) - (make-load-lexical term0 destination-location funobj nil frame-map)) - #+ignore - ((integerp destination-location) - (make-store-lexical destination-location loc0 nil funobj frame-map)) - (t (break "Unknown Y zero-add: ~S" instruction)))) - ((and (movitz-subtypep type0 'fixnum) - (movitz-subtypep type1 'fixnum) - (movitz-subtypep result-type 'fixnum)) - (let ((constant0 (let ((x (type-specifier-singleton type0))) - (when x (movitz-immediate-value (car x))))) - (constant1 (let ((x (type-specifier-singleton type1))) - (when x (movitz-immediate-value (car x)))))) + ((type-specifier-singleton result-type) + ;; (break "constant add: ~S" instruction) + (make-load-constant (car (type-specifier-singleton result-type)) + destination funobj frame-map)) + ((movitz-subtypep type0 '(integer 0 0)) + (cond + ((eql destination loc1) + #+ignore (break "NOP add: ~S" instruction) + nil) + ((and (member destination-location '(:eax :ebx :ecx :edx)) + (member loc1 '(:eax :ebx :ecx :edx))) + `((:movl ,loc1 ,destination-location))) + ((integerp loc1) + (make-load-lexical term1 destination-location funobj nil frame-map)) + #+ignore + ((integerp destination-location) + (make-store-lexical destination-location loc1 nil funobj frame-map)) + (t (break "Unknown X zero-add: ~S" instruction)))) + ((movitz-subtypep type1 '(integer 0 0)) + ;; (warn "zero-add ~S => ~S [~S]" loc0 destination-location result-type) + (cond + ((eql destination loc0) + #+ignore (break "NOP add: ~S" instruction) + nil) + ((and (member destination-location '(:eax :ebx :ecx :edx)) + (member loc0 '(:eax :ebx :ecx :edx))) + `((:movl ,loc0 ,destination-location))) + ((integerp loc0) + (make-load-lexical term0 destination-location funobj nil frame-map)) + #+ignore + ((integerp destination-location) + (make-store-lexical destination-location loc0 nil funobj frame-map)) + (t (break "Unknown Y zero-add: ~S" instruction)))) + ((and (movitz-subtypep type0 'fixnum) + (movitz-subtypep type1 'fixnum) + (movitz-subtypep result-type 'fixnum)) (assert (not (and constant0 (zerop constant0)))) (assert (not (and constant1 (zerop constant1)))) (cond @@ -6933,6 +6937,18 @@ constant1 (member loc0 '(:eax :ebx :ecx :edx))) `((:leal (,loc0 ,constant1) ,destination-location))) + ((and (member destination-location '(:eax :ebx :ecx :edx)) + constant0 + (eq :argument-stack (operator loc1))) + `((:movl (:ebp ,(argument-stack-offset (binding-target term1))) + ,destination-location) + (:addl ,constant0 ,destination-location))) + ((and (member destination-location '(:eax :ebx :ecx :edx)) + constant1 + (eq :argument-stack (operator loc0))) + `((:movl (:ebp ,(argument-stack-offset (binding-target term0))) + ,destination-location) + (:addl ,constant1 ,destination-location))) (t (warn "Unknown fixnum ADD: ~A/~S = ~A/~S + ~A/~S" destination-location destination @@ -6979,8 +6995,28 @@ (binding-lended-p (binding-target term0)) (binding-lended-p (binding-target term1))))) (t (warn "Unknown fixnum add: ~S" instruction) - (make-default-add))))) - (t (make-default-add)))))))) + (make-default-add)))) + #+ignore + ((and (movitz-subtypep result-type '(unsigned-byte 32)) + (movitz-subtypep type0 'fixnum) + (movitz-subtypep type1 'fixnum)) + (cond + ((and (not (binding-lended-p (binding-target term0))) + (not (binding-lended-p (binding-target term1))) + (not (and (bindingp destination) + (binding-lended-p (binding-target destination))))) + (cond + ((and (not constant0) + (not constant1) + (member destination-location '(:eax :ebx :edx))) + (print-code instruction + (append (make-load-lexical term0 :untagged-fixnum-ecx funobj nil frame-map) + `((,*compiler-local-segment-prefix* + :movl :ecx (:edi ,(global-constant-offset 'raw-scratch0)))) + ))) + (t (make-default-add)))) + (t (make-default-add)))) + (t (make-default-add)))))))))
;;;;;;;