[movitz-cvs] CVS update: movitz/compiler.lisp
Frode Vatvedt Fjeld
ffjeld at common-lisp.net
Sun Aug 21 15:27:20 UTC 2005
Update of /project/movitz/cvsroot/movitz
In directory common-lisp.net:/tmp/cvs-serv4805
Modified Files:
compiler.lisp
Log Message:
Improved :add extended-code.
Date: Sun Aug 21 17:27:19 2005
Author: ffjeld
Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.150 movitz/compiler.lisp:1.151
--- movitz/compiler.lisp:1.150 Sat Aug 20 22:30:40 2005
+++ movitz/compiler.lisp Sun Aug 21 17:27:19 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.150 2005/08/20 20:30:40 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.151 2005/08/21 15:27:19 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
@@ -3066,33 +3066,6 @@
(warn "Unused variable: ~S"
(binding-name binding))))
((not (plusp (or (car (gethash binding var-counts)) 0))))))
- collect binding)
- #+ignore
- (loop for (variable . binding) in (movitz-environment-bindings env)
- unless (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 env nil)
- (movitz-env-get variable 'ignorable nil env 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)
@@ -3145,6 +3118,13 @@
(when bindings-to-locate
(dox (binding-env (first bindings-to-locate))
#'movitz-environment-uplink)))))
+ #+ignore
+ (loop for binding in bindings-to-locate
+ do (when (binding-store-type binding)
+ (warn "~S => ~S" binding (binding-store-type binding)))
+ (when (typep (binding-store-type binding) 'lexical-binding)
+ (warn "binding ~S == ~S"
+ binding (binding-store-type binding))))
;; First, make several passes while trying to locate bindings
;; into registers.
(loop repeat 100 with try-again = t and did-assign = t
@@ -6835,72 +6815,111 @@
((and (movitz-subtypep type0 'fixnum)
(movitz-subtypep type1 'fixnum)
(movitz-subtypep result-type 'fixnum))
- #+ignore (warn "ADDX: ~S" instruction)
- (cond
- ((and (type-specifier-singleton type0)
- (eq loc1 destination-location))
+ (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
- ((member destination-location '(:eax :ebx :ecx :edx))
- `((:addl ,(movitz-immediate-value (car (type-specifier-singleton type0)))
- ,destination)))
- ((integerp loc1)
- ;; (break "check that this is correct..")
- `((:addl ,(movitz-immediate-value (car (type-specifier-singleton type0)))
- (:ebp ,(stack-frame-offset loc1)))))
- ((eq :argument-stack (operator loc1))
- `((:addl ,(movitz-immediate-value (car (type-specifier-singleton type0)))
- (:ebp ,(argument-stack-offset (binding-target term1))))))
- (t (error "Don't know how to add this for loc1 ~S" loc1))))
- ((and (type-specifier-singleton type0)
- (eq term1 destination)
- (integerp destination-location))
- (break "untested")
- `((:addl ,(movitz-immediate-value (car (type-specifier-singleton type0)))
- (:ebp ,(stack-frame-offset destination-location)))))
- ((and (type-specifier-singleton type0)
- (symbolp loc1)
- (integerp destination-location))
- (append `((:addl ,(movitz-immediate-value (car (type-specifier-singleton type0)))
- ,loc1))
- (make-store-lexical destination loc1 nil funobj frame-map)))
- ((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))))
- (t (warn "ADD: ~A/~S = ~A/~S + ~A/~S"
- destination-location
- destination
- loc0 term0
- loc1 term1)
- #+ignore (warn "map: ~A" frame-map)
+ ((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)))))))
+ (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))))))))
(t (append (cond
((type-specifier-singleton type0)
(append (make-load-lexical term1 :eax funobj nil frame-map)
More information about the Movitz-cvs
mailing list