Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv32117
Modified Files: compiler.lisp Log Message: Improved the add compiler.
Date: Mon Aug 22 00:06:53 2005 Author: ffjeld
Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.152 movitz/compiler.lisp:1.153 --- movitz/compiler.lisp:1.152 Sun Aug 21 19:51:53 2005 +++ movitz/compiler.lisp Mon Aug 22 00:06:48 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.152 2005/08/21 17:51:53 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.153 2005/08/21 22:06:48 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------
@@ -3611,7 +3611,10 @@ (located-binding (let ((binding-type (binding-store-type binding)) (binding-location (new-binding-location binding frame-map))) - #+ignore (warn "~S type: ~S" binding binding-type) + #+ignore (warn "~S type: ~S ~:[~;lended~]" + binding + binding-type + (binding-lended-p binding)) (cond ((and (binding-lended-p binding) (not shared-reference-p)) @@ -6757,13 +6760,15 @@ ;;; (warn "dest: ~S ~S" ;;; (apply #'encoded-type-decode (binding-store-type destination)) ;;; result-type) - (when (binding-lended-p term0) - (warn "Add for lend0: ~S" term0)) - (when (binding-lended-p term1) - (warn "Add for lend0: ~S" term1)) - (when (and (bindingp destination) - (binding-lended-p destination)) - (warn "Add for lend0: ~S" destination)) +;;; (when (binding-lended-p term0) +;;; (warn "Add from lend0: ~S" term0)) +;;; (when (binding-lended-p term1) +;;; (warn "Add from lend1: ~S" term1)) +;;; (when (and (bindingp destination) +;;; (binding-lended-p destination)) +;;; (warn "Add for lended dest: ~S" destination)) +;;; (when (typep destination 'borrowed-binding) +;;; (warn "Add for borrowed ~S" destination)) (let ((loc0 (new-binding-location (binding-target term0) frame-map :default nil)) (loc1 (new-binding-location (binding-target term1) frame-map :default nil))) #+ignore @@ -6774,185 +6779,208 @@ term0 loc0 term1 loc1) #+ignore - (when (eql loc0 loc1) - (warn "add for:~%~A/~A in ~S~&~A/~A in ~S." + (when (eql destination-location 9) + (warn "add for: ~S/~S~%= ~A/~A in ~S~&~A/~A in ~S." + destination destination-location term0 loc0 (binding-extent-env (binding-target term0)) - term1 loc1 (binding-extent-env (binding-target term1)))) - (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)) - (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) + term1 loc1 (binding-extent-env (binding-target term1))) + (print-code 'load-term1 (make-load-lexical term1 :eax funobj nil frame-map)) + (print-code 'load-dest (make-load-lexical destination :eax funobj nil frame-map))) + (flet ((make-default-add () + (when (movitz-subtypep result-type '(unsigned-byte 32)) + (warn "Defaulting u32 ADD: ~A/~S = ~A/~S + ~A/~S" + destination-location + destination + loc0 term0 + loc1 term1)) + (append (cond + ((type-specifier-singleton type0) + (append (make-load-lexical term1 :eax funobj nil frame-map) + (make-load-constant (car (type-specifier-singleton type0)) + :ebx funobj frame-map))) + ((type-specifier-singleton type1) + (append (make-load-lexical term0 :eax funobj nil frame-map) + (make-load-constant (car (type-specifier-singleton type1)) + :ebx funobj frame-map))) + ((and (eq :eax loc0) (eq :ebx loc1)) + nil) + ((and (eq :ebx loc0) (eq :eax loc1)) + nil) ; terms order isn't important + ((eq :eax loc1) + (append + (make-load-lexical term0 :ebx funobj nil frame-map))) + (t (append + (make-load-lexical term0 :eax funobj nil frame-map) + (make-load-lexical term1 :ebx funobj nil frame-map)))) + `((:movl (:edi ,(global-constant-offset '+)) :esi)) + (make-compiled-funcall-by-esi 2) + (etypecase destination + (symbol + (unless (eq destination :eax) + `((:movl :eax ,destination)))) + (binding + (make-store-lexical destination :eax nil funobj frame-map)))))) (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)))))) - (assert (not (and constant0 (zerop constant0)))) - (assert (not (and constant1 (zerop constant1)))) + ((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 - ((and constant0 - (equal loc1 destination-location)) - (cond - ((member destination-location '(:eax :ebx :ecx :edx)) - `((:addl ,constant0 ,destination-location))) - ((integerp loc1) - `((:addl ,constant0 (:ebp ,(stack-frame-offset loc1))))) - ((eq :argument-stack (operator loc1)) - `((:addl ,constant0 - (:ebp ,(argument-stack-offset (binding-target term1)))))) - (t (error "Don't know how to add this for loc1 ~S" loc1)))) - ((and constant0 - (integerp destination-location) - (eql term1 destination-location)) - (break "untested") - `((:addl ,constant0 (:ebp ,(stack-frame-offset destination-location))))) - ((and constant0 - (integerp destination-location) - (member loc1 '(:eax :ebx :ecx :edx))) - (break "check this!") - `((:addl ,constant0 ,loc1) - (:movl ,loc1 (:ebp ,(stack-frame-offset destination-location))))) - ((and (integerp loc0) - (integerp loc1) - (member destination-location '(:eax :ebx :ecx :edx))) - (append `((:movl (:ebp ,(stack-frame-offset loc0)) ,destination-location) - (:addl (:ebp ,(stack-frame-offset loc1)) ,destination-location)))) - ((and (integerp destination-location) - (eql loc0 destination-location) - constant1) - `((:addl ,constant1 (:ebp ,(stack-frame-offset destination-location))))) - ((and (integerp destination-location) - (eql loc1 destination-location) - constant0) - `((:addl ,constant0 (:ebp ,(stack-frame-offset destination-location))))) - ((and (member destination-location '(:eax :ebx :ecx :edx)) - (eq loc0 :untagged-fixnum-ecx) - constant1) - `((:leal ((:ecx ,+movitz-fixnum-factor+) ,constant1) - ,destination-location))) - ((and (member destination-location '(:eax :ebx :ecx :edx)) - (integerp loc1) - constant0) - `((:movl (:ebp ,(stack-frame-offset loc1)) ,destination-location) - (:addl ,constant0 ,destination-location))) + ((eql destination loc1) + #+ignore (break "NOP add: ~S" instruction) + nil) ((and (member destination-location '(:eax :ebx :ecx :edx)) - (integerp loc0) - constant1) - `((:movl (:ebp ,(stack-frame-offset loc0)) ,destination-location) - (:addl ,constant1 ,destination-location))) - ((and (member destination-location '(:eax :ebx :ecx :edx)) - (integerp loc0) - (member loc1 '(:eax :ebx :ecx :edx)) - (not (eq destination-location loc1))) - `((:movl (:ebp ,(stack-frame-offset loc0)) ,destination-location) - (:addl ,loc1 ,destination-location))) - ((and (member destination-location '(:eax :ebx :ecx :edx)) - constant0 (member loc1 '(:eax :ebx :ecx :edx))) - `((:leal (,loc1 ,constant0) ,destination-location))) + `((: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)) - constant1 (member loc0 '(:eax :ebx :ecx :edx))) - `((:leal (,loc0 ,constant1) ,destination-location))) - (t (warn "Unknown fixnum ADD: ~A/~S = ~A/~S + ~A/~S" - destination-location - destination - loc0 term0 - loc1 term1) - #+ignore (warn "map: ~A" frame-map) + `((: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)))))) + (assert (not (and constant0 (zerop constant0)))) + (assert (not (and constant1 (zerop constant1)))) + (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 constant0 + (equal loc1 destination-location)) + (cond + ((member destination-location '(:eax :ebx :ecx :edx)) + `((:addl ,constant0 ,destination-location))) + ((integerp loc1) + `((:addl ,constant0 (:ebp ,(stack-frame-offset loc1))))) + ((eq :argument-stack (operator loc1)) + `((:addl ,constant0 + (:ebp ,(argument-stack-offset (binding-target term1)))))) + (t (error "Don't know how to add this for loc1 ~S" loc1)))) + ((and constant0 + (integerp destination-location) + (eql term1 destination-location)) + (break "untested") + `((:addl ,constant0 (:ebp ,(stack-frame-offset destination-location))))) + ((and constant0 + (integerp destination-location) + (member loc1 '(:eax :ebx :ecx :edx))) + (break "check this!") + `((:addl ,constant0 ,loc1) + (:movl ,loc1 (:ebp ,(stack-frame-offset destination-location))))) + ((and (integerp loc0) + (integerp loc1) + (member destination-location '(:eax :ebx :ecx :edx))) + (append `((:movl (:ebp ,(stack-frame-offset loc0)) ,destination-location) + (:addl (:ebp ,(stack-frame-offset loc1)) ,destination-location)))) + ((and (integerp destination-location) + (eql loc0 destination-location) + constant1) + `((:addl ,constant1 (:ebp ,(stack-frame-offset destination-location))))) + ((and (integerp destination-location) + (eql loc1 destination-location) + constant0) + `((:addl ,constant0 (:ebp ,(stack-frame-offset destination-location))))) + ((and (member destination-location '(:eax :ebx :ecx :edx)) + (eq loc0 :untagged-fixnum-ecx) + constant1) + `((:leal ((:ecx ,+movitz-fixnum-factor+) ,constant1) + ,destination-location))) + ((and (member destination-location '(:eax :ebx :ecx :edx)) + (integerp loc1) + constant0) + `((:movl (:ebp ,(stack-frame-offset loc1)) ,destination-location) + (:addl ,constant0 ,destination-location))) + ((and (member destination-location '(:eax :ebx :ecx :edx)) + (integerp loc0) + constant1) + `((:movl (:ebp ,(stack-frame-offset loc0)) ,destination-location) + (:addl ,constant1 ,destination-location))) + ((and (member destination-location '(:eax :ebx :ecx :edx)) + (integerp loc0) + (member loc1 '(:eax :ebx :ecx :edx)) + (not (eq destination-location loc1))) + `((:movl (:ebp ,(stack-frame-offset loc0)) ,destination-location) + (:addl ,loc1 ,destination-location))) + ((and (member destination-location '(:eax :ebx :ecx :edx)) + constant0 + (member loc1 '(:eax :ebx :ecx :edx))) + `((:leal (,loc1 ,constant0) ,destination-location))) + ((and (member destination-location '(:eax :ebx :ecx :edx)) + constant1 + (member loc0 '(:eax :ebx :ecx :edx))) + `((:leal (,loc0 ,constant1) ,destination-location))) + (t (warn "Unknown fixnum ADD: ~A/~S = ~A/~S + ~A/~S" + destination-location + destination + loc0 term0 + loc1 term1) + #+ignore (warn "map: ~A" frame-map) ;;; (warn "ADDI: ~S" instruction) - (append (cond - ((type-specifier-singleton type0) - (append (make-load-lexical term1 :eax funobj nil frame-map) - (make-load-constant (car (type-specifier-singleton type0)) - :ebx funobj frame-map))) - ((type-specifier-singleton type1) - (append (make-load-lexical term0 :eax funobj nil frame-map) - (make-load-constant (car (type-specifier-singleton type1)) - :ebx funobj frame-map))) - ((and (eq :eax loc0) (eq :ebx loc1)) - nil) - ((and (eq :ebx loc0) (eq :eax loc1)) - nil) ; terms order isn't important - ((eq :eax loc1) - (append - (make-load-lexical term0 :ebx funobj nil frame-map))) - (t (append - (make-load-lexical term0 :eax funobj nil frame-map) - (make-load-lexical term1 :ebx funobj nil frame-map)))) - `((:movl (:edi ,(global-constant-offset '+)) :esi)) - (make-compiled-funcall-by-esi 2) - (etypecase destination - (symbol - (unless (eq destination :eax) - `((:movl :eax ,destination)))) - (binding - (make-store-lexical destination :eax nil funobj frame-map)))))))) - ((and (movitz-subtypep result-type '(unsigned-byte 32)) - (warn "Unknown u32 ADD: ~A/~S = ~A/~S + ~A/~S" - destination-location - destination - loc0 term0 - loc1 term1))) - (t (append (cond - ((type-specifier-singleton type0) - (append (make-load-lexical term1 :eax funobj nil frame-map) - (make-load-constant (car (type-specifier-singleton type0)) - :ebx funobj frame-map))) - ((type-specifier-singleton type1) - (append (make-load-lexical term0 :eax funobj nil frame-map) - (make-load-constant (car (type-specifier-singleton type1)) - :ebx funobj frame-map))) - ((and (eq :eax loc0) (eq :ebx loc1)) - nil) - ((and (eq :ebx loc0) (eq :eax loc1)) - nil) ; terms order isn't important - ((eq :eax loc1) - (append - (make-load-lexical term0 :ebx funobj nil frame-map))) - (t (append - (make-load-lexical term0 :eax funobj nil frame-map) - (make-load-lexical term1 :ebx funobj nil frame-map)))) - `((:movl (:edi ,(global-constant-offset '+)) :esi)) - (make-compiled-funcall-by-esi 2) - (etypecase destination - (symbol - (unless (eq destination :eax) - `((:movl :eax ,destination)))) - (binding - (make-store-lexical destination :eax nil funobj frame-map)))))))))) + (append (cond + ((type-specifier-singleton type0) + (append (make-load-lexical term1 :eax funobj nil frame-map) + (make-load-constant (car (type-specifier-singleton type0)) + :ebx funobj frame-map))) + ((type-specifier-singleton type1) + (append (make-load-lexical term0 :eax funobj nil frame-map) + (make-load-constant (car (type-specifier-singleton type1)) + :ebx funobj frame-map))) + ((and (eq :eax loc0) (eq :ebx loc1)) + nil) + ((and (eq :ebx loc0) (eq :eax loc1)) + nil) ; terms order isn't important + ((eq :eax loc1) + (append + (make-load-lexical term0 :ebx funobj nil frame-map))) + (t (append + (make-load-lexical term0 :eax funobj nil frame-map) + (make-load-lexical term1 :ebx funobj nil frame-map)))) + `((:movl (:edi ,(global-constant-offset '+)) :esi)) + (make-compiled-funcall-by-esi 2) + (etypecase destination + (symbol + (unless (eq destination :eax) + `((:movl :eax ,destination)))) + (binding + (make-store-lexical destination :eax nil funobj frame-map))))))) + ((and constant0 + (integerp destination-location) + (eql loc1 destination-location) + (binding-lended-p (binding-target destination))) + (assert (binding-lended-p (binding-target term1))) + (append (make-load-lexical destination :eax funobj t frame-map) + `((:addl ,constant0 (-1 :eax))))) + ((warn "~S" (list (and (bindingp destination) + (binding-lended-p (binding-target destination))) + (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))))))))
;;;;;;;