From: Taylor R Campbell <campbell@mumble.net>
Date: Fri, 30 Nov 2018 00:43:36 +0000 (+0000)
Subject: Open-code flo:copysign on amd64.
X-Git-Tag: mit-scheme-pucked-10.1.7~3^2~88
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=10950793f22ff2a681b8f15a9e7ce40087fb4947;p=mit-scheme.git

Open-code flo:copysign on amd64.
---

diff --git a/src/compiler/machines/C/machin.scm b/src/compiler/machines/C/machin.scm
index bbb68bf81..6fef5701a 100644
--- 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 703fdcd67..8d0551bfa 100644
--- 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 0a429640d..2055c0070 100644
--- 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))
 
 ;;;; Closure format
 
diff --git a/src/compiler/machines/x86-64/rulflo.scm b/src/compiler/machines/x86-64/rulflo.scm
index 790679ff7..05fcbf0c3 100644
--- 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))
 
+;;; 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))))))))
+
 ;;;; 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 745c069e8..27d44eb97 100644
--- 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))
 
 (for-each
  (lambda (flonum-pred)
diff --git a/src/sf/gconst.scm b/src/sf/gconst.scm
index f0f92e8a5..ffedb2fbc 100644
--- 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)