Commit cab4b732 authored by rtoy's avatar rtoy
Browse files

Add double-double-float support for x86.

bootfiles/19c/boot-2006-06-1-cross-dd-x86.lisp:
o Cross-compile script to use.

compiler/x86/float.lisp
compiler/x86/parms.lisp
compiler/x86/type-vops.lisp
compiler/x86/vm.lisp:
o Add necessary vops and support for double-double-float.  Based on
  sparc port, with cargo-culting of complex-double-float stuff to make
  it work for double-double-float.
parent 7f3e47ac
Loading
Loading
Loading
Loading
+223 −0
Original line number Diff line number Diff line
(in-package :cl-user)

;;; Rename the X86 package and backend so that new-backend does the
;;; right thing.
(rename-package "X86" "OLD-X86")
(setf (c:backend-name c:*native-backend*) "OLD-X86")

(c::new-backend "X86"
   ;; Features to add here
   '(:x86 :i486 :pentium
     :stack-checking
     :heap-overflow-check
     :relative-package-names
     :mp
     :gencgc
     :conservative-float-type
     :hash-new :random-mt19937
     :linux :glibc2 :glibc2.1
     :cmu :cmu19 :cmu19c
     :double-double			; double-double-float
     )
   ;; Features to remove from current *features* here
   '(:x86-bootstrap :alpha :osf1 :mips
     :propagate-fun-type :propagate-float-type :constrain-float-type
     :openbsd :freebsd :glibc2 :linux
     :long-float :new-random :small))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Things needed to cross-compile double-double changes.
(in-package "KERNEL")

(eval-when (compile load eval)
(c:defknown double-double-float-p (t)
  boolean
  (c:movable c:foldable c:flushable))
)

(eval-when (compile load eval)
  (handler-bind ((error (lambda (c)
			  (declare (ignore c))
			  (invoke-restart 'continue))))
    (defconstant type-test-ordering
      '(fixnum single-float double-float integer #+long-float long-float
	double-double-float bignum
	complex ratio))
    ))

(eval-when (compile load eval)
  (handler-bind ((error (lambda (c)
			  (declare (ignore c))
			  (invoke-restart 'continue))))
    (defconstant float-formats
      '(double-double-float long-float double-float single-float short-float))))

(in-package "LISP")
(define-fop (fop-double-double-float 67)
  (prepare-for-fast-read-byte *fasl-file*
    (prog1
	(let ((hi-lo (fast-read-u-integer 4))
	      (hi-hi (fast-read-s-integer 4))
	      (lo-lo (fast-read-u-integer 4))
	      (lo-hi (fast-read-s-integer 4)))
	  (kernel::make-double-double-float
	   (make-double-float hi-hi hi-lo)
	   (make-double-float lo-hi lo-lo)))
      (done-with-fast-read-byte))))

;; End changes for double-double
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(in-package :cl-user)

;;; Compile the new backend.
(pushnew :bootstrap *features*)
(pushnew :building-cross-compiler *features*)
(load "target:tools/comcom")

;;; Load the new backend.
(setf (search-list "c:")
      '("target:compiler/"))
(setf (search-list "vm:")
      '("c:x86/" "c:generic/"))
(setf (search-list "assem:")
      '("target:assembly/" "target:assembly/x86/"))

;; Load the backend of the compiler.

(in-package "C")

(load "vm:vm-macs")
(load "vm:parms")
(load "vm:objdef")
(load "vm:interr")
(load "assem:support")

(load "target:compiler/srctran")
(load "vm:vm-typetran")
(load "target:compiler/float-tran")
(load "target:compiler/saptran")

(load "vm:macros")
(load "vm:utils")

(load "vm:vm")
(load "vm:insts")
(load "vm:primtype")
(load "vm:move")
(load "vm:sap")
(load "vm:system")
(load "vm:char")
(load "vm:float")

(load "vm:memory")
(load "vm:static-fn")
(load "vm:arith")
(load "vm:cell")
(load "vm:subprim")
(load "vm:debug")
(load "vm:c-call")
(load "vm:print")
(load "vm:alloc")
(load "vm:call")
(load "vm:nlx")
(load "vm:values")
(load "vm:array")
(load "vm:pred")
(load "vm:type-vops")

(load "assem:assem-rtns")

(load "assem:array")
(load "assem:arith")
(load "assem:alloc")

(load "c:pseudo-vops")

(check-move-function-consistency)

(load "vm:new-genesis")

;;; OK, the cross compiler backend is loaded.

(setf *features* (remove :building-cross-compiler *features*))

;;; Info environment hacks.
(macrolet ((frob (&rest syms)
	     `(progn ,@(mapcar #'(lambda (sym)
				   `(handler-bind ((error #'(lambda (c)
							      (declare (ignore c))
							      (invoke-restart 'kernel::continue))))
				      (defconstant ,sym
					(symbol-value
					 (find-symbol ,(symbol-name sym)
						      :vm)))))
			       syms))))
  (frob OLD-X86:BYTE-BITS OLD-X86:WORD-BITS
	#+long-float OLD-X86:SIMPLE-ARRAY-LONG-FLOAT-TYPE 
	OLD-X86:SIMPLE-ARRAY-DOUBLE-FLOAT-TYPE 
	OLD-X86:SIMPLE-ARRAY-SINGLE-FLOAT-TYPE
	#+long-float OLD-X86:SIMPLE-ARRAY-COMPLEX-LONG-FLOAT-TYPE 
	OLD-X86:SIMPLE-ARRAY-COMPLEX-DOUBLE-FLOAT-TYPE 
	OLD-X86:SIMPLE-ARRAY-COMPLEX-SINGLE-FLOAT-TYPE
	OLD-X86:SIMPLE-ARRAY-UNSIGNED-BYTE-2-TYPE 
	OLD-X86:SIMPLE-ARRAY-UNSIGNED-BYTE-4-TYPE
	OLD-X86:SIMPLE-ARRAY-UNSIGNED-BYTE-8-TYPE 
	OLD-X86:SIMPLE-ARRAY-UNSIGNED-BYTE-16-TYPE 
	OLD-X86:SIMPLE-ARRAY-UNSIGNED-BYTE-32-TYPE 
	OLD-X86:SIMPLE-ARRAY-SIGNED-BYTE-8-TYPE 
	OLD-X86:SIMPLE-ARRAY-SIGNED-BYTE-16-TYPE
	OLD-X86:SIMPLE-ARRAY-SIGNED-BYTE-30-TYPE 
	OLD-X86:SIMPLE-ARRAY-SIGNED-BYTE-32-TYPE
	OLD-X86:SIMPLE-BIT-VECTOR-TYPE
	OLD-X86:SIMPLE-STRING-TYPE OLD-X86:SIMPLE-VECTOR-TYPE 
	OLD-X86:SIMPLE-ARRAY-TYPE OLD-X86:VECTOR-DATA-OFFSET
	))

(let ((function (symbol-function 'kernel:error-number-or-lose)))
  (let ((*info-environment* (c:backend-info-environment c:*target-backend*)))
    (setf (symbol-function 'kernel:error-number-or-lose) function)
    (setf (info function kind 'kernel:error-number-or-lose) :function)
    (setf (info function where-from 'kernel:error-number-or-lose) :defined)))

(defun fix-class (name)
  (let* ((new-value (find-class name))
	 (new-layout (kernel::%class-layout new-value))
	 (new-cell (kernel::find-class-cell name))
	 (*info-environment* (c:backend-info-environment c:*target-backend*)))
    (remhash name kernel::*forward-referenced-layouts*)
    (kernel::%note-type-defined name)
    (setf (info type kind name) :instance)
    (setf (info type class name) new-cell)
    (setf (info type compiler-layout name) new-layout)
    new-value))
(fix-class 'c::vop-parse)
(fix-class 'c::operand-parse)

#+random-mt19937
(declaim (notinline kernel:random-chunk))

(setf c:*backend* c:*target-backend*)

;;; Extern-alien-name for the new backend.
(in-package :vm)
(defun extern-alien-name (name)
  (declare (type simple-string name))
  #+(and bsd (not elf))
  (concatenate 'string "_" name)
  #-(and bsd (not elf))
  name)
(export 'extern-alien-name)
(export 'fixup-code-object)
(export 'sanctify-for-execution)
(in-package :cl-user)

;;; Don't load compiler parts from the target compilation

(defparameter *load-stuff* nil)

;; hack, hack, hack: Make old-x86::any-reg the same as
;; x86::any-reg as an SC.  Do this by adding old-x86::any-reg
;; to the hash table with the same value as x86::any-reg.
(let ((ht (c::backend-sc-names c::*target-backend*)))
  (setf (gethash 'old-x86::any-reg ht)
	(gethash 'x86::any-reg ht)))
+223 −0
Original line number Diff line number Diff line
(in-package :cl-user)

;;; Rename the X86 package and backend so that new-backend does the
;;; right thing.
(rename-package "X86" "OLD-X86")
(setf (c:backend-name c:*native-backend*) "OLD-X86")

(c::new-backend "X86"
   ;; Features to add here
   '(:x86 :i486 :pentium
     :stack-checking
     :heap-overflow-check
     :relative-package-names
     :mp
     :gencgc
     :conservative-float-type
     :hash-new :random-mt19937
     :linux :glibc2 :glibc2.1
     :cmu :cmu19 :cmu19c
     :double-double			; double-double-float
     )
   ;; Features to remove from current *features* here
   '(:x86-bootstrap :alpha :osf1 :mips
     :propagate-fun-type :propagate-float-type :constrain-float-type
     :openbsd :freebsd :glibc2 :linux
     :long-float :new-random :small))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Things needed to cross-compile double-double changes.
(in-package "KERNEL")

(eval-when (compile load eval)
(c:defknown double-double-float-p (t)
  boolean
  (c:movable c:foldable c:flushable))
)

(eval-when (compile load eval)
  (handler-bind ((error (lambda (c)
			  (declare (ignore c))
			  (invoke-restart 'continue))))
    (defconstant type-test-ordering
      '(fixnum single-float double-float integer #+long-float long-float
	double-double-float bignum
	complex ratio))
    ))

(eval-when (compile load eval)
  (handler-bind ((error (lambda (c)
			  (declare (ignore c))
			  (invoke-restart 'continue))))
    (defconstant float-formats
      '(double-double-float long-float double-float single-float short-float))))

(in-package "LISP")
(define-fop (fop-double-double-float 67)
  (prepare-for-fast-read-byte *fasl-file*
    (prog1
	(let ((hi-lo (fast-read-u-integer 4))
	      (hi-hi (fast-read-s-integer 4))
	      (lo-lo (fast-read-u-integer 4))
	      (lo-hi (fast-read-s-integer 4)))
	  (kernel::make-double-double-float
	   (make-double-float hi-hi hi-lo)
	   (make-double-float lo-hi lo-lo)))
      (done-with-fast-read-byte))))

;; End changes for double-double
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(in-package :cl-user)

;;; Compile the new backend.
(pushnew :bootstrap *features*)
(pushnew :building-cross-compiler *features*)
(load "target:tools/comcom")

;;; Load the new backend.
(setf (search-list "c:")
      '("target:compiler/"))
(setf (search-list "vm:")
      '("c:x86/" "c:generic/"))
(setf (search-list "assem:")
      '("target:assembly/" "target:assembly/x86/"))

;; Load the backend of the compiler.

(in-package "C")

(load "vm:vm-macs")
(load "vm:parms")
(load "vm:objdef")
(load "vm:interr")
(load "assem:support")

(load "target:compiler/srctran")
(load "vm:vm-typetran")
(load "target:compiler/float-tran")
(load "target:compiler/saptran")

(load "vm:macros")
(load "vm:utils")

(load "vm:vm")
(load "vm:insts")
(load "vm:primtype")
(load "vm:move")
(load "vm:sap")
(load "vm:system")
(load "vm:char")
(load "vm:float")

(load "vm:memory")
(load "vm:static-fn")
(load "vm:arith")
(load "vm:cell")
(load "vm:subprim")
(load "vm:debug")
(load "vm:c-call")
(load "vm:print")
(load "vm:alloc")
(load "vm:call")
(load "vm:nlx")
(load "vm:values")
(load "vm:array")
(load "vm:pred")
(load "vm:type-vops")

(load "assem:assem-rtns")

(load "assem:array")
(load "assem:arith")
(load "assem:alloc")

(load "c:pseudo-vops")

(check-move-function-consistency)

(load "vm:new-genesis")

;;; OK, the cross compiler backend is loaded.

(setf *features* (remove :building-cross-compiler *features*))

;;; Info environment hacks.
(macrolet ((frob (&rest syms)
	     `(progn ,@(mapcar #'(lambda (sym)
				   `(handler-bind ((error #'(lambda (c)
							      (declare (ignore c))
							      (invoke-restart 'kernel::continue))))
				      (defconstant ,sym
					(symbol-value
					 (find-symbol ,(symbol-name sym)
						      :vm)))))
			       syms))))
  (frob OLD-X86:BYTE-BITS OLD-X86:WORD-BITS
	#+long-float OLD-X86:SIMPLE-ARRAY-LONG-FLOAT-TYPE 
	OLD-X86:SIMPLE-ARRAY-DOUBLE-FLOAT-TYPE 
	OLD-X86:SIMPLE-ARRAY-SINGLE-FLOAT-TYPE
	#+long-float OLD-X86:SIMPLE-ARRAY-COMPLEX-LONG-FLOAT-TYPE 
	OLD-X86:SIMPLE-ARRAY-COMPLEX-DOUBLE-FLOAT-TYPE 
	OLD-X86:SIMPLE-ARRAY-COMPLEX-SINGLE-FLOAT-TYPE
	OLD-X86:SIMPLE-ARRAY-UNSIGNED-BYTE-2-TYPE 
	OLD-X86:SIMPLE-ARRAY-UNSIGNED-BYTE-4-TYPE
	OLD-X86:SIMPLE-ARRAY-UNSIGNED-BYTE-8-TYPE 
	OLD-X86:SIMPLE-ARRAY-UNSIGNED-BYTE-16-TYPE 
	OLD-X86:SIMPLE-ARRAY-UNSIGNED-BYTE-32-TYPE 
	OLD-X86:SIMPLE-ARRAY-SIGNED-BYTE-8-TYPE 
	OLD-X86:SIMPLE-ARRAY-SIGNED-BYTE-16-TYPE
	OLD-X86:SIMPLE-ARRAY-SIGNED-BYTE-30-TYPE 
	OLD-X86:SIMPLE-ARRAY-SIGNED-BYTE-32-TYPE
	OLD-X86:SIMPLE-BIT-VECTOR-TYPE
	OLD-X86:SIMPLE-STRING-TYPE OLD-X86:SIMPLE-VECTOR-TYPE 
	OLD-X86:SIMPLE-ARRAY-TYPE OLD-X86:VECTOR-DATA-OFFSET
	))

(let ((function (symbol-function 'kernel:error-number-or-lose)))
  (let ((*info-environment* (c:backend-info-environment c:*target-backend*)))
    (setf (symbol-function 'kernel:error-number-or-lose) function)
    (setf (info function kind 'kernel:error-number-or-lose) :function)
    (setf (info function where-from 'kernel:error-number-or-lose) :defined)))

(defun fix-class (name)
  (let* ((new-value (find-class name))
	 (new-layout (kernel::%class-layout new-value))
	 (new-cell (kernel::find-class-cell name))
	 (*info-environment* (c:backend-info-environment c:*target-backend*)))
    (remhash name kernel::*forward-referenced-layouts*)
    (kernel::%note-type-defined name)
    (setf (info type kind name) :instance)
    (setf (info type class name) new-cell)
    (setf (info type compiler-layout name) new-layout)
    new-value))
(fix-class 'c::vop-parse)
(fix-class 'c::operand-parse)

#+random-mt19937
(declaim (notinline kernel:random-chunk))

(setf c:*backend* c:*target-backend*)

;;; Extern-alien-name for the new backend.
(in-package :vm)
(defun extern-alien-name (name)
  (declare (type simple-string name))
  #+(and bsd (not elf))
  (concatenate 'string "_" name)
  #-(and bsd (not elf))
  name)
(export 'extern-alien-name)
(export 'fixup-code-object)
(export 'sanctify-for-execution)
(in-package :cl-user)

;;; Don't load compiler parts from the target compilation

(defparameter *load-stuff* nil)

;; hack, hack, hack: Make old-x86::any-reg the same as
;; x86::any-reg as an SC.  Do this by adding old-x86::any-reg
;; to the hash table with the same value as x86::any-reg.
(let ((ht (c::backend-sc-names c::*target-backend*)))
  (setf (gethash 'old-x86::any-reg ht)
	(gethash 'x86::any-reg ht)))
+259 −1
Original line number Diff line number Diff line
@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(ext:file-comment
  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/float.lisp,v 1.41 2003/07/03 02:14:58 toy Exp $")
  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/float.lisp,v 1.41.18.1 2006/06/10 03:29:19 rtoy Exp $")
;;;
;;; **********************************************************************
;;;
@@ -726,6 +726,7 @@

(define-move-vop move-argument :move-argument
  (single-reg double-reg #+long-float long-reg
   #+double-double double-double-reg
   complex-single-reg complex-double-reg #+long-float complex-long-reg)
  (descriptor-reg))

@@ -1206,6 +1207,12 @@
	(= (long-float-high-bits x) (long-float-high-bits y))
	(= (long-float-exp-bits x) (long-float-exp-bits y))))

#+double-double
(deftransform eql ((x y) (double-double-float double-double-float))
  '(and (eql (double-double-hi x) (double-double-hi y))
	(eql (double-double-lo x) (double-double-lo y))))


(define-vop (=/float)
  (:args (x) (y))
  (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
@@ -4641,3 +4648,254 @@
  (:note "inline dummy FP register bias")
  (:ignore x)
  (:generator 0))

;;; Support for double-double floats

(defun double-double-reg-hi-tn (x)
  (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*)
		  :offset (tn-offset x)))

(defun double-double-reg-lo-tn (x)
  (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*)
		  :offset (1+ (tn-offset x))))

(define-move-function (load-double-double 4) (vop x y)
  ((double-double-stack) (double-double-reg))
  (let ((real-tn (double-double-reg-hi-tn y)))
    (with-empty-tn@fp-top(real-tn)
      (inst fldd (ea-for-cdf-real-stack x))))
  (let ((imag-tn (double-double-reg-lo-tn y)))
    (with-empty-tn@fp-top(imag-tn)
      (inst fldd (ea-for-cdf-imag-stack x)))))

(define-move-function (store-double-double 4) (vop x y)
  ((double-double-reg) (double-double-stack))
  (let ((real-tn (double-double-reg-hi-tn x)))
    (cond ((zerop (tn-offset real-tn))
	   (inst fstd (ea-for-cdf-real-stack y)))
	  (t
	   (inst fxch real-tn)
	   (inst fstd (ea-for-cdf-real-stack y))
	   (inst fxch real-tn))))
  (let ((imag-tn (double-double-reg-lo-tn x)))
    (inst fxch imag-tn)
    (inst fstd (ea-for-cdf-imag-stack y))
    (inst fxch imag-tn)))
)

;;; Double-double float register to register moves

(define-vop (double-double-move)
  (:args (x :scs (double-double-reg)
	    :target y :load-if (not (location= x y))))
  (:results (y :scs (double-double-reg) :load-if (not (location= x y))))
  (:note "double-double float move")
  (:generator 0
     (unless (location= x y)
       ;; Note the double-float-regs are aligned to every second
       ;; float register so there is not need to worry about overlap.
       (let ((x-hi (double-double-reg-hi-tn x))
	     (y-hi (double-double-reg-hi-tn y)))
	 (cond ((zerop (tn-offset y-hi))
		(copy-fp-reg-to-fr0 x-hi))
	       ((zerop (tn-offset x-hi))
		(inst fstd y-hi))
	       (t
		(inst fxch x-hi)
		(inst fstd y-hi)
		(inst fxch x-hi))))
       (let ((x-lo (double-double-reg-lo-tn x))
	     (y-lo (double-double-reg-lo-tn y)))
	 (inst fxch x-lo)
	 (inst fstd y-lo)
	 (inst fxch x-lo)))))
;;;
(define-move-vop double-double-move :move
  (double-double-reg) (double-double-reg))

;;; Move from a complex float to a descriptor register allocating a
;;; new complex float object in the process.

(define-vop (move-from-double-double)
  (:args (x :scs (double-double-reg) :to :save))
  (:results (y :scs (descriptor-reg)))
  (:node-var node)
  (:note "double double float to pointer coercion")
  (:generator 13
     (with-fixed-allocation (y vm:double-double-float-type
			       vm:double-double-float-size node)
       (let ((real-tn (double-double-reg-hi-tn x)))
	 (with-tn@fp-top(real-tn)
	   (inst fstd (ea-for-cdf-real-desc y))))
       (let ((imag-tn (double-double-reg-lo-tn x)))
	 (with-tn@fp-top(imag-tn)
	   (inst fstd (ea-for-cdf-imag-desc y)))))))
;;;
(define-move-vop move-from-double-double :move
  (double-double-reg) (descriptor-reg))

;;; Move from a descriptor to a double-double float register

(define-vop (move-to-double-double)
  (:args (x :scs (descriptor-reg)))
  (:results (y :scs (double-double-reg)))
  (:note "pointer to double-double-float coercion")
  (:generator 2
    (let ((real-tn (double-double-reg-hi-tn y)))
      (with-empty-tn@fp-top(real-tn)
	(inst fldd (ea-for-cdf-real-desc x))))
    (let ((imag-tn (double-double-reg-lo-tn y)))
      (with-empty-tn@fp-top(imag-tn)
	(inst fldd (ea-for-cdf-imag-desc x))))))

(define-move-vop move-to-double-double :move
  (descriptor-reg) (double-double-reg))

;;; double-double float move-argument vop

(define-vop (move-double-double-float-argument)
  (:args (x :scs (double-double-reg) :target y)
	 (fp :scs (any-reg) :load-if (not (sc-is y double-double-reg))))
  (:results (y))
  (:note "double double-float argument move")
  (:generator 2
    (sc-case y
      (double-double-reg
       (unless (location= x y)
	 (let ((x-real (double-double-reg-hi-tn x))
	       (y-real (double-double-reg-hi-tn y)))
	   (cond ((zerop (tn-offset y-real))
		  (copy-fp-reg-to-fr0 x-real))
		 ((zerop (tn-offset x-real))
		  (inst fstd y-real))
		 (t
		  (inst fxch x-real)
		  (inst fstd y-real)
		  (inst fxch x-real))))
	 (let ((x-imag (double-double-reg-lo-tn x))
	       (y-imag (double-double-reg-lo-tn y)))
	   (inst fxch x-imag)
	   (inst fstd y-imag)
	   (inst fxch x-imag))))
      (double-double-stack
       (let ((hi-tn (double-double-reg-hi-tn x)))
	 (cond ((zerop (tn-offset hi-tn))
		(inst fstd (ea-for-cdf-real-stack y fp)))
	       (t
		(inst fxch hi-tn)
		(inst fstd (ea-for-cdf-real-stack y fp))
		(inst fxch hi-tn))))
       (let ((lo-tn (double-double-reg-lo-tn x)))
	 (inst fxch lo-tn)
	 (inst fstd (ea-for-cdf-imag-stack y fp))
	 (inst fxch lo-tn))))))

(define-move-vop move-double-double-float-argument :move-argument
  (double-double-reg descriptor-reg) (double-double-reg))


#+double-double
(progn

(define-vop (make/double-double-float)
  (:args (hi :scs (double-reg) :target r
	     :load-if (not (location= hi r)))
	 (lo :scs (double-reg) :to :save))
  (:results (r :scs (double-double-reg) :from (:argument 0)
	       :load-if (not (sc-is r double-double-stack))))
  (:arg-types double-float double-float)
  (:result-types double-double-float)
  (:translate kernel::make-double-double-float)
  (:note "inline double-double-float creation")
  (:policy :fast-safe)
  (:vop-var vop)
  (:generator 5
    (sc-case r
      (double-double-reg
       (let ((r-real (double-double-reg-hi-tn r)))
	 (unless (location= hi r-real)
	   (cond ((zerop (tn-offset r-real))
		  (copy-fp-reg-to-fr0 hi))
		 ((zerop (tn-offset hi))
		  (inst fstd r-real))
		 (t
		  (inst fxch hi)
		  (inst fstd r-real)
		  (inst fxch hi)))))
       (let ((r-imag (double-double-reg-lo-tn r)))
	 (unless (location= lo r-imag)
	   (cond ((zerop (tn-offset lo))
		  (inst fstd r-imag))
		 (t
		  (inst fxch lo)
		  (inst fstd r-imag)
		  (inst fxch lo))))))
      (double-double-stack
       (unless (location= hi r)
	 (cond ((zerop (tn-offset hi))
		(inst fstd (ea-for-cdf-real-stack r)))
	       (t
		(inst fxch hi)
		(inst fstd (ea-for-cdf-real-stack r))
		(inst fxch hi))))
       (inst fxch lo)
       (inst fstd (ea-for-cdf-imag-stack r))
       (inst fxch lo)))))

(define-vop (double-double-value)
  (:args (x :target r))
  (:results (r))
  (:variant-vars offset)
  (:policy :fast-safe)
  (:generator 3
    (cond ((sc-is x double-double-reg)
	   (let ((value-tn
		  (make-random-tn :kind :normal
				  :sc (sc-or-lose 'double-reg *backend*)
				  :offset (+ offset (tn-offset x)))))
	     (unless (location= value-tn r)
	       (cond ((zerop (tn-offset r))
		      (copy-fp-reg-to-fr0 value-tn))
		     ((zerop (tn-offset value-tn))
		      (inst fstd r))
		     (t
		      (inst fxch value-tn)
		      (inst fstd r)
		      (inst fxch value-tn))))))
	  ((sc-is r double-reg)
	   (let ((ea (sc-case x
		       (double-double-stack
			(ecase offset
			  (0 (ea-for-cdf-real-stack x))
			  (1 (ea-for-cdf-imag-stack x))))
		       (descriptor-reg
			(ecase offset
			  (0 (ea-for-cdf-real-desc x))
			  (1 (ea-for-cdf-imag-desc x)))))))
	     (with-empty-tn@fp-top(r)
	       (inst fldd ea))))
	  (t (error "double-double-value VOP failure")))))


(define-vop (hi/double-double-value double-double-value)
  (:translate kernel::double-double-hi)
  (:args (x :scs (double-double-reg double-double-stack descriptor-reg)
	    :target r))
  (:arg-types double-double-float)
  (:results (r :scs (double-reg)))
  (:result-types double-float)
  (:note "double-double high part")
  (:variant 0))

(define-vop (lo/double-double-value double-double-value)
  (:translate kernel::double-double-lo)
  (:args (x :scs (double-double-reg double-double-stack descriptor-reg)
	    :target r))
  (:arg-types double-double-float)
  (:results (r :scs (double-reg)))
  (:result-types double-float)
  (:note "double-double low part")
  (:variant 1))


); progn
+9 −1
Original line number Diff line number Diff line
@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(ext:file-comment
  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/parms.lisp,v 1.28 2004/07/07 15:03:11 rtoy Exp $")
  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/parms.lisp,v 1.28.8.1 2006/06/10 03:29:19 rtoy Exp $")
;;;
;;; **********************************************************************
;;;
@@ -85,6 +85,8 @@
	  float-imprecise-trap-bit float-invalid-trap-bit
	  float-divide-by-zero-trap-bit))

#+double-double
(export '(double-double-float-digits))
	  

(eval-when (compile load eval)
@@ -143,6 +145,12 @@
(defconstant long-float-digits
  (+ (byte-size long-float-significand-byte) word-bits 1))

;; What is the right value for double-double floats?  I (rtoy)
;; subtract 1 because the hidden bit in the low float doesn't count.
#+double-double
(defconstant double-double-float-digits
  (1- (* 2 double-float-digits)))

;;; pfw -- from i486 microprocessor programmers reference manual
(defconstant float-invalid-trap-bit        (ash 1 0))
(defconstant float-denormal-trap-bit       (ash 1 1))
+13 −4
Original line number Diff line number Diff line
@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(ext:file-comment
 "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/type-vops.lisp,v 1.12 1998/07/24 17:22:43 dtc Exp $")
 "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/type-vops.lisp,v 1.12.24.1 2006/06/10 03:29:19 rtoy Exp $")
;;;
;;; **********************************************************************
;;; 
@@ -387,6 +387,11 @@
(def-type-vops long-float-p check-long-float long-float
  object-not-long-float-error long-float-type)

#+double-double
(def-type-vops double-double-float-p check-double-double-float
  double-double-float object-not-double-double-float-error
  vm:double-double-float-type)
	       
(def-type-vops simple-string-p check-simple-string simple-string
  object-not-simple-string-error simple-string-type)

@@ -564,7 +569,9 @@

(def-type-vops numberp check-number nil object-not-number-error
  even-fixnum-type odd-fixnum-type bignum-type ratio-type
  single-float-type double-float-type #+long-float long-float-type complex-type
  single-float-type double-float-type #+long-float long-float-type
  #+double-double vm:double-double-float-type
  complex-type
  complex-single-float-type complex-double-float-type
  #+long-float complex-long-float-type)

@@ -575,11 +582,13 @@
  even-fixnum-type odd-fixnum-type bignum-type)

(def-type-vops floatp check-float nil object-not-float-error
  single-float-type double-float-type #+long-float long-float-type)
  single-float-type double-float-type #+long-float long-float-type
  #+double-double vm:double-double-float-type)

(def-type-vops realp check-real nil object-not-real-error
  even-fixnum-type odd-fixnum-type ratio-type bignum-type
  single-float-type double-float-type #+long-float long-float-type)
  single-float-type double-float-type #+long-float long-float-type
  #+double-double vm:double-double-float-type)


;;;; Other integer ranges.
Loading