Changeset 6171

Timestamp:

Apr 7, 2007, 7:48:25 PM (18 years ago)

Author:

Gary Byers

Message:

Fix a long-standing bug involving LAMBDA-BIND operator, dynamic-extent
&REST, and stack memoization.
Handle DarwinPPC64 ABI conventions, where SINGLE-FLOATs may be passed
in the same doubleword as GPRs.
%DOUBLE-FLOAT, %SINGLE-FLOAT stuff: do inlining late, catch some other
cases.

File:

• trunk/ccl/compiler/PPC/ppc2.lisp (modified) (6 diffs)

trunk/ccl/compiler/PPC/ppc2.lisp

@@ -7869 +7869 @@
               (setq restloc (%i+ restloc *ppc2-target-node-size*))))
           (ppc2-set-nargs seg (length rest-arg))
+          (ppc2-set-vstack restloc)
           (if (%ilogbitp $vbitdynamicextent (nx-var-bits rest))
             (progn
@@ -7874 +7875 @@
               (ppc2-open-undo $undostkblk))
             (! list))
-          (ppc2-vpush-register seg ppc::arg_z)
-          (ppc2-set-vstack (%i+ restloc *ppc2-target-node-size*)))
+          (ppc2-vpush-register seg ppc::arg_z))
         (when rest (ppc2-bind-var seg rest restloc))
         (destructuring-bind (vars inits) auxen
@@ -8232 +8232 @@
              (setq return-registers t)
              (ppc2-push-register seg (ppc2-one-untargeted-reg-form seg valform ppc::arg_z)))
-            ((:signed-doubleword :unsigned-doubleword)
+            ((:signed-doubleword :unsigned-doubleword :hybrid-int-float :hybrid-float-float :hybrid-float-int)
+                                 
              (ppc2-one-targeted-reg-form seg valform ($ ppc::arg_z))
              (if (eq spec :signed-doubleword)
@@ -8242 +8243 @@
                (incf nextarg)
                (! set-c-arg ($ ppc::imm1) nextarg))
-              (:ppc64)))
+              (:ppc64
+               (case spec
+                 (:hybrid-int-float (push (cons :single-float nextarg) fp-loads))
+                 (:hybrid-float-int (push (cons :single-float-high nextarg) fp-loads))
+                 (:hybrid-float-float
+                  (push (cons :single-float-high nextarg) fp-loads)
+                  (push (cons :single-float nextarg) fp-loads))))))
             (:double-float
              (let* ((df ($ ppc::fp1 :class :fpr :mode :double-float)))
@@ -8295 +8302 @@
           (if (eq size :double-float)
             (! reload-double-c-arg fpreg from)
-            (! reload-single-c-arg fpreg from))))
+            (if (eq size :single-float-high)
+              (! reload-single-c-arg-high fpreg from)
+              (! reload-single-c-arg fpreg from)))))
       return-registers)))
 
@@ -8943 +8952 @@
       (<- (set-regspec-mode dreg hard-reg-class-fpr-mode-single))
       (^))))
-        
+
+(defppc2 ppc2-%double-float %double-float (seg vreg xfer arg)
+  (let* ((real (or (acode-fixnum-form-p arg)
+                   (let* ((form (acode-unwrapped-form arg)))
+                     (if (and (acode-p form)
+                              (eq (acode-operator form)
+                                  (%nx1-operator immediate))
+                              (typep (cadr form) 'real))
+                       (cadr form))))))
+    (if real
+      (ppc2-immediate seg vreg xfer (float real 0.0d0))
+      (if (ppc2-form-typep arg 'single-float)
+        (ppc2-use-operator (%nx1-operator %single-to-double)
+                           seg
+                           vreg
+                           xfer
+                           arg)
+        (if (ppc2-form-typep arg 'fixnum)
+          (ppc2-use-operator (%nx1-operator %fixnum-to-double)
+                             seg
+                             vreg
+                             xfer
+                             arg)
+          (ppc2-use-operator (%nx1-operator call)
+                             seg
+                             vreg
+                             xfer
+                             (make-acode (%nx1-operator immediate)
+                                         '%double-float)
+                             (list nil (list arg))))))))
+
+(defppc2 ppc2-%single-float %single-float (seg vreg xfer arg)
+  (let* ((real (or (acode-fixnum-form-p arg)
+                   (let* ((form (acode-unwrapped-form arg)))
+                     (if (and (acode-p form)
+                              (eq (acode-operator form)
+                                  (%nx1-operator immediate))
+                              (typep (cadr form) 'real))
+                       (cadr form))))))
+    (if real
+      (ppc2-immediate seg vreg xfer (float real 0.0f0))
+      (if (ppc2-form-typep arg 'double-float)
+        (ppc2-use-operator (%nx1-operator %double-to-single)
+                           seg
+                           vreg
+                           xfer
+                           arg)
+        (if (ppc2-form-typep arg 'fixnum)
+          (ppc2-use-operator (%nx1-operator %fixnum-to-single)
+                             seg
+                             vreg
+                             xfer
+                             arg)
+          (ppc2-use-operator (%nx1-operator call)
+                             seg
+                             vreg
+                             xfer
+                             (make-acode (%nx1-operator immediate)
+                                         '%short-float)
+                             (list nil (list arg))))))))
 
 ;------