CMUCL commit: src (21 files)
Raymond Toy
rtoy at common-lisp.net
Mon Nov 2 16:05:08 CET 2009
Date: Monday, November 2, 2009 @ 10:05:08
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
Revert previous changes. They were supposed to go on
amd64-dd-branch.
------------------------------------------+
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 | 10
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, 193 insertions(+), 1122 deletions(-)
Index: src/code/pred.lisp
diff -u src/code/pred.lisp:1.61 src/code/pred.lisp:1.62
--- src/code/pred.lisp:1.61 Sun Nov 1 21:51:57 2009
+++ src/code/pred.lisp Mon Nov 2 10:05:06 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.61 2009-11-02 02:51:57 rtoy Exp $")
+ "$Header: /project/cmucl/cvsroot/src/code/pred.lisp,v 1.62 2009-11-02 15:05:06 rtoy Exp $")
;;;
;;; **********************************************************************
;;;
@@ -127,39 +127,6 @@
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.20 src/code/sap.lisp:1.21
--- src/code/sap.lisp:1.20 Sun Nov 1 21:51:58 2009
+++ src/code/sap.lisp Mon Nov 2 10:05:06 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.20 2009-11-02 02:51:58 rtoy Exp $")
+ "$Header: /project/cmucl/cvsroot/src/code/sap.lisp,v 1.21 2009-11-02 15:05:06 rtoy Exp $")
;;;
;;; **********************************************************************
;;;
@@ -77,16 +77,10 @@
(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.50 src/code/unix-glibc2.lisp:1.51
--- src/code/unix-glibc2.lisp:1.50 Sun Nov 1 21:51:58 2009
+++ src/code/unix-glibc2.lisp Mon Nov 2 10:05:06 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.50 2009-11-02 02:51:58 rtoy Exp $")
+ "$Header: /project/cmucl/cvsroot/src/code/unix-glibc2.lisp,v 1.51 2009-11-02 15:05:06 rtoy Exp $")
;;;
;;; **********************************************************************
;;;
@@ -265,7 +265,7 @@
(defconstant ms_invalidate 2)
;; The return value from mmap that means mmap failed.
-(defconstant map_failed (int-sap #+amd64 0 #-amd64 (1- (ash 1 vm:word-bits))))
+(defconstant map_failed (int-sap (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.3 src/compiler/amd64/float.lisp:1.4
--- src/compiler/amd64/float.lisp:1.3 Sun Nov 1 21:51:58 2009
+++ src/compiler/amd64/float.lisp Mon Nov 2 10:05:06 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.3 2009-11-02 02:51:58 rtoy Exp $")
+ "$Header: /project/cmucl/cvsroot/src/compiler/amd64/float.lisp,v 1.4 2009-11-02 15:05:06 rtoy Exp $")
;;;
;;; **********************************************************************
;;;
@@ -61,20 +61,7 @@
(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))
- #+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))
- )
+ (ea-for-xf-desc tn vm:complex-long-float-imag-slot)))
(macrolet ((ea-for-xf-stack (tn kind)
`(make-ea
@@ -99,13 +86,7 @@
(:single 1)
(:double 2)
(:long 3))
- (ecase ,slot
- (:real 1)
- (:imag 2)
- (:real-hi 1)
- (:real-lo 2)
- (:imag-hi 3)
- (:imag-lo 4))))
+ (ecase ,slot (:real 1) (:imag 2))))
vm:word-bytes)))))
(defun ea-for-csf-real-stack (tn &optional (base rbp-tn))
(ea-for-cxf-stack tn :single :real base))
@@ -122,21 +103,7 @@
(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))
-
- #+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))
- )
+ (ea-for-cxf-stack tn :long :imag 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
@@ -269,21 +236,6 @@
(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))
@@ -356,49 +308,6 @@
(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:
@@ -637,12 +546,11 @@
(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 temp node)
+ vm:complex-long-float-size 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))))
@@ -653,32 +561,6 @@
(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
;;;
@@ -846,93 +728,14 @@
(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
- #+double-double double-double-reg
- complex-single-reg complex-double-reg #+long-float complex-long-reg
- #+double-double complex-double-double-reg)
+ complex-single-reg complex-double-reg #+long-float complex-long-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
@@ -1407,12 +1210,6 @@
(= (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)
@@ -1710,7 +1507,6 @@
(: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
@@ -1736,14 +1532,12 @@
(: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")
@@ -1875,41 +1669,11 @@
(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)))
@@ -1933,27 +1697,6 @@
#+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)
@@ -1984,7 +1727,6 @@
(inst fst y)
(inst fxch x))))))))
- #+(or)
(frob %single-float/double-float %single-float double-reg
double-float single-reg single-float)
#+long-float
@@ -2002,54 +1744,7 @@
(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))
@@ -2114,7 +1809,6 @@
(: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)
@@ -2384,53 +2078,55 @@
;;;; Float mode hackery:
-(deftype float-modes () '(unsigned-byte 24))
-(defknown x87-floating-point-modes () float-modes (flushable))
-(defknown ((setf x87-floating-point-modes)) (float-modes)
+(deftype float-modes () '(unsigned-byte 32)) ; really only 16
+(defknown floating-point-modes () float-modes (flushable))
+(defknown ((setf floating-point-modes)) (float-modes)
float-modes)
-(define-vop (x87-floating-point-modes)
+(defconstant npx-env-size (* 7 vm:word-bytes))
+(defconstant npx-cw-offset 0)
+(defconstant npx-sw-offset 4)
+
+(define-vop (floating-point-modes)
(:results (res :scs (unsigned-reg)))
(:result-types unsigned-num)
- (:translate x87-floating-point-modes)
+ (:translate floating-point-modes)
(:policy :fast-safe)
- (:temporary (:sc unsigned-stack) cw-stack)
- (:temporary (:sc unsigned-reg :offset eax-offset) sw-reg)
+ (:temporary (:sc unsigned-reg :offset rax-offset :target res
+ :to :result) rax)
(:generator 8
- (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)))
+ (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)))
-(define-vop (set-x87-floating-point-modes)
+(define-vop (set-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 x87-floating-point-modes))
+ (:translate (setf floating-point-modes))
(:policy :fast-safe)
- (: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
+ (: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
(move res new)))
@@ -2473,9 +2169,7 @@
;; 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))
@@ -2497,7 +2191,6 @@
(: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)
@@ -2783,7 +2476,6 @@
(: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))
@@ -2840,7 +2532,6 @@
(: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))
@@ -2896,7 +2587,6 @@
(: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
@@ -2948,7 +2638,6 @@
(: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
@@ -3003,7 +2692,6 @@
(: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
@@ -3118,7 +2806,6 @@
(: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
@@ -3186,7 +2873,6 @@
(: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
@@ -3288,8 +2974,7 @@
(:arg-types double-float)
(:result-types double-float)
(:policy :fast-safe)
- (:guard (or (not (backend-featurep :pentium))
- (not (backend-featurep :sse2))))
+ (:guard (not (backend-featurep :pentium)))
(:note "inline log1p function")
(:ignore temp)
(:generator 5
@@ -3343,8 +3028,7 @@
(:arg-types double-float)
(:result-types double-float)
(:policy :fast-safe)
- (:guard (and (backend-featurep :pentium)
- (not (backend-featurep :sse2))))
+ (:guard (backend-featurep :pentium))
(:note "inline log1p with limited x range function")
(:vop-var vop)
(:save-p :compute-only)
@@ -3399,7 +3083,6 @@
(: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
@@ -3446,7 +3129,6 @@
(: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
@@ -3494,7 +3176,6 @@
(: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
@@ -4964,424 +4645,3 @@
(: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.4 src/compiler/amd64/parms.lisp:1.5
--- src/compiler/amd64/parms.lisp:1.4 Sun Nov 1 21:51:58 2009
+++ src/compiler/amd64/parms.lisp Mon Nov 2 10:05:06 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.4 2009-11-02 02:51:58 rtoy Exp $")
+ "$Header: /project/cmucl/cvsroot/src/compiler/amd64/parms.lisp,v 1.5 2009-11-02 15:05:06 rtoy Exp $")
;;;
;;; **********************************************************************
;;;
@@ -55,8 +55,7 @@
;;;; Machine Architecture parameters:
-(export '(word-bits byte-bits char-bits word-shift word-bytes char-bytes
- float-sign-shift
+(export '(word-bits byte-bits word-shift word-bytes float-sign-shift
single-float-bias single-float-exponent-byte
single-float-significand-byte single-float-normal-exponent-min
@@ -77,8 +76,6 @@
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)
@@ -89,12 +86,6 @@
(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.")
@@ -143,10 +134,6 @@
(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))
@@ -160,26 +147,16 @@
(defconstant float-round-to-positive 2)
(defconstant float-round-to-zero 3)
-;; 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-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))
(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
@@ -194,15 +171,9 @@
;;; Where to put the different spaces.
;;;
(defconstant target-read-only-space-start #x10000000)
-(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-static-space-start #x28000000)
+(defconstant target-dynamic-space-start #x48000000)
+(defconstant target-foreign-linkage-space-start #xB0000000)
(defconstant target-foreign-linkage-entry-size 16) ;In bytes. Duh.
;;; Given that NIL is the first thing allocated in static space, we
@@ -334,20 +305,6 @@
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
@@ -359,6 +316,13 @@
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.2 src/compiler/amd64/type-vops.lisp:1.3
--- src/compiler/amd64/type-vops.lisp:1.2 Sun Nov 1 21:51:58 2009
+++ src/compiler/amd64/type-vops.lisp Mon Nov 2 10:05:06 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.2 2009-11-02 02:51:58 rtoy Exp $")
+ "$Header: /project/cmucl/cvsroot/src/compiler/amd64/type-vops.lisp,v 1.3 2009-11-02 15:05:06 rtoy Exp $")
;;;
;;; **********************************************************************
;;;
@@ -32,7 +32,7 @@
(defparameter function-header-types
- (list funcallable-instance-header-type
+ (list funcallable-instance-header-type dylan-function-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.3 src/compiler/amd64/vm.lisp:1.4
--- src/compiler/amd64/vm.lisp:1.3 Sun Nov 1 21:51:58 2009
+++ src/compiler/amd64/vm.lisp Mon Nov 2 10:05:07 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.3 2009-11-02 02:51:58 rtoy Exp $")
+ "$Header: /project/cmucl/cvsroot/src/compiler/amd64/vm.lisp,v 1.4 2009-11-02 15:05:07 rtoy Exp $")
;;;
;;; **********************************************************************
;;;
@@ -215,17 +215,13 @@
(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)
@@ -322,14 +318,6 @@
: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
@@ -351,13 +339,6 @@
: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.134 src/compiler/float-tran.lisp:1.135
--- src/compiler/float-tran.lisp:1.134 Sun Nov 1 21:51:58 2009
+++ src/compiler/float-tran.lisp Mon Nov 2 10:05:06 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.134 2009-11-02 02:51:58 rtoy Exp $")
+ "$Header: /project/cmucl/cvsroot/src/compiler/float-tran.lisp,v 1.135 2009-11-02 15:05:06 rtoy Exp $")
;;;
;;; **********************************************************************
;;;
@@ -82,8 +82,6 @@
(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.4 src/lisp/Config.amd64:1.5
--- src/lisp/Config.amd64:1.4 Sun Nov 1 21:51:58 2009
+++ src/lisp/Config.amd64 Mon Nov 2 10:05:07 2009
@@ -2,52 +2,17 @@
vpath %.h $(PATH1)
vpath %.c $(PATH1)
vpath %.S $(PATH1)
-
-
-# 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
-
+CPPFLAGS = -I. -I$(PATH1) -I-
CC = gcc
LD = ld
CPP = cpp
-CFLAGS += -m64 -Wstrict-prototypes -Wall -g
-ASFLAGS = -g
-
+CFLAGS = -m64 -rdynamic -Wstrict-prototypes -Wall -g -DGENCGC -DLINKAGE_TABLE
+ASFLAGS = -g -DGENCGC -DLINKAGE_TABLE
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 e_rem_pio2.c k_rem_pio2.c
+OS_SRC = Linux-os.c os-common.c elf.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.45 src/lisp/Linux-os.c:1.46
--- src/lisp/Linux-os.c:1.45 Sun Nov 1 21:51:58 2009
+++ src/lisp/Linux-os.c Mon Nov 2 10:05:07 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.45 2009-11-02 02:51:58 rtoy Exp $
+ * $Header: /project/cmucl/cvsroot/src/lisp/Linux-os.c,v 1.46 2009-11-02 15:05:07 rtoy Exp $
*
*/
@@ -153,52 +153,45 @@
#endif
#ifdef __x86_64
-unsigned long *
-os_sigcontext_reg(ucontext_t *c, int offset)
+int *
+sc_reg(ucontext_t *c, int offset)
{
switch (offset) {
case 0:
- return (unsigned long *)&c->uc_mcontext.gregs[REG_RAX];
+ return &c->uc_mcontext.gregs[REG_RAX];
case 2:
- return (unsigned long *)&c->uc_mcontext.gregs[REG_RCX];
+ return &c->uc_mcontext.gregs[REG_RCX];
case 4:
- return (unsigned long *)&c->uc_mcontext.gregs[REG_RDX];
+ return &c->uc_mcontext.gregs[REG_RDX];
case 6:
- return (unsigned long *)&c->uc_mcontext.gregs[REG_RBX];
+ return &c->uc_mcontext.gregs[REG_RBX];
case 8:
- return (unsigned long *)&c->uc_mcontext.gregs[REG_RSP];
+ return &c->uc_mcontext.gregs[REG_RSP];
case 10:
- return (unsigned long *)&c->uc_mcontext.gregs[REG_RBP];
+ return &c->uc_mcontext.gregs[REG_RBP];
case 12:
- return (unsigned long *)&c->uc_mcontext.gregs[REG_RSI];
+ return &c->uc_mcontext.gregs[REG_RSI];
case 14:
- return (unsigned long *)&c->uc_mcontext.gregs[REG_RDI];
+ return &c->uc_mcontext.gregs[REG_RDI];
case 16:
- return (unsigned long *)&c->uc_mcontext.gregs[REG_R8];
+ return &c->uc_mcontext.gregs[REG_R8];
case 18:
- return (unsigned long *)&c->uc_mcontext.gregs[REG_R9];
+ return &c->uc_mcontext.gregs[REG_R9];
case 20:
- return (unsigned long *)&c->uc_mcontext.gregs[REG_R10];
+ return &c->uc_mcontext.gregs[REG_R10];
case 22:
- return (unsigned long *)&c->uc_mcontext.gregs[REG_R11];
+ return &c->uc_mcontext.gregs[REG_R11];
case 24:
- return (unsigned long *)&c->uc_mcontext.gregs[REG_R12];
+ return &c->uc_mcontext.gregs[REG_R12];
case 26:
- return (unsigned long *)&c->uc_mcontext.gregs[REG_R13];
+ return &c->uc_mcontext.gregs[REG_R13];
case 28:
- return (unsigned long *)&c->uc_mcontext.gregs[REG_R14];
+ return &c->uc_mcontext.gregs[REG_R14];
case 30:
- return (unsigned long *)&c->uc_mcontext.gregs[REG_R15];
+ return &c->uc_mcontext.gregs[REG_R15];
}
- return (unsigned long *) 0;
+ return (int *) 0;
}
-
-unsigned long *
-os_sigcontext_pc(ucontext_t *scp)
-{
- return (unsigned long *) &scp->uc_mcontext.gregs[REG_RIP];
-}
-
#endif
os_vm_address_t
@@ -305,12 +298,7 @@
void
sigsegv_handler(HANDLER_ARGS)
{
- long fault_addr =
-#ifdef i386
- context->uc_mcontext.cr2;
-#else
- context->uc_mcontext.gregs[REG_CR2];
-#endif
+ int fault_addr = context->uc_mcontext.cr2;
#ifdef RED_ZONE_HIT
if (os_control_stack_overflow((void *) fault_addr, context))
@@ -434,7 +422,6 @@
}
}
-#ifdef i386
void
restore_fpu(ucontext_t *context)
{
@@ -457,27 +444,3 @@
#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.29 src/lisp/Linux-os.h:1.30
--- src/lisp/Linux-os.h:1.29 Sun Nov 1 21:51:58 2009
+++ src/lisp/Linux-os.h Mon Nov 2 10:05:07 2009
@@ -1,4 +1,4 @@
-/* $Header: /project/cmucl/cvsroot/src/lisp/Linux-os.h,v 1.29 2009-11-02 02:51:58 rtoy Exp $
+/* $Header: /project/cmucl/cvsroot/src/lisp/Linux-os.h,v 1.30 2009-11-02 15:05:07 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,9 +26,6 @@
#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.10 src/lisp/amd64-arch.c:1.11
--- src/lisp/amd64-arch.c:1.10 Sun Nov 1 21:51:58 2009
+++ src/lisp/amd64-arch.c Mon Nov 2 10:05:07 2009
@@ -1,6 +1,6 @@
/* x86-arch.c -*- Mode: C; comment-column: 40 -*-
*
- * $Header: /project/cmucl/cvsroot/src/lisp/amd64-arch.c,v 1.10 2009-11-02 02:51:58 rtoy Exp $
+ * $Header: /project/cmucl/cvsroot/src/lisp/amd64-arch.c,v 1.11 2009-11-02 15:05:07 rtoy Exp $
*
*/
@@ -12,7 +12,6 @@
#include "os.h"
#include "internals.h"
#include "arch.h"
-#define __USE_GNU
#include "lispregs.h"
#include "signal.h"
#include "alloc.h"
@@ -40,22 +39,22 @@
*/
void
-arch_skip_instruction(os_context_t *context)
+arch_skip_instruction(struct sigcontext *context)
{
int vlen, code;
- DPRINTF(0, (stderr, "[arch_skip_inst at %x>]\n", SC_PC(context)));
+ DPRINTF(0, (stderr, "[arch_skip_inst at %x>]\n", context->sc_pc));
/* Get and skip the lisp error code. */
- code = *(char *) SC_PC(context)++;
+ code = *(char *) context->sc_pc++;
switch (code) {
case trap_Error:
case trap_Cerror:
/* Lisp error arg vector length */
- vlen = *(char *) SC_PC(context)++;
+ vlen = *(char *) context->sc_pc++;
/* Skip lisp error arg data bytes */
while (vlen-- > 0)
- SC_PC(context)++;
+ ((char *) context->sc_pc)++;
break;
case trap_Breakpoint:
@@ -72,23 +71,23 @@
break;
}
- DPRINTF(0, (stderr, "[arch_skip_inst resuming at %x>]\n", SC_PC(context)));
+ DPRINTF(0, (stderr, "[arch_skip_inst resuming at %x>]\n", context->sc_pc));
}
unsigned char *
-arch_internal_error_arguments(os_context_t *context)
+arch_internal_error_arguments(struct sigcontext *context)
{
- return (unsigned char *) (SC_PC(context) + 1);
+ return (unsigned char *) (context->sc_pc + 1);
}
boolean
-arch_pseudo_atomic_atomic(os_context_t *context)
+arch_pseudo_atomic_atomic(struct sigcontext *context)
{
return SymbolValue(PSEUDO_ATOMIC_ATOMIC);
}
void
-arch_set_pseudo_atomic_interrupted(os_context_t *context)
+arch_set_pseudo_atomic_interrupted(struct sigcontext *context)
{
SetSymbolValue(PSEUDO_ATOMIC_INTERRUPTED, make_fixnum(1));
}
@@ -129,9 +128,9 @@
#endif
void
-arch_do_displaced_inst(os_context_t *context, unsigned long orig_inst)
+arch_do_displaced_inst(struct sigcontext *context, unsigned long orig_inst)
{
- unsigned int *pc = (unsigned int *) SC_PC(context);
+ unsigned int *pc = (unsigned int *) context->sc_pc;
/*
* Put the original instruction back.
@@ -140,8 +139,8 @@
*((char *) pc) = orig_inst & 0xff;
*((char *) pc + 1) = (orig_inst & 0xff00) >> 8;
-#ifdef SC_EFLAGS
- SC_EFLAGS(context) |= 0x100;
+#ifdef __linux__
+ context->eflags |= 0x100;
#else
/*
@@ -160,7 +159,7 @@
single_stepping = (unsigned int *) pc;
#ifndef __linux__
- (unsigned int *) SC_PC(context) = (char *) pc - 9;
+ (unsigned int *) context->sc_pc = (char *) pc - 9;
#endif
}
@@ -170,9 +169,12 @@
{
unsigned int trap;
+#ifdef __linux__
+ GET_CONTEXT
+#endif
#if 0
fprintf(stderr, "x86sigtrap: %8x %x\n",
- SC_PC(context), *(unsigned char *) (SC_PC(context) - 1));
+ context->sc_pc, *(unsigned char *) (context->sc_pc - 1));
fprintf(stderr, "sigtrap(%d %d %x)\n", signal, code, context);
#endif
@@ -181,21 +183,20 @@
fprintf(stderr, "* Single step trap %x\n", single_stepping);
#endif
-#ifdef SC_EFLAGS
- /* Disable single-stepping */
- SC_EFLAGS(context) ^= 0x100;
-#else
+#ifndef __linux__
/* 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) SC_PC(context) == (int) single_stepping + 1)
+ if ((int) context->sc_pc == (int) single_stepping + 1)
fprintf(stderr, "* Breakpoint not re-install\n");
else {
char *ptr = (char *) single_stepping;
@@ -209,9 +210,21 @@
}
/* This is just for info in case monitor wants to print an approx */
- current_control_stack_pointer = (unsigned long *) SC_SP(context);
+ 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
- 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
@@ -219,7 +232,7 @@
* arguments to follow.
*/
- trap = *(unsigned char *) (SC_PC(context));
+ trap = *(unsigned char *) (context->sc_pc);
switch (trap) {
case trap_PendingInterrupt:
@@ -248,23 +261,27 @@
case trap_Error:
case trap_Cerror:
DPRINTF(0, (stderr, "<trap Error %d>\n", code));
- interrupt_internal_error(signal, code, context, CODE(code) == trap_Cerror);
+#ifdef __linux__
+ interrupt_internal_error(signal, contextstruct, code == trap_Cerror);
+#else
+ interrupt_internal_error(signal, code, context, code == trap_Cerror);
+#endif
break;
case trap_Breakpoint:
#if 0
fprintf(stderr, "*C break\n");
#endif
- SC_PC(context) -= 1;
- handle_breakpoint(signal, CODE(code), context);
+ (char *) context->sc_pc -= 1;
+ handle_breakpoint(signal, code, context);
#if 0
fprintf(stderr, "*C break return\n");
#endif
break;
case trap_FunctionEndBreakpoint:
- SC_PC(context) -= 1;
- SC_PC(context) =
+ (char *) context->sc_pc -= 1;
+ context->sc_pc =
(int) handle_function_end_breakpoint(signal, code, context);
break;
@@ -286,7 +303,11 @@
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.11 src/lisp/amd64-assem.S:1.12
--- src/lisp/amd64-assem.S:1.11 Sun Nov 1 21:51:58 2009
+++ src/lisp/amd64-assem.S Mon Nov 2 10:05:07 2009
@@ -1,6 +1,6 @@
### amd64-assem.S -*- Mode: Asm; -*-
/**
- * $Header: /project/cmucl/cvsroot/src/lisp/amd64-assem.S,v 1.11 2009-11-02 02:51:58 rtoy Exp $
+ * $Header: /project/cmucl/cvsroot/src/lisp/amd64-assem.S,v 1.12 2009-11-02 15:05:07 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 *%rbx
+ jmp *%ebx
.size GNAME(call_into_c), . - GNAME(call_into_c)
Index: src/lisp/amd64-lispregs.h
diff -u src/lisp/amd64-lispregs.h:1.5 src/lisp/amd64-lispregs.h:1.6
--- src/lisp/amd64-lispregs.h:1.5 Sun Nov 1 21:51:58 2009
+++ src/lisp/amd64-lispregs.h Mon Nov 2 10:05:07 2009
@@ -1,5 +1,5 @@
/* x86-lispregs.h -*- Mode: C; -*-
- * $Header: /project/cmucl/cvsroot/src/lisp/amd64-lispregs.h,v 1.5 2009-11-02 02:51:58 rtoy Exp $
+ * $Header: /project/cmucl/cvsroot/src/lisp/amd64-lispregs.h,v 1.6 2009-11-02 15:05:07 rtoy Exp $
*/
/* These register names and offsets correspond to definitions
@@ -52,9 +52,7 @@
* xxx-os.c handle it.
*/
-#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)
+#define SC_REG(sc, n) (*sc_reg(sc,n))
+#define SC_PC(sc) ((sc)->sc_pc)
#endif /* _AMD64_LISPREGS_H_ */
Index: src/lisp/backtrace.c
diff -u src/lisp/backtrace.c:1.19 src/lisp/backtrace.c:1.20
--- src/lisp/backtrace.c:1.19 Sun Nov 1 22:07:01 2009
+++ src/lisp/backtrace.c Mon Nov 2 10:05:07 2009
@@ -1,4 +1,4 @@
-/* $Header: /project/cmucl/cvsroot/src/lisp/backtrace.c,v 1.19 2009-11-02 03:07:01 rtoy Exp $
+/* $Header: /project/cmucl/cvsroot/src/lisp/backtrace.c,v 1.20 2009-11-02 15:05:07 rtoy Exp $
*
* Simple backtrace facility. More or less from Rob's lisp version.
*/
@@ -497,12 +497,8 @@
unsigned long fp;
int i;
-#ifdef __x86_64
- __asm__("movq %%rbp,%0":"=g"(fp));
-#else
- __asm__("movl %%rbp,%0":"=g"(fp));
-#endif
-
+ __asm__("movl %%ebp,%0":"=g"(fp));
+
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.100 src/lisp/gencgc.c:1.101
--- src/lisp/gencgc.c:1.100 Sun Nov 1 21:51:58 2009
+++ src/lisp/gencgc.c Mon Nov 2 10:05:07 2009
@@ -7,7 +7,7 @@
*
* Douglas Crosher, 1996, 1997, 1998, 1999.
*
- * $Header: /project/cmucl/cvsroot/src/lisp/gencgc.c,v 1.100 2009-11-02 02:51:58 rtoy Exp $
+ * $Header: /project/cmucl/cvsroot/src/lisp/gencgc.c,v 1.101 2009-11-02 15:05:07 rtoy Exp $
*
*/
@@ -3990,7 +3990,6 @@
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))
@@ -4003,9 +4002,7 @@
if (removep) {
free_hash_entry(hash_table, old_index, i);
}
- } else
-#endif
- {
+ } else {
/* If the key is EQ-hashed and moves, schedule it for rehashing. */
scavenge(&kv_vector[2 * i], 2);
#if 0
@@ -4072,7 +4069,6 @@
boolean value_survives = weak_value_survives(value);
-#ifdef KEY
if ((hash_table->weak_p == KEY)
&& key_survives
&& !survives_gc(value)) {
@@ -4115,7 +4111,6 @@
scavenged = 1;
}
}
-#endif
}
return scavenged;
Index: src/lisp/gencgc.h
diff -u src/lisp/gencgc.h:1.15 src/lisp/gencgc.h:1.16
--- src/lisp/gencgc.h:1.15 Sun Nov 1 21:51:58 2009
+++ src/lisp/gencgc.h Mon Nov 2 10:05:07 2009
@@ -7,7 +7,7 @@
*
* Douglas Crosher, 1996, 1997.
*
- * $Header: /project/cmucl/cvsroot/src/lisp/gencgc.h,v 1.15 2009-11-02 02:51:58 rtoy Exp $
+ * $Header: /project/cmucl/cvsroot/src/lisp/gencgc.h,v 1.16 2009-11-02 15:05:07 rtoy Exp $
*
*/
@@ -123,7 +123,7 @@
* write protected.
*/
-#if defined(i386) || defined(__x86_64)
+#if defined(i386)
#define PAGE_SIZE 4096
#elif defined(sparc)
/*
Index: src/lisp/globals.h
diff -u src/lisp/globals.h:1.12 src/lisp/globals.h:1.13
--- src/lisp/globals.h:1.12 Sun Nov 1 21:51:58 2009
+++ src/lisp/globals.h Mon Nov 2 10:05:07 2009
@@ -1,4 +1,4 @@
-/* $Header: /project/cmucl/cvsroot/src/lisp/globals.h,v 1.12 2009-11-02 02:51:58 rtoy Exp $ */
+/* $Header: /project/cmucl/cvsroot/src/lisp/globals.h,v 1.13 2009-11-02 15:05:07 rtoy Exp $ */
#ifndef _GLOBALS_H_
#define _GLOBALS_H_
@@ -31,7 +31,7 @@
#endif
extern lispobj *current_dynamic_space;
-#if !defined(ibmrt) && !defined(i386) && !defined(__x86_64)
+#if !defined(ibmrt) && !defined(i386)
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.59 src/lisp/interrupt.c:1.60
--- src/lisp/interrupt.c:1.59 Sun Nov 1 21:51:58 2009
+++ src/lisp/interrupt.c Mon Nov 2 10:05:07 2009
@@ -1,4 +1,4 @@
-/* $Header: /project/cmucl/cvsroot/src/lisp/interrupt.c,v 1.59 2009-11-02 02:51:58 rtoy Exp $ */
+/* $Header: /project/cmucl/cvsroot/src/lisp/interrupt.c,v 1.60 2009-11-02 15:05:07 rtoy Exp $ */
/* Interrupt handling magic. */
@@ -22,8 +22,6 @@
#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.7 src/tools/clean-target.sh:1.8
--- src/tools/clean-target.sh:1.7 Sun Nov 1 21:51:58 2009
+++ src/tools/clean-target.sh Mon Nov 2 10:05:07 2009
@@ -63,7 +63,6 @@
-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.2 src/tools/cross-scripts/cross-x86-amd64.lisp:1.3
--- src/tools/cross-scripts/cross-x86-amd64.lisp:1.2 Sun Nov 1 21:51:58 2009
+++ src/tools/cross-scripts/cross-x86-amd64.lisp Mon Nov 2 10:05:07 2009
@@ -102,7 +102,7 @@
;;; Rename the X86 package and backend so that new-backend does the
;;; right thing.
-(rename-package "X86" "OLD-X86" '("OLD-VM"))
+(rename-package "X86" "OLD-X86")
(setf (c:backend-name c:*native-backend*) "OLD-X86")
(c::new-backend "AMD64"
@@ -118,25 +118,12 @@
'(: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")
@@ -217,41 +204,30 @@
(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-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))
+ (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
+ ))
(let ((function (symbol-function 'kernel:error-number-or-lose)))
(let ((*info-environment* (c:backend-info-environment c:*target-backend*)))
@@ -301,4 +277,3 @@
(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