Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv14806
Modified Files: compiler.lisp Log Message: Various tweaks for compiling forms with literal objects as arguments to certain operators.
--- /project/movitz/cvsroot/movitz/compiler.lisp 2006/04/28 23:20:45 1.168 +++ /project/movitz/cvsroot/movitz/compiler.lisp 2006/05/02 19:59:55 1.169 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.168 2006/04/28 23:20:45 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.169 2006/05/02 19:59:55 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------
@@ -3889,10 +3889,21 @@ (ecase (operator location) ((:argument-stack) `((:movl ,immediate (:ebp ,(argument-stack-offset binding))))) - ((:eax :ebx :edx) + ((:eax :ebx :ecx :edx) (make-immediate-move immediate location)) ((:untagged-fixnum-ecx) (make-immediate-move (movitz-fixnum-value value) :ecx)))))) + (movitz-character + (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)))))) + (ecase (operator location) + ((:argument-stack) + `((:movl ,immediate (:ebp ,(argument-stack-offset binding))))) + ((:eax :ebx :ecx :edx) + (make-immediate-move immediate location)))))) (movitz-heap-object (etypecase location ((member :eax :ebx :edx) @@ -6676,50 +6687,65 @@ (destructuring-bind (op cell dst) (cdr instruction) (check-type dst (member :eax :ebx :ecx :edx)) - (multiple-value-bind (op-offset fast-op fast-op-ebx) + (multiple-value-bind (op-offset fast-op fast-op-ebx cl-op) (ecase op (:car (values (bt:slot-offset 'movitz-cons 'car) 'fast-car - 'fast-car-ebx)) + 'fast-car-ebx + 'movitz-car)) (:cdr (values (bt:slot-offset 'movitz-cons 'cdr) 'fast-cdr - 'fast-cdr-ebx))) - (let* ((binding (binding-target (ensure-local-binding (binding-target cell) funobj))) - (location (new-binding-location (binding-target binding) frame-map)) - (binding-is-list-p (binding-store-subtypep binding 'list))) - #+ignore (warn "~A of loc ~A bind ~A" op location binding) - (cond - ((and binding-is-list-p - (member location '(:eax :ebx :ecx :edx))) - `((,*compiler-nonlocal-lispval-read-segment-prefix* - :movl (,location ,op-offset) ,dst))) - (binding-is-list-p - `(,@(make-load-lexical binding dst funobj nil frame-map) - (,*compiler-nonlocal-lispval-read-segment-prefix* - :movl (,dst ,op-offset) ,dst))) - ((not *compiler-use-cons-reader-segment-protocol-p*) - (cond - ((eq location :ebx) - `((,*compiler-global-segment-prefix* - :call (:edi ,(global-constant-offset fast-op-ebx))) - ,@(when (not (eq dst :eax)) - `((:movl :eax ,dst))))) - (t `(,@(make-load-lexical binding :eax funobj nil frame-map) - (,*compiler-global-segment-prefix* - :call (:edi ,(global-constant-offset fast-op))) - ,@(when (not (eq dst :eax)) - `((:movl :eax ,dst))))))) - (t (cond - ((member location '(:ebx :ecx :edx)) - `((,(or *compiler-cons-read-segment-prefix* - *compiler-nonlocal-lispval-read-segment-prefix*) - :movl (:eax ,op-offset) ,dst))) - (t (append (make-load-lexical binding :eax funobj nil frame-map) - `((,(or *compiler-cons-read-segment-prefix* - *compiler-nonlocal-lispval-read-segment-prefix*) - :movl (:eax ,op-offset) ,dst))))))))))) - - + 'fast-cdr-ebx + 'movitz-cdr))) + (let ((binding (binding-target (ensure-local-binding (binding-target cell) funobj)))) + (etypecase binding + (constant-object-binding + (let ((x (constant-object binding))) + (typecase x + (movitz-null + (make-load-constant *movitz-nil* dst funobj frame-map)) + (movitz-cons + (append (make-load-constant x dst funobj frame-map) + `((:movl (,dst ,op-offset) ,dst)))) + (t `(,@(make-load-lexical binding :eax funobj nil frame-map) + (,*compiler-global-segment-prefix* + :call (:edi ,(global-constant-offset fast-op))) + ,@(when (not (eq dst :eax)) + `((:movl :eax ,dst)))))))) + (lexical-binding + (let ((location (new-binding-location (binding-target binding) frame-map)) + (binding-is-list-p (binding-store-subtypep binding 'list))) + #+ignore (warn "~A of loc ~A bind ~A" op location binding) + (cond + ((and binding-is-list-p + (member location '(:eax :ebx :ecx :edx))) + `((,*compiler-nonlocal-lispval-read-segment-prefix* + :movl (,location ,op-offset) ,dst))) + (binding-is-list-p + `(,@(make-load-lexical binding dst funobj nil frame-map) + (,*compiler-nonlocal-lispval-read-segment-prefix* + :movl (,dst ,op-offset) ,dst))) + ((not *compiler-use-cons-reader-segment-protocol-p*) + (cond + ((eq location :ebx) + `((,*compiler-global-segment-prefix* + :call (:edi ,(global-constant-offset fast-op-ebx))) + ,@(when (not (eq dst :eax)) + `((:movl :eax ,dst))))) + (t `(,@(make-load-lexical binding :eax funobj nil frame-map) + (,*compiler-global-segment-prefix* + :call (:edi ,(global-constant-offset fast-op))) + ,@(when (not (eq dst :eax)) + `((:movl :eax ,dst))))))) + (t (cond + ((member location '(:ebx :ecx :edx)) + `((,(or *compiler-cons-read-segment-prefix* + *compiler-nonlocal-lispval-read-segment-prefix*) + :movl (:eax ,op-offset) ,dst))) + (t (append (make-load-lexical binding :eax funobj nil frame-map) + `((,(or *compiler-cons-read-segment-prefix* + *compiler-nonlocal-lispval-read-segment-prefix*) + :movl (:eax ,op-offset) ,dst))))))))))))))
;;;;;;;;;;;;;;;;;; endp @@ -6732,39 +6758,49 @@ (define-extended-code-expander :endp (instruction funobj frame-map) (destructuring-bind (cell result-mode) (cdr instruction) - (let* ((binding (binding-target (ensure-local-binding (binding-target cell) funobj))) - (location (new-binding-location (binding-target binding) frame-map)) - (binding-is-list-p (binding-store-subtypep binding 'list)) - (tmp-register (case location - ((:eax :ebx :ecx :edx) - location)))) - ;; (warn "endp of loc ~A bind ~A" location binding) - (cond - ((and binding-is-list-p - (member location '(:eax :ebx :ecx :edx))) - (make-result-and-returns-glue result-mode :boolean-zf=1 - `((:cmpl :edi ,location)))) - ((eq :boolean-branch-on-true (result-mode-type result-mode)) - (let ((tmp-register (or tmp-register :ecx))) - (append (make-load-lexical binding - (cons :boolean-branch-on-false - (cdr result-mode)) - funobj nil frame-map) - (unless binding-is-list-p - (append (make-load-lexical binding tmp-register funobj nil frame-map) - `((:leal (,tmp-register -1) :ecx) - (:testb 3 :cl) - (:jnz '(:sub-program (,(gensym "endp-not-cons-")) - (:int 66))))))))) - (t (let ((tmp-register (or tmp-register :eax))) - (append (make-load-lexical binding tmp-register funobj nil frame-map) - (unless binding-is-list-p - `((:leal (,tmp-register -1) :ecx) - (:testb 3 :cl) - (:jnz '(:sub-program (,(gensym "endp-not-cons-")) - (:int 66))))) - `((:cmpl :edi ,tmp-register)) - (make-result-and-returns-glue result-mode :boolean-zf=1)))))))) + (let ((binding (binding-target (ensure-local-binding (binding-target cell) funobj)))) + (etypecase binding + (constant-object-binding + (let ((x (constant-object binding))) + (typecase x + (movitz-cons + (make-load-constant *movitz-nil* result-mode funobj frame-map)) + (movitz-null + (make-load-constant (image-t-symbol *image*) result-mode funobj frame-map)) + (t '((:int 61)))))) + (lexical-binding + (let* ((location (new-binding-location (binding-target binding) frame-map)) + (binding-is-list-p (binding-store-subtypep binding 'list)) + (tmp-register (case location + ((:eax :ebx :ecx :edx) + location)))) + ;; (warn "endp of loc ~A bind ~A" location binding) + (cond + ((and binding-is-list-p + (member location '(:eax :ebx :ecx :edx))) + (make-result-and-returns-glue result-mode :boolean-zf=1 + `((:cmpl :edi ,location)))) + ((eq :boolean-branch-on-true (result-mode-type result-mode)) + (let ((tmp-register (or tmp-register :ecx))) + (append (make-load-lexical binding + (cons :boolean-branch-on-false + (cdr result-mode)) + funobj nil frame-map) + (unless binding-is-list-p + (append (make-load-lexical binding tmp-register funobj nil frame-map) + `((:leal (,tmp-register -1) :ecx) + (:testb 3 :cl) + (:jnz '(:sub-program (,(gensym "endp-not-cons-")) + (:int 66))))))))) + (t (let ((tmp-register (or tmp-register :eax))) + (append (make-load-lexical binding tmp-register funobj nil frame-map) + (unless binding-is-list-p + `((:leal (,tmp-register -1) :ecx) + (:testb 3 :cl) + (:jnz '(:sub-program (,(gensym "endp-not-cons-")) + (:int 66))))) + `((:cmpl :edi ,tmp-register)) + (make-result-and-returns-glue result-mode :boolean-zf=1)))))))))))
;;;;;;;;;;;;;;;;;; incf-lexvar @@ -6867,11 +6903,23 @@ (type1 (and (binding-store-type term1) (apply #'encoded-type-decode (binding-store-type term1)))) (singleton0 (and type0 (type-specifier-singleton type0))) - (singleton1 (and type1 (type-specifier-singleton type1)))) - (append (unless (and singleton0 (typep (car singleton0) 'movitz-fixnum)) - (list term0)) - (unless (and singleton1 (typep (car singleton1) 'movitz-fixnum)) - (list term1))))) + (singleton1 (and type1 (type-specifier-singleton type1))) + (singleton-sum (and singleton0 singleton1 + (type-specifier-singleton + (apply #'encoded-integer-types-add + (append (binding-store-type term0) + (binding-store-type term1))))))) + (cond + (singleton-sum + (let ((b (make-instance 'constant-object-binding + :name (gensym "constant-sum") + :object (car singleton-sum)))) + (movitz-env-add-binding (binding-env term0) b) + (list b))) + (t (append (unless (and singleton0 (typep (car singleton0) 'movitz-fixnum)) + (list term0)) + (unless (and singleton1 (typep (car singleton1) 'movitz-fixnum)) + (list term1)))))))
(define-extended-code-expander :add (instruction funobj frame-map) (destructuring-bind (term0 term1 destination)