Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv6248

Modified Files: compiler.lisp Log Message: Many fixes to the compiler. Basic change is that LET init-forms are compiled with compile-form-unprotected, and that compile-lexical-variable and compile-self-evaluating return binding only as "returns", not in the form of "code".

Date: Sun Aug 28 23:03:43 2005 Author: ffjeld

Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.160 movitz/compiler.lisp:1.161 --- movitz/compiler.lisp:1.160 Fri Aug 26 23:42:08 2005 +++ movitz/compiler.lisp Sun Aug 28 23:03:41 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.160 2005/08/26 21:42:08 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.161 2005/08/28 21:03:41 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------

@@ -1510,6 +1510,7 @@

(defun optimize-code (unoptimized-code &rest args) + #+ignore (print-code 'to-optimize unoptimized-code) (if (not *compiler-do-optimize*) unoptimized-code (apply #'optimize-code-internal @@ -2883,7 +2884,7 @@ (let* ((count-init-pc (gethash binding var-counts)) (count (car count-init-pc)) (init-pc (second count-init-pc))) - ;; (warn "b ~S: count: ~D, init-pc: ~{~&~A~}" binding count init-pc) + #+ignore (warn "b ~S: count: ~D, init-pc: ~{~&~A~}" binding count init-pc) (cond ((and (not *compiler-allow-transients*) (typep binding 'function-argument)) @@ -2972,7 +2973,7 @@ (take-note-of-binding (binding &optional storep init-pc) (let ((count-init-pc (or (gethash binding var-counter) (setf (gethash binding var-counter) - (list 0 nil t))))) + (list 0 nil (not storep)))))) (when init-pc (assert (not (second count-init-pc))) (setf (second count-init-pc) init-pc)) @@ -2980,10 +2981,17 @@ (unless (eq binding (binding-target binding)) ;; (break "ewfew: ~S" (gethash (binding-target binding) var-counter)) (take-note-of-binding (binding-target binding))) + (setf (third count-init-pc) t) (incf (car count-init-pc)))) #+ignore (when (typep binding 'forwarding-binding) (take-note-of-binding (forwarding-binding-target binding) storep))) + (take-note-of-init (binding init-pc) + (let ((count-init-pc (or (gethash binding var-counter) + (setf (gethash binding var-counter) + (list 0 nil nil))))) + (assert (not (second count-init-pc))) + (setf (second count-init-pc) init-pc))) (do-discover-variables (code env) (loop for pc on code as instruction in code when (listp instruction) @@ -3028,11 +3036,14 @@ protect-registers protect-carry) (cdr instruction) (declare (ignore protect-registers protect-carry init-with-type)) - (when init-with-register + (cond + ((not init-with-register) + (take-note-of-init binding pc)) + (init-with-register (take-note-of-binding binding t pc) (when (and (typep init-with-register 'binding) (not (typep binding 'forwarding-binding))) ; XXX - (take-note-of-binding init-with-register))))) + (take-note-of-binding init-with-register)))))) (t (mapcar #'take-note-of-binding (find-read-bindings instruction)) (mapcar #'record-binding-used ; This is just concerning "unused variable" @@ -3072,34 +3083,35 @@ (let* ((stack-frame-position (env-floor env)) (bindings-to-locate (loop for binding being the hash-keys of var-counts - when (eq env (binding-extent-env binding)) - unless (let ((variable (binding-name binding))) - (cond - ((not (typep binding 'lexical-binding))) - ((typep binding 'lambda-binding)) - ((typep binding 'constant-object-binding)) - ((typep binding 'forwarding-binding) - ;; Immediately "assign" to target. - (when (plusp (or (car (gethash binding var-counts)) 0)) - (setf (new-binding-location binding frame-map) - (forwarding-binding-target binding))) - t) - ((typep binding 'borrowed-binding)) - ((typep binding 'funobj-binding)) - ((and (typep binding 'fixed-required-function-argument) - (plusp (or (car (gethash binding var-counts)) 0))) - (prog1 nil ; may need lending-cons - (setf (new-binding-location binding frame-map) - `(:argument-stack ,(function-argument-argnum binding))))) - ((unless (or (movitz-env-get variable 'ignore nil - (binding-env binding) nil) - (movitz-env-get variable 'ignorable nil - (binding-env binding) nil) - (typep binding 'hidden-rest-function-argument) - (third (gethash binding var-counts))) - (warn "Unused variable: ~S" - (binding-name binding)))) - ((not (plusp (or (car (gethash binding var-counts)) 0)))))) + when + (and (eq env (binding-extent-env binding)) + (not (let ((variable (binding-name binding))) + (cond + ((not (typep binding 'lexical-binding))) + ((typep binding 'lambda-binding)) + ((typep binding 'constant-object-binding)) + ((typep binding 'forwarding-binding) + ;; Immediately "assign" to target. + (when (plusp (or (car (gethash binding var-counts)) 0)) + (setf (new-binding-location binding frame-map) + (forwarding-binding-target binding))) + t) + ((typep binding 'borrowed-binding)) + ((typep binding 'funobj-binding)) + ((and (typep binding 'fixed-required-function-argument) + (plusp (or (car (gethash binding var-counts)) 0))) + (prog1 nil ; may need lending-cons + (setf (new-binding-location binding frame-map) + `(:argument-stack ,(function-argument-argnum binding))))) + ((unless (or (movitz-env-get variable 'ignore nil + (binding-env binding) nil) + (movitz-env-get variable 'ignorable nil + (binding-env binding) nil) + (typep binding 'hidden-rest-function-argument) + (third (gethash binding var-counts))) + (warn "Unused variable: ~S" + (binding-name binding)))) + ((not (plusp (or (car (gethash binding var-counts)) 0)))))))) collect binding)) (bindings-fun-arg-sorted (when (eq env function-env) @@ -3371,6 +3383,7 @@ (etypecase x (symbol x) (cons (car x)) + (constant-object-binding :constant-binding) (lexical-binding :lexical-binding) (dynamic-binding :dynamic-binding)))

@@ -3512,7 +3525,8 @@ (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))) - (let ((protect-registers (cons :edx protect-registers))) + (let ((binding (ensure-local-binding binding funobj)) + (protect-registers (cons :edx protect-registers))) (labels ((chose-tmp-register (&optional preferred) (or tmp-register (unless (member preferred protect-registers) @@ -3673,7 +3687,9 @@ (t (make-result-and-returns-glue result-mode :eax (install-for-single-value binding binding-location :eax t))))) - (t (case (result-mode-type result-mode) + (t (when (integerp result-mode) + (break "result-mode: ~S" result-mode)) + (case (result-mode-type result-mode) ((:single-value :eax :ebx :ecx :edx :esi :esp :ebp) (install-for-single-value binding binding-location (single-value-register result-mode) nil)) @@ -3816,6 +3832,14 @@ (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) @@ -4803,8 +4827,9 @@ `((:init-lexvar ,binding) ,@(when supplied-p-var `((:init-lexvar ,supplied-p-binding))) - ,@(compiler-call #'compile-self-evaluating - :form (eval-form (optional-function-argument-init-form binding) env nil) + ,@(compiler-call #'compile-form + :form (list 'muerte.cl:quote + (eval-form (optional-function-argument-init-form binding) env nil)) :funobj funobj :env env :result-mode :ebx) @@ -4912,8 +4937,10 @@ `((:init-lexvar ,supplied-p-binding :init-with-register :edi :init-with-type null))) - (compiler-call #'compile-self-evaluating - :form (eval-form (optional-function-argument-init-form binding) env) + (compiler-call #'compile-form + :form (list 'muerte.cl:quote + (eval-form (optional-function-argument-init-form binding) + env)) :env env :funobj funobj :result-mode :eax) @@ -5115,6 +5142,11 @@ (lexical-binding (values (append code `((:load-lexical ,returns-provided ,desired-result))) + desired-result)) + (constant-object-binding + (values (if (eq *movitz-nil* (constant-object returns-provided)) + nil + `((:jmp ',(operands desired-result)))) desired-result)))) (:boolean-branch-on-false (etypecase (operator returns-provided) @@ -5144,9 +5176,14 @@ (lexical-binding (values (append code `((:load-lexical ,returns-provided ,desired-result))) + desired-result)) + (constant-object-binding + (values (if (not (eq *movitz-nil* (constant-object returns-provided))) + nil + `((:jmp ',(operands desired-result)))) desired-result)))) (:untagged-fixnum-ecx - (case returns-provided + (case (result-mode-type returns-provided) (:untagged-fixnum-ecx (values code :untagged-fixnum-ecx)) ((:eax :single-value :multiple-values :function) @@ -5155,10 +5192,19 @@ :call (:edi ,(global-constant-offset 'unbox-u32))))) :untagged-fixnum-ecx)) (:ecx + ;; In theory (at least..) ECX can only hold non-pointers, so don't check. (values (append code - `((:testb ,+movitz-fixnum-zmask+ :cl) - (:jnz '(:sub-program (not-an-integer) (:int 107))) ; - (:sarl ,+movitz-fixnum-shift+ :ecx))) + `((:shrl ,+movitz-fixnum-shift+ :ecx))) + :untagged-fixnum-ecx)) + ((:ebx :edx) + (values (append code + `((:movl ,returns-provided :eax) + (,*compiler-global-segment-prefix* + :call (:edi ,(global-constant-offset 'unbox-u32))))) + :untagged-fixnum-ecx)) + (:lexical-binding + (values (append code + `((:load-lexical ,returns-provided :untagged-fixnum-ecx))) :untagged-fixnum-ecx)))) ((:single-value :eax) (cond @@ -5226,11 +5272,6 @@ (values (append code `((:load-lexical ,returns-provided ,desired-result))) desired-result)) (t (case (operator returns-provided) - #+ignore - (:untagged-fixnum-eax - (values (append code - `((:leal ((:eax 4)) ,desired-result))) - desired-result)) (:nothing (values (append code `((:movl :edi ,desired-result))) @@ -5337,7 +5378,14 @@ :multiple-values))))) (unless new-returns-provided (multiple-value-setq (new-code new-returns-provided glue-side-effects-p) - (ecase (operator returns-provided) + (ecase (result-mode-type returns-provided) + (:constant-binding + (case (result-mode-type desired-result) + ((:eax :ebx :ecx :edx :push :lexical-binding) + (values (append code + `((:load-constant ,(constant-object returns-provided) + ,desired-result))) + desired-result)))) (#.+boolean-modes+ (make-result-and-returns-glue desired-result :eax (make-result-and-returns-glue :eax returns-provided code @@ -5900,6 +5948,12 @@ (:ignore (compiler-values () :final-form binding)) + (t (compiler-values () + :code nil + :final-form binding + :returns binding + :functional-p t)) + #+ignore (t (let ((returns (ecase (result-mode-type result-mode) ((:function :multiple-values :eax) :eax) @@ -6037,13 +6091,15 @@ (compiler-values (self-eval) :returns :nothing :type nil)) - ((:eax :single-value :multiple-values :function) - (compiler-values (self-eval) - :code `((:load-lexical ,binding :eax)) - :returns :eax)) (t (compiler-values (self-eval) - :code `((:load-lexical ,binding ,result-mode)) - :returns result-mode)))))) + :returns binding)))))) +;;; ((:eax :single-value :multiple-values :function) +;;; (compiler-values (self-eval) +;;; :code `((:load-lexical ,binding :eax)) +;;; :returns :eax)) +;;; (t (compiler-values (self-eval) +;;; :code `((:load-lexical ,binding ,result-mode)) +;;; :returns result-mode))))))

(define-compiler compile-implicit-progn (&all all &form forms &top-level-p top-level-p &result-mode result-mode) @@ -6738,7 +6794,7 @@ (destructuring-bind (object result-mode &key (op :movl)) (cdr instruction) (when (and (eq op :movl) (typep result-mode 'binding)) - (check-type result-mode 'lexical-binding) + (check-type result-mode lexical-binding) (values result-mode `(eql ,object)))))

(define-extended-code-expander :load-constant (instruction funobj frame-map) @@ -6795,330 +6851,333 @@ (destination-location (if (or (not (bindingp destination)) (typep destination 'borrowed-binding)) destination - (new-binding-location (binding-target destination) frame-map))) + (new-binding-location (binding-target destination) + frame-map + :default nil))) (type0 (apply #'encoded-type-decode (binding-store-type term0))) (type1 (apply #'encoded-type-decode (binding-store-type term1))) (result-type (multiple-value-call #'encoded-integer-types-add (values-list (binding-store-type term0)) (values-list (binding-store-type term1))))) -;;; (warn "dest: ~S ~S" -;;; (apply #'encoded-type-decode (binding-store-type destination)) -;;; result-type) -;;; (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 - (warn "add: ~A for ~A" instruction result-type) - #+ignore - (warn "add for: ~S is ~A, from ~A/~A and ~A/~A." - destination result-type - term0 loc0 - term1 loc1) - #+ignore - (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))) - (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-store (source destination) - (cond - ((eq source destination) - nil) - ((member destination '(:eax :ebx :ecx :edx)) - `((:movl ,source ,destination))) - (t (make-store-lexical destination source nil funobj frame-map)))) - (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)))))) - (let ((constant0 (let ((x (type-specifier-singleton type0))) - (when (and x (typep (car x) 'movitz-fixnum)) - (movitz-immediate-value (car x))))) - (constant1 (let ((x (type-specifier-singleton type1))) - (when (and x (typep (car x) 'movitz-fixnum)) - (movitz-immediate-value (car x)))))) - (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) - (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)))) + ;; A null location means the binding is unused, in which + ;; case there's no need to perform the addition. + (when destination-location + (let ((loc0 (new-binding-location (binding-target term0) frame-map :default nil)) + (loc1 (new-binding-location (binding-target term1) frame-map :default nil))) + #+ignore + (warn "add: ~A for ~A" instruction result-type) + #+ignore + (warn "add for: ~S is ~A, from ~A/~A and ~A/~A." + destination result-type + term0 loc0 + term1 loc1) + #+ignore + (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))) + (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-store (source destination) + (cond + ((eq source destination) + nil) + ((member destination '(:eax :ebx :ecx :edx)) + `((:movl ,source ,destination))) + (t (make-store-lexical destination source nil funobj frame-map)))) + (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)))))) + (let ((constant0 (let ((x (type-specifier-singleton type0))) + (when (and x (typep (car x) 'movitz-fixnum)) + (movitz-immediate-value (car x))))) + (constant1 (let ((x (type-specifier-singleton type1))) + (when (and x (typep (car x) 'movitz-fixnum)) + (movitz-immediate-value (car x)))))) (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))))) + ((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 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-location 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))) - ((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 - 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 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)))) - ((and (movitz-subtypep type0 'fixnum) - (movitz-subtypep type1 'fixnum)) - (flet ((mkadd-into (src destreg) - (assert (eq destreg :eax) (destreg) - "Movitz' INTO protocol says the overflowed value must be in EAX, ~ -but it's requested to be in ~S." - destreg) - (let ((srcloc (new-binding-location (binding-target src) frame-map))) - (unless (eql srcloc loc1) (break)) - (if (integerp srcloc) - `((:addl (:ebp ,(stack-frame-offset srcloc)) - ,destreg) - (:into)) - (ecase (operator srcloc) - ((:eax :ebx :ecx :edx) - `((:addl ,srcloc ,destreg) - (:into))) - ((:argument-stack) - `((:addl (:ebx ,(argument-stack-offset src)) - ,destreg) - (:into))) - ))))) + `((:movl ,loc0 ,destination-location))) + ((member loc0 '(:eax :ebx :ecx :edx)) + (make-store-lexical destination loc0 nil funobj frame-map)) + ((integerp loc0) + (make-load-lexical term0 destination funobj nil 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 - ((and (not constant0) - (not constant1) - (not (binding-lended-p (binding-target term0))) + ((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 (eq loc0 :untagged-fixnum-ecx)) - (not (eq loc1 :untagged-fixnum-ecx)) - (not (eq destination-location :untagged-fixnum-ecx))) - (append (cond - ((and (eq loc0 :eax) (eq loc1 :eax)) - `((:addl :eax :eax) - (:into))) - ((eq loc0 :eax) - (mkadd-into term1 :eax)) - ((eq loc1 :eax) - (mkadd-into term0 :eax)) - (t (append (make-load-lexical term0 :eax funobj nil frame-map - :protect-registers (list loc1)) - (mkadd-into term1 :eax)))) + ((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))) + `((: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))) + ((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))) + (constant0 + (append (make-load-lexical term1 :eax funobj nil frame-map) + `((:addl ,constant0 :eax)) (make-store :eax destination))) - (t (make-default-add) - #+ignore - (append (make-load-lexical term0 :untagged-fixnum-ecx funobj nil frame-map) - `((,*compiler-local-segment-prefix* - :movl :ecx (:edi ,(global-constant-offset 'raw-scratch0)))) - (make-load-lexical term1 :untagged-fixnum-ecx funobj nil frame-map) - `((,*compiler-local-segment-prefix* - :addl (:edi ,(global-constant-offset 'raw-scratch0)) :ecx)) - (if (integerp destination-location) - `((,*compiler-local-segment-prefix* - :call (:edi ,(global-constant-offset 'box-u32-ecx))) - (:movl :eax (:ebp ,(stack-frame-offset destination-location)))) - (ecase (operator destination-location) - ((:untagged-fixnum-ecx) - nil) - ((:eax) - `((,*compiler-local-segment-prefix* - :call (:edi ,(global-constant-offset 'box-u32-ecx))))) - ((:ebx :ecx :edx) - `((,*compiler-local-segment-prefix* - :call (:edi ,(global-constant-offset 'box-u32-ecx))) - (:movl :eax ,destination-location))) - ((:argument-stack) - `((,*compiler-local-segment-prefix* - :call (:edi ,(global-constant-offset 'box-u32-ecx))) - (:movl :eax (:ebp ,(argument-stack-offset - (binding-target destination)))))))))))) - (t (make-default-add))))) - (t (make-default-add))))))))) + (constant1 + (append (make-load-lexical term0 :eax funobj nil frame-map) + `((:addl ,constant1 :eax)) + (make-store :eax destination))) + ((eql loc0 loc1) + (append (make-load-lexical term0 :eax funobj nil frame-map) + `((:addl :eax :eax)) + (make-store :eax destination))) + (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 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)))) + ((and (movitz-subtypep type0 'fixnum) + (movitz-subtypep type1 'fixnum)) + (flet ((mkadd-into (src destreg) + (assert (eq destreg :eax) (destreg) + "Movitz' INTO protocol says the overflowed value must be in EAX, ~ +but it's requested to be in ~S." + destreg) + (let ((srcloc (new-binding-location (binding-target src) frame-map))) + (unless (eql srcloc loc1) (break)) + (if (integerp srcloc) + `((:addl (:ebp ,(stack-frame-offset srcloc)) + ,destreg) + (:into)) + (ecase (operator srcloc) + ((:eax :ebx :ecx :edx) + `((:addl ,srcloc ,destreg) + (:into))) + ((:argument-stack) + `((:addl (:ebx ,(argument-stack-offset src)) + ,destreg) + (:into))) + ))))) + (cond + ((and (not constant0) + (not constant1) + (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 (eq loc0 :untagged-fixnum-ecx)) + (not (eq loc1 :untagged-fixnum-ecx)) + (not (eq destination-location :untagged-fixnum-ecx))) + (append (cond + ((and (eq loc0 :eax) (eq loc1 :eax)) + `((:addl :eax :eax) + (:into))) + ((eq loc0 :eax) + (mkadd-into term1 :eax)) + ((eq loc1 :eax) + (mkadd-into term0 :eax)) + (t (append (make-load-lexical term0 :eax funobj nil frame-map + :protect-registers (list loc1)) + (mkadd-into term1 :eax)))) + (make-store :eax destination))) + (t (make-default-add) + #+ignore + (append (make-load-lexical term0 :untagged-fixnum-ecx funobj nil frame-map) + `((,*compiler-local-segment-prefix* + :movl :ecx (:edi ,(global-constant-offset 'raw-scratch0)))) + (make-load-lexical term1 :untagged-fixnum-ecx funobj nil frame-map) + `((,*compiler-local-segment-prefix* + :addl (:edi ,(global-constant-offset 'raw-scratch0)) :ecx)) + (if (integerp destination-location) + `((,*compiler-local-segment-prefix* + :call (:edi ,(global-constant-offset 'box-u32-ecx))) + (:movl :eax (:ebp ,(stack-frame-offset destination-location)))) + (ecase (operator destination-location) + ((:untagged-fixnum-ecx) + nil) + ((:eax) + `((,*compiler-local-segment-prefix* + :call (:edi ,(global-constant-offset 'box-u32-ecx))))) + ((:ebx :ecx :edx) + `((,*compiler-local-segment-prefix* + :call (:edi ,(global-constant-offset 'box-u32-ecx))) + (:movl :eax ,destination-location))) + ((:argument-stack) + `((,*compiler-local-segment-prefix* + :call (:edi ,(global-constant-offset 'box-u32-ecx))) + (:movl :eax (:ebp ,(argument-stack-offset + (binding-target destination)))))))))))) + (t (make-default-add))))) + (t (make-default-add))))))))))

;;;;;;;