CMUCL commit: amd64-dd-branch src/compiler/amd64 (float.lisp)

[Raymond Toy]

    Date: Tuesday, November 3, 2009 @ 15:07:55
  Author: rtoy
    Path: /project/cmucl/cvsroot/src/compiler/amd64
     Tag: amd64-dd-branch

Modified: float.lisp

DOUBLE-FLOAT-HIGH-BITS and DOUBLE-FLOAT-LOW-BITS were sometimes grabbing the
wrong set of bits (reading stack from wrong address).  And then they
returned too many bits.  Need to mask off the appropriate 32-bit
chunks.  

(These should be revisited.)


------------+
 float.lisp |   15 +++++++++------
 1 file changed, 9 insertions(+), 6 deletions(-)


Index: src/compiler/amd64/float.lisp
diff -u src/compiler/amd64/float.lisp:1.2.36.1 src/compiler/amd64/float.lisp:1.2.36.2
--- src/compiler/amd64/float.lisp:1.2.36.1	Mon Nov  2 09:29:46 2009
+++ src/compiler/amd64/float.lisp	Tue Nov  3 15:07:54 2009
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group at cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /project/cmucl/cvsroot/src/compiler/amd64/float.lisp,v 1.2.36.1 2009-11-02 14:29:46 rtoy Exp $")
+  "$Header: /project/cmucl/cvsroot/src/compiler/amd64/float.lisp,v 1.2.36.2 2009-11-03 20:07:54 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -2265,12 +2265,13 @@
 				:disp (- (* (+ 2 (tn-offset temp))
 					    word-bytes)))))
 	    (inst fstd where)))
-	(loadw hi-bits rbp-tn (- (1+ (tn-offset temp)))))
+	(loadw hi-bits rbp-tn (- (+ 2 (tn-offset temp)))))
        (double-stack
-	(loadw hi-bits rbp-tn (- (1+ (tn-offset float)))))
+	(loadw hi-bits rbp-tn (- (+ 2 (tn-offset float)))))
        (descriptor-reg
-	(loadw hi-bits float (1+ vm:double-float-value-slot)
-	       vm:other-pointer-type)))))
+	(loadw hi-bits float vm:double-float-value-slot
+	       vm:other-pointer-type)))
+     (inst sar hi-bits 32)))
 
 (define-vop (double-float-low-bits)
   (:args (float :scs (double-reg descriptor-reg)
@@ -2295,7 +2296,9 @@
 	(loadw lo-bits rbp-tn (- (+ 2 (tn-offset float)))))
        (descriptor-reg
 	(loadw lo-bits float vm:double-float-value-slot
-	       vm:other-pointer-type)))))
+	       vm:other-pointer-type)))
+     (inst shl lo-bits 32)
+     (inst shr lo-bits 32)))
 
 #+long-float
 (define-vop (long-float-exp-bits)