CMUCL commit: src (21 files)
Raymond Toy
rtoy at common-lisp.net
Mon Nov 2 03:51:59 CET 2009
Date: Sunday, November 1, 2009 @ 21:51:58
Author: rtoy
Path: /project/cmucl/cvsroot/src
Modified: code/pred.lisp code/sap.lisp code/unix-glibc2.lisp
compiler/amd64/float.lisp compiler/amd64/parms.lisp
compiler/amd64/type-vops.lisp compiler/amd64/vm.lisp
compiler/float-tran.lisp lisp/Config.amd64 lisp/Linux-os.c
lisp/Linux-os.h lisp/amd64-arch.c lisp/amd64-assem.S
lisp/amd64-lispregs.h lisp/backtrace.c lisp/gencgc.c lisp/gencgc.h
lisp/globals.h lisp/interrupt.c tools/clean-target.sh
tools/cross-scripts/cross-x86-amd64.lisp
This large checkin brings the amd64 port up-to-date with the current
sources. No real attempt has been made to make it work, but the
cross-compile does create a kernel.core, and the C code compiles (on
openSuSE 10.3). The resulting kernel.core does not yet work.
Use cross-x86-amd64.lisp as the cross-compile script. This is
intended to be cross-compiled using the 20a release for Linux, and
only supports x87. The sse2 support has not be ported yet.
tools/cross-scripts/cross-x86-amd64.lisp:
o Update cross-compile with some missing constants, and frob new
symbols.
tools/clean-target.sh:
o Remove amd64f files too.
code/pred.lisp:
o Define predicates for double-doubles for bootstrapping to work
around recursive known function problems with these predicates.
code/sap.lisp:
o Define int-sap with (unsigned-byte 64) type declaration. (May not
be needed?)
code/unix-glibc2.lisp:
o Build fails defining map_failed to (int-sap -1). Just hard-wire to
0 for now so we can build.
compiler/float-tran.lisp:
o Add missing conditional for %complex-double-double-float.
compiler/amd64/float.lisp:
o Merge double-double support for amd64. Not really tested yet.
compiler/amd64/parms.lisp:
o Update to match x86 build. In particular, get the space address
correct and update the static symbols.
compiler/amd64/type-vops.lisp:
o DYLAN-FUNCTION-HEADER-TYPE no longer exists.
compiler/amd64/vm.lisp:
o Add double-double storage classes and register definitions.
lisp/Config.amd64:
o Bring in line with Config.x86 and friends.
lisp/Linux-os.c:
o Bring amd64 code up-to-date with x86/linux code.
lisp/Linux-os.h
o Need to include sys/ucontext.h to get ucontext defined. (Why?)
o Also define __USE_GNU so we get the register offsets in the ucontext
defined. (Why?)
lisp/amd64-arch.c:
o Change struct sigcontext to os_context_t.
o Use SC_PC instead of context->sc_pc.
o Merge some changes in from x86 version, like SC_EFLAGS. May need
more work.
lisp/amd64-assem.s:
o Use rbx instead of ebx for jmp.
lisp/amd64-lispregs.h:
o Define SC_REG, SC_PC, SC_SP using the new x86 style.
lisp/backtrace.c:
o Remove inline assembly for now until I figure out what the amd64
version should be.
lisp/gencgc.c:
o Conditionalize out weak hash table support for now.
lisp/gencgc.h:
o Set PAGE_SIZE for amd64. (Is 4096 right?)
lisp/globals.h:
o Export current_dynamic_space_free_pointer and
current_auto_gc_trigger like for x86.
------------------------------------------+
code/pred.lisp | 35 +
code/sap.lisp | 8
code/unix-glibc2.lisp | 4
compiler/amd64/float.lisp | 830 +++++++++++++++++++++++++++--
compiler/amd64/parms.lisp | 78 +-
compiler/amd64/type-vops.lisp | 4
compiler/amd64/vm.lisp | 23
compiler/float-tran.lisp | 4
lisp/Config.amd64 | 43 +
lisp/Linux-os.c | 79 ++
lisp/Linux-os.h | 5
lisp/amd64-arch.c | 83 +-
lisp/amd64-assem.S | 4
lisp/amd64-lispregs.h | 8
lisp/backtrace.c | 7
lisp/gencgc.c | 9
lisp/gencgc.h | 4
lisp/globals.h | 4
lisp/interrupt.c | 4
tools/clean-target.sh | 1
tools/cross-scripts/cross-x86-amd64.lisp | 75 +-
21 files changed, 1120 insertions(+), 192 deletions(-)
Index: src/code/pred.lisp
diff -u src/code/pred.lisp:1.60 src/code/pred.lisp:1.61
--- src/code/pred.lisp:1.60 Fri Jun 30 14:41:22 2006
+++ src/code/pred.lisp Sun Nov 1 21:51:57 2009
@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
- "$Header: /project/cmucl/cvsroot/src/code/pred.lisp,v 1.60 2006-06-30 18:41:22 rtoy Rel $")
+ "$Header: /project/cmucl/cvsroot/src/code/pred.lisp,v 1.61 2009-11-02 02:51:57 rtoy Exp $")
;;;
;;; **********************************************************************
;;;
@@ -127,6 +127,39 @@
primitive-predicates))))
(frob))
+;;; FIXME: The next four functions are for bootstrapping double-double
+;;; for AMD64. This works around the recursive known function problem
+;;; when compiling the predicate functions for double-double. This
+;;; should be eventually removed when double-double float support for
+;;; the compiler is working.
+(defun double-double-float-p (x)
+ (let* ((addr (kernel:get-lisp-obj-address x))
+ (ptr (logandc2 addr #x7)))
+ (when (= 1 (logand addr 1))
+ (= 26 (ldb (byte 8 0)
+ (sys:sap-ref-32 (sys:int-sap ptr) 0))))))
+
+(defun complex-double-double-float-p (x)
+ (let* ((addr (kernel:get-lisp-obj-address x))
+ (ptr (logandc2 addr #x7)))
+ (when (= 1 (logand addr 1))
+ (= 42 (ldb (byte 8 0)
+ (sys:sap-ref-32 (sys:int-sap ptr) 0))))))
+
+(defun simple-array-double-double-float-p (x)
+ (let* ((addr (kernel:get-lisp-obj-address x))
+ (ptr (logandc2 addr #x7)))
+ (when (= 1 (logand addr 1))
+ (= 106 (ldb (byte 8 0)
+ (sys:sap-ref-32 (sys:int-sap ptr) 0))))))
+
+(defun simple-array-complex-double-double-float-p (x)
+ (let* ((addr (kernel:get-lisp-obj-address x))
+ (ptr (logandc2 addr #x7)))
+ (when (= 1 (logand addr 1))
+ (= 118 (ldb (byte 8 0)
+ (sys:sap-ref-32 (sys:int-sap ptr) 0))))))
+
;;;; TYPE-OF -- public.
;;;
Index: src/code/sap.lisp
diff -u src/code/sap.lisp:1.19 src/code/sap.lisp:1.20
--- src/code/sap.lisp:1.19 Thu Jan 3 06:41:52 2008
+++ src/code/sap.lisp Sun Nov 1 21:51:58 2009
@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
- "$Header: /project/cmucl/cvsroot/src/code/sap.lisp,v 1.19 2008-01-03 11:41:52 cshapiro Rel $")
+ "$Header: /project/cmucl/cvsroot/src/code/sap.lisp,v 1.20 2009-11-02 02:51:58 rtoy Exp $")
;;;
;;; **********************************************************************
;;;
@@ -77,10 +77,16 @@
(declare (type system-area-pointer sap))
(sap-int sap))
+#-amd64
(defun int-sap (int)
"Converts an integer into a System Area Pointer."
(declare (type (unsigned-byte #-alpha #.vm:word-bits #+alpha 64) int))
(int-sap int))
+#+amd64
+(defun int-sap (int)
+ "Converts an integer into a System Area Pointer."
+ (declare (type (unsigned-byte 64) int))
+ (int-sap int))
(defun sap-ref-8 (sap offset)
"Returns the 8-bit byte at OFFSET bytes from SAP."
Index: src/code/unix-glibc2.lisp
diff -u src/code/unix-glibc2.lisp:1.49 src/code/unix-glibc2.lisp:1.50
--- src/code/unix-glibc2.lisp:1.49 Thu Oct 15 10:07:35 2009
+++ src/code/unix-glibc2.lisp Sun Nov 1 21:51:58 2009
@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
- "$Header: /project/cmucl/cvsroot/src/code/unix-glibc2.lisp,v 1.49 2009-10-15 14:07:35 rtoy Exp $")
+ "$Header: /project/cmucl/cvsroot/src/code/unix-glibc2.lisp,v 1.50 2009-11-02 02:51:58 rtoy Exp $")
;;;
;;; **********************************************************************
;;;
@@ -265,7 +265,7 @@
(defconstant ms_invalidate 2)
;; The return value from mmap that means mmap failed.
-(defconstant map_failed (int-sap (1- (ash 1 vm:word-bits))))
+(defconstant map_failed (int-sap #+amd64 0 #-amd64 (1- (ash 1 vm:word-bits))))
(defun unix-mmap (addr length prot flags fd offset)
(declare (type (or null system-area-pointer) addr)
Index: src/compiler/amd64/float.lisp
diff -u src/compiler/amd64/float.lisp:1.2 src/compiler/amd64/float.lisp:1.3
--- src/compiler/amd64/float.lisp:1.2 Wed Jul 14 16:57:31 2004
+++ src/compiler/amd64/float.lisp Sun Nov 1 21:51:58 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 2004-07-14 20:57:31 cwang Rel $")
+ "$Header: /project/cmucl/cvsroot/src/compiler/amd64/float.lisp,v 1.3 2009-11-02 02:51:58 rtoy Exp $")
;;;
;;; **********************************************************************
;;;
@@ -61,7 +61,20 @@
(ea-for-xf-desc tn vm:complex-long-float-real-slot))
#+long-float
(defun ea-for-clf-imag-desc (tn)
- (ea-for-xf-desc tn vm:complex-long-float-imag-slot)))
+ (ea-for-xf-desc tn vm:complex-long-float-imag-slot))
+ #+double-double
+ (defun ea-for-cddf-real-hi-desc (tn)
+ (ea-for-xf-desc tn vm:complex-double-double-float-real-hi-slot))
+ #+double-double
+ (defun ea-for-cddf-real-lo-desc (tn)
+ (ea-for-xf-desc tn vm:complex-double-double-float-real-lo-slot))
+ #+double-double
+ (defun ea-for-cddf-imag-hi-desc (tn)
+ (ea-for-xf-desc tn vm:complex-double-double-float-imag-hi-slot))
+ #+double-double
+ (defun ea-for-cddf-imag-lo-desc (tn)
+ (ea-for-xf-desc tn vm:complex-double-double-float-imag-lo-slot))
+ )
(macrolet ((ea-for-xf-stack (tn kind)
`(make-ea
@@ -86,7 +99,13 @@
(:single 1)
(:double 2)
(:long 3))
- (ecase ,slot (:real 1) (:imag 2))))
+ (ecase ,slot
+ (:real 1)
+ (:imag 2)
+ (:real-hi 1)
+ (:real-lo 2)
+ (:imag-hi 3)
+ (:imag-lo 4))))
vm:word-bytes)))))
(defun ea-for-csf-real-stack (tn &optional (base rbp-tn))
(ea-for-cxf-stack tn :single :real base))
@@ -103,7 +122,21 @@
(ea-for-cxf-stack tn :long :real base))
#+long-float
(defun ea-for-clf-imag-stack (tn &optional (base rbp-tn))
- (ea-for-cxf-stack tn :long :imag base)))
+ (ea-for-cxf-stack tn :long :imag base))
+
+ #+double-double
+ (defun ea-for-cddf-real-hi-stack (tn &optional (base rbp-tn))
+ (ea-for-cxf-stack tn :double :real-hi base))
+ #+double-double
+ (defun ea-for-cddf-real-lo-stack (tn &optional (base rbp-tn))
+ (ea-for-cxf-stack tn :double :real-lo base))
+ #+double-double
+ (defun ea-for-cddf-imag-hi-stack (tn &optional (base rbp-tn))
+ (ea-for-cxf-stack tn :double :imag-hi base))
+ #+double-double
+ (defun ea-for-cddf-imag-lo-stack (tn &optional (base rbp-tn))
+ (ea-for-cxf-stack tn :double :imag-lo base))
+ )
;;; Abstract out the copying of a FP register to the FP stack top, and
;;; provide two alternatives for its implementation. Note: it's not
@@ -236,6 +269,21 @@
(make-random-tn :kind :normal :sc (sc-or-lose 'long-reg *backend*)
:offset (1+ (tn-offset x))))
+#+double-double
+(progn
+(defun complex-double-double-reg-real-hi-tn (x)
+ (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*)
+ :offset (tn-offset x)))
+(defun complex-double-double-reg-real-lo-tn (x)
+ (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*)
+ :offset (+ 1 (tn-offset x))))
+(defun complex-double-double-reg-imag-hi-tn (x)
+ (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*)
+ :offset (+ 2 (tn-offset x))))
+(defun complex-double-double-reg-imag-lo-tn (x)
+ (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*)
+ :offset (+ 3 (tn-offset x))))
+)
;;; x is source, y is destination
(define-move-function (load-complex-single 2) (vop x y)
((complex-single-stack) (complex-single-reg))
@@ -308,6 +356,49 @@
(store-long-float (ea-for-clf-imag-stack y))
(inst fxch imag-tn)))
+#+double-double
+(progn
+(define-move-function (load-complex-double-double 4) (vop x y)
+ ((complex-double-double-stack) (complex-double-double-reg))
+ (let ((real-tn (complex-double-double-reg-real-hi-tn y)))
+ (with-empty-tn at fp-top(real-tn)
+ (inst fldd (ea-for-cddf-real-hi-stack x))))
+ (let ((real-tn (complex-double-double-reg-real-lo-tn y)))
+ (with-empty-tn at fp-top(real-tn)
+ (inst fldd (ea-for-cddf-real-lo-stack x))))
+ (let ((imag-tn (complex-double-double-reg-imag-hi-tn y)))
+ (with-empty-tn at fp-top(imag-tn)
+ (inst fldd (ea-for-cddf-imag-hi-stack x))))
+ (let ((imag-tn (complex-double-double-reg-imag-lo-tn y)))
+ (with-empty-tn at fp-top(imag-tn)
+ (inst fldd (ea-for-cddf-imag-lo-stack x)))))
+
+(define-move-function (store-complex-double-double 4) (vop x y)
+ ((complex-double-double-reg) (complex-double-double-stack))
+ ;; FIXME: These may not be right!!!!
+ (let ((real-tn (complex-double-double-reg-real-hi-tn x)))
+ (cond ((zerop (tn-offset real-tn))
+ (inst fstd (ea-for-cddf-real-hi-stack y)))
+ (t
+ (inst fxch real-tn)
+ (inst fstd (ea-for-cddf-real-hi-stack y))
+ (inst fxch real-tn))))
+ (let ((real-tn (complex-double-double-reg-real-lo-tn x)))
+ (cond ((zerop (tn-offset real-tn))
+ (inst fstd (ea-for-cddf-real-lo-stack y)))
+ (t
+ (inst fxch real-tn)
+ (inst fstd (ea-for-cddf-real-lo-stack y))
+ (inst fxch real-tn))))
+ (let ((imag-tn (complex-double-double-reg-imag-hi-tn x)))
+ (inst fxch imag-tn)
+ (inst fstd (ea-for-cddf-imag-hi-stack y))
+ (inst fxch imag-tn))
+ (let ((imag-tn (complex-double-double-reg-imag-lo-tn x)))
+ (inst fxch imag-tn)
+ (inst fstd (ea-for-cddf-imag-lo-stack y))
+ (inst fxch imag-tn)))
+)
;;;; Move VOPs:
@@ -546,11 +637,12 @@
(define-vop (move-from-complex-long)
(:args (x :scs (complex-long-reg) :to :save))
(:results (y :scs (descriptor-reg)))
+ (:temporary (:sc any-reg :offset r11-offset) temp)
(:node-var node)
(:note "complex float to pointer coercion")
(:generator 13
(with-fixed-allocation (y vm:complex-long-float-type
- vm:complex-long-float-size node)
+ vm:complex-long-float-size temp node)
(let ((real-tn (complex-long-reg-real-tn x)))
(with-tn at fp-top(real-tn)
(store-long-float (ea-for-clf-real-desc y))))
@@ -561,6 +653,32 @@
(define-move-vop move-from-complex-long :move
(complex-long-reg) (descriptor-reg))
+#+double-double
+(define-vop (move-from-complex-double-double)
+ (:args (x :scs (complex-double-double-reg) :to :save))
+ (:results (y :scs (descriptor-reg)))
+ (:temporary (:sc any-reg :offset r11-offset) temp)
+ (:node-var node)
+ (:note "complex double-double float to pointer coercion")
+ (:generator 13
+ (with-fixed-allocation (y vm::complex-double-double-float-type
+ vm::complex-double-double-float-size temp node)
+ (let ((real-tn (complex-double-double-reg-real-hi-tn x)))
+ (with-tn at fp-top(real-tn)
+ (inst fstd (ea-for-cddf-real-hi-desc y))))
+ (let ((real-tn (complex-double-double-reg-real-lo-tn x)))
+ (with-tn at fp-top(real-tn)
+ (inst fstd (ea-for-cddf-real-lo-desc y))))
+ (let ((imag-tn (complex-double-double-reg-imag-hi-tn x)))
+ (with-tn at fp-top(imag-tn)
+ (inst fstd (ea-for-cddf-imag-hi-desc y))))
+ (let ((imag-tn (complex-double-double-reg-imag-lo-tn x)))
+ (with-tn at fp-top(imag-tn)
+ (inst fstd (ea-for-cddf-imag-lo-desc y)))))))
+;;;
+#+double-double
+(define-move-vop move-from-complex-double-double :move
+ (complex-double-double-reg) (descriptor-reg))
;;;
;;; Move from a descriptor to a complex float register
;;;
@@ -728,14 +846,93 @@
(frob move-complex-long-float-argument
complex-long-reg complex-long-stack :long))
+#+double-double
+(define-vop (move-complex-double-double-float-argument)
+ (:args (x :scs (complex-double-double-reg) :target y)
+ (fp :scs (any-reg) :load-if (not (sc-is y complex-double-double-reg))))
+ (:results (y))
+ (:note "complex double-double-float argument move")
+ (:generator 2
+ (sc-case y
+ (complex-double-double-reg
+ (unless (location= x y)
+ (let ((x-real (complex-double-double-reg-real-hi-tn x))
+ (y-real (complex-double-double-reg-real-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-real (complex-double-double-reg-real-lo-tn x))
+ (y-real (complex-double-double-reg-real-lo-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 (complex-double-double-reg-imag-hi-tn x))
+ (y-imag (complex-double-double-reg-imag-hi-tn y)))
+ (inst fxch x-imag)
+ (inst fstd y-imag)
+ (inst fxch x-imag))
+ (let ((x-imag (complex-double-double-reg-imag-lo-tn x))
+ (y-imag (complex-double-double-reg-imag-lo-tn y)))
+ (inst fxch x-imag)
+ (inst fstd y-imag)
+ (inst fxch x-imag))))
+ (complex-double-double-stack
+ (let ((real-tn (complex-double-double-reg-real-hi-tn x)))
+ (cond ((zerop (tn-offset real-tn))
+ (inst fstd (ea-for-cddf-real-hi-stack y fp)))
+ (t
+ (inst fxch real-tn)
+ (inst fstd (ea-for-cddf-real-hi-stack y fp))
+ (inst fxch real-tn))))
+ (let ((real-tn (complex-double-double-reg-real-lo-tn x)))
+ (cond ((zerop (tn-offset real-tn))
+ (inst fstd (ea-for-cddf-real-lo-stack y fp)))
+ (t
+ (inst fxch real-tn)
+ (inst fstd (ea-for-cddf-real-lo-stack y fp))
+ (inst fxch real-tn))))
+ (let ((imag-tn (complex-double-double-reg-imag-hi-tn x)))
+ (inst fxch imag-tn)
+ (inst fstd (ea-for-cddf-imag-hi-stack y fp))
+ (inst fxch imag-tn))
+ (let ((imag-tn (complex-double-double-reg-imag-lo-tn x)))
+ (inst fxch imag-tn)
+ (inst fstd (ea-for-cddf-imag-lo-stack y fp))
+ (inst fxch imag-tn))))
+ ))
+
+#+double-double
+(define-move-vop move-complex-double-double-float-argument :move-argument
+ (complex-double-double-reg descriptor-reg) (complex-double-double-reg))
+
(define-move-vop move-argument :move-argument
(single-reg double-reg #+long-float long-reg
- complex-single-reg complex-double-reg #+long-float complex-long-reg)
+ #+double-double double-double-reg
+ complex-single-reg complex-double-reg #+long-float complex-long-reg
+ #+double-double complex-double-double-reg)
(descriptor-reg))
;;;; Arithmetic VOPs:
+
+;; Save the top-of-stack to memory and reload it. This ensures that
+;; the stack top has the desired precision.
+(defmacro save-and-reload-tos (tmp)
+ `(progn
+ (inst fstp ,tmp)
+ (inst fld ,tmp)))
+
;;; dtc: The floating point arithmetic vops.
;;;
;;; Note: Although these can accept x and y on the stack or pointed to
@@ -1210,6 +1407,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 rax-offset :from :eval) temp)
@@ -1507,6 +1710,7 @@
(:save-p :compute-only)
(:note "inline float comparison")
(:ignore temp y)
+ (:guard (not (backend-featurep :sse2)))
(:generator 2
(note-this-location vop :internal-error)
(cond
@@ -1532,12 +1736,14 @@
(:translate ,translate)
(:args (x :scs (single-reg)))
(:arg-types single-float (:constant (single-float 0f0 0f0)))
+ (:guard (not (backend-featurep :sse2)))
(:variant ,test))
(define-vop (,(symbolicate translate "0/DOUBLE-FLOAT")
float-test)
(:translate ,translate)
(:args (x :scs (double-reg)))
(:arg-types double-float (:constant (double-float 0d0 0d0)))
+ (:guard (not (backend-featurep :sse2)))
(:variant ,test))
#+long-float
(define-vop (,(symbolicate translate "0/LONG-FLOAT")
@@ -1669,11 +1875,41 @@
(with-empty-tn at fp-top(y)
(note-this-location vop :internal-error)
(inst fild x))))))))
+ #+(or)
(frob %single-float/signed %single-float single-reg single-float)
(frob %double-float/signed %double-float double-reg double-float)
#+long-float
(frob %long-float/signed %long-float long-reg long-float))
+(define-vop (%single-float/signed)
+ (:args (x :scs (signed-stack signed-reg) :target temp))
+ (:temporary (:sc signed-stack) temp)
+ (:temporary (:sc single-stack) sf-temp)
+ (:results (y :scs (single-reg)))
+ (:arg-types signed-num)
+ (:result-types single-float)
+ (:policy :fast-safe)
+ (:note "inline float coercion")
+ (:translate %single-float)
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 5
+ (sc-case x
+ (signed-reg
+ (inst mov temp x)
+ (with-empty-tn at fp-top(y)
+ (note-this-location vop :internal-error)
+ (inst fild temp)
+ (inst fstp sf-temp)
+ (inst fld sf-temp)))
+ (signed-stack
+ (with-empty-tn at fp-top(y)
+ (note-this-location vop :internal-error)
+ (inst fild x)
+ (inst fstp sf-temp)
+ (inst fld sf-temp))))))
+
+#-sse2
(macrolet ((frob (name translate to-sc to-type)
`(define-vop (,name)
(:args (x :scs (unsigned-reg)))
@@ -1697,6 +1933,27 @@
#+long-float
(frob %long-float/unsigned %long-float long-reg long-float))
+;;#+(or)
+(define-vop (%single-float/unsigned)
+ (:args (x :scs (unsigned-reg)))
+ (:results (y :scs (single-reg)))
+ (:arg-types unsigned-num)
+ (:result-types single-float)
+ (:policy :fast-safe)
+ (:note "inline float coercion")
+ (:translate %single-float)
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 6
+ (inst push 0)
+ (inst push x)
+ (with-empty-tn at fp-top(y)
+ (note-this-location vop :internal-error)
+ (inst fildl (make-ea :dword :base rsp-tn))
+ (inst fstp (make-ea :dword :base rsp-tn))
+ (inst fld (make-ea :dword :base rsp-tn)))
+ (inst add rsp-tn 8)))
+
;;; These should be no-ops but the compiler might want to move
;;; some things around
(macrolet ((frob (name translate from-sc from-type to-sc to-type)
@@ -1727,6 +1984,7 @@
(inst fst y)
(inst fxch x))))))))
+ #+(or)
(frob %single-float/double-float %single-float double-reg
double-float single-reg single-float)
#+long-float
@@ -1744,7 +2002,54 @@
(frob %long-float/double-float %long-float double-reg double-float
long-reg long-float))
+(define-vop (%single-float/double-float)
+ (:args (x :scs (double-reg) :target y))
+ (:results (y :scs (single-reg)))
+ (:arg-types double-float)
+ (:result-types single-float)
+ (:policy :fast-safe)
+ (:note "inline float coercion")
+ (:translate %single-float)
+ (:temporary (:sc single-stack) sf-temp)
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 2
+ (note-this-location vop :internal-error)
+ (cond
+ ((zerop (tn-offset x))
+ (cond
+ ((zerop (tn-offset y))
+ ;; x is in ST0, y is also in ST0
+ (inst fstp sf-temp)
+ (inst fld sf-temp))
+ (t
+ ;; x is in ST0, y is in another reg. not ST0
+ ;; Save st0 (x) to memory, swap, reload, then swap back.
+ (inst fst sf-temp)
+ (inst fxch y)
+ (fp-pop)
+ (inst fld sf-temp)
+ (inst fxch y))))
+ ((zerop (tn-offset y))
+ ;; y is in ST0, x is in another reg. not ST0
+ ;; Swap, save x to memory, reload, swap back
+ (inst fxch x)
+ (inst fstp sf-temp)
+ (inst fld sf-temp)
+ (inst fxch x))
+ (t
+ ;; Neither x or y are in ST0, and they are not in
+ ;; the same reg.
+ ;; Get x to st0. Store it away. Swap back. Get y to st0,
+ ;; load. Swap back.
+ (inst fxch x)
+ (inst fst sf-temp)
+ (inst fxch x)
+ (inst fxch y)
+ (fp-pop)
+ (inst fld sf-temp)
+ (inst fxch y)))))
(macrolet ((frob (trans from-sc from-type round-p)
`(define-vop (,(symbolicate trans "/" from-type))
@@ -1809,6 +2114,7 @@
(:note "inline float truncate")
(:vop-var vop)
(:save-p :compute-only)
+ (:guard (not (backend-featurep :sse2)))
(:generator 5
,@(unless round-p
'((note-this-location vop :internal-error)
@@ -2078,55 +2384,53 @@
;;;; Float mode hackery:
-(deftype float-modes () '(unsigned-byte 32)) ; really only 16
-(defknown floating-point-modes () float-modes (flushable))
-(defknown ((setf floating-point-modes)) (float-modes)
+(deftype float-modes () '(unsigned-byte 24))
+(defknown x87-floating-point-modes () float-modes (flushable))
+(defknown ((setf x87-floating-point-modes)) (float-modes)
float-modes)
-(defconstant npx-env-size (* 7 vm:word-bytes))
-(defconstant npx-cw-offset 0)
-(defconstant npx-sw-offset 4)
-
-(define-vop (floating-point-modes)
+(define-vop (x87-floating-point-modes)
(:results (res :scs (unsigned-reg)))
(:result-types unsigned-num)
- (:translate floating-point-modes)
+ (:translate x87-floating-point-modes)
(:policy :fast-safe)
- (:temporary (:sc unsigned-reg :offset rax-offset :target res
- :to :result) rax)
+ (:temporary (:sc unsigned-stack) cw-stack)
+ (:temporary (:sc unsigned-reg :offset eax-offset) sw-reg)
(:generator 8
- (inst sub rsp-tn npx-env-size) ; make space on stack
- (inst wait) ; Catch any pending FPE exceptions
- (inst fstenv (make-ea :qword :base rsp-tn)) ; masks all exceptions
- (inst fldenv (make-ea :qword :base rsp-tn)) ; restore previous state
- ;; Current status to high word
- (inst mov rax (make-ea :qword :base rsp-tn :disp (- npx-sw-offset 2)))
- ;; Exception mask to low word
- (inst mov ax-tn (make-ea :word :base rsp-tn :disp npx-cw-offset))
- (inst add rsp-tn npx-env-size) ; Pop stack
- (inst xor rax #x3f) ; Flip exception mask to trap enable bits
- (move res rax)))
+ (inst fnstsw)
+ (inst fnstcw cw-stack)
+ (inst and sw-reg #xff) ; mask exception flags
+ (inst shl sw-reg 16)
+ (inst byte #x66) ; operand size prefix
+ (inst or sw-reg cw-stack)
+ (inst xor sw-reg #x3f) ; invert exception mask
+ (move res sw-reg)))
-(define-vop (set-floating-point-modes)
+(define-vop (set-x87-floating-point-modes)
(:args (new :scs (unsigned-reg) :to :result :target res))
(:results (res :scs (unsigned-reg)))
(:arg-types unsigned-num)
(:result-types unsigned-num)
- (:translate (setf floating-point-modes))
+ (:translate (setf x87-floating-point-modes))
(:policy :fast-safe)
- (:temporary (:sc unsigned-reg :offset rax-offset
- :from :eval :to :result) rax)
- (:generator 3
- (inst sub rsp-tn npx-env-size) ; make space on stack
- (inst wait) ; Catch any pending FPE exceptions
- (inst fstenv (make-ea :qword :base rsp-tn))
- (inst mov rax new)
- (inst xor rax #x3f) ; turn trap enable bits into exception mask
- (inst mov (make-ea :word :base rsp-tn :disp npx-cw-offset) ax-tn)
- (inst shr rax 16) ; position status word
- (inst mov (make-ea :word :base rsp-tn :disp npx-sw-offset) ax-tn)
- (inst fldenv (make-ea :qword :base rsp-tn))
- (inst add rsp-tn npx-env-size) ; Pop stack
+ (:temporary (:sc unsigned-stack) cw-stack)
+ (:temporary (:sc byte-reg :offset al-offset) sw-reg)
+ (:temporary (:sc unsigned-reg :offset ecx-offset) old)
+ (:generator 6
+ (inst mov cw-stack new)
+ (inst xor cw-stack #x3f) ; invert exception mask
+ (inst fnstsw)
+ (inst fldcw cw-stack) ; always update the control word
+ (inst mov old new)
+ (inst shr old 16)
+ (inst cmp cl-tn sw-reg) ; compare exception flags
+ (inst jmp :z DONE) ; skip updating the status word
+ (inst sub rsp-tn 28)
+ (inst fstenv (make-ea :dword :base rsp-tn))
+ (inst mov (make-ea :byte :base rsp-tn :disp 4) cl-tn)
+ (inst fldenv (make-ea :dword :base rsp-tn))
+ (inst add rsp-tn 28)
+ DONE
(move res new)))
@@ -2169,7 +2473,9 @@
;; Quick versions of fsin and fcos that require the argument to be
;; within range 2^63.
+ #-sse2
(frob fsin-quick %sin-quick fsin)
+ #-sse2
(frob fcos-quick %cos-quick fcos)
;;
(frob fsqrt %sqrt fsqrt))
@@ -2191,6 +2497,7 @@
(:vop-var vop)
(:save-p :compute-only)
(:ignore fr0)
+ (:guard (not (backend-featurep :sse2)))
(:generator 5
(note-this-location vop :internal-error)
(case (tn-offset x)
@@ -2476,6 +2783,7 @@
(:vop-var vop)
(:save-p :compute-only)
(:ignore temp)
+ (:guard (not (backend-featurep :sse2)))
(:generator 5
(note-this-location vop :internal-error)
(unless (zerop (tn-offset x))
@@ -2532,6 +2840,7 @@
(:vop-var vop)
(:save-p :compute-only)
(:ignore temp fr0)
+ (:guard (not (backend-featurep :sse2)))
(:generator 5
(note-this-location vop :internal-error)
(unless (zerop (tn-offset x))
@@ -2587,6 +2896,7 @@
(:note "inline log function")
(:vop-var vop)
(:save-p :compute-only)
+ (:guard (not (backend-featurep :sse2)))
(:generator 5
(note-this-location vop :internal-error)
(sc-case x
@@ -2638,6 +2948,7 @@
(:note "inline log10 function")
(:vop-var vop)
(:save-p :compute-only)
+ (:guard (not (backend-featurep :sse2)))
(:generator 5
(note-this-location vop :internal-error)
(sc-case x
@@ -2692,6 +3003,7 @@
(:note "inline pow function")
(:vop-var vop)
(:save-p :compute-only)
+ (:guard (not (backend-featurep :sse2)))
(:generator 5
(note-this-location vop :internal-error)
;; Setup x in fr0 and y in fr1
@@ -2806,6 +3118,7 @@
(:policy :fast-safe)
(:note "inline scalbn function")
(:ignore fr0)
+ (:guard (not (backend-featurep :sse2)))
(:generator 5
;; Setup x in fr0 and y in fr1
(sc-case x
@@ -2873,6 +3186,7 @@
(:vop-var vop)
(:save-p :compute-only)
(:ignore fr0)
+ (:guard (not (backend-featurep :sse2)))
(:generator 5
(note-this-location vop :internal-error)
;; Setup x in fr0 and y in fr1
@@ -2974,7 +3288,8 @@
(:arg-types double-float)
(:result-types double-float)
(:policy :fast-safe)
- (:guard (not (backend-featurep :pentium)))
+ (:guard (or (not (backend-featurep :pentium))
+ (not (backend-featurep :sse2))))
(:note "inline log1p function")
(:ignore temp)
(:generator 5
@@ -3028,7 +3343,8 @@
(:arg-types double-float)
(:result-types double-float)
(:policy :fast-safe)
- (:guard (backend-featurep :pentium))
+ (:guard (and (backend-featurep :pentium)
+ (not (backend-featurep :sse2))))
(:note "inline log1p with limited x range function")
(:vop-var vop)
(:save-p :compute-only)
@@ -3083,6 +3399,7 @@
(:vop-var vop)
(:save-p :compute-only)
(:ignore fr0)
+ (:guard (not (backend-featurep :sse2)))
(:generator 5
(note-this-location vop :internal-error)
(sc-case x
@@ -3129,6 +3446,7 @@
(:note "inline atan function")
(:vop-var vop)
(:save-p :compute-only)
+ (:guard (not (backend-featurep :sse2)))
(:generator 5
(note-this-location vop :internal-error)
;; Setup x in fr1 and 1.0 in fr0
@@ -3176,6 +3494,7 @@
(:note "inline atan2 function")
(:vop-var vop)
(:save-p :compute-only)
+ (:guard (not (backend-featurep :sse2)))
(:generator 5
(note-this-location vop :internal-error)
;; Setup x in fr1 and y in fr0
@@ -4645,3 +4964,424 @@
(:note "inline dummy FP register bias")
(:ignore x)
(:generator 0))
+
+;;; Support for double-double floats
+
+#+double-double
+(progn
+
+(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 at fp-top(real-tn)
+ (inst fldd (ea-for-cdf-real-stack x))))
+ (let ((imag-tn (double-double-reg-lo-tn y)))
+ (with-empty-tn at 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)))
+ (:temporary (:sc any-reg :offset r11-offset) temp)
+ (: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 temp node)
+ (let ((real-tn (double-double-reg-hi-tn x)))
+ (with-tn at fp-top(real-tn)
+ (inst fstd (ea-for-cdf-real-desc y))))
+ (let ((imag-tn (double-double-reg-lo-tn x)))
+ (with-tn at 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 at fp-top(real-tn)
+ (inst fldd (ea-for-cdf-real-desc x))))
+ (let ((imag-tn (double-double-reg-lo-tn y)))
+ (with-empty-tn at 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))
+
+
+(define-vop (move-to-complex-double-double)
+ (:args (x :scs (descriptor-reg)))
+ (:results (y :scs (complex-double-double-reg)))
+ (:note "pointer to complex float coercion")
+ (:generator 2
+ (let ((real-tn (complex-double-double-reg-real-hi-tn y)))
+ (with-empty-tn at fp-top(real-tn)
+ (inst fldd (ea-for-cddf-real-hi-desc x))))
+ (let ((real-tn (complex-double-double-reg-real-lo-tn y)))
+ (with-empty-tn at fp-top(real-tn)
+ (inst fldd (ea-for-cddf-real-lo-desc x))))
+ (let ((imag-tn (complex-double-double-reg-imag-hi-tn y)))
+ (with-empty-tn at fp-top(imag-tn)
+ (inst fldd (ea-for-cddf-imag-hi-desc x))))
+ (let ((imag-tn (complex-double-double-reg-imag-lo-tn y)))
+ (with-empty-tn at fp-top(imag-tn)
+ (inst fldd (ea-for-cddf-imag-lo-desc x))))))
+
+(define-move-vop move-to-complex-double-double :move
+ (descriptor-reg) (complex-double-double-reg))
+
+
+(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 at 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))
+
+(define-vop (make-complex-double-double-float)
+ (:translate complex)
+ (:args (real :scs (double-double-reg) :target r
+ :load-if (not (location= real r))
+ )
+ (imag :scs (double-double-reg) :to :save))
+ (:arg-types double-double-float double-double-float)
+ (:results (r :scs (complex-double-double-reg) :from (:argument 0)
+ :load-if (not (sc-is r complex-double-double-stack))))
+ (:result-types complex-double-double-float)
+ (:note "inline complex double-double-float creation")
+ (:policy :fast-safe)
+ (:generator 5
+ (sc-case r
+ (complex-double-double-reg
+ (let ((r-real (complex-double-double-reg-real-hi-tn r))
+ (a-real (double-double-reg-hi-tn real)))
+ (unless (location= a-real r-real)
+ (cond ((zerop (tn-offset r-real))
+ (copy-fp-reg-to-fr0 a-real))
+ ((zerop (tn-offset a-real))
+ (inst fstd r-real))
+ (t
+ (inst fxch a-real)
+ (inst fstd r-real)
+ (inst fxch a-real)))))
+ (let ((r-real (complex-double-double-reg-real-lo-tn r))
+ (a-real (double-double-reg-lo-tn real)))
+ (unless (location= a-real r-real)
+ (cond ((zerop (tn-offset r-real))
+ (copy-fp-reg-to-fr0 a-real))
+ ((zerop (tn-offset a-real))
+ (inst fstd r-real))
+ (t
+ (inst fxch a-real)
+ (inst fstd r-real)
+ (inst fxch a-real)))))
+ (let ((r-imag (complex-double-double-reg-imag-hi-tn r))
+ (a-imag (double-double-reg-hi-tn imag)))
+ (unless (location= a-imag r-imag)
+ (cond ((zerop (tn-offset a-imag))
+ (inst fstd r-imag))
+ (t
+ (inst fxch a-imag)
+ (inst fstd r-imag)
+ (inst fxch a-imag)))))
+ (let ((r-imag (complex-double-double-reg-imag-lo-tn r))
+ (a-imag (double-double-reg-lo-tn imag)))
+ (unless (location= a-imag r-imag)
+ (cond ((zerop (tn-offset a-imag))
+ (inst fstd r-imag))
+ (t
+ (inst fxch a-imag)
+ (inst fstd r-imag)
+ (inst fxch a-imag))))))
+ (complex-double-double-stack
+ (unless (location= real r)
+ (cond ((zerop (tn-offset real))
+ (inst fstd (ea-for-cddf-real-hi-stack r)))
+ (t
+ (inst fxch real)
+ (inst fstd (ea-for-cddf-real-hi-stack r))
+ (inst fxch real))))
+ (let ((real-lo (double-double-reg-lo-tn real)))
+ (cond ((zerop (tn-offset real-lo))
+ (inst fstd (ea-for-cddf-real-lo-stack r)))
+ (t
+ (inst fxch real-lo)
+ (inst fstd (ea-for-cddf-real-lo-stack r))
+ (inst fxch real-lo))))
+ (let ((imag-val (double-double-reg-hi-tn imag)))
+ (inst fxch imag-val)
+ (inst fstd (ea-for-cddf-imag-hi-stack r))
+ (inst fxch imag-val))
+ (let ((imag-val (double-double-reg-lo-tn imag)))
+ (inst fxch imag-val)
+ (inst fstd (ea-for-cddf-imag-lo-stack r))
+ (inst fxch imag-val))))))
+
+(define-vop (complex-double-double-float-value)
+ (:args (x :scs (complex-double-double-reg descriptor-reg) :target r
+ :load-if (not (sc-is x complex-double-double-stack))))
+ (:arg-types complex-double-double-float)
+ (:results (r :scs (double-double-reg)))
+ (:result-types double-double-float)
+ (:variant-vars slot)
+ (:policy :fast-safe)
+ (:generator 3
+ (sc-case x
+ (complex-double-double-reg
+ (let ((value-tn (ecase slot
+ (:real (complex-double-double-reg-real-hi-tn x))
+ (:imag (complex-double-double-reg-imag-hi-tn x))))
+ (r-hi (double-double-reg-hi-tn r)))
+ (unless (location= value-tn r-hi)
+ (cond ((zerop (tn-offset r-hi))
+ (copy-fp-reg-to-fr0 value-tn))
+ ((zerop (tn-offset value-tn))
+ (inst fstd r-hi))
+ (t
+ (inst fxch value-tn)
+ (inst fstd r-hi)
+ (inst fxch value-tn)))))
+ (let ((value-tn (ecase slot
+ (:real (complex-double-double-reg-real-lo-tn x))
+ (:imag (complex-double-double-reg-imag-lo-tn x))))
+ (r-lo (double-double-reg-lo-tn r)))
+ (unless (location= value-tn r-lo)
+ (cond ((zerop (tn-offset r-lo))
+ (copy-fp-reg-to-fr0 value-tn))
+ ((zerop (tn-offset value-tn))
+ (inst fstd r-lo))
+ (t
+ (inst fxch value-tn)
+ (inst fstd r-lo)
+ (inst fxch value-tn))))))
+ (complex-double-double-stack
+ (let ((r-hi (double-double-reg-hi-tn r)))
+ (with-empty-tn at fp-top (r-hi)
+ (inst fldd (ecase slot
+ (:real (ea-for-cddf-real-hi-stack x))
+ (:imag (ea-for-cddf-imag-hi-stack x))))))
+ (let ((r-lo (double-double-reg-lo-tn r)))
+ (with-empty-tn at fp-top (r-lo)
+ (inst fldd (ecase slot
+ (:real (ea-for-cddf-real-lo-stack x))
+ (:imag (ea-for-cddf-imag-lo-stack x)))))))
+ (descriptor-reg
+ (let ((r-hi (double-double-reg-hi-tn r)))
+ (with-empty-tn at fp-top (r-hi)
+ (inst fldd (ecase slot
+ (:real (ea-for-cddf-real-hi-desc x))
+ (:imag (ea-for-cddf-imag-hi-desc x))))))
+ (let ((r-lo (double-double-reg-lo-tn r)))
+ (with-empty-tn at fp-top (r-lo)
+ (inst fldd (ecase slot
+ (:real (ea-for-cddf-real-lo-desc x))
+ (:imag (ea-for-cddf-imag-lo-desc x))))))))))
+
+(define-vop (realpart/complex-double-double-float complex-double-double-float-value)
+ (:translate realpart)
+ (:note "complex float realpart")
+ (:variant :real))
+
+(define-vop (imagpart/complex-double-double-float complex-double-double-float-value)
+ (:translate imagpart)
+ (:note "complex float imagpart")
+ (:variant :imag))
+
+); progn
Index: src/compiler/amd64/parms.lisp
diff -u src/compiler/amd64/parms.lisp:1.3 src/compiler/amd64/parms.lisp:1.4
--- src/compiler/amd64/parms.lisp:1.3 Fri Jun 18 19:44:42 2004
+++ src/compiler/amd64/parms.lisp Sun Nov 1 21:51:58 2009
@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group at cs.cmu.edu.
;;;
(ext:file-comment
- "$Header: /project/cmucl/cvsroot/src/compiler/amd64/parms.lisp,v 1.3 2004-06-18 23:44:42 cwang Rel $")
+ "$Header: /project/cmucl/cvsroot/src/compiler/amd64/parms.lisp,v 1.4 2009-11-02 02:51:58 rtoy Exp $")
;;;
;;; **********************************************************************
;;;
@@ -55,7 +55,8 @@
;;;; Machine Architecture parameters:
-(export '(word-bits byte-bits word-shift word-bytes float-sign-shift
+(export '(word-bits byte-bits char-bits word-shift word-bytes char-bytes
+ float-sign-shift
single-float-bias single-float-exponent-byte
single-float-significand-byte single-float-normal-exponent-min
@@ -76,6 +77,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)
@@ -86,6 +89,12 @@
(defconstant byte-bits 8
"Number of bits per byte where a byte is the smallest addressable object.")
+(defconstant char-bits #-unicode 8 #+unicode 16
+ "Number of bits needed to represent a character")
+
+(defconstant char-bytes (truncate char-bits byte-bits)
+ "Number of bytes needed to represent a character")
+
(defconstant word-shift (1- (integer-length (/ word-bits byte-bits)))
"Number of bits to shift between word addresses and byte addresses.")
@@ -134,6 +143,10 @@
(defconstant long-float-digits
(+ (byte-size long-float-significand-byte) 32 1))
+#+double-double
+(defconstant double-double-float-digits
+ (* 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))
@@ -147,16 +160,26 @@
(defconstant float-round-to-positive 2)
(defconstant float-round-to-zero 3)
-(defconstant float-precision-24-bit 0)
-(defconstant float-precision-53-bit 2)
-(defconstant float-precision-64-bit 3)
-
-(defconstant float-rounding-mode (byte 2 10))
-(defconstant float-sticky-bits (byte 6 16))
-(defconstant float-traps-byte (byte 6 0))
-(defconstant float-exceptions-byte (byte 6 16))
-(defconstant float-precision-control (byte 2 8))
+;; NOTE: These actually match the SSE2 MXCSR register definitions. We
+;; need to do it this way because the interface assumes the modes are
+;; in the same order as the MXCSR register.
+(defconstant float-rounding-mode (byte 2 13))
+(defconstant float-sticky-bits (byte 6 0))
+(defconstant float-traps-byte (byte 6 7))
+(defconstant float-exceptions-byte (byte 6 0))
+
+#-sse2
+(progn
(defconstant float-fast-bit 0) ; No fast mode on x86
+)
+
+#+sse2
+(progn
+;; SSE2 has a flush-to-zero flag, which we use as the fast bit. Some
+;; versions of sse2 also have a denormals-are-zeros flag. We don't
+;; currently use denormals-are-zeroes for anything.
+(defconstant float-fast-bit (ash 1 15))
+)
); eval-when
@@ -171,9 +194,15 @@
;;; Where to put the different spaces.
;;;
(defconstant target-read-only-space-start #x10000000)
-(defconstant target-static-space-start #x28000000)
-(defconstant target-dynamic-space-start #x48000000)
-(defconstant target-foreign-linkage-space-start #xB0000000)
+(defconstant target-static-space-start
+ #+FreeBSD #x28F00000
+ #-FreeBSD #x28000000)
+(defconstant target-dynamic-space-start
+ #+linux #x58100000
+ #-linux #x48000000)
+(defconstant target-foreign-linkage-space-start
+ #+linux #x58000000
+ #-linux #xB0000000)
(defconstant target-foreign-linkage-entry-size 16) ;In bytes. Duh.
;;; Given that NIL is the first thing allocated in static space, we
@@ -305,6 +334,20 @@
lisp::*cmucl-lib*
lisp::*cmucl-core-path*
+ ;; Weak hash table support
+ :key
+ :value
+ :key-and-value
+ :key-or-value
+
+ ;; Used by CGC.
+ *x86-cgc-active-p*
+ ;; Foreign linkage stuff
+ lisp::*linkage-table-data*
+ system::*global-table*
+ *current-region-free-pointer*
+ *current-region-end-addr*
+
;; Spare symbols. Rename these when you need to add some static
;; symbols and don't want to do a cross-compile.
spare-8
@@ -316,13 +359,6 @@
spare-2
spare-1
- ;; Used by CGC.
- *x86-cgc-active-p*
- ;; Foreign linkage stuff
- lisp::*linkage-table-data*
- system::*global-table*
- *current-region-free-pointer*
- *current-region-end-addr*
*static-blue-bag* ; Must be last or change C code
Index: src/compiler/amd64/type-vops.lisp
diff -u src/compiler/amd64/type-vops.lisp:1.1 src/compiler/amd64/type-vops.lisp:1.2
--- src/compiler/amd64/type-vops.lisp:1.1 Mon May 24 18:35:00 2004
+++ src/compiler/amd64/type-vops.lisp Sun Nov 1 21:51:58 2009
@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group at cs.cmu.edu.
;;;
(ext:file-comment
- "$Header: /project/cmucl/cvsroot/src/compiler/amd64/type-vops.lisp,v 1.1 2004-05-24 22:35:00 cwang Rel $")
+ "$Header: /project/cmucl/cvsroot/src/compiler/amd64/type-vops.lisp,v 1.2 2009-11-02 02:51:58 rtoy Exp $")
;;;
;;; **********************************************************************
;;;
@@ -32,7 +32,7 @@
(defparameter function-header-types
- (list funcallable-instance-header-type dylan-function-header-type
+ (list funcallable-instance-header-type
byte-code-function-type byte-code-closure-type
function-header-type closure-function-header-type
closure-header-type))
Index: src/compiler/amd64/vm.lisp
diff -u src/compiler/amd64/vm.lisp:1.2 src/compiler/amd64/vm.lisp:1.3
--- src/compiler/amd64/vm.lisp:1.2 Tue Jul 6 16:23:30 2004
+++ src/compiler/amd64/vm.lisp Sun Nov 1 21:51:58 2009
@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group at cs.cmu.edu.
;;;
(ext:file-comment
- "$Header: /project/cmucl/cvsroot/src/compiler/amd64/vm.lisp,v 1.2 2004-07-06 20:23:30 cwang Rel $")
+ "$Header: /project/cmucl/cvsroot/src/compiler/amd64/vm.lisp,v 1.3 2009-11-02 02:51:58 rtoy Exp $")
;;;
;;; **********************************************************************
;;;
@@ -215,13 +215,17 @@
(sap-stack stack) ; System area pointers.
(single-stack stack) ; single-floats
(double-stack stack :element-size 2) ; double-floats.
+ #+double-double
+ (double-double-stack stack :element-size 4) ; double-double-float
#+long-float
(long-stack stack :element-size 3) ; long-floats.
(complex-single-stack stack :element-size 2) ; complex-single-floats
(complex-double-stack stack :element-size 4) ; complex-double-floats
#+long-float
(complex-long-stack stack :element-size 6) ; complex-long-floats
-
+ #+double-double
+ (complex-double-double-stack stack :element-size 8) ; complex-double-double-floats
+
;; **** Magic SCs.
(ignore-me noise)
@@ -318,6 +322,14 @@
:save-p t
:alternate-scs (long-stack))
+ #+double-double
+ (double-double-reg float-registers
+ :locations (0 2 4 6)
+ :element-size 2
+ :constant-scs ()
+ :save-p t
+ :alternate-scs (double-double-stack))
+
(complex-single-reg float-registers
:locations (0 2 4 6)
:element-size 2
@@ -339,6 +351,13 @@
:constant-scs ()
:save-p t
:alternate-scs (complex-long-stack))
+ #+double-double
+ (complex-double-double-reg float-registers
+ :locations (0 4)
+ :element-size 4
+ :constant-scs ()
+ :save-p t
+ :alternate-scs (complex-double-double-stack))
;; A catch or unwind block.
(catch-block stack :element-size vm:catch-block-size)
Index: src/compiler/float-tran.lisp
diff -u src/compiler/float-tran.lisp:1.133 src/compiler/float-tran.lisp:1.134
--- src/compiler/float-tran.lisp:1.133 Tue Aug 11 14:32:55 2009
+++ src/compiler/float-tran.lisp Sun Nov 1 21:51:58 2009
@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
- "$Header: /project/cmucl/cvsroot/src/compiler/float-tran.lisp,v 1.133 2009-08-11 18:32:55 rtoy Rel $")
+ "$Header: /project/cmucl/cvsroot/src/compiler/float-tran.lisp,v 1.134 2009-11-02 02:51:58 rtoy Exp $")
;;;
;;; **********************************************************************
;;;
@@ -82,6 +82,8 @@
(movable foldable flushable))
(defknown %complex-double-float (number) (complex double-float)
(movable foldable flushable))
+
+#+double-double
(defknown %complex-double-double-float (number) (complex double-double-float)
(movable foldable flushable))
Index: src/lisp/Config.amd64
diff -u src/lisp/Config.amd64:1.3 src/lisp/Config.amd64:1.4
--- src/lisp/Config.amd64:1.3 Wed Feb 27 18:30:46 2008
+++ src/lisp/Config.amd64 Sun Nov 1 21:51:58 2009
@@ -2,17 +2,52 @@
vpath %.h $(PATH1)
vpath %.c $(PATH1)
vpath %.S $(PATH1)
-CPPFLAGS = -I. -I$(PATH1) -I-
+
+
+# Enable support for :linkage-table feature.
+ifdef FEATURE_LINKAGE_TABLE
+CPP_DEFINE_OPTIONS += -DLINKAGE_TABLE
+endif
+
+
+# Enable support for generational GC
+ifdef FEATURE_GENCGC
+CPP_DEFINE_OPTIONS += -DGENCGC
+GC_SRC := gencgc.c
+else
+GC_SRC := cgc.c
+CPP_DEFINE_OPTIONS += -DWANT_CGC
+endif
+
+ifeq ($(filter 2% 3%, $(shell $(CC) -dumpversion)),)
+CPP_INCLUDE_OPTIONS := -iquote . -iquote $(PATH1)
+else
+CPP_INCLUDE_OPTIONS := -I. -I$(PATH1) -I-
+endif
+CPPFLAGS := $(CPP_DEFINE_OPTIONS) $(CPP_INCLUDE_OPTIONS)
+CFLAGS += -Wstrict-prototypes -Wall -g
+ASFLAGS = -g
+
CC = gcc
LD = ld
CPP = cpp
-CFLAGS = -m64 -rdynamic -Wstrict-prototypes -Wall -g -DGENCGC -DLINKAGE_TABLE
-ASFLAGS = -g -DGENCGC -DLINKAGE_TABLE
+CFLAGS += -m64 -Wstrict-prototypes -Wall -g
+ASFLAGS = -g
+
NM = $(PATH1)/linux-nm
UNDEFSYMPATTERN = -Xlinker -u -Xlinker &
+
ASSEM_SRC = amd64-assem.S linux-stubs.S
ARCH_SRC = amd64-arch.c
-OS_SRC = Linux-os.c os-common.c elf.c
+OS_SRC = Linux-os.c os-common.c elf.c e_rem_pio2.c k_rem_pio2.c
OS_LINK_FLAGS = -rdynamic -Xlinker --export-dynamic -Xlinker -Map -Xlinker foo
OS_LIBS = -ldl
GC_SRC = gencgc.c
+
+DEPEND = $(CC) -MM -E
+DEPEND_FLAGS =
+
+# This no longer has aliasing problems, so no need to use
+# -ffloat-store and -fno-strict-aliasing anymore.
+e_rem_pio2.o : e_rem_pio2.c
+ $(CC) -c $(CFLAGS) $(CPPFLAGS) $<
Index: src/lisp/Linux-os.c
diff -u src/lisp/Linux-os.c:1.44 src/lisp/Linux-os.c:1.45
--- src/lisp/Linux-os.c:1.44 Thu Oct 15 11:05:51 2009
+++ src/lisp/Linux-os.c Sun Nov 1 21:51:58 2009
@@ -15,7 +15,7 @@
* GENCGC support by Douglas Crosher, 1996, 1997.
* Alpha support by Julian Dolby, 1999.
*
- * $Header: /project/cmucl/cvsroot/src/lisp/Linux-os.c,v 1.44 2009-10-15 15:05:51 rtoy Exp $
+ * $Header: /project/cmucl/cvsroot/src/lisp/Linux-os.c,v 1.45 2009-11-02 02:51:58 rtoy Exp $
*
*/
@@ -153,45 +153,52 @@
#endif
#ifdef __x86_64
-int *
-sc_reg(ucontext_t *c, int offset)
+unsigned long *
+os_sigcontext_reg(ucontext_t *c, int offset)
{
switch (offset) {
case 0:
- return &c->uc_mcontext.gregs[REG_RAX];
+ return (unsigned long *)&c->uc_mcontext.gregs[REG_RAX];
case 2:
- return &c->uc_mcontext.gregs[REG_RCX];
+ return (unsigned long *)&c->uc_mcontext.gregs[REG_RCX];
case 4:
- return &c->uc_mcontext.gregs[REG_RDX];
+ return (unsigned long *)&c->uc_mcontext.gregs[REG_RDX];
case 6:
- return &c->uc_mcontext.gregs[REG_RBX];
+ return (unsigned long *)&c->uc_mcontext.gregs[REG_RBX];
case 8:
- return &c->uc_mcontext.gregs[REG_RSP];
+ return (unsigned long *)&c->uc_mcontext.gregs[REG_RSP];
case 10:
- return &c->uc_mcontext.gregs[REG_RBP];
+ return (unsigned long *)&c->uc_mcontext.gregs[REG_RBP];
case 12:
- return &c->uc_mcontext.gregs[REG_RSI];
+ return (unsigned long *)&c->uc_mcontext.gregs[REG_RSI];
case 14:
- return &c->uc_mcontext.gregs[REG_RDI];
+ return (unsigned long *)&c->uc_mcontext.gregs[REG_RDI];
case 16:
- return &c->uc_mcontext.gregs[REG_R8];
+ return (unsigned long *)&c->uc_mcontext.gregs[REG_R8];
case 18:
- return &c->uc_mcontext.gregs[REG_R9];
+ return (unsigned long *)&c->uc_mcontext.gregs[REG_R9];
case 20:
- return &c->uc_mcontext.gregs[REG_R10];
+ return (unsigned long *)&c->uc_mcontext.gregs[REG_R10];
case 22:
- return &c->uc_mcontext.gregs[REG_R11];
+ return (unsigned long *)&c->uc_mcontext.gregs[REG_R11];
case 24:
- return &c->uc_mcontext.gregs[REG_R12];
+ return (unsigned long *)&c->uc_mcontext.gregs[REG_R12];
case 26:
- return &c->uc_mcontext.gregs[REG_R13];
+ return (unsigned long *)&c->uc_mcontext.gregs[REG_R13];
case 28:
- return &c->uc_mcontext.gregs[REG_R14];
+ return (unsigned long *)&c->uc_mcontext.gregs[REG_R14];
case 30:
- return &c->uc_mcontext.gregs[REG_R15];
+ return (unsigned long *)&c->uc_mcontext.gregs[REG_R15];
}
- return (int *) 0;
+ return (unsigned long *) 0;
}
+
+unsigned long *
+os_sigcontext_pc(ucontext_t *scp)
+{
+ return (unsigned long *) &scp->uc_mcontext.gregs[REG_RIP];
+}
+
#endif
os_vm_address_t
@@ -298,7 +305,12 @@
void
sigsegv_handler(HANDLER_ARGS)
{
- int fault_addr = context->uc_mcontext.cr2;
+ long fault_addr =
+#ifdef i386
+ context->uc_mcontext.cr2;
+#else
+ context->uc_mcontext.gregs[REG_CR2];
+#endif
#ifdef RED_ZONE_HIT
if (os_control_stack_overflow((void *) fault_addr, context))
@@ -422,6 +434,7 @@
}
}
+#ifdef i386
void
restore_fpu(ucontext_t *context)
{
@@ -444,3 +457,27 @@
#endif
}
}
+#else
+void
+restore_fpu(ucontext_t *context)
+{
+ if (context->uc_mcontext.fpregs) {
+ short cw = context->uc_mcontext.fpregs->cwd;
+ DPRINTF(0, (stderr, "restore_fpu: cw = %08x\n", cw));
+ __asm__ __volatile__ ("fldcw %0" : : "m" (*&cw));
+#ifdef FEATURE_SSE2
+ if (fpu_mode == SSE2) {
+ struct _fpstate *fpstate;
+ unsigned int mxcsr;
+
+ fpstate = (struct _fpstate*) context->uc_mcontext.fpregs;
+ if (fpstate->magic != 0xffff) {
+ mxcsr = fpstate->mxcsr;
+ DPRINTF(0, (stderr, "restore_fpu: mxcsr (raw) = %04x\n", mxcsr));
+ __asm__ __volatile__ ("ldmxcsr %0" :: "m" (*&mxcsr));
+ }
+ }
+#endif
+ }
+}
+#endif
Index: src/lisp/Linux-os.h
diff -u src/lisp/Linux-os.h:1.28 src/lisp/Linux-os.h:1.29
--- src/lisp/Linux-os.h:1.28 Thu Jan 3 06:41:54 2008
+++ src/lisp/Linux-os.h Sun Nov 1 21:51:58 2009
@@ -1,4 +1,4 @@
-/* $Header: /project/cmucl/cvsroot/src/lisp/Linux-os.h,v 1.28 2008-01-03 11:41:54 cshapiro Rel $
+/* $Header: /project/cmucl/cvsroot/src/lisp/Linux-os.h,v 1.29 2009-11-02 02:51:58 rtoy Exp $
This code was written as part of the CMU Common Lisp project at
Carnegie Mellon University, and has been placed in the public domain.
@@ -26,6 +26,9 @@
#include <asm/unistd.h>
#include <errno.h>
+#define __USE_GNU
+#include <sys/ucontext.h>
+
typedef caddr_t os_vm_address_t; /* like hpux */
typedef size_t os_vm_size_t; /* like hpux */
typedef off_t os_vm_offset_t; /* like hpux */
Index: src/lisp/amd64-arch.c
diff -u src/lisp/amd64-arch.c:1.9 src/lisp/amd64-arch.c:1.10
--- src/lisp/amd64-arch.c:1.9 Sat Dec 6 21:33:55 2008
+++ src/lisp/amd64-arch.c Sun Nov 1 21:51:58 2009
@@ -1,6 +1,6 @@
/* x86-arch.c -*- Mode: C; comment-column: 40 -*-
*
- * $Header: /project/cmucl/cvsroot/src/lisp/amd64-arch.c,v 1.9 2008-12-07 02:33:55 agoncharov Rel $
+ * $Header: /project/cmucl/cvsroot/src/lisp/amd64-arch.c,v 1.10 2009-11-02 02:51:58 rtoy Exp $
*
*/
@@ -12,6 +12,7 @@
#include "os.h"
#include "internals.h"
#include "arch.h"
+#define __USE_GNU
#include "lispregs.h"
#include "signal.h"
#include "alloc.h"
@@ -39,22 +40,22 @@
*/
void
-arch_skip_instruction(struct sigcontext *context)
+arch_skip_instruction(os_context_t *context)
{
int vlen, code;
- DPRINTF(0, (stderr, "[arch_skip_inst at %x>]\n", context->sc_pc));
+ DPRINTF(0, (stderr, "[arch_skip_inst at %x>]\n", SC_PC(context)));
/* Get and skip the lisp error code. */
- code = *(char *) context->sc_pc++;
+ code = *(char *) SC_PC(context)++;
switch (code) {
case trap_Error:
case trap_Cerror:
/* Lisp error arg vector length */
- vlen = *(char *) context->sc_pc++;
+ vlen = *(char *) SC_PC(context)++;
/* Skip lisp error arg data bytes */
while (vlen-- > 0)
- ((char *) context->sc_pc)++;
+ SC_PC(context)++;
break;
case trap_Breakpoint:
@@ -71,23 +72,23 @@
break;
}
- DPRINTF(0, (stderr, "[arch_skip_inst resuming at %x>]\n", context->sc_pc));
+ DPRINTF(0, (stderr, "[arch_skip_inst resuming at %x>]\n", SC_PC(context)));
}
unsigned char *
-arch_internal_error_arguments(struct sigcontext *context)
+arch_internal_error_arguments(os_context_t *context)
{
- return (unsigned char *) (context->sc_pc + 1);
+ return (unsigned char *) (SC_PC(context) + 1);
}
boolean
-arch_pseudo_atomic_atomic(struct sigcontext *context)
+arch_pseudo_atomic_atomic(os_context_t *context)
{
return SymbolValue(PSEUDO_ATOMIC_ATOMIC);
}
void
-arch_set_pseudo_atomic_interrupted(struct sigcontext *context)
+arch_set_pseudo_atomic_interrupted(os_context_t *context)
{
SetSymbolValue(PSEUDO_ATOMIC_INTERRUPTED, make_fixnum(1));
}
@@ -128,9 +129,9 @@
#endif
void
-arch_do_displaced_inst(struct sigcontext *context, unsigned long orig_inst)
+arch_do_displaced_inst(os_context_t *context, unsigned long orig_inst)
{
- unsigned int *pc = (unsigned int *) context->sc_pc;
+ unsigned int *pc = (unsigned int *) SC_PC(context);
/*
* Put the original instruction back.
@@ -139,8 +140,8 @@
*((char *) pc) = orig_inst & 0xff;
*((char *) pc + 1) = (orig_inst & 0xff00) >> 8;
-#ifdef __linux__
- context->eflags |= 0x100;
+#ifdef SC_EFLAGS
+ SC_EFLAGS(context) |= 0x100;
#else
/*
@@ -159,7 +160,7 @@
single_stepping = (unsigned int *) pc;
#ifndef __linux__
- (unsigned int *) context->sc_pc = (char *) pc - 9;
+ (unsigned int *) SC_PC(context) = (char *) pc - 9;
#endif
}
@@ -169,12 +170,9 @@
{
unsigned int trap;
-#ifdef __linux__
- GET_CONTEXT
-#endif
#if 0
fprintf(stderr, "x86sigtrap: %8x %x\n",
- context->sc_pc, *(unsigned char *) (context->sc_pc - 1));
+ SC_PC(context), *(unsigned char *) (SC_PC(context) - 1));
fprintf(stderr, "sigtrap(%d %d %x)\n", signal, code, context);
#endif
@@ -183,20 +181,21 @@
fprintf(stderr, "* Single step trap %x\n", single_stepping);
#endif
-#ifndef __linux__
+#ifdef SC_EFLAGS
+ /* Disable single-stepping */
+ SC_EFLAGS(context) ^= 0x100;
+#else
/* Un-install single step helper instructions. */
*(single_stepping - 3) = single_step_save1;
*(single_stepping - 2) = single_step_save2;
*(single_stepping - 1) = single_step_save3;
-#else
- context->eflags ^= 0x100;
#endif
/*
* Re-install the breakpoint if possible.
*/
- if ((int) context->sc_pc == (int) single_stepping + 1)
+ if ((int) SC_PC(context) == (int) single_stepping + 1)
fprintf(stderr, "* Breakpoint not re-install\n");
else {
char *ptr = (char *) single_stepping;
@@ -210,21 +209,9 @@
}
/* This is just for info in case monitor wants to print an approx */
- current_control_stack_pointer = (unsigned long *) context->sc_sp;
-
-#if defined(__linux__) && (defined(i386) || defined(__x86_64))
- /*
- * Restore the FPU control word, setting the rounding mode to nearest.
- */
-
- if (contextstruct.fpstate)
-#if defined(__x86_64)
- setfpucw(contextstruct.fpstate->cwd & ~0xc00);
-#else
- setfpucw(contextstruct.fpstate->cw & ~0xc00);
-#endif
-#endif
+ current_control_stack_pointer = (unsigned long *) SC_SP(context);
+ RESTORE_FPU(context);
/*
* On entry %eip points just after the INT3 byte and aims at the
* 'kind' value (eg trap_Cerror). For error-trap and Cerror-trap a
@@ -232,7 +219,7 @@
* arguments to follow.
*/
- trap = *(unsigned char *) (context->sc_pc);
+ trap = *(unsigned char *) (SC_PC(context));
switch (trap) {
case trap_PendingInterrupt:
@@ -261,27 +248,23 @@
case trap_Error:
case trap_Cerror:
DPRINTF(0, (stderr, "<trap Error %d>\n", code));
-#ifdef __linux__
- interrupt_internal_error(signal, contextstruct, code == trap_Cerror);
-#else
- interrupt_internal_error(signal, code, context, code == trap_Cerror);
-#endif
+ interrupt_internal_error(signal, code, context, CODE(code) == trap_Cerror);
break;
case trap_Breakpoint:
#if 0
fprintf(stderr, "*C break\n");
#endif
- (char *) context->sc_pc -= 1;
- handle_breakpoint(signal, code, context);
+ SC_PC(context) -= 1;
+ handle_breakpoint(signal, CODE(code), context);
#if 0
fprintf(stderr, "*C break return\n");
#endif
break;
case trap_FunctionEndBreakpoint:
- (char *) context->sc_pc -= 1;
- context->sc_pc =
+ SC_PC(context) -= 1;
+ SC_PC(context) =
(int) handle_function_end_breakpoint(signal, code, context);
break;
@@ -303,11 +286,7 @@
DPRINTF(0,
(stderr, "[C--trap default %d %d %x]\n", signal, code,
context));
-#ifdef __linux__
- interrupt_handle_now(signal, contextstruct);
-#else
interrupt_handle_now(signal, code, context);
-#endif
break;
}
}
Index: src/lisp/amd64-assem.S
diff -u src/lisp/amd64-assem.S:1.10 src/lisp/amd64-assem.S:1.11
--- src/lisp/amd64-assem.S:1.10 Tue Jul 27 18:03:53 2004
+++ src/lisp/amd64-assem.S Sun Nov 1 21:51:58 2009
@@ -1,6 +1,6 @@
### amd64-assem.S -*- Mode: Asm; -*-
/**
- * $Header: /project/cmucl/cvsroot/src/lisp/amd64-assem.S,v 1.10 2004-07-27 22:03:53 cwang Rel $
+ * $Header: /project/cmucl/cvsroot/src/lisp/amd64-assem.S,v 1.11 2009-11-02 02:51:58 rtoy Exp $
*
* Authors: Paul F. Werkowski <pw at snoopy.mv.com>
* Douglas T. Crosher
@@ -119,7 +119,7 @@
movl $0,GNAME(foreign_function_call_active)
/* Return */
- jmp *%ebx
+ jmp *%rbx
.size GNAME(call_into_c), . - GNAME(call_into_c)
Index: src/lisp/amd64-lispregs.h
diff -u src/lisp/amd64-lispregs.h:1.4 src/lisp/amd64-lispregs.h:1.5
--- src/lisp/amd64-lispregs.h:1.4 Tue Nov 7 06:24:12 2006
+++ src/lisp/amd64-lispregs.h Sun Nov 1 21:51:58 2009
@@ -1,5 +1,5 @@
/* x86-lispregs.h -*- Mode: C; -*-
- * $Header: /project/cmucl/cvsroot/src/lisp/amd64-lispregs.h,v 1.4 2006-11-07 11:24:12 cshapiro Rel $
+ * $Header: /project/cmucl/cvsroot/src/lisp/amd64-lispregs.h,v 1.5 2009-11-02 02:51:58 rtoy Exp $
*/
/* These register names and offsets correspond to definitions
@@ -52,7 +52,9 @@
* xxx-os.c handle it.
*/
-#define SC_REG(sc, n) (*sc_reg(sc,n))
-#define SC_PC(sc) ((sc)->sc_pc)
+#define SC_REG(sc, n) (*os_sigcontext_reg(sc,n))
+#define SC_PC(sc) (*os_sigcontext_pc(sc))
+#define SC_EFLAGS(sc) ((sc)->uc_mcontext.gregs[REG_EFL])
+#define SC_SP(scp) SC_REG(scp, reg_RSP)
#endif /* _AMD64_LISPREGS_H_ */
Index: src/lisp/backtrace.c
diff -u src/lisp/backtrace.c:1.17 src/lisp/backtrace.c:1.18
--- src/lisp/backtrace.c:1.17 Thu Jun 11 12:04:01 2009
+++ src/lisp/backtrace.c Sun Nov 1 21:51:58 2009
@@ -1,4 +1,4 @@
-/* $Header: /project/cmucl/cvsroot/src/lisp/backtrace.c,v 1.17 2009-06-11 16:04:01 rtoy Rel $
+/* $Header: /project/cmucl/cvsroot/src/lisp/backtrace.c,v 1.18 2009-11-02 02:51:58 rtoy Exp $
*
* Simple backtrace facility. More or less from Rob's lisp version.
*/
@@ -497,8 +497,11 @@
unsigned long fp;
int i;
+#ifdef __x86_64
+#else
__asm__("movl %%ebp,%0":"=g"(fp));
-
+#endif
+
for (i = 0; i < nframes; ++i) {
lispobj *p;
unsigned long ra, next_fp;
Index: src/lisp/gencgc.c
diff -u src/lisp/gencgc.c:1.99 src/lisp/gencgc.c:1.100
--- src/lisp/gencgc.c:1.99 Tue Jul 7 13:09:17 2009
+++ src/lisp/gencgc.c Sun Nov 1 21:51:58 2009
@@ -7,7 +7,7 @@
*
* Douglas Crosher, 1996, 1997, 1998, 1999.
*
- * $Header: /project/cmucl/cvsroot/src/lisp/gencgc.c,v 1.99 2009-07-07 17:09:17 rtoy Rel $
+ * $Header: /project/cmucl/cvsroot/src/lisp/gencgc.c,v 1.100 2009-11-02 02:51:58 rtoy Exp $
*
*/
@@ -3990,6 +3990,7 @@
boolean eq_hash_p = eq_based_hash_vector(hash_vector, i);
unsigned int index_value = index_vector[old_index];
+#ifdef KEY
if (((weak == KEY)
&& removable_weak_key(old_key, index_value,
eq_hash_p))
@@ -4002,7 +4003,9 @@
if (removep) {
free_hash_entry(hash_table, old_index, i);
}
- } else {
+ } else
+#endif
+ {
/* If the key is EQ-hashed and moves, schedule it for rehashing. */
scavenge(&kv_vector[2 * i], 2);
#if 0
@@ -4069,6 +4072,7 @@
boolean value_survives = weak_value_survives(value);
+#ifdef KEY
if ((hash_table->weak_p == KEY)
&& key_survives
&& !survives_gc(value)) {
@@ -4111,6 +4115,7 @@
scavenged = 1;
}
}
+#endif
}
return scavenged;
Index: src/lisp/gencgc.h
diff -u src/lisp/gencgc.h:1.14 src/lisp/gencgc.h:1.15
--- src/lisp/gencgc.h:1.14 Tue Sep 16 04:52:32 2008
+++ src/lisp/gencgc.h Sun Nov 1 21:51:58 2009
@@ -7,7 +7,7 @@
*
* Douglas Crosher, 1996, 1997.
*
- * $Header: /project/cmucl/cvsroot/src/lisp/gencgc.h,v 1.14 2008-09-16 08:52:32 cshapiro Rel $
+ * $Header: /project/cmucl/cvsroot/src/lisp/gencgc.h,v 1.15 2009-11-02 02:51:58 rtoy Exp $
*
*/
@@ -123,7 +123,7 @@
* write protected.
*/
-#if defined(i386)
+#if defined(i386) || defined(__x86_64)
#define PAGE_SIZE 4096
#elif defined(sparc)
/*
Index: src/lisp/globals.h
diff -u src/lisp/globals.h:1.11 src/lisp/globals.h:1.12
--- src/lisp/globals.h:1.11 Mon Jan 5 17:26:27 2009
+++ src/lisp/globals.h Sun Nov 1 21:51:58 2009
@@ -1,4 +1,4 @@
-/* $Header: /project/cmucl/cvsroot/src/lisp/globals.h,v 1.11 2009-01-05 22:26:27 rtoy Rel $ */
+/* $Header: /project/cmucl/cvsroot/src/lisp/globals.h,v 1.12 2009-11-02 02:51:58 rtoy Exp $ */
#ifndef _GLOBALS_H_
#define _GLOBALS_H_
@@ -31,7 +31,7 @@
#endif
extern lispobj *current_dynamic_space;
-#if !defined(ibmrt) && !defined(i386)
+#if !defined(ibmrt) && !defined(i386) && !defined(__x86_64)
extern lispobj *current_dynamic_space_free_pointer;
extern lispobj *current_auto_gc_trigger;
#endif
Index: src/lisp/interrupt.c
diff -u src/lisp/interrupt.c:1.58 src/lisp/interrupt.c:1.59
--- src/lisp/interrupt.c:1.58 Tue Jul 7 13:06:54 2009
+++ src/lisp/interrupt.c Sun Nov 1 21:51:58 2009
@@ -1,4 +1,4 @@
-/* $Header: /project/cmucl/cvsroot/src/lisp/interrupt.c,v 1.58 2009-07-07 17:06:54 rtoy Rel $ */
+/* $Header: /project/cmucl/cvsroot/src/lisp/interrupt.c,v 1.59 2009-11-02 02:51:58 rtoy Exp $ */
/* Interrupt handling magic. */
@@ -22,6 +22,8 @@
#include "dynbind.h"
#include "interr.h"
+#include "bits/xopen_lim.h"
+
boolean internal_errors_enabled = 0;
os_context_t *lisp_interrupt_contexts[MAX_INTERRUPTS];
Index: src/tools/clean-target.sh
diff -u src/tools/clean-target.sh:1.6 src/tools/clean-target.sh:1.7
--- src/tools/clean-target.sh:1.6 Mon Apr 20 16:54:10 2009
+++ src/tools/clean-target.sh Sun Nov 1 21:51:58 2009
@@ -63,6 +63,7 @@
-name "*.ppcf" -o \
-name "*.sparcf" -o \
-name "*.x86f" -o \
+ -name "*.amd64f" -o \
-name "*.sse2f" $CORE | $GREP | xargs rm 2> /dev/null
for d in $TARGET
Index: src/tools/cross-scripts/cross-x86-amd64.lisp
diff -u src/tools/cross-scripts/cross-x86-amd64.lisp:1.1 src/tools/cross-scripts/cross-x86-amd64.lisp:1.2
--- src/tools/cross-scripts/cross-x86-amd64.lisp:1.1 Tue Oct 20 17:58:50 2009
+++ src/tools/cross-scripts/cross-x86-amd64.lisp Sun Nov 1 21:51:58 2009
@@ -102,7 +102,7 @@
;;; Rename the X86 package and backend so that new-backend does the
;;; right thing.
-(rename-package "X86" "OLD-X86")
+(rename-package "X86" "OLD-X86" '("OLD-VM"))
(setf (c:backend-name c:*native-backend*) "OLD-X86")
(c::new-backend "AMD64"
@@ -118,12 +118,25 @@
'(:x86 :i486 :pentium :x86-bootstrap :alpha :osf1 :mips
:propagate-fun-type :propagate-float-type :constrain-float-type
:openbsd :freebsd :glibc2 :linux :mp :heap-overflow-check
- :long-float :new-random :small))
+ :long-float :new-random :small
+ ))
;;; Compile the new backend.
(pushnew :bootstrap *features*)
(pushnew :building-cross-compiler *features*)
+(in-package "VM")
+(defconstant byte-bits 8
+ "Number of bits per byte where a byte is the smallest addressable object.")
+
+(defconstant char-bits #-unicode 8 #+unicode 16
+ "Number of bits needed to represent a character")
+
+(defconstant char-bytes (truncate char-bits byte-bits)
+ "Number of bytes needed to represent a character")
+
+(export '(byte-bits char-bits char-bytes) "VM")
+
(in-package :cl-user)
(load "target:tools/comcom")
@@ -204,30 +217,41 @@
(macrolet ((frob (&rest syms)
`(progn ,@(mapcar #'(lambda (sym)
`(defconstant ,sym
- (symbol-value
- (find-symbol ,(symbol-name sym)
- :vm))))
+ (symbol-value
+ (find-symbol ,(symbol-name sym)
+ :vm))))
syms))))
- (frob OLD-X86:BYTE-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
- ))
+ (frob OLD-VM:BYTE-BITS OLD-VM:WORD-BITS
+ OLD-VM:CHAR-BITS
+ #+long-float OLD-VM:SIMPLE-ARRAY-LONG-FLOAT-TYPE
+ OLD-VM:SIMPLE-ARRAY-DOUBLE-FLOAT-TYPE
+ OLD-VM:SIMPLE-ARRAY-SINGLE-FLOAT-TYPE
+ #+long-float OLD-VM:SIMPLE-ARRAY-COMPLEX-LONG-FLOAT-TYPE
+ OLD-VM:SIMPLE-ARRAY-COMPLEX-DOUBLE-FLOAT-TYPE
+ OLD-VM:SIMPLE-ARRAY-COMPLEX-SINGLE-FLOAT-TYPE
+ OLD-VM:SIMPLE-ARRAY-UNSIGNED-BYTE-2-TYPE
+ OLD-VM:SIMPLE-ARRAY-UNSIGNED-BYTE-4-TYPE
+ OLD-VM:SIMPLE-ARRAY-UNSIGNED-BYTE-8-TYPE
+ OLD-VM:SIMPLE-ARRAY-UNSIGNED-BYTE-16-TYPE
+ OLD-VM:SIMPLE-ARRAY-UNSIGNED-BYTE-32-TYPE
+ OLD-VM:SIMPLE-ARRAY-SIGNED-BYTE-8-TYPE
+ OLD-VM:SIMPLE-ARRAY-SIGNED-BYTE-16-TYPE
+ OLD-VM:SIMPLE-ARRAY-SIGNED-BYTE-30-TYPE
+ OLD-VM:SIMPLE-ARRAY-SIGNED-BYTE-32-TYPE
+ OLD-VM:SIMPLE-BIT-VECTOR-TYPE
+ OLD-VM:SIMPLE-STRING-TYPE OLD-VM:SIMPLE-VECTOR-TYPE
+ OLD-VM:SIMPLE-ARRAY-TYPE OLD-VM:VECTOR-DATA-OFFSET
+ OLD-VM:DOUBLE-FLOAT-EXPONENT-BYTE
+ OLD-VM:DOUBLE-FLOAT-NORMAL-EXPONENT-MAX
+ OLD-VM:DOUBLE-FLOAT-SIGNIFICAND-BYTE
+ OLD-VM:SINGLE-FLOAT-EXPONENT-BYTE
+ OLD-VM:SINGLE-FLOAT-NORMAL-EXPONENT-MAX
+ OLD-VM:SINGLE-FLOAT-SIGNIFICAND-BYTE
+ )
+ #+double-double
+ (frob OLD-VM:SIMPLE-ARRAY-COMPLEX-DOUBLE-DOUBLE-FLOAT-TYPE
+ OLD-VM:SIMPLE-ARRAY-DOUBLE-DOUBLE-FLOAT-TYPE
+ OLD-VM:DOUBLE-DOUBLE-FLOAT-DIGITS))
(let ((function (symbol-function 'kernel:error-number-or-lose)))
(let ((*info-environment* (c:backend-info-environment c:*target-backend*)))
@@ -277,3 +301,4 @@
(let ((ht (c::backend-sc-names c::*target-backend*)))
(setf (gethash 'old-x86::any-reg ht)
(gethash 'amd64::any-reg ht)))
+
More information about the cmucl-commit
mailing list