Implemented type inliners for arithmetic operations

src/cmp/cmpc-inliner.lsp

@@ -15,14 +15,23 @@
 
 (in-package "COMPILER")
 
+(defun inlined-arg-loc (arg)
+  (second arg))
+
+(defun inlined-arg-type (arg)
+  (first arg))
+
+(defun inlined-arg-rep-type (arg)
+  (loc-representation-type (second arg)))
+
 (defmacro define-c-inliner (fname lambda-list &body body)
-  `(setf (gethash fname *cinline-dispatch-table*)
-	 #'(ext:lambda-block ,fname ,lambda-list ,@body)))
+  `(setf (gethash ',fname *cinline-dispatch-table*)
+	 #'(lambda ,lambda-list (block nil ,@body))))
 
 (defun apply-inliner (fname return-type inlined-args)
   (let ((fd (gethash fname *cinline-dispatch-table*)))
     (if fd
-	(apply fd inlined-args)
+	(apply fd return-type inlined-args)
 	(default-c-inliner fname return-type inlined-args))))
 
 (defun default-c-inliner (fname return-type inlined-args)

src/cmp/cmpinline.lsp

@@ -41,6 +41,18 @@
           (incf *inline-blocks*)
           var))))
 
+(defun save-inline-loc (loc)
+  (let* ((rep-type (loc-representation-type (second loc)))
+         (temp (make-inline-temp-var (first loc) rep-type))
+         (*destination* temp))
+    (set-loc loc)
+    temp))
+
+(defmacro with-inlined-loc ((temp-loc loc) &rest body)
+  `(let ((,temp-loc (save-inline-loc ,loc)))
+     (setf ,temp-loc (list (var-type ,temp-loc) ,temp-loc))
+     ,@body))
+
 (defun emit-inlined-variable (form rest-forms)
   (let ((var (c1form-arg 0 form))
         (value-type (c1form-primary-type form)))
@@ -64,7 +76,7 @@
          (return-type (c1form-primary-type form))
          (fun (find fname *global-funs* :key #'fun-name :test #'same-fname-p))
          (loc (call-global-loc fname fun args return-type expected-type))
-         (type (loc-type loc))
+         (type (type-and return-type (loc-type loc)))
          (temp (make-inline-temp-var type (loc-representation-type loc)))
          (*destination* temp))
     (set-loc loc)

src/cmp/cmpnum.lsp

@@ -122,6 +122,81 @@
 (def-type-propagator / (fname op1 &rest others)
   (arithmetic-propagator op1 others 'rational))
 
+(defun inline-binop (expected-type arg1 arg2 integer-result-type
+		     consing non-consing)
+  (multiple-value-bind (result t1 t2)
+      (maximum-number-type (inlined-arg-type arg1) (inlined-arg-type arg2))
+    (when (member result '(integer fixnum))
+      (setf result integer-result-type))
+    (let (c-rep-type)
+      (if (and (or (and (c-number-type-p result)
+			(setf c-rep-type (lisp-type->rep-type result)))
+		   (and (policy-assume-right-type)
+			(c-number-type-p expected-type)
+			(setf c-rep-type (lisp-type->rep-type expected-type))))
+	       (c-number-type-p t1)
+	       (c-number-type-p t2))
+	  (produce-inline-loc (list arg1 arg2) (list c-rep-type c-rep-type)
+			      (list c-rep-type) non-consing nil t)
+	  (produce-inline-loc (list arg1 arg2) '(:object :object) '(:object)
+			      consing nil t)))))
+
+(trace inline-binop)
+
+(defun inline-arith-unop (arg1 consing non-consing)
+  (let ((c-rep-type (inlined-arg-rep-type arg1)))
+    (if (c-number-rep-type-p c-rep-type)
+        (produce-inline-loc (list arg1) (list c-rep-type)
+                            (list c-rep-type) non-consing nil t)
+	(produce-inline-loc (list arg1) '(:object) '(:object)
+			    consing nil t))))
+
+(define-c-inliner + (return-type &rest arguments &aux arg1 arg2)
+  (when (null arguments)
+    (return '(fixnum-value 0)))
+  (setf arg1 (pop arguments))
+  (when (null arguments)
+    (return (inlined-arg-loc arg1)))
+  (loop for arg2 = (pop arguments)
+     for result = (inline-binop return-type arg1 arg2 'integer
+				"ecl_plus(#0,#1)" "(#0)+(#1)")
+     do (if arguments
+	    (setf arg1 (save-inline-loc result))
+	    (return result))))
+
+(define-c-inliner - (return-type arg1 &rest arguments &aux arg2)
+  (when (null arguments)
+    (return (inline-arith-unop arg1 "ecl_negate(#0)" "-(#0)")))
+  (loop for arg2 = (pop arguments)
+     for result = (inline-binop return-type arg1 arg2 'integer
+				"ecl_minus(#0,#1)" "(#0)-(#1)")
+     do (if arguments
+	    (setf arg1 (save-inline-loc result))
+	    (return result))))
+
+(define-c-inliner * (return-type &rest arguments &aux arg1 arg2)
+  (when (null arguments)
+    (return '(fixnum-value 1)))
+  (setf arg1 (pop arguments))
+  (when (null arguments)
+    (return (inlined-arg-loc arg1)))
+  (loop for arg2 = (pop arguments)
+     for result = (inline-binop return-type arg1 arg2 'integer
+				"ecl_times(#0,#1)" "(#0)*(#1)")
+     do (if arguments
+	    (setf arg1 (save-inline-loc result))
+	    (return result))))
+
+(define-c-inliner / (return-type arg1 &rest arguments &aux arg2)
+  (when (null arguments)
+    (return (inline-arith-unop arg1 "ecl_divide(MAKE_FIXNUM(1),(#0))" "1/(#0)")))
+  (loop for arg2 = (pop arguments)
+     for result = (inline-binop return-type arg1 arg2 'rational
+				"ecl_divide(#0,#1)" "(#0)/(#1)")
+     do (if arguments
+	    (setf arg1 (save-inline-loc result))
+	    (return result))))
+
 ;;;
 ;;; SPECIAL FUNCTIONS
 ;;;