Add support for double-double-float for ppc. (7f3e47ac) · Commits · Tarn Burton / cmucl

bootfiles/19c/Attic/boot-2006-06-1-cross-dd-ppc.lisp

0 → 100644

+245 −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 "PPC" "OLD-PPC")
		(setf (c:backend-name c:native-backend) "OLD-PPC")

		(c::new-backend "PPC"
		;; Features to add here
		'(:ppc
		:new-assembler
		:conservative-float-type
		:hash-new
		:random-mt19937
		:darwin :bsd
		:cmu :cmu19 :cmu19c
		:relative-package-names ; Relative package names from Allegro
		:linkage-table
		:modular-arith
		:double-double ; Double-double float support
		:gencgc ; Generational gc
		)
		;; Features to remove from current features here
		'(:x86-bootstrap :alpha :osf1 :mips :x86 :i486 :pentium :ppro
		:propagate-fun-type :propagate-float-type :constrain-float-type
		:openbsd :freebsd :glibc2 :linux :pentium :elf :mp
		:stack-checking :heap-overflow-check
		:cgc :long-float :new-random :small))

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

		;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
		;;; 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
		;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

		;;; 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:ppc/" "c:generic/"))
		(setf (search-list "assem:")
		'("target:assembly/" "target:assembly/ppc/"))

		;; 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-PPC:BYTE-BITS OLD-PPC:WORD-BITS
		#+long-float OLD-PPC:SIMPLE-ARRAY-LONG-FLOAT-TYPE
		OLD-PPC:SIMPLE-ARRAY-DOUBLE-FLOAT-TYPE
		OLD-PPC:SIMPLE-ARRAY-SINGLE-FLOAT-TYPE
		#+long-float OLD-PPC:SIMPLE-ARRAY-COMPLEX-LONG-FLOAT-TYPE
		OLD-PPC:SIMPLE-ARRAY-COMPLEX-DOUBLE-FLOAT-TYPE
		OLD-PPC:SIMPLE-ARRAY-COMPLEX-SINGLE-FLOAT-TYPE
		OLD-PPC:SIMPLE-ARRAY-UNSIGNED-BYTE-2-TYPE
		OLD-PPC:SIMPLE-ARRAY-UNSIGNED-BYTE-4-TYPE
		OLD-PPC:SIMPLE-ARRAY-UNSIGNED-BYTE-8-TYPE
		OLD-PPC:SIMPLE-ARRAY-UNSIGNED-BYTE-16-TYPE
		OLD-PPC:SIMPLE-ARRAY-UNSIGNED-BYTE-32-TYPE
		OLD-PPC:SIMPLE-ARRAY-SIGNED-BYTE-8-TYPE
		OLD-PPC:SIMPLE-ARRAY-SIGNED-BYTE-16-TYPE
		OLD-PPC:SIMPLE-ARRAY-SIGNED-BYTE-30-TYPE
		OLD-PPC:SIMPLE-ARRAY-SIGNED-BYTE-32-TYPE
		OLD-PPC:SIMPLE-BIT-VECTOR-TYPE
		OLD-PPC:SIMPLE-STRING-TYPE OLD-PPC:SIMPLE-VECTOR-TYPE
		OLD-PPC:SIMPLE-ARRAY-TYPE OLD-PPC: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))
		(concatenate 'string "_" 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-ppc::any-reg ht)
		(gethash 'ppc::any-reg ht)))

		;; A hack for ppc. Make sure the vop, move-double-to-int-arg, is
		;; available in both the OLD-PPC and new PPC package. (I don't know
		;; why this is needed, but it seems to be.)
		(let ((ht (c::backend-template-names c::target-backend)))
		(dolist (syms '((old-ppc::move-double-to-int-arg
		ppc::move-double-to-int-arg)
		(old-ppc::move-single-to-int-arg
		ppc::move-single-to-int-arg)))
		(destructuring-bind (old new)
		syms
		(setf (gethash old
		ht)
		(gethash new ht)))))

bootfiles/19c/boot-2006-06-1-cross-dd-ppc.lisp

0 → 100644

+245 −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 "PPC" "OLD-PPC")
		(setf (c:backend-name c:native-backend) "OLD-PPC")

		(c::new-backend "PPC"
		;; Features to add here
		'(:ppc
		:new-assembler
		:conservative-float-type
		:hash-new
		:random-mt19937
		:darwin :bsd
		:cmu :cmu19 :cmu19c
		:relative-package-names ; Relative package names from Allegro
		:linkage-table
		:modular-arith
		:double-double ; Double-double float support
		:gencgc ; Generational gc
		)
		;; Features to remove from current features here
		'(:x86-bootstrap :alpha :osf1 :mips :x86 :i486 :pentium :ppro
		:propagate-fun-type :propagate-float-type :constrain-float-type
		:openbsd :freebsd :glibc2 :linux :pentium :elf :mp
		:stack-checking :heap-overflow-check
		:cgc :long-float :new-random :small))

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

		;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
		;;; 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
		;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

		;;; 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:ppc/" "c:generic/"))
		(setf (search-list "assem:")
		'("target:assembly/" "target:assembly/ppc/"))

		;; 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-PPC:BYTE-BITS OLD-PPC:WORD-BITS
		#+long-float OLD-PPC:SIMPLE-ARRAY-LONG-FLOAT-TYPE
		OLD-PPC:SIMPLE-ARRAY-DOUBLE-FLOAT-TYPE
		OLD-PPC:SIMPLE-ARRAY-SINGLE-FLOAT-TYPE
		#+long-float OLD-PPC:SIMPLE-ARRAY-COMPLEX-LONG-FLOAT-TYPE
		OLD-PPC:SIMPLE-ARRAY-COMPLEX-DOUBLE-FLOAT-TYPE
		OLD-PPC:SIMPLE-ARRAY-COMPLEX-SINGLE-FLOAT-TYPE
		OLD-PPC:SIMPLE-ARRAY-UNSIGNED-BYTE-2-TYPE
		OLD-PPC:SIMPLE-ARRAY-UNSIGNED-BYTE-4-TYPE
		OLD-PPC:SIMPLE-ARRAY-UNSIGNED-BYTE-8-TYPE
		OLD-PPC:SIMPLE-ARRAY-UNSIGNED-BYTE-16-TYPE
		OLD-PPC:SIMPLE-ARRAY-UNSIGNED-BYTE-32-TYPE
		OLD-PPC:SIMPLE-ARRAY-SIGNED-BYTE-8-TYPE
		OLD-PPC:SIMPLE-ARRAY-SIGNED-BYTE-16-TYPE
		OLD-PPC:SIMPLE-ARRAY-SIGNED-BYTE-30-TYPE
		OLD-PPC:SIMPLE-ARRAY-SIGNED-BYTE-32-TYPE
		OLD-PPC:SIMPLE-BIT-VECTOR-TYPE
		OLD-PPC:SIMPLE-STRING-TYPE OLD-PPC:SIMPLE-VECTOR-TYPE
		OLD-PPC:SIMPLE-ARRAY-TYPE OLD-PPC: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))
		(concatenate 'string "_" 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-ppc::any-reg ht)
		(gethash 'ppc::any-reg ht)))

		;; A hack for ppc. Make sure the vop, move-double-to-int-arg, is
		;; available in both the OLD-PPC and new PPC package. (I don't know
		;; why this is needed, but it seems to be.)
		(let ((ht (c::backend-template-names c::target-backend)))
		(dolist (syms '((old-ppc::move-double-to-int-arg
		ppc::move-double-to-int-arg)
		(old-ppc::move-single-to-int-arg
		ppc::move-single-to-int-arg)))
		(destructuring-bind (old new)
		syms
		(setf (gethash old
		ht)
		(gethash new ht)))))

compiler/ppc/float.lisp

+184 −2

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/ppc/float.lisp,v 1.5 2005/11/17 03:33:45 rtoy Exp $")
		"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/float.lisp,v 1.5.2.1 2006/06/10 00:24:37 rtoy Exp $")
		;;;
		;;; **********************************************************************
		;;;
		@@ -354,7 +354,8 @@


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


		@@ -930,3 +931,184 @@
		(:variant :imag))


		;;; Support for double-double floats

		(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))))

		(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 ((nfp (current-nfp-tn vop))
		(offset (* (tn-offset x) vm:word-bytes)))
		(let ((hi-tn (double-double-reg-hi-tn y)))
		(inst lfd hi-tn nfp offset))
		(let ((lo-tn (double-double-reg-lo-tn y)))
		(inst lfd lo-tn nfp (+ offset vm:word-bytes)))))

		(define-move-function (store-double-double 4) (vop x y)
		((double-double-reg) (double-double-stack))
		(let ((nfp (current-nfp-tn vop))
		(offset (* (tn-offset y) vm:word-bytes)))
		(let ((hi-tn (double-double-reg-hi-tn x)))
		(inst stfd hi-tn nfp offset))
		(let ((lo-tn (double-double-reg-lo-tn x)))
		(inst stfd lo-tn nfp (+ offset (* 2 vm:word-bytes))))))

		;;; 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)))
		(inst fmr y-hi x-hi))
		(let ((x-lo (double-double-reg-lo-tn x))
		(y-lo (double-double-reg-lo-tn y)))
		(inst fmr y-lo 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)))
		(:temporary (:scs (non-descriptor-reg)) ndescr)
		(:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag)
		(:note "double double float to pointer coercion")
		(:generator 13
		(with-fixed-allocation (y pa-flag ndescr vm::double-double-float-type
		vm::double-double-float-size))
		(let ((hi-tn (double-double-reg-hi-tn x)))
		(inst stfd hi-tn y (- (* vm::double-double-float-hi-slot
		vm:word-bytes)
		vm:other-pointer-type)))
		(let ((lo-tn (double-double-reg-lo-tn x)))
		(inst stfd lo-tn y (- (* vm::double-double-float-lo-slot
		vm:word-bytes)
		vm:other-pointer-type)))))
		;;;
		(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 float coercion")
		(:generator 2
		(let ((hi-tn (double-double-reg-hi-tn y)))
		(inst lfd hi-tn x (- (* double-double-float-hi-slot word-bytes)
		other-pointer-type)))
		(let ((lo-tn (double-double-reg-lo-tn y)))
		(inst lfd lo-tn x (- (* double-double-float-lo-slot word-bytes)
		other-pointer-type)))))

		(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)
		(nfp :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-hi (double-double-reg-hi-tn x))
		(y-hi (double-double-reg-hi-tn y)))
		(inst fmr y-hi x-hi))
		(let ((x-lo (double-double-reg-lo-tn x))
		(y-lo (double-double-reg-lo-tn y)))
		(inst fmr y-lo x-lo))))
		(double-double-stack
		(let ((offset (* (tn-offset y) word-bytes)))
		(let ((hi-tn (double-double-reg-hi-tn x)))
		(inst stfd hi-tn nfp offset))
		(let ((lo-tn (double-double-reg-lo-tn x)))
		(inst stfd lo-tn nfp (+ offset (* 2 word-bytes)))))))))

		(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))
		(:arg-types double-float double-float)
		(:results (r :scs (double-double-reg) :from (:argument 0)
		:load-if (not (sc-is r double-double-stack))))
		(:result-types double-double-float)
		(:translate kernel::make-double-double-float)
		(:note "inline double-double-float creation")
		(:policy :fast-safe)
		(:vop-var vop)
		(:generator 2
		(sc-case r
		(double-double-reg
		(let ((r-hi (double-double-reg-hi-tn r)))
		(unless (location= hi r-hi)
		(inst fmr r-hi hi)))
		(let ((r-lo (double-double-reg-lo-tn r)))
		(unless (location= lo r-lo)
		(inst fmr r-lo lo))))
		(double-double-stack
		(let ((nfp (current-nfp-tn vop))
		(offset (* (tn-offset r) vm:word-bytes)))
		(unless (location= hi r)
		(inst stfd hi nfp offset))
		(inst stfd lo nfp (+ offset (* 2 vm:word-bytes))))))))

		(define-vop (double-double-value)
		(:args (x :scs (double-double-reg)))
		(:arg-types double-double-float)
		(:results (r :scs (double-reg)))
		(:result-types double-float)
		(:variant-vars slot)
		(:policy :fast-safe)
		(:vop-var vop)
		(:generator 3
		(let ((value-tn (ecase slot
		(:hi (double-double-reg-hi-tn x))
		(:lo (double-double-reg-lo-tn x)))))
		(unless (location= value-tn r)
		(inst fmr r value-tn)))))


		(define-vop (hi/double-double-value double-double-value)
		(:translate kernel::double-double-hi)
		(:note "double-double high part")
		(:variant :hi))

		(define-vop (lo/double-double-value double-double-value)
		(:translate kernel::double-double-lo)
		(:note "double-double low part")
		(:variant :lo))


		); progn

compiler/ppc/parms.lisp

+8 −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/ppc/parms.lisp,v 1.11 2006/05/07 23:50:00 rtoy Exp $")
		"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/parms.lisp,v 1.11.2.1 2006/06/10 00:24:37 rtoy Exp $")
		;;;
		;;; **********************************************************************
		;;;
		@@ -60,6 +60,8 @@
		float-imprecise-trap-bit float-invalid-trap-bit
		float-divide-by-zero-trap-bit))

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



		@@ -103,6 +105,11 @@
		(defconstant double-float-digits
		(+ (byte-size double-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
		(+ double-float-digits (- double-float-digits 1)))

		(defconstant float-inexact-trap-bit (ash 1 0))
		(defconstant float-divide-by-zero-trap-bit (ash 1 1))

compiler/ppc/type-vops.lisp

+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/ppc/type-vops.lisp,v 1.2 2001/02/11 16:43:19 dtc Exp $")
		"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/type-vops.lisp,v 1.2.24.1 2006/06/10 00:24:37 rtoy Exp $")
		;;;
		;;; **********************************************************************
		;;;
		@@ -137,6 +137,11 @@
		(def-type-vops double-float-p check-double-float double-float
		object-not-double-float-error vm:double-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 vm:simple-string-type)

		@@ -295,7 +300,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 complex-type
		single-float-type double-float-type
		#+double-double vm:double-double-float-type
		complex-type
		complex-single-float-type complex-double-float-type)

		(def-type-vops rationalp check-rational nil object-not-rational-error
		@@ -305,11 +312,13 @@
		vm:even-fixnum-type vm:odd-fixnum-type vm:bignum-type)

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

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


		;;;; Other integer ranges.