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

Modified Files: compiler.lisp Log Message: Improved various aspects related to compiling :incf-lexvar.

Date: Fri Feb 13 05:40:15 2004 Author: ffjeld

Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.23 movitz/compiler.lisp:1.24 --- movitz/compiler.lisp:1.23 Thu Feb 12 16:57:05 2004 +++ movitz/compiler.lisp Fri Feb 13 05:40:14 2004 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.23 2004/02/12 21:57:05 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.24 2004/02/13 10:40:14 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------

@@ -2709,6 +2709,14 @@ mode) (t default-mode)))

+(defun chose-free-register (unfree-registers &optional (preferred-register :eax)) + (cond + ((not (member preferred-register unfree-registers)) + preferred-register) + ((find-if (lambda (r) (not (member r unfree-registers))) + '(:eax :ebx :ecx :edx))) + (t (error "Unable to find a free register.")))) + (defun make-indirect-reference (base-register offset) "Make the shortest possible assembly indirect reference, explointing the constant edi register." (if (<= #x-80 offset #x7f) @@ -2874,51 +2882,55 @@ (install-for-single-value binding binding-location :eax nil))) ))))))))

-(defun make-store-lexical (binding source shared-reference-p frame-map) +(defun make-store-lexical (binding source shared-reference-p frame-map + &key protect-registers) (assert (not (and shared-reference-p (not (binding-lended-p binding)))) (binding) "funny binding: ~W" binding) - (cond - ((typep binding 'borrowed-binding) - (let ((slot (borrowed-binding-reference-slot binding))) - (if (not shared-reference-p) - (let ((tmp-reg (if (eq source :eax) :ebx :eax))) - `((:movl (:esi ,(+ (slot-offset 'movitz-funobj 'constant0) (* 4 slot))) - ,tmp-reg) - (:movl ,source (-1 ,tmp-reg)))) - `((:movl ,source (:esi ,(+ (slot-offset 'movitz-funobj 'constant0) (* 4 slot)))))))) - ((typep binding 'forwarding-binding) - (assert (not (binding-lended-p binding)) (binding)) - (make-store-lexical (forwarding-binding-target binding) - source shared-reference-p frame-map)) - ((not (new-binding-located-p binding frame-map)) - ;; (warn "Can't store to unlocated binding ~S." binding) - nil) - ((and (binding-lended-p binding) - (not shared-reference-p)) - (let ((tmp-reg (if (eq source :eax) :ebx :eax)) - (location (new-binding-location binding frame-map))) - (if (integerp location) - `((:movl (:ebp ,(stack-frame-offset location)) ,tmp-reg) - (:movl ,source (,tmp-reg -1))) - (ecase location - (:argument-stack - (assert (<= 2 (function-argument-argnum binding)) () - "store-lexical argnum can't be ~A." (function-argument-argnum binding)) - `((:movl (:ebp ,(argument-stack-offset binding)) ,tmp-reg) - (:movl ,source (,tmp-reg -1)))))))) - (t (let ((location (new-binding-location binding frame-map))) + (let ((protect-registers (cons source protect-registers))) + (cond + ((typep binding 'borrowed-binding) + (let ((slot (borrowed-binding-reference-slot binding))) + (if (not shared-reference-p) + (let ((tmp-reg (chose-free-register protect-registers) + #+ignore(if (eq source :eax) :ebx :eax))) + `((:movl (:esi ,(+ (slot-offset 'movitz-funobj 'constant0) (* 4 slot))) + ,tmp-reg) + (:movl ,source (-1 ,tmp-reg)))) + `((:movl ,source (:esi ,(+ (slot-offset 'movitz-funobj 'constant0) (* 4 slot)))))))) + ((typep binding 'forwarding-binding) + (assert (not (binding-lended-p binding)) (binding)) + (make-store-lexical (forwarding-binding-target binding) + source shared-reference-p frame-map)) + ((not (new-binding-located-p binding frame-map)) + ;; (warn "Can't store to unlocated binding ~S." binding) + nil) + ((and (binding-lended-p binding) + (not shared-reference-p)) + (let ((tmp-reg (chose-free-register protect-registers) + #+ignore (if (eq source :eax) :ebx :eax)) + (location (new-binding-location binding frame-map))) (if (integerp location) - `((:movl ,source (:ebp ,(stack-frame-offset location)))) + `((:movl (:ebp ,(stack-frame-offset location)) ,tmp-reg) + (:movl ,source (,tmp-reg -1))) (ecase location - ((:eax :ebx :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))))))))))) + `((: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 location + ((:eax :ebx :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))))))))))))

(defun finalize-code (code funobj frame-map) (labels ((actual-binding (b) @@ -5333,17 +5345,17 @@ ;;;;;;;;;;;;;;;;;; incf-lexvar

(define-find-write-binding-and-type :incf-lexvar (instruction) - (destructuring-bind (binding delta) + (destructuring-bind (binding delta &key protect-registers) (cdr instruction) - (declare (ignore delta)) + (declare (ignore delta protect-registers)) (values binding 'integer)))

-(define-find-read-bindings :incf-lexvar (binding delta) - (declare (ignore delta)) +(define-find-read-bindings :incf-lexvar (binding delta &key protect-registers) + (declare (ignore delta protect-registers)) binding)

(define-extended-code-expander :incf-lexvar (instruction funobj frame-map) - (destructuring-bind (binding delta) + (destructuring-bind (binding delta &key protect-registers) (cdr instruction) (check-type binding binding) (check-type delta integer) @@ -5353,32 +5365,38 @@ "Weird encoded-type: ~S" (binding-store-type binding)) (cond ((and location + (not (binding-lended-p binding)) (multiple-value-call #'encoded-subtypep (values-list (binding-store-type binding)) (type-specifier-encode 'integer))) - #+ignore - (warn "incf ~S type: ~S location: ~S" - binding - (apply #'encoded-type-decode (binding-store-type binding)) - location) + ;; This is an optimized incf that doesn't have to do type-checking. (check-type location (integer 1 *)) `((:addl ,(* delta +movitz-fixnum-factor+) (:ebp ,(stack-frame-offset location))) (:into))) ((multiple-value-call #'encoded-subtypep - (values-list (binding-store-type binding)) - (type-specifier-encode 'integer)) - `(,@(make-load-lexical (ensure-local-binding binding funobj) :eax funobj nil frame-map) - (:addl ,(* delta +movitz-fixnum-factor+) :eax) - (:into) - ,@(make-store-lexical (ensure-local-binding binding funobj) - :eax nil frame-map))) - (t `(,@(make-load-lexical (ensure-local-binding binding funobj) :eax funobj nil frame-map) - (:testb ,+movitz-fixnum-zmask+ :al) - (:jnz '(:sub-program (,(gensym "not-integer-")) - (:int 107) - (:jmp (:pc+ -4)))) + (values-list (binding-store-type binding)) + (type-specifier-encode 'integer)) + (let ((register (chose-free-register protect-registers))) + `(,@(make-load-lexical (ensure-local-binding binding funobj) + register funobj nil frame-map + :protect-registers protect-registers) (:addl ,(* delta +movitz-fixnum-factor+) :eax) (:into) - ,@(make-store-lexical (ensure-local-binding binding funobj) :eax nil frame-map))))))) + ,@(make-store-lexical (ensure-local-binding binding funobj) + register nil frame-map + :protect-registers protect-registers)))) + (t (let ((register (chose-free-register protect-registers))) + `(,@(make-load-lexical (ensure-local-binding binding funobj) + register funobj nil frame-map + :protect-registers protect-registers) + (:testb ,+movitz-fixnum-zmask+ ,(register32-to-low8 register)) + (:jnz '(:sub-program (,(gensym "not-integer-")) + (:int 107) + (:jmp (:pc+ -4)))) + (:addl ,(* delta +movitz-fixnum-factor+) ,register) + (:into) + ,@(make-store-lexical (ensure-local-binding binding funobj) + register nil frame-map + :protect-registers protect-registers))))))))