[movitz-cvs] CVS update: movitz/compiler.lisp
Frode Vatvedt Fjeld
ffjeld at common-lisp.net
Sat Jul 10 13:29:11 UTC 2004
Update of /project/movitz/cvsroot/movitz
In directory common-lisp.net:/tmp/cvs-serv11680
Modified Files:
compiler.lisp
Log Message:
Re-working the compilation of addition. Now use a proper extended-code
instruction (which is like a "vop", I think).
Date: Sat Jul 10 06:29:11 2004
Author: ffjeld
Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.71 movitz/compiler.lisp:1.72
--- movitz/compiler.lisp:1.71 Fri Jul 9 09:11:20 2004
+++ movitz/compiler.lisp Sat Jul 10 06:29:11 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.71 2004/07/09 16:11:20 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.72 2004/07/10 13:29:11 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
@@ -389,6 +389,9 @@
(member-type-encode (constant-object target-binding))))))
(t (pushnew target-binding (type-analysis-binding-types analysis))
(setf more-binding-references-p t)))))
+ ((and (bindingp type)
+ (binding-eql type binding))
+ nil)
(t (setf (type-analysis-encoded-type analysis)
(multiple-value-list
(multiple-value-call
@@ -5425,7 +5428,6 @@
(compiler-values ()
:code (make-compiled-lexical-load binding returns)
:final-form binding
- :type (binding-type-specifier binding)
:returns returns
:functional-p t))))))
@@ -6098,47 +6100,88 @@
(define-find-read-bindings :add (term0 term1 destination)
(declare (ignore destination))
- (remove-if-not #'bindingp (list term0 term1)))
+ (list term0 term1))
(define-extended-code-expander :add (instruction funobj frame-map)
(destructuring-bind (term0 term1 destination)
(cdr instruction)
- (cond
- ((and (bindingp term0)
- (bindingp term1)
- (member destination
- '(:function :multple-values :eax :ebx :ecx :edx)))
- #+ignore
- (when (and (binding-store-subtypep term0 'fixnum)
- (binding-store-subtypep term1 'fixnum)
- (movitz-subtypep (multiple-value-call #'encoded-integer-types-add
- (values-list (binding-store-type term0))
- (values-list (binding-store-type term1)))
- 'fixnum))
- (warn "add: ~S~%~A => ~A~%~S, ~S"
- instruction
- (binding-type-specifier term0)
- (binding-type-specifier term1)
- (binding-store-subtypep term0 'fixnum)
- (binding-store-subtypep term1 'fixnum)))
+ (assert (and (bindingp term0)
+ (bindingp term1)
+ (member (result-mode-type destination)
+ '(:lexical-binding :function :multple-values :eax :ebx :ecx :edx))))
+ (let* ((term0 (binding-target term0))
+ (term1 (binding-target term1))
+ (destination (if (or (not (bindingp destination))
+ (not (symbolp (new-binding-location destination frame-map :default 0))))
+ destination
+ (new-binding-location destination frame-map)))
+ (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 "add for: ~S is ~A." destination result-type)
(let ((loc0 (new-binding-location term0 frame-map :default nil))
(loc1 (new-binding-location term1 frame-map :default nil)))
- (append (cond
- ((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)
- (ecase destination
- ((:function :multple-values :eax))
- ((:ebx :ecx :edx)
- `((:movl :eax ,destination))))
- )))
- (t (error "Unknown add: ~S" instruction)))))
+ (cond
+ ((type-specifier-singleton result-type)
+ ;; (break "constant add: ~S" instruction)
+ (make-load-constant (car (type-specifier-singleton result-type))
+ destination funobj frame-map))
+ ((and (movitz-subtypep type1 'fixnum)
+ (movitz-subtypep type1 'fixnum)
+ (movitz-subtypep result-type 'fixnum))
+ (cond
+ ((and (type-specifier-singleton type0)
+ (eq loc1 destination))
+ (cond
+ ((member destination '(:eax :ebx :ecx :edx))
+ `((:addl ,(movitz-immediate-value (car (type-specifier-singleton type0)))
+ ,destination)))
+ (t (assert (integerp loc1))
+ (break "check that this is correct..")
+ `((:addl ,(movitz-immediate-value (car (type-specifier-singleton type0)))
+ (:ebp ,(stack-frame-offset loc1)))))))
+ (t (warn "ADD: ~S = ~A + ~A, ~A ~A, ~A ~A"
+ destination loc0 loc1 type0 type1
+ (type-specifier-singleton type0)
+ (eq loc1 destination))
+ (warn "ADDI: ~S" instruction)
+ (append (cond
+ ((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 frame-map)))))))
+ (t (append (cond
+ ((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 frame-map))))))))))
More information about the Movitz-cvs
mailing list