Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv30482
Modified Files: compiler.lisp Log Message: Smarted up make-load-lexical and make-store-lexical somewhat regarding recognizing constant values.
Date: Mon Aug 15 23:44:24 2005 Author: ffjeld
Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.148 movitz/compiler.lisp:1.149 --- movitz/compiler.lisp:1.148 Thu Jul 21 19:28:46 2005 +++ movitz/compiler.lisp Mon Aug 15 23:44:23 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.148 2005/07/21 17:28:46 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.149 2005/08/15 21:44:23 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------
@@ -3446,62 +3446,86 @@ (first (set-difference '(:eax :ebx :edx) protect-registers)) (error "Unable to chose a temporary register."))) - (install-for-single-value (lexb lexb-location result-mode indirect-p) - (cond - ((and (eq result-mode :untagged-fixnum-ecx) - (integerp lexb-location)) - (assert (not indirect-p)) - (assert (not (member :eax protect-registers))) - (append (install-for-single-value lexb lexb-location :eax nil) - `((,*compiler-global-segment-prefix* - :call (:edi ,(global-constant-offset 'unbox-u32)))))) - ((integerp lexb-location) - (append `((:movl ,(make-indirect-reference :ebp (stack-frame-offset lexb-location)) - ,(single-value-register result-mode))) - (when indirect-p - `((:movl (-1 ,(single-value-register result-mode)) - ,(single-value-register result-mode)))))) - (t (ecase (operator lexb-location) - (:push - (assert (member result-mode '(:eax :ebx :ecx :edx))) - (assert (not indirect-p)) - `((:popl ,result-mode))) - (:eax - (assert (not indirect-p)) - (ecase result-mode - ((:ebx :ecx :edx :esi) `((:movl :eax ,result-mode))) - ((:eax :single-value) nil) - (:untagged-fixnum-ecx - `((,*compiler-global-segment-prefix* - :call (:edi ,(global-constant-offset 'unbox-u32))))))) - ((:ebx :ecx :edx) - (assert (not indirect-p)) - (unless (eq result-mode lexb-location) + (install-for-single-value (lexb lexb-location result-mode indirect-p + &optional binding-type) + (let ((decoded-type (when binding-type + (apply #'encoded-type-decode binding-type)))) + (cond + ((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)) + (warn "Immloadlex: ~S" + (type-specifier-singleton decoded-type)) + (make-immediate-move (movitz-immediate-value + (car (type-specifier-singleton decoded-type))) + :ecx)) + (t + (assert (not indirect-p)) + (assert (not (member :eax protect-registers))) + (append (install-for-single-value lexb lexb-location :eax nil) + `((,*compiler-global-segment-prefix* + :call (:edi ,(global-constant-offset 'unbox-u32)))))))) + ((integerp lexb-location) + (append `((:movl ,(make-indirect-reference :ebp (stack-frame-offset lexb-location)) + ,(single-value-register result-mode))) + (when indirect-p + `((:movl (-1 ,(single-value-register result-mode)) + ,(single-value-register result-mode)))))) + ((eq lexb-location result-mode) + ()) + (t (when (and (eq result-mode :untagged-fixnum-ecx) + binding-type + (type-specifier-singleton decoded-type)) + (break "xxx Immloadlex: ~S ~S" + (operator lexb-location) + (type-specifier-singleton decoded-type))) + (ecase (operator lexb-location) + (:push + (assert (member result-mode '(:eax :ebx :ecx :edx))) + (assert (not indirect-p)) + `((:popl ,result-mode))) + (:eax + (assert (not indirect-p)) (ecase result-mode - ((:eax :single-value) `((:movl ,lexb-location :eax))) - ((:ebx :ecx :edx :esi) `((:movl ,lexb-location ,result-mode))) + ((:ebx :ecx :edx :esi) `((:movl :eax ,result-mode))) + ((:eax :single-value) nil) (:untagged-fixnum-ecx - `((:movl ,lexb-location :ecx) - (:sarl ,movitz:+movitz-fixnum-shift+ :ecx)))))) - (:argument-stack - (assert (<= 2 (function-argument-argnum lexb)) () - "lexical :argument-stack argnum can't be ~A." (function-argument-argnum lexb)) - (cond - ((eq result-mode :untagged-fixnum-ecx) + `((,*compiler-global-segment-prefix* + :call (:edi ,(global-constant-offset 'unbox-u32))))))) + ((:ebx :ecx :edx) (assert (not indirect-p)) - `((:movl (:ebp ,(argument-stack-offset lexb)) :ecx) - (:sarl ,+movitz-fixnum-shift+ :ecx))) - (t (append `((:movl (:ebp ,(argument-stack-offset lexb)) - ,(single-value-register result-mode))) - (when indirect-p - `((:movl (-1 ,(single-value-register result-mode)) - ,(single-value-register result-mode)))))))) - (:untagged-fixnum-ecx - (ecase result-mode - ((:eax :ebx :ecx :edx) - `((:leal ((:ecx ,+movitz-fixnum-factor+)) ,result-mode))) - (:untagged-fixnum-ecx - nil)))))))) + (unless (eq result-mode lexb-location) + (ecase result-mode + ((:eax :single-value) `((:movl ,lexb-location :eax))) + ((:ebx :ecx :edx :esi) `((:movl ,lexb-location ,result-mode))) + (:untagged-fixnum-ecx + `((:movl ,lexb-location :ecx) + (:sarl ,movitz:+movitz-fixnum-shift+ :ecx)))))) + (:argument-stack + (assert (<= 2 (function-argument-argnum lexb)) () + "lexical :argument-stack argnum can't be ~A." (function-argument-argnum lexb)) + (cond + ((eq result-mode :untagged-fixnum-ecx) + (assert (not indirect-p)) + `((:movl (:ebp ,(argument-stack-offset lexb)) :ecx) + (:sarl ,+movitz-fixnum-shift+ :ecx))) + (t (append `((:movl (:ebp ,(argument-stack-offset lexb)) + ,(single-value-register result-mode))) + (when indirect-p + `((:movl (-1 ,(single-value-register result-mode)) + ,(single-value-register result-mode)))))))) + (:untagged-fixnum-ecx + (ecase result-mode + ((:eax :ebx :ecx :edx) + `((:leal ((:ecx ,+movitz-fixnum-factor+)) ,result-mode))) + (:untagged-fixnum-ecx + nil))))))))) (etypecase binding (forwarding-binding (assert (not (binding-lended-p binding)) (binding) @@ -3545,7 +3569,8 @@ ,tmp-register) (:movl (,tmp-register -1) ,tmp-register)))))))))) (located-binding - (let ((binding-location (new-binding-location binding frame-map))) + (let ((binding-type (binding-store-type binding)) + (binding-location (new-binding-location binding frame-map))) (cond ((and (binding-lended-p binding) (not shared-reference-p)) @@ -3607,7 +3632,8 @@ `((:cmpl :edi (:ebp ,(argument-stack-offset binding))) (:je ',(operands result-mode))))))) (:untagged-fixnum-ecx - (install-for-single-value binding binding-location :untagged-fixnum-ecx nil)) + (install-for-single-value binding binding-location :untagged-fixnum-ecx nil + binding-type)) (:lexical-binding (let* ((destination result-mode) (dest-location (new-binding-location destination frame-map :default nil))) @@ -3639,16 +3665,9 @@ (not (binding-lended-p binding)))) (binding) "funny binding: ~W" binding) - (if (typep source 'constant-object-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)) - #+ignore (source (if (not (typep source 'constant-object-binding)) - source - (etypecase (constant-object source) - (movitz-null - :edi) - (movitz-immediate-object - (movitz-immediate-value (constant-object source))))))) + (let ((protect-registers (cons source protect-registers))) (cond ((eq :untagged-fixnum-ecx source) (if (eq :untagged-fixnum-ecx @@ -3690,28 +3709,72 @@ `((:movl (:ebp ,(argument-stack-offset binding)) ,tmp-reg) (:movl ,source (,tmp-reg -1)))))))) (t (let ((location (new-binding-location binding frame-map))) - (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 - (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))))))))))))))) + (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)))))))))) + ((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)))))))))
(defun finalize-code (code funobj frame-map) ;; (print-code 'to-be-finalized code) @@ -3980,7 +4043,7 @@ (make-store-lexical result-mode :eax nil funobj frame-map))) (:untagged-fixnum-ecx (let ((value (movitz-fixnum-value object))) - (check-type value (signed-byte 30)) + (check-type value (unsigned-byte 32)) (make-immediate-move value :ecx))) (:push `((:pushl ,x))) @@ -6179,16 +6242,6 @@ (borrowed-binding-target binding))) (error "Can't install non-local binding ~W." binding)))))))
-(defun binding-type-specifier (binding) - (break "nix binding-type-specifier: ~S" binding) - (etypecase binding - (forwarding-binding - (binding-type-specifier (forwarding-binding-target binding))) - (constant-object-binding - `(eql ,(constant-object binding))) - (binding - `(binding-type ,binding)))) - (defun binding-store-subtypep (binding type-specifier) "Is type-specifier a supertype of all values ever stored to binding? (Assuming analyze-bindings has put this information into binding-store-type.)" @@ -6197,6 +6250,11 @@ (multiple-value-call #'encoded-subtypep (values-list (binding-store-type binding)) (type-specifier-encode type-specifier)))) + +(defun binding-singleton (binding) + (let ((btype (binding-store-type binding))) + (when btype + (type-specifier-singleton (apply #'encoded-type-decode btype)))))
;;;;;;; ;;;;;;; Extended-code handlers