diff --git a/code/pred.lisp b/code/pred.lisp index c74f115b717a5c491665dcd2205316a368a1de0f..3ab8de8f249923a2dc1e18e2cebfff225998845e 100644 --- a/code/pred.lisp +++ b/code/pred.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pred.lisp,v 1.61 2009/11/02 02:51:57 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/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. ;;; diff --git a/code/sap.lisp b/code/sap.lisp index 77f87192d1b39835127f0f786caeb1a772fc6f47..b3a80db63d326870e0af65551cb7438a788fe70c 100644 --- a/code/sap.lisp +++ b/code/sap.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/sap.lisp,v 1.20 2009/11/02 02:51:58 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/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." diff --git a/code/unix-glibc2.lisp b/code/unix-glibc2.lisp index 17934c78b59c088770b9db96bac00f31244011c8..5fc3ad549cc034b3e0567afb978943ae9fa11c7e 100644 --- a/code/unix-glibc2.lisp +++ b/code/unix-glibc2.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/unix-glibc2.lisp,v 1.50 2009/11/02 02:51:58 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/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) diff --git a/compiler/amd64/float.lisp b/compiler/amd64/float.lisp index f1abfafd105b4d7bfd621a5c71631251fec9bb0a..45f51128f5e61e3132e451fbc4589c913dec4d21 100644 --- a/compiler/amd64/float.lisp +++ b/compiler/amd64/float.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/amd64/float.lisp,v 1.3 2009/11/02 02:51:58 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/amd64/float.lisp,v 1.4 2009/11/02 15:05:06 rtoy Rel $") ;;; ;;; ********************************************************************** ;;; @@ -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@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@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@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@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@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@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@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@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@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@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@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@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@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))) - -(define-vop (set-x87-floating-point-modes) + (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-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@fp-top(real-tn) - (inst fldd (ea-for-cdf-real-stack x)))) - (let ((imag-tn (double-double-reg-lo-tn y))) - (with-empty-tn@fp-top(imag-tn) - (inst fldd (ea-for-cdf-imag-stack x))))) - -(define-move-function (store-double-double 4) (vop x y) - ((double-double-reg) (double-double-stack)) - (let ((real-tn (double-double-reg-hi-tn x))) - (cond ((zerop (tn-offset real-tn)) - (inst fstd (ea-for-cdf-real-stack y))) - (t - (inst fxch real-tn) - (inst fstd (ea-for-cdf-real-stack y)) - (inst fxch real-tn)))) - (let ((imag-tn (double-double-reg-lo-tn x))) - (inst fxch imag-tn) - (inst fstd (ea-for-cdf-imag-stack y)) - (inst fxch imag-tn))) - -;;; Double-double float register to register moves - -(define-vop (double-double-move) - (:args (x :scs (double-double-reg) - :target y :load-if (not (location= x y)))) - (:results (y :scs (double-double-reg) :load-if (not (location= x y)))) - (:note "double-double float move") - (:generator 0 - (unless (location= x y) - ;; Note the double-float-regs are aligned to every second - ;; float register so there is not need to worry about overlap. - (let ((x-hi (double-double-reg-hi-tn x)) - (y-hi (double-double-reg-hi-tn y))) - (cond ((zerop (tn-offset y-hi)) - (copy-fp-reg-to-fr0 x-hi)) - ((zerop (tn-offset x-hi)) - (inst fstd y-hi)) - (t - (inst fxch x-hi) - (inst fstd y-hi) - (inst fxch x-hi)))) - (let ((x-lo (double-double-reg-lo-tn x)) - (y-lo (double-double-reg-lo-tn y))) - (inst fxch x-lo) - (inst fstd y-lo) - (inst fxch x-lo))))) -;;; -(define-move-vop double-double-move :move - (double-double-reg) (double-double-reg)) - -;;; Move from a complex float to a descriptor register allocating a -;;; new complex float object in the process. - -(define-vop (move-from-double-double) - (:args (x :scs (double-double-reg) :to :save)) - (:results (y :scs (descriptor-reg))) - (: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@fp-top(real-tn) - (inst fstd (ea-for-cdf-real-desc y)))) - (let ((imag-tn (double-double-reg-lo-tn x))) - (with-tn@fp-top(imag-tn) - (inst fstd (ea-for-cdf-imag-desc y))))))) -;;; -(define-move-vop move-from-double-double :move - (double-double-reg) (descriptor-reg)) - -;;; Move from a descriptor to a double-double float register - -(define-vop (move-to-double-double) - (:args (x :scs (descriptor-reg))) - (:results (y :scs (double-double-reg))) - (:note "pointer to double-double-float coercion") - (:generator 2 - (let ((real-tn (double-double-reg-hi-tn y))) - (with-empty-tn@fp-top(real-tn) - (inst fldd (ea-for-cdf-real-desc x)))) - (let ((imag-tn (double-double-reg-lo-tn y))) - (with-empty-tn@fp-top(imag-tn) - (inst fldd (ea-for-cdf-imag-desc x)))))) - -(define-move-vop move-to-double-double :move - (descriptor-reg) (double-double-reg)) - -;;; double-double float move-argument vop - -(define-vop (move-double-double-float-argument) - (:args (x :scs (double-double-reg) :target y) - (fp :scs (any-reg) :load-if (not (sc-is y double-double-reg)))) - (:results (y)) - (:note "double double-float argument move") - (:generator 2 - (sc-case y - (double-double-reg - (unless (location= x y) - (let ((x-real (double-double-reg-hi-tn x)) - (y-real (double-double-reg-hi-tn y))) - (cond ((zerop (tn-offset y-real)) - (copy-fp-reg-to-fr0 x-real)) - ((zerop (tn-offset x-real)) - (inst fstd y-real)) - (t - (inst fxch x-real) - (inst fstd y-real) - (inst fxch x-real)))) - (let ((x-imag (double-double-reg-lo-tn x)) - (y-imag (double-double-reg-lo-tn y))) - (inst fxch x-imag) - (inst fstd y-imag) - (inst fxch x-imag)))) - (double-double-stack - (let ((hi-tn (double-double-reg-hi-tn x))) - (cond ((zerop (tn-offset hi-tn)) - (inst fstd (ea-for-cdf-real-stack y fp))) - (t - (inst fxch hi-tn) - (inst fstd (ea-for-cdf-real-stack y fp)) - (inst fxch hi-tn)))) - (let ((lo-tn (double-double-reg-lo-tn x))) - (inst fxch lo-tn) - (inst fstd (ea-for-cdf-imag-stack y fp)) - (inst fxch lo-tn)))))) - -(define-move-vop move-double-double-float-argument :move-argument - (double-double-reg descriptor-reg) (double-double-reg)) - - -(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@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@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@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@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@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@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@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@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@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 diff --git a/compiler/amd64/parms.lisp b/compiler/amd64/parms.lisp index f8ef6632ddb53caccebea841cb755bf7aec4161f..289e917eeeb24525a82bdd6b0ce8f25db3f3a2ac 100644 --- a/compiler/amd64/parms.lisp +++ b/compiler/amd64/parms.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/amd64/parms.lisp,v 1.4 2009/11/02 02:51:58 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/amd64/parms.lisp,v 1.5 2009/11/02 15:05:06 rtoy Rel $") ;;; ;;; ********************************************************************** ;;; @@ -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)) +(defconstant float-precision-24-bit 0) +(defconstant float-precision-53-bit 2) +(defconstant float-precision-64-bit 3) -#-sse2 -(progn +(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 diff --git a/compiler/amd64/type-vops.lisp b/compiler/amd64/type-vops.lisp index e9c78b83d16a27e72216103f75bed4596d9ff5c4..863c055e568cfdc41f31842e3af13f83281d5677 100644 --- a/compiler/amd64/type-vops.lisp +++ b/compiler/amd64/type-vops.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/amd64/type-vops.lisp,v 1.2 2009/11/02 02:51:58 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/amd64/type-vops.lisp,v 1.3 2009/11/02 15:05:06 rtoy Rel $") ;;; ;;; ********************************************************************** ;;; @@ -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)) diff --git a/compiler/amd64/vm.lisp b/compiler/amd64/vm.lisp index 046ceb93aa9eeae06f1c41497ab5c250fa7513f2..1dea75eadcbbbccc2c8048fea47a8f729dafe13a 100644 --- a/compiler/amd64/vm.lisp +++ b/compiler/amd64/vm.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/amd64/vm.lisp,v 1.3 2009/11/02 02:51:58 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/amd64/vm.lisp,v 1.4 2009/11/02 15:05:07 rtoy Rel $") ;;; ;;; ********************************************************************** ;;; @@ -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) diff --git a/compiler/float-tran.lisp b/compiler/float-tran.lisp index 792bfff198ac617a410b500c2f3087ce822ffe4a..eb9dadd8b8c1af8954b5bb4de8350627e5161e0b 100644 --- a/compiler/float-tran.lisp +++ b/compiler/float-tran.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/float-tran.lisp,v 1.134 2009/11/02 02:51:58 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/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)) diff --git a/lisp/Config.amd64 b/lisp/Config.amd64 index 4f80ce2389f6067b27e57853b57bf7f413e6a50d..dc2b82eecaae3686d1aca1b9f426deefd320d2da 100644 --- a/lisp/Config.amd64 +++ b/lisp/Config.amd64 @@ -2,52 +2,17 @@ PATH1 = ../../src/lisp 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) $< diff --git a/lisp/Linux-os.c b/lisp/Linux-os.c index 5d806ac4e8eff61d1a202dd8c704b4fb7c6b4c28..2679bd26a8f1a3f7a843fab3ddb8d0ff1d3d1286 100644 --- a/lisp/Linux-os.c +++ b/lisp/Linux-os.c @@ -15,7 +15,7 @@ * GENCGC support by Douglas Crosher, 1996, 1997. * Alpha support by Julian Dolby, 1999. * - * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/Linux-os.c,v 1.45 2009/11/02 02:51:58 rtoy Exp $ + * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/Linux-os.c,v 1.46 2009/11/02 15:05:07 rtoy Exp $ * */ @@ -153,52 +153,45 @@ os_sigcontext_fpu_modes(ucontext_t *scp) #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 @@ sigsegv_handler_tramp(void) 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 @@ os_dlsym(const char *sym_name, lispobj lib_list) } } -#ifdef i386 void restore_fpu(ucontext_t *context) { @@ -457,27 +444,3 @@ restore_fpu(ucontext_t *context) #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 diff --git a/lisp/Linux-os.h b/lisp/Linux-os.h index 6797704e6efefa9572d8b4a1cce102131cb8f9a6..06acf3b8bd7d0ae6a11fe65baf44e00f94bde58b 100644 --- a/lisp/Linux-os.h +++ b/lisp/Linux-os.h @@ -1,4 +1,4 @@ -/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/Linux-os.h,v 1.29 2009/11/02 02:51:58 rtoy Exp $ +/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/Linux-os.h,v 1.30 2009/11/02 15:05:07 rtoy Rel $ 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 */ diff --git a/lisp/amd64-arch.c b/lisp/amd64-arch.c index 3f8977958c55bd4f366a88cb6fff78296ce0956b..95a6c95651bab438a7ac86d901e626aee910b309 100644 --- a/lisp/amd64-arch.c +++ b/lisp/amd64-arch.c @@ -1,6 +1,6 @@ /* x86-arch.c -*- Mode: C; comment-column: 40 -*- * - * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/amd64-arch.c,v 1.10 2009/11/02 02:51:58 rtoy Exp $ + * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/amd64-arch.c,v 1.11 2009/11/02 15:05:07 rtoy Rel $ * */ @@ -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 @@ arch_init(fpu_mode_t mode) */ 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 @@ arch_skip_instruction(os_context_t *context) 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 @@ unsigned int single_step_save3; #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 @@ arch_do_displaced_inst(os_context_t *context, unsigned long orig_inst) *((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 @@ arch_do_displaced_inst(os_context_t *context, unsigned long orig_inst) 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 @@ sigtrap_handler(HANDLER_ARGS) { 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 @@ sigtrap_handler(HANDLER_ARGS) 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 @@ sigtrap_handler(HANDLER_ARGS) } /* 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 @@ sigtrap_handler(HANDLER_ARGS) * arguments to follow. */ - trap = *(unsigned char *) (SC_PC(context)); + trap = *(unsigned char *) (context->sc_pc); switch (trap) { case trap_PendingInterrupt: @@ -248,23 +261,27 @@ sigtrap_handler(HANDLER_ARGS) 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 @@ sigtrap_handler(HANDLER_ARGS) 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; } } diff --git a/lisp/amd64-assem.S b/lisp/amd64-assem.S index bd6e11a5e4a1ad33bd3f2b003fd11ec8103276cc..f145fba373130cf382af3b5774a10dc9f39c9720 100644 --- a/lisp/amd64-assem.S +++ b/lisp/amd64-assem.S @@ -1,6 +1,6 @@ ### amd64-assem.S -*- Mode: Asm; -*- /** - * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/amd64-assem.S,v 1.11 2009/11/02 02:51:58 rtoy Exp $ + * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/amd64-assem.S,v 1.12 2009/11/02 15:05:07 rtoy Rel $ * * Authors: Paul F. Werkowski <pw@snoopy.mv.com> * Douglas T. Crosher @@ -119,7 +119,7 @@ Lfp_rtn_value: movl $0,GNAME(foreign_function_call_active) /* Return */ - jmp *%rbx + jmp *%ebx .size GNAME(call_into_c), . - GNAME(call_into_c) diff --git a/lisp/amd64-lispregs.h b/lisp/amd64-lispregs.h index 1fb95cd8b3f26d409802d9a175943c08a0ca8ebf..aa5c67af28a9ea5bc0b8b09d0ba43c0368223d8e 100644 --- a/lisp/amd64-lispregs.h +++ b/lisp/amd64-lispregs.h @@ -1,5 +1,5 @@ /* x86-lispregs.h -*- Mode: C; -*- - * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/amd64-lispregs.h,v 1.5 2009/11/02 02:51:58 rtoy Exp $ + * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/amd64-lispregs.h,v 1.6 2009/11/02 15:05:07 rtoy Rel $ */ /* 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_ */ diff --git a/lisp/backtrace.c b/lisp/backtrace.c index 76778e4d9958f02a320b1f57a713f80db5531000..789455eb849818100814611e29f439f7119c1286 100644 --- a/lisp/backtrace.c +++ b/lisp/backtrace.c @@ -1,4 +1,4 @@ -/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/backtrace.c,v 1.19 2009/11/02 03:07:01 rtoy Exp $ +/* $Header: /Volumes/share2/src/cmucl/cvs2git/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 @@ backtrace(int nframes) 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; diff --git a/lisp/gencgc.c b/lisp/gencgc.c index bc39798c5aa26890a217ad266bf0a2629d5882c0..53e37b14f310f9901e5047f14ec8cce1c452662c 100644 --- a/lisp/gencgc.c +++ b/lisp/gencgc.c @@ -7,7 +7,7 @@ * * Douglas Crosher, 1996, 1997, 1998, 1999. * - * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/gencgc.c,v 1.100 2009/11/02 02:51:58 rtoy Exp $ + * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/gencgc.c,v 1.101 2009/11/02 15:05:07 rtoy Exp $ * */ @@ -3990,7 +3990,6 @@ scav_hash_entries(struct hash_table *hash_table, lispobj weak, int removep) 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 @@ scav_hash_entries(struct hash_table *hash_table, lispobj weak, int removep) 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 @@ scav_weak_entries(struct hash_table *hash_table) boolean value_survives = weak_value_survives(value); -#ifdef KEY if ((hash_table->weak_p == KEY) && key_survives && !survives_gc(value)) { @@ -4115,7 +4111,6 @@ scav_weak_entries(struct hash_table *hash_table) scavenged = 1; } } -#endif } return scavenged; diff --git a/lisp/gencgc.h b/lisp/gencgc.h index 04989d5324f3715bc7f0cc065b45d4bf105b706e..1b8e545044d880967d44562832419d05b2613572 100644 --- a/lisp/gencgc.h +++ b/lisp/gencgc.h @@ -7,7 +7,7 @@ * * Douglas Crosher, 1996, 1997. * - * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/gencgc.h,v 1.15 2009/11/02 02:51:58 rtoy Exp $ + * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/gencgc.h,v 1.16 2009/11/02 15:05:07 rtoy Rel $ * */ @@ -123,7 +123,7 @@ struct page { * write protected. */ -#if defined(i386) || defined(__x86_64) +#if defined(i386) #define PAGE_SIZE 4096 #elif defined(sparc) /* diff --git a/lisp/globals.h b/lisp/globals.h index 4f3cee6c328188f54720152b742ccb8cd96fafbc..76eb770ac44a1b84f30709ff1e07cd1001a80883 100644 --- a/lisp/globals.h +++ b/lisp/globals.h @@ -1,4 +1,4 @@ -/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/globals.h,v 1.12 2009/11/02 02:51:58 rtoy Exp $ */ +/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/globals.h,v 1.13 2009/11/02 15:05:07 rtoy Rel $ */ #ifndef _GLOBALS_H_ #define _GLOBALS_H_ @@ -31,7 +31,7 @@ extern lispobj *control_stack_end; #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 diff --git a/lisp/interrupt.c b/lisp/interrupt.c index 10f141cb665535e8499086d836f6cdc2394416b0..39a2d87ff98454dd99b603089a85099743d60b25 100644 --- a/lisp/interrupt.c +++ b/lisp/interrupt.c @@ -1,4 +1,4 @@ -/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/interrupt.c,v 1.59 2009/11/02 02:51:58 rtoy Exp $ */ +/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/interrupt.c,v 1.60 2009/11/02 15:05:07 rtoy Rel $ */ /* 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]; diff --git a/tools/clean-target.sh b/tools/clean-target.sh index d994fc2e4c786d5c39371bbbbb389d875ff070d1..6e5b074a77be0679c50e3bc5c55663fa94a8e31b 100755 --- a/tools/clean-target.sh +++ b/tools/clean-target.sh @@ -63,7 +63,6 @@ find $TARGET -name "*.bytef" -o -name "*.lbytef" -o -name "*.assem" -o \ -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 diff --git a/tools/cross-scripts/cross-x86-amd64.lisp b/tools/cross-scripts/cross-x86-amd64.lisp index d275638ea1c5b946fec8f5ced192e5422b7c9947..b053290dab8f6a8f278a6a0312d08b499def50dc 100644 --- a/tools/cross-scripts/cross-x86-amd64.lisp +++ b/tools/cross-scripts/cross-x86-amd64.lisp @@ -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))) -