Open-code flo:copysign on amd64.

diff --git a/src/compiler/machines/C/machin.scm b/src/compiler/machines/C/machin.scm
index bbb68bf81afb03637b8d2165d91eef7bf2d08545..6fef5701a841fc699494513ea6ac28d7471b725a 100644 (file)
--- a/src/compiler/machines/C/machin.scm
+++ b/src/compiler/machines/C/machin.scm
@@ -306,4 +306,4 @@ USA.
     FLONUM-IS-LESS? FLONUM-IS-LESS-OR-EQUAL?
     FLONUM-IS-GREATER? FLONUM-IS-GREATER-OR-EQUAL?
     FLONUM-IS-LESS-OR-GREATER? FLONUM-IS-UNORDERED?
-    FLONUM-IS-NEGATIVE?))
\ No newline at end of file
+    FLONUM-IS-NEGATIVE? FLONUM-COPYSIGN))
\ No newline at end of file

diff --git a/src/compiler/machines/i386/machin.scm b/src/compiler/machines/i386/machin.scm
index 703fdcd670f091dff08104058edde23d60d94b5f..8d0551bfab65acca062c22e3c07bb006f7a4b2ae 100644 (file)
--- a/src/compiler/machines/i386/machin.scm
+++ b/src/compiler/machines/i386/machin.scm
@@ -359,4 +359,4 @@ USA.
                  FLONUM-IS-LESS? FLONUM-IS-LESS-OR-EQUAL?
                  FLONUM-IS-GREATER? FLONUM-IS-GREATER-OR-EQUAL?
                  FLONUM-IS-LESS-OR-GREATER? FLONUM-IS-UNORDERED?
-                 FLONUM-IS-NEGATIVE?))
\ No newline at end of file
+                 FLONUM-IS-NEGATIVE? FLONUM-COPYSIGN))
\ No newline at end of file

diff --git a/src/compiler/machines/svm/machine.scm b/src/compiler/machines/svm/machine.scm
index 0a429640d8ca6e625f7860eb6ebb6964315f78fd..2055c0070659bc252cb3e6b42e7e4bef70d358cb 100644 (file)
--- a/src/compiler/machines/svm/machine.scm
+++ b/src/compiler/machines/svm/machine.scm
@@ -489,7 +489,7 @@ USA.
                  FLONUM-IS-LESS? FLONUM-IS-LESS-OR-EQUAL?
                  FLONUM-IS-GREATER? FLONUM-IS-GREATER-OR-EQUAL?
                  FLONUM-IS-LESS-OR-GREATER? FLONUM-IS-UNORDERED?
-                 FLONUM-IS-NEGATIVE?))
+                 FLONUM-IS-NEGATIVE? FLONUM-COPYSIGN))
 \f
 ;;;; Closure format
 

diff --git a/src/compiler/machines/x86-64/rulflo.scm b/src/compiler/machines/x86-64/rulflo.scm
index 790679ff758e1da1a00dc4eb7dedbfcce444849d..05fcbf0c3e06ddf47cecce5f22bdd4adc3756a6f 100644 (file)
--- a/src/compiler/machines/x86-64/rulflo.scm
+++ b/src/compiler/machines/x86-64/rulflo.scm
@@ -280,6 +280,62 @@ USA.
   (binary-operation FLONUM-MULTIPLY MULF #t)
   (binary-operation FLONUM-SUBTRACT SUBF #f))
 \f
+;;; It is tempting to use memory operands for the masks, but because
+;;; OR, AND, &c., are packed, not scalar, the memory operands must be
+;;; 128-bit-aligned, and right now compiled code blocks are only
+;;; guaranteed to be 64-bit aligned.  We could change that but it would
+;;; take a bit of work.
+
+(define-arithmetic-method 'FLONUM-COPYSIGN flonum-methods/2-args
+  (flonum-2-args/standard #f
+    (lambda (target source)
+      (let* ((bits (bit-string-not double-flobits:negative-zero))
+             (label (allocate-double-float-bits-label bits))
+             (temp (reference-temporary-register! 'FLOAT)))
+        (LAP
+         ;; Set temp := 0x7fff....
+         (MOVF S D ,temp (@PCR ,label))
+         ;; target holds arg1.  Set target := arg1 & 0x7fff....
+         (ANDF P D ,target ,temp)
+         ;; source holds arg2.  Set temp := arg2 & 0x1000....
+         (ANDNF P D ,temp ,source)
+         ;; Set target := (arg1 & 0x7fff...) & (arg2 & 0x1000...).
+         (ORF P D ,target ,temp))))))
+
+(define-arithmetic-method 'FLONUM-COPYSIGN flonum-methods/register*constant
+  (lambda (target source constant)
+    (let ((target (float-move-to-target! source target)))
+      (if (flo:sign-negative? constant)
+          (let* ((bits double-flobits:negative-zero)
+                 (label (allocate-double-float-bits-label bits))
+                 (temp (reference-temporary-register! 'FLOAT)))
+            (LAP (MOVF S D ,temp (@PCR ,label))
+                 (ORF P D ,target ,temp)))
+          (let* ((bits (bit-string-not double-flobits:negative-zero))
+                 (label (allocate-double-float-bits-label bits))
+                 (temp (reference-temporary-register! 'FLOAT)))
+            (LAP (MOVF S D ,temp (@PCR ,label))
+                 (ANDF P D ,target ,temp)))))))
+
+(define-arithmetic-method 'FLONUM-COPYSIGN flonum-methods/constant*register
+  (lambda (target constant source)
+    (with-float-operand (flo:abs constant)
+      (lambda (operand)
+        (let ((target (float-move-to-target! source target)))
+          (let* ((bits double-flobits:negative-zero)
+                 (label (allocate-double-float-bits-label bits))
+                 (temp (reference-temporary-register! 'FLOAT)))
+            ;; target holds arg2, which specifies the sign.
+            (LAP
+             ;; temp := 0x1000....
+             (MOVF S D ,temp (@PCR ,label))
+             ;; target := target & 0x1000...
+             (ANDF P D ,target ,temp)
+             ;; temp := abs(arg1)
+             (MOVF S D ,temp ,operand)
+             ;; target := (target & 0x1000...) | abs(arg1)
+             (ORF P D ,target ,temp))))))))
+\f
 ;;;; Flonum Predicates
 
 (define double-flobits:zero
@@ -492,3 +548,6 @@ USA.
      (let ((flonum-data-offset-in-bits (* 8 (bytes-per-object))))
        (read-bits! flonum flonum-data-offset-in-bits bit-string))
      bit-string)))
+
+(define (float-move-to-target! source target)
+  (register-reference (move-to-alias-register! source 'FLOAT target)))
\ No newline at end of file

diff --git a/src/compiler/rtlgen/opncod.scm b/src/compiler/rtlgen/opncod.scm
index 745c069e8f9ed8666223786ba43e4890bac26b0b..27d44eb970d68c4949a804dbe23d7d84530e4394 100644 (file)
--- a/src/compiler/rtlgen/opncod.scm
+++ b/src/compiler/rtlgen/opncod.scm
@@ -1530,7 +1530,8 @@ USA.
           expressions)))
       '(0 1)
       internal-close-coding-for-type-checks)))
- '(FLONUM-ADD FLONUM-SUBTRACT FLONUM-MULTIPLY FLONUM-DIVIDE FLONUM-ATAN2))
+ '(FLONUM-ADD FLONUM-SUBTRACT FLONUM-MULTIPLY FLONUM-DIVIDE FLONUM-ATAN2
+   FLONUM-COPYSIGN))
 \f
 (for-each
  (lambda (flonum-pred)

diff --git a/src/sf/gconst.scm b/src/sf/gconst.scm
index f0f92e8a53b9194f328d5f9b29df3c6df5f061a9..ffedb2fbcad69a7f8b421d8b8d516f369288affd 100644 (file)
--- a/src/sf/gconst.scm
+++ b/src/sf/gconst.scm
@@ -126,6 +126,7 @@ USA.
     (flo:atan2 flonum-atan2)
     (flo:ceiling flonum-ceiling)
     (flo:ceiling->exact flonum-ceiling->exact)
+    (flo:copysign flonum-copysign)
     (flo:cos flonum-cos)
     (flo:exp flonum-exp)
     (flo:expm1 flonum-expm1)