[movitz-cvs] CVS update: movitz/compiler.lisp

[Frode Vatvedt Fjeld]

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

Modified Files:
	compiler.lisp 
Log Message:
Implementing :add extended-code.

Date: Fri Jul  9 09:11:20 2004
Author: ffjeld

Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.70 movitz/compiler.lisp:1.71
--- movitz/compiler.lisp:1.70	Wed Jul  7 10:34:09 2004
+++ movitz/compiler.lisp	Fri Jul  9 09:11:20 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.70 2004/07/07 17:34:09 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.71 2004/07/09 16:11:20 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -459,7 +459,7 @@
 		   (when (apply #'encoded-type-singleton (type-analysis-encoded-type analysis))
 		     (warn "Singleton: ~A" binding))
 		   #+ignore
-		   (when (or #+ignore (not (apply #'encoded-allp (type-analysis-encoded-type analysis)))
+		   (when (or t #+ignore (not (apply #'encoded-allp (type-analysis-encoded-type analysis)))
 			     #+ignore (multiple-value-call #'encoded-subtypep
 					(values-list (type-analysis-encoded-type analysis))
 					(type-specifier-encode 'list)))
@@ -3024,6 +3024,9 @@
 		   (when x (return t)))))))
     (code-search code binding load store call)))
 
+(defun bindingp (x)
+  (typep x 'binding))
+
 (defun binding-target (binding)
   "Resolve a binding in terms of forwarding."
   (etypecase binding
@@ -5759,7 +5762,7 @@
      `(binding-type ,binding))))
 
 (defun binding-store-subtypep (binding type-specifier)
-  "Is type-specifier a subtype of all values ever stored to binding?
+  "Is type-specifier a supertype of all values ever stored to binding?
    (Assuming analyze-bindings has put this information into binding-store-type.)"
   (if (not (binding-store-type binding))
       nil
@@ -6083,3 +6086,59 @@
   (destructuring-bind (object result-mode &key (op :movl))
       (cdr instruction)
     (make-load-constant object result-mode funobj frame-map :op op)))
+
+;;;;; Add
+
+(define-find-write-binding-and-type :add (instruction)
+  (destructuring-bind (term0 term1 destination)
+      (cdr instruction)
+    (declare (ignore term0 term1))
+    (when (typep destination 'binding)
+      (values destination 'integer))))
+
+(define-find-read-bindings :add (term0 term1 destination)
+  (declare (ignore destination))
+  (remove-if-not #'bindingp (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)))
+      (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)))))