diff --git a/code/pred.lisp b/code/pred.lisp index 0a43965155dcd531a2333ff07e82d271cedfdfe1..c74f115b717a5c491665dcd2205316a368a1de0f 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.60 2006/06/30 18:41:22 rtoy Rel $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pred.lisp,v 1.61 2009/11/02 02:51:57 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -127,6 +127,39 @@ primitive-predicates)))) (frob)) +;;; FIXME: The next four functions are for bootstrapping double-double +;;; for AMD64. This works around the recursive known function problem +;;; when compiling the predicate functions for double-double. This +;;; should be eventually removed when double-double float support for +;;; the compiler is working. +(defun double-double-float-p (x) + (let* ((addr (kernel:get-lisp-obj-address x)) + (ptr (logandc2 addr #x7))) + (when (= 1 (logand addr 1)) + (= 26 (ldb (byte 8 0) + (sys:sap-ref-32 (sys:int-sap ptr) 0)))))) + +(defun complex-double-double-float-p (x) + (let* ((addr (kernel:get-lisp-obj-address x)) + (ptr (logandc2 addr #x7))) + (when (= 1 (logand addr 1)) + (= 42 (ldb (byte 8 0) + (sys:sap-ref-32 (sys:int-sap ptr) 0)))))) + +(defun simple-array-double-double-float-p (x) + (let* ((addr (kernel:get-lisp-obj-address x)) + (ptr (logandc2 addr #x7))) + (when (= 1 (logand addr 1)) + (= 106 (ldb (byte 8 0) + (sys:sap-ref-32 (sys:int-sap ptr) 0)))))) + +(defun simple-array-complex-double-double-float-p (x) + (let* ((addr (kernel:get-lisp-obj-address x)) + (ptr (logandc2 addr #x7))) + (when (= 1 (logand addr 1)) + (= 118 (ldb (byte 8 0) + (sys:sap-ref-32 (sys:int-sap ptr) 0)))))) + ;;;; TYPE-OF -- public. ;;; diff --git a/code/sap.lisp b/code/sap.lisp index df735a266d15087ae8b00030c291875d3c3d88c2..77f87192d1b39835127f0f786caeb1a772fc6f47 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.19 2008/01/03 11:41:52 cshapiro Rel $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/sap.lisp,v 1.20 2009/11/02 02:51:58 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -77,10 +77,16 @@ (declare (type system-area-pointer sap)) (sap-int sap)) +#-amd64 (defun int-sap (int) "Converts an integer into a System Area Pointer." (declare (type (unsigned-byte #-alpha #.vm:word-bits #+alpha 64) int)) (int-sap int)) +#+amd64 +(defun int-sap (int) + "Converts an integer into a System Area Pointer." + (declare (type (unsigned-byte 64) int)) + (int-sap int)) (defun sap-ref-8 (sap offset) "Returns the 8-bit byte at OFFSET bytes from SAP." diff --git a/code/unix-glibc2.lisp b/code/unix-glibc2.lisp index c1930291bc233975fe1db4b6390444cc707e92d9..17934c78b59c088770b9db96bac00f31244011c8 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.49 2009/10/15 14:07:35 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/unix-glibc2.lisp,v 1.50 2009/11/02 02:51:58 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -265,7 +265,7 @@ (defconstant ms_invalidate 2) ;; The return value from mmap that means mmap failed. -(defconstant map_failed (int-sap (1- (ash 1 vm:word-bits)))) +(defconstant map_failed (int-sap #+amd64 0 #-amd64 (1- (ash 1 vm:word-bits)))) (defun unix-mmap (addr length prot flags fd offset) (declare (type (or null system-area-pointer) addr) diff --git a/compiler/amd64/float.lisp b/compiler/amd64/float.lisp index 4ad80a6238905a8b0a0545dd49e85e6d0ab99d00..f1abfafd105b4d7bfd621a5c71631251fec9bb0a 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.2 2004/07/14 20:57:31 cwang Rel $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/amd64/float.lisp,v 1.3 2009/11/02 02:51:58 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -61,7 +61,20 @@ (ea-for-xf-desc tn vm:complex-long-float-real-slot)) #+long-float (defun ea-for-clf-imag-desc (tn) - (ea-for-xf-desc tn vm:complex-long-float-imag-slot))) + (ea-for-xf-desc tn vm:complex-long-float-imag-slot)) + #+double-double + (defun ea-for-cddf-real-hi-desc (tn) + (ea-for-xf-desc tn vm:complex-double-double-float-real-hi-slot)) + #+double-double + (defun ea-for-cddf-real-lo-desc (tn) + (ea-for-xf-desc tn vm:complex-double-double-float-real-lo-slot)) + #+double-double + (defun ea-for-cddf-imag-hi-desc (tn) + (ea-for-xf-desc tn vm:complex-double-double-float-imag-hi-slot)) + #+double-double + (defun ea-for-cddf-imag-lo-desc (tn) + (ea-for-xf-desc tn vm:complex-double-double-float-imag-lo-slot)) + ) (macrolet ((ea-for-xf-stack (tn kind) `(make-ea @@ -86,7 +99,13 @@ (:single 1) (:double 2) (:long 3)) - (ecase ,slot (:real 1) (:imag 2)))) + (ecase ,slot + (:real 1) + (:imag 2) + (:real-hi 1) + (:real-lo 2) + (:imag-hi 3) + (:imag-lo 4)))) vm:word-bytes))))) (defun ea-for-csf-real-stack (tn &optional (base rbp-tn)) (ea-for-cxf-stack tn :single :real base)) @@ -103,7 +122,21 @@ (ea-for-cxf-stack tn :long :real base)) #+long-float (defun ea-for-clf-imag-stack (tn &optional (base rbp-tn)) - (ea-for-cxf-stack tn :long :imag base))) + (ea-for-cxf-stack tn :long :imag base)) + + #+double-double + (defun ea-for-cddf-real-hi-stack (tn &optional (base rbp-tn)) + (ea-for-cxf-stack tn :double :real-hi base)) + #+double-double + (defun ea-for-cddf-real-lo-stack (tn &optional (base rbp-tn)) + (ea-for-cxf-stack tn :double :real-lo base)) + #+double-double + (defun ea-for-cddf-imag-hi-stack (tn &optional (base rbp-tn)) + (ea-for-cxf-stack tn :double :imag-hi base)) + #+double-double + (defun ea-for-cddf-imag-lo-stack (tn &optional (base rbp-tn)) + (ea-for-cxf-stack tn :double :imag-lo base)) + ) ;;; Abstract out the copying of a FP register to the FP stack top, and ;;; provide two alternatives for its implementation. Note: it's not @@ -236,6 +269,21 @@ (make-random-tn :kind :normal :sc (sc-or-lose 'long-reg *backend*) :offset (1+ (tn-offset x)))) +#+double-double +(progn +(defun complex-double-double-reg-real-hi-tn (x) + (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*) + :offset (tn-offset x))) +(defun complex-double-double-reg-real-lo-tn (x) + (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*) + :offset (+ 1 (tn-offset x)))) +(defun complex-double-double-reg-imag-hi-tn (x) + (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*) + :offset (+ 2 (tn-offset x)))) +(defun complex-double-double-reg-imag-lo-tn (x) + (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*) + :offset (+ 3 (tn-offset x)))) +) ;;; x is source, y is destination (define-move-function (load-complex-single 2) (vop x y) ((complex-single-stack) (complex-single-reg)) @@ -308,6 +356,49 @@ (store-long-float (ea-for-clf-imag-stack y)) (inst fxch imag-tn))) +#+double-double +(progn +(define-move-function (load-complex-double-double 4) (vop x y) + ((complex-double-double-stack) (complex-double-double-reg)) + (let ((real-tn (complex-double-double-reg-real-hi-tn y))) + (with-empty-tn@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: @@ -546,11 +637,12 @@ (define-vop (move-from-complex-long) (:args (x :scs (complex-long-reg) :to :save)) (:results (y :scs (descriptor-reg))) + (:temporary (:sc any-reg :offset r11-offset) temp) (:node-var node) (:note "complex float to pointer coercion") (:generator 13 (with-fixed-allocation (y vm:complex-long-float-type - vm:complex-long-float-size node) + vm:complex-long-float-size temp node) (let ((real-tn (complex-long-reg-real-tn x))) (with-tn@fp-top(real-tn) (store-long-float (ea-for-clf-real-desc y)))) @@ -561,6 +653,32 @@ (define-move-vop move-from-complex-long :move (complex-long-reg) (descriptor-reg)) +#+double-double +(define-vop (move-from-complex-double-double) + (:args (x :scs (complex-double-double-reg) :to :save)) + (:results (y :scs (descriptor-reg))) + (:temporary (:sc any-reg :offset r11-offset) temp) + (:node-var node) + (:note "complex double-double float to pointer coercion") + (:generator 13 + (with-fixed-allocation (y vm::complex-double-double-float-type + vm::complex-double-double-float-size temp node) + (let ((real-tn (complex-double-double-reg-real-hi-tn x))) + (with-tn@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 ;;; @@ -728,14 +846,93 @@ (frob move-complex-long-float-argument complex-long-reg complex-long-stack :long)) +#+double-double +(define-vop (move-complex-double-double-float-argument) + (:args (x :scs (complex-double-double-reg) :target y) + (fp :scs (any-reg) :load-if (not (sc-is y complex-double-double-reg)))) + (:results (y)) + (:note "complex double-double-float argument move") + (:generator 2 + (sc-case y + (complex-double-double-reg + (unless (location= x y) + (let ((x-real (complex-double-double-reg-real-hi-tn x)) + (y-real (complex-double-double-reg-real-hi-tn y))) + (cond ((zerop (tn-offset y-real)) + (copy-fp-reg-to-fr0 x-real)) + ((zerop (tn-offset x-real)) + (inst fstd y-real)) + (t + (inst fxch x-real) + (inst fstd y-real) + (inst fxch x-real)))) + (let ((x-real (complex-double-double-reg-real-lo-tn x)) + (y-real (complex-double-double-reg-real-lo-tn y))) + (cond ((zerop (tn-offset y-real)) + (copy-fp-reg-to-fr0 x-real)) + ((zerop (tn-offset x-real)) + (inst fstd y-real)) + (t + (inst fxch x-real) + (inst fstd y-real) + (inst fxch x-real)))) + (let ((x-imag (complex-double-double-reg-imag-hi-tn x)) + (y-imag (complex-double-double-reg-imag-hi-tn y))) + (inst fxch x-imag) + (inst fstd y-imag) + (inst fxch x-imag)) + (let ((x-imag (complex-double-double-reg-imag-lo-tn x)) + (y-imag (complex-double-double-reg-imag-lo-tn y))) + (inst fxch x-imag) + (inst fstd y-imag) + (inst fxch x-imag)))) + (complex-double-double-stack + (let ((real-tn (complex-double-double-reg-real-hi-tn x))) + (cond ((zerop (tn-offset real-tn)) + (inst fstd (ea-for-cddf-real-hi-stack y fp))) + (t + (inst fxch real-tn) + (inst fstd (ea-for-cddf-real-hi-stack y fp)) + (inst fxch real-tn)))) + (let ((real-tn (complex-double-double-reg-real-lo-tn x))) + (cond ((zerop (tn-offset real-tn)) + (inst fstd (ea-for-cddf-real-lo-stack y fp))) + (t + (inst fxch real-tn) + (inst fstd (ea-for-cddf-real-lo-stack y fp)) + (inst fxch real-tn)))) + (let ((imag-tn (complex-double-double-reg-imag-hi-tn x))) + (inst fxch imag-tn) + (inst fstd (ea-for-cddf-imag-hi-stack y fp)) + (inst fxch imag-tn)) + (let ((imag-tn (complex-double-double-reg-imag-lo-tn x))) + (inst fxch imag-tn) + (inst fstd (ea-for-cddf-imag-lo-stack y fp)) + (inst fxch imag-tn)))) + )) + +#+double-double +(define-move-vop move-complex-double-double-float-argument :move-argument + (complex-double-double-reg descriptor-reg) (complex-double-double-reg)) + (define-move-vop move-argument :move-argument (single-reg double-reg #+long-float long-reg - complex-single-reg complex-double-reg #+long-float complex-long-reg) + #+double-double double-double-reg + complex-single-reg complex-double-reg #+long-float complex-long-reg + #+double-double complex-double-double-reg) (descriptor-reg)) ;;;; Arithmetic VOPs: + +;; Save the top-of-stack to memory and reload it. This ensures that +;; the stack top has the desired precision. +(defmacro save-and-reload-tos (tmp) + `(progn + (inst fstp ,tmp) + (inst fld ,tmp))) + ;;; dtc: The floating point arithmetic vops. ;;; ;;; Note: Although these can accept x and y on the stack or pointed to @@ -1210,6 +1407,12 @@ (= (long-float-high-bits x) (long-float-high-bits y)) (= (long-float-exp-bits x) (long-float-exp-bits y)))) +#+double-double +(deftransform eql ((x y) (double-double-float double-double-float)) + '(and (eql (double-double-hi x) (double-double-hi y)) + (eql (double-double-lo x) (double-double-lo y)))) + + (define-vop (=/float) (:args (x) (y)) (:temporary (:sc word-reg :offset rax-offset :from :eval) temp) @@ -1507,6 +1710,7 @@ (:save-p :compute-only) (:note "inline float comparison") (:ignore temp y) + (:guard (not (backend-featurep :sse2))) (:generator 2 (note-this-location vop :internal-error) (cond @@ -1532,12 +1736,14 @@ (:translate ,translate) (:args (x :scs (single-reg))) (:arg-types single-float (:constant (single-float 0f0 0f0))) + (:guard (not (backend-featurep :sse2))) (:variant ,test)) (define-vop (,(symbolicate translate "0/DOUBLE-FLOAT") float-test) (:translate ,translate) (:args (x :scs (double-reg))) (:arg-types double-float (:constant (double-float 0d0 0d0))) + (:guard (not (backend-featurep :sse2))) (:variant ,test)) #+long-float (define-vop (,(symbolicate translate "0/LONG-FLOAT") @@ -1669,11 +1875,41 @@ (with-empty-tn@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))) @@ -1697,6 +1933,27 @@ #+long-float (frob %long-float/unsigned %long-float long-reg long-float)) +;;#+(or) +(define-vop (%single-float/unsigned) + (:args (x :scs (unsigned-reg))) + (:results (y :scs (single-reg))) + (:arg-types unsigned-num) + (:result-types single-float) + (:policy :fast-safe) + (:note "inline float coercion") + (:translate %single-float) + (:vop-var vop) + (:save-p :compute-only) + (:generator 6 + (inst push 0) + (inst push x) + (with-empty-tn@fp-top(y) + (note-this-location vop :internal-error) + (inst fildl (make-ea :dword :base rsp-tn)) + (inst fstp (make-ea :dword :base rsp-tn)) + (inst fld (make-ea :dword :base rsp-tn))) + (inst add rsp-tn 8))) + ;;; These should be no-ops but the compiler might want to move ;;; some things around (macrolet ((frob (name translate from-sc from-type to-sc to-type) @@ -1727,6 +1984,7 @@ (inst fst y) (inst fxch x)))))))) + #+(or) (frob %single-float/double-float %single-float double-reg double-float single-reg single-float) #+long-float @@ -1744,7 +2002,54 @@ (frob %long-float/double-float %long-float double-reg double-float long-reg long-float)) +(define-vop (%single-float/double-float) + (:args (x :scs (double-reg) :target y)) + (:results (y :scs (single-reg))) + (:arg-types double-float) + (:result-types single-float) + (:policy :fast-safe) + (:note "inline float coercion") + (:translate %single-float) + (:temporary (:sc single-stack) sf-temp) + (:vop-var vop) + (:save-p :compute-only) + (:generator 2 + (note-this-location vop :internal-error) + (cond + ((zerop (tn-offset x)) + (cond + ((zerop (tn-offset y)) + ;; x is in ST0, y is also in ST0 + (inst fstp sf-temp) + (inst fld sf-temp)) + (t + ;; x is in ST0, y is in another reg. not ST0 + ;; Save st0 (x) to memory, swap, reload, then swap back. + (inst fst sf-temp) + (inst fxch y) + (fp-pop) + (inst fld sf-temp) + (inst fxch y)))) + ((zerop (tn-offset y)) + ;; y is in ST0, x is in another reg. not ST0 + ;; Swap, save x to memory, reload, swap back + (inst fxch x) + (inst fstp sf-temp) + (inst fld sf-temp) + (inst fxch x)) + (t + ;; Neither x or y are in ST0, and they are not in + ;; the same reg. + ;; Get x to st0. Store it away. Swap back. Get y to st0, + ;; load. Swap back. + (inst fxch x) + (inst fst sf-temp) + (inst fxch x) + (inst fxch y) + (fp-pop) + (inst fld sf-temp) + (inst fxch y))))) (macrolet ((frob (trans from-sc from-type round-p) `(define-vop (,(symbolicate trans "/" from-type)) @@ -1809,6 +2114,7 @@ (:note "inline float truncate") (:vop-var vop) (:save-p :compute-only) + (:guard (not (backend-featurep :sse2))) (:generator 5 ,@(unless round-p '((note-this-location vop :internal-error) @@ -2078,55 +2384,53 @@ ;;;; Float mode hackery: -(deftype float-modes () '(unsigned-byte 32)) ; really only 16 -(defknown floating-point-modes () float-modes (flushable)) -(defknown ((setf floating-point-modes)) (float-modes) +(deftype float-modes () '(unsigned-byte 24)) +(defknown x87-floating-point-modes () float-modes (flushable)) +(defknown ((setf x87-floating-point-modes)) (float-modes) float-modes) -(defconstant npx-env-size (* 7 vm:word-bytes)) -(defconstant npx-cw-offset 0) -(defconstant npx-sw-offset 4) - -(define-vop (floating-point-modes) +(define-vop (x87-floating-point-modes) (:results (res :scs (unsigned-reg))) (:result-types unsigned-num) - (:translate floating-point-modes) + (:translate x87-floating-point-modes) (:policy :fast-safe) - (:temporary (:sc unsigned-reg :offset rax-offset :target res - :to :result) rax) + (:temporary (:sc unsigned-stack) cw-stack) + (:temporary (:sc unsigned-reg :offset eax-offset) sw-reg) (:generator 8 - (inst sub rsp-tn npx-env-size) ; make space on stack - (inst wait) ; Catch any pending FPE exceptions - (inst fstenv (make-ea :qword :base rsp-tn)) ; masks all exceptions - (inst fldenv (make-ea :qword :base rsp-tn)) ; restore previous state - ;; Current status to high word - (inst mov rax (make-ea :qword :base rsp-tn :disp (- npx-sw-offset 2))) - ;; Exception mask to low word - (inst mov ax-tn (make-ea :word :base rsp-tn :disp npx-cw-offset)) - (inst add rsp-tn npx-env-size) ; Pop stack - (inst xor rax #x3f) ; Flip exception mask to trap enable bits - (move res rax))) - -(define-vop (set-floating-point-modes) + (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) (:args (new :scs (unsigned-reg) :to :result :target res)) (:results (res :scs (unsigned-reg))) (:arg-types unsigned-num) (:result-types unsigned-num) - (:translate (setf floating-point-modes)) + (:translate (setf x87-floating-point-modes)) (:policy :fast-safe) - (:temporary (:sc unsigned-reg :offset rax-offset - :from :eval :to :result) rax) - (:generator 3 - (inst sub rsp-tn npx-env-size) ; make space on stack - (inst wait) ; Catch any pending FPE exceptions - (inst fstenv (make-ea :qword :base rsp-tn)) - (inst mov rax new) - (inst xor rax #x3f) ; turn trap enable bits into exception mask - (inst mov (make-ea :word :base rsp-tn :disp npx-cw-offset) ax-tn) - (inst shr rax 16) ; position status word - (inst mov (make-ea :word :base rsp-tn :disp npx-sw-offset) ax-tn) - (inst fldenv (make-ea :qword :base rsp-tn)) - (inst add rsp-tn npx-env-size) ; Pop stack + (:temporary (:sc unsigned-stack) cw-stack) + (:temporary (:sc byte-reg :offset al-offset) sw-reg) + (:temporary (:sc unsigned-reg :offset ecx-offset) old) + (:generator 6 + (inst mov cw-stack new) + (inst xor cw-stack #x3f) ; invert exception mask + (inst fnstsw) + (inst fldcw cw-stack) ; always update the control word + (inst mov old new) + (inst shr old 16) + (inst cmp cl-tn sw-reg) ; compare exception flags + (inst jmp :z DONE) ; skip updating the status word + (inst sub rsp-tn 28) + (inst fstenv (make-ea :dword :base rsp-tn)) + (inst mov (make-ea :byte :base rsp-tn :disp 4) cl-tn) + (inst fldenv (make-ea :dword :base rsp-tn)) + (inst add rsp-tn 28) + DONE (move res new))) @@ -2169,7 +2473,9 @@ ;; Quick versions of fsin and fcos that require the argument to be ;; within range 2^63. + #-sse2 (frob fsin-quick %sin-quick fsin) + #-sse2 (frob fcos-quick %cos-quick fcos) ;; (frob fsqrt %sqrt fsqrt)) @@ -2191,6 +2497,7 @@ (:vop-var vop) (:save-p :compute-only) (:ignore fr0) + (:guard (not (backend-featurep :sse2))) (:generator 5 (note-this-location vop :internal-error) (case (tn-offset x) @@ -2476,6 +2783,7 @@ (:vop-var vop) (:save-p :compute-only) (:ignore temp) + (:guard (not (backend-featurep :sse2))) (:generator 5 (note-this-location vop :internal-error) (unless (zerop (tn-offset x)) @@ -2532,6 +2840,7 @@ (:vop-var vop) (:save-p :compute-only) (:ignore temp fr0) + (:guard (not (backend-featurep :sse2))) (:generator 5 (note-this-location vop :internal-error) (unless (zerop (tn-offset x)) @@ -2587,6 +2896,7 @@ (:note "inline log function") (:vop-var vop) (:save-p :compute-only) + (:guard (not (backend-featurep :sse2))) (:generator 5 (note-this-location vop :internal-error) (sc-case x @@ -2638,6 +2948,7 @@ (:note "inline log10 function") (:vop-var vop) (:save-p :compute-only) + (:guard (not (backend-featurep :sse2))) (:generator 5 (note-this-location vop :internal-error) (sc-case x @@ -2692,6 +3003,7 @@ (:note "inline pow function") (:vop-var vop) (:save-p :compute-only) + (:guard (not (backend-featurep :sse2))) (:generator 5 (note-this-location vop :internal-error) ;; Setup x in fr0 and y in fr1 @@ -2806,6 +3118,7 @@ (:policy :fast-safe) (:note "inline scalbn function") (:ignore fr0) + (:guard (not (backend-featurep :sse2))) (:generator 5 ;; Setup x in fr0 and y in fr1 (sc-case x @@ -2873,6 +3186,7 @@ (:vop-var vop) (:save-p :compute-only) (:ignore fr0) + (:guard (not (backend-featurep :sse2))) (:generator 5 (note-this-location vop :internal-error) ;; Setup x in fr0 and y in fr1 @@ -2974,7 +3288,8 @@ (:arg-types double-float) (:result-types double-float) (:policy :fast-safe) - (:guard (not (backend-featurep :pentium))) + (:guard (or (not (backend-featurep :pentium)) + (not (backend-featurep :sse2)))) (:note "inline log1p function") (:ignore temp) (:generator 5 @@ -3028,7 +3343,8 @@ (:arg-types double-float) (:result-types double-float) (:policy :fast-safe) - (:guard (backend-featurep :pentium)) + (:guard (and (backend-featurep :pentium) + (not (backend-featurep :sse2)))) (:note "inline log1p with limited x range function") (:vop-var vop) (:save-p :compute-only) @@ -3083,6 +3399,7 @@ (:vop-var vop) (:save-p :compute-only) (:ignore fr0) + (:guard (not (backend-featurep :sse2))) (:generator 5 (note-this-location vop :internal-error) (sc-case x @@ -3129,6 +3446,7 @@ (:note "inline atan function") (:vop-var vop) (:save-p :compute-only) + (:guard (not (backend-featurep :sse2))) (:generator 5 (note-this-location vop :internal-error) ;; Setup x in fr1 and 1.0 in fr0 @@ -3176,6 +3494,7 @@ (:note "inline atan2 function") (:vop-var vop) (:save-p :compute-only) + (:guard (not (backend-featurep :sse2))) (:generator 5 (note-this-location vop :internal-error) ;; Setup x in fr1 and y in fr0 @@ -4645,3 +4964,424 @@ (:note "inline dummy FP register bias") (:ignore x) (:generator 0)) + +;;; Support for double-double floats + +#+double-double +(progn + +(defun double-double-reg-hi-tn (x) + (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*) + :offset (tn-offset x))) + +(defun double-double-reg-lo-tn (x) + (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*) + :offset (1+ (tn-offset x)))) + +(define-move-function (load-double-double 4) (vop x y) + ((double-double-stack) (double-double-reg)) + (let ((real-tn (double-double-reg-hi-tn y))) + (with-empty-tn@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 dea1a26164e6a66d6356cace068fdab4985eb12b..f8ef6632ddb53caccebea841cb755bf7aec4161f 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.3 2004/06/18 23:44:42 cwang Rel $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/amd64/parms.lisp,v 1.4 2009/11/02 02:51:58 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -55,7 +55,8 @@ ;;;; Machine Architecture parameters: -(export '(word-bits byte-bits word-shift word-bytes float-sign-shift +(export '(word-bits byte-bits char-bits word-shift word-bytes char-bytes + float-sign-shift single-float-bias single-float-exponent-byte single-float-significand-byte single-float-normal-exponent-min @@ -76,6 +77,8 @@ float-imprecise-trap-bit float-invalid-trap-bit float-divide-by-zero-trap-bit)) +#+double-double +(export '(double-double-float-digits)) (eval-when (compile load eval) @@ -86,6 +89,12 @@ (defconstant byte-bits 8 "Number of bits per byte where a byte is the smallest addressable object.") +(defconstant char-bits #-unicode 8 #+unicode 16 + "Number of bits needed to represent a character") + +(defconstant char-bytes (truncate char-bits byte-bits) + "Number of bytes needed to represent a character") + (defconstant word-shift (1- (integer-length (/ word-bits byte-bits))) "Number of bits to shift between word addresses and byte addresses.") @@ -134,6 +143,10 @@ (defconstant long-float-digits (+ (byte-size long-float-significand-byte) 32 1)) +#+double-double +(defconstant double-double-float-digits + (* 2 double-float-digits)) + ;;; pfw -- from i486 microprocessor programmers reference manual (defconstant float-invalid-trap-bit (ash 1 0)) (defconstant float-denormal-trap-bit (ash 1 1)) @@ -147,16 +160,26 @@ (defconstant float-round-to-positive 2) (defconstant float-round-to-zero 3) -(defconstant float-precision-24-bit 0) -(defconstant float-precision-53-bit 2) -(defconstant float-precision-64-bit 3) +;; 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-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)) +#-sse2 +(progn (defconstant float-fast-bit 0) ; No fast mode on x86 +) + +#+sse2 +(progn +;; SSE2 has a flush-to-zero flag, which we use as the fast bit. Some +;; versions of sse2 also have a denormals-are-zeros flag. We don't +;; currently use denormals-are-zeroes for anything. +(defconstant float-fast-bit (ash 1 15)) +) ); eval-when @@ -171,9 +194,15 @@ ;;; Where to put the different spaces. ;;; (defconstant target-read-only-space-start #x10000000) -(defconstant target-static-space-start #x28000000) -(defconstant target-dynamic-space-start #x48000000) -(defconstant target-foreign-linkage-space-start #xB0000000) +(defconstant target-static-space-start + #+FreeBSD #x28F00000 + #-FreeBSD #x28000000) +(defconstant target-dynamic-space-start + #+linux #x58100000 + #-linux #x48000000) +(defconstant target-foreign-linkage-space-start + #+linux #x58000000 + #-linux #xB0000000) (defconstant target-foreign-linkage-entry-size 16) ;In bytes. Duh. ;;; Given that NIL is the first thing allocated in static space, we @@ -305,6 +334,20 @@ lisp::*cmucl-lib* lisp::*cmucl-core-path* + ;; Weak hash table support + :key + :value + :key-and-value + :key-or-value + + ;; Used by CGC. + *x86-cgc-active-p* + ;; Foreign linkage stuff + lisp::*linkage-table-data* + system::*global-table* + *current-region-free-pointer* + *current-region-end-addr* + ;; Spare symbols. Rename these when you need to add some static ;; symbols and don't want to do a cross-compile. spare-8 @@ -316,13 +359,6 @@ spare-2 spare-1 - ;; Used by CGC. - *x86-cgc-active-p* - ;; Foreign linkage stuff - lisp::*linkage-table-data* - system::*global-table* - *current-region-free-pointer* - *current-region-end-addr* *static-blue-bag* ; Must be last or change C code diff --git a/compiler/amd64/type-vops.lisp b/compiler/amd64/type-vops.lisp index 50960ffcd24bc1ec2944ecb1078fa2596527d03f..e9c78b83d16a27e72216103f75bed4596d9ff5c4 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.1 2004/05/24 22:35:00 cwang Rel $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/amd64/type-vops.lisp,v 1.2 2009/11/02 02:51:58 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -32,7 +32,7 @@ (defparameter function-header-types - (list funcallable-instance-header-type dylan-function-header-type + (list funcallable-instance-header-type byte-code-function-type byte-code-closure-type function-header-type closure-function-header-type closure-header-type)) diff --git a/compiler/amd64/vm.lisp b/compiler/amd64/vm.lisp index 1c8c2262551c628e18b0e4dbb4573560545424d1..046ceb93aa9eeae06f1c41497ab5c250fa7513f2 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.2 2004/07/06 20:23:30 cwang Rel $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/amd64/vm.lisp,v 1.3 2009/11/02 02:51:58 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -215,13 +215,17 @@ (sap-stack stack) ; System area pointers. (single-stack stack) ; single-floats (double-stack stack :element-size 2) ; double-floats. + #+double-double + (double-double-stack stack :element-size 4) ; double-double-float #+long-float (long-stack stack :element-size 3) ; long-floats. (complex-single-stack stack :element-size 2) ; complex-single-floats (complex-double-stack stack :element-size 4) ; complex-double-floats #+long-float (complex-long-stack stack :element-size 6) ; complex-long-floats - + #+double-double + (complex-double-double-stack stack :element-size 8) ; complex-double-double-floats + ;; **** Magic SCs. (ignore-me noise) @@ -318,6 +322,14 @@ :save-p t :alternate-scs (long-stack)) + #+double-double + (double-double-reg float-registers + :locations (0 2 4 6) + :element-size 2 + :constant-scs () + :save-p t + :alternate-scs (double-double-stack)) + (complex-single-reg float-registers :locations (0 2 4 6) :element-size 2 @@ -339,6 +351,13 @@ :constant-scs () :save-p t :alternate-scs (complex-long-stack)) + #+double-double + (complex-double-double-reg float-registers + :locations (0 4) + :element-size 4 + :constant-scs () + :save-p t + :alternate-scs (complex-double-double-stack)) ;; A catch or unwind block. (catch-block stack :element-size vm:catch-block-size) diff --git a/compiler/float-tran.lisp b/compiler/float-tran.lisp index 16428f103c08e674cb9c3591ec98579ce4848a07..792bfff198ac617a410b500c2f3087ce822ffe4a 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.133 2009/08/11 18:32:55 rtoy Rel $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/float-tran.lisp,v 1.134 2009/11/02 02:51:58 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -82,6 +82,8 @@ (movable foldable flushable)) (defknown %complex-double-float (number) (complex double-float) (movable foldable flushable)) + +#+double-double (defknown %complex-double-double-float (number) (complex double-double-float) (movable foldable flushable)) diff --git a/lisp/Config.amd64 b/lisp/Config.amd64 index dc2b82eecaae3686d1aca1b9f426deefd320d2da..4f80ce2389f6067b27e57853b57bf7f413e6a50d 100644 --- a/lisp/Config.amd64 +++ b/lisp/Config.amd64 @@ -2,17 +2,52 @@ PATH1 = ../../src/lisp vpath %.h $(PATH1) vpath %.c $(PATH1) vpath %.S $(PATH1) -CPPFLAGS = -I. -I$(PATH1) -I- + + +# Enable support for :linkage-table feature. +ifdef FEATURE_LINKAGE_TABLE +CPP_DEFINE_OPTIONS += -DLINKAGE_TABLE +endif + + +# Enable support for generational GC +ifdef FEATURE_GENCGC +CPP_DEFINE_OPTIONS += -DGENCGC +GC_SRC := gencgc.c +else +GC_SRC := cgc.c +CPP_DEFINE_OPTIONS += -DWANT_CGC +endif + +ifeq ($(filter 2% 3%, $(shell $(CC) -dumpversion)),) +CPP_INCLUDE_OPTIONS := -iquote . -iquote $(PATH1) +else +CPP_INCLUDE_OPTIONS := -I. -I$(PATH1) -I- +endif +CPPFLAGS := $(CPP_DEFINE_OPTIONS) $(CPP_INCLUDE_OPTIONS) +CFLAGS += -Wstrict-prototypes -Wall -g +ASFLAGS = -g + CC = gcc LD = ld CPP = cpp -CFLAGS = -m64 -rdynamic -Wstrict-prototypes -Wall -g -DGENCGC -DLINKAGE_TABLE -ASFLAGS = -g -DGENCGC -DLINKAGE_TABLE +CFLAGS += -m64 -Wstrict-prototypes -Wall -g +ASFLAGS = -g + NM = $(PATH1)/linux-nm UNDEFSYMPATTERN = -Xlinker -u -Xlinker & + ASSEM_SRC = amd64-assem.S linux-stubs.S ARCH_SRC = amd64-arch.c -OS_SRC = Linux-os.c os-common.c elf.c +OS_SRC = Linux-os.c os-common.c elf.c e_rem_pio2.c k_rem_pio2.c OS_LINK_FLAGS = -rdynamic -Xlinker --export-dynamic -Xlinker -Map -Xlinker foo OS_LIBS = -ldl GC_SRC = gencgc.c + +DEPEND = $(CC) -MM -E +DEPEND_FLAGS = + +# This no longer has aliasing problems, so no need to use +# -ffloat-store and -fno-strict-aliasing anymore. +e_rem_pio2.o : e_rem_pio2.c + $(CC) -c $(CFLAGS) $(CPPFLAGS) $< diff --git a/lisp/Linux-os.c b/lisp/Linux-os.c index 60ee9ff9f83fac7a3dc4ae945c81adeb0c7f25b9..5d806ac4e8eff61d1a202dd8c704b4fb7c6b4c28 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.44 2009/10/15 15:05:51 rtoy Exp $ + * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/Linux-os.c,v 1.45 2009/11/02 02:51:58 rtoy Exp $ * */ @@ -153,45 +153,52 @@ os_sigcontext_fpu_modes(ucontext_t *scp) #endif #ifdef __x86_64 -int * -sc_reg(ucontext_t *c, int offset) +unsigned long * +os_sigcontext_reg(ucontext_t *c, int offset) { switch (offset) { case 0: - return &c->uc_mcontext.gregs[REG_RAX]; + return (unsigned long *)&c->uc_mcontext.gregs[REG_RAX]; case 2: - return &c->uc_mcontext.gregs[REG_RCX]; + return (unsigned long *)&c->uc_mcontext.gregs[REG_RCX]; case 4: - return &c->uc_mcontext.gregs[REG_RDX]; + return (unsigned long *)&c->uc_mcontext.gregs[REG_RDX]; case 6: - return &c->uc_mcontext.gregs[REG_RBX]; + return (unsigned long *)&c->uc_mcontext.gregs[REG_RBX]; case 8: - return &c->uc_mcontext.gregs[REG_RSP]; + return (unsigned long *)&c->uc_mcontext.gregs[REG_RSP]; case 10: - return &c->uc_mcontext.gregs[REG_RBP]; + return (unsigned long *)&c->uc_mcontext.gregs[REG_RBP]; case 12: - return &c->uc_mcontext.gregs[REG_RSI]; + return (unsigned long *)&c->uc_mcontext.gregs[REG_RSI]; case 14: - return &c->uc_mcontext.gregs[REG_RDI]; + return (unsigned long *)&c->uc_mcontext.gregs[REG_RDI]; case 16: - return &c->uc_mcontext.gregs[REG_R8]; + return (unsigned long *)&c->uc_mcontext.gregs[REG_R8]; case 18: - return &c->uc_mcontext.gregs[REG_R9]; + return (unsigned long *)&c->uc_mcontext.gregs[REG_R9]; case 20: - return &c->uc_mcontext.gregs[REG_R10]; + return (unsigned long *)&c->uc_mcontext.gregs[REG_R10]; case 22: - return &c->uc_mcontext.gregs[REG_R11]; + return (unsigned long *)&c->uc_mcontext.gregs[REG_R11]; case 24: - return &c->uc_mcontext.gregs[REG_R12]; + return (unsigned long *)&c->uc_mcontext.gregs[REG_R12]; case 26: - return &c->uc_mcontext.gregs[REG_R13]; + return (unsigned long *)&c->uc_mcontext.gregs[REG_R13]; case 28: - return &c->uc_mcontext.gregs[REG_R14]; + return (unsigned long *)&c->uc_mcontext.gregs[REG_R14]; case 30: - return &c->uc_mcontext.gregs[REG_R15]; + return (unsigned long *)&c->uc_mcontext.gregs[REG_R15]; } - return (int *) 0; + return (unsigned long *) 0; } + +unsigned long * +os_sigcontext_pc(ucontext_t *scp) +{ + return (unsigned long *) &scp->uc_mcontext.gregs[REG_RIP]; +} + #endif os_vm_address_t @@ -298,7 +305,12 @@ sigsegv_handler_tramp(void) void sigsegv_handler(HANDLER_ARGS) { - int fault_addr = context->uc_mcontext.cr2; + long fault_addr = +#ifdef i386 + context->uc_mcontext.cr2; +#else + context->uc_mcontext.gregs[REG_CR2]; +#endif #ifdef RED_ZONE_HIT if (os_control_stack_overflow((void *) fault_addr, context)) @@ -422,6 +434,7 @@ os_dlsym(const char *sym_name, lispobj lib_list) } } +#ifdef i386 void restore_fpu(ucontext_t *context) { @@ -444,3 +457,27 @@ 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 a6d5edfbaaed3e620ffa25c4512fc7785a657286..6797704e6efefa9572d8b4a1cce102131cb8f9a6 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.28 2008/01/03 11:41:54 cshapiro Rel $ +/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/Linux-os.h,v 1.29 2009/11/02 02:51:58 rtoy Exp $ This code was written as part of the CMU Common Lisp project at Carnegie Mellon University, and has been placed in the public domain. @@ -26,6 +26,9 @@ #include <asm/unistd.h> #include <errno.h> +#define __USE_GNU +#include <sys/ucontext.h> + typedef caddr_t os_vm_address_t; /* like hpux */ typedef size_t os_vm_size_t; /* like hpux */ typedef off_t os_vm_offset_t; /* like hpux */ diff --git a/lisp/amd64-arch.c b/lisp/amd64-arch.c index 6baaafec13f7352e48ce531474bd6f6d6a77a4c7..3f8977958c55bd4f366a88cb6fff78296ce0956b 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.9 2008/12/07 02:33:55 agoncharov Rel $ + * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/amd64-arch.c,v 1.10 2009/11/02 02:51:58 rtoy Exp $ * */ @@ -12,6 +12,7 @@ #include "os.h" #include "internals.h" #include "arch.h" +#define __USE_GNU #include "lispregs.h" #include "signal.h" #include "alloc.h" @@ -39,22 +40,22 @@ arch_init(fpu_mode_t mode) */ void -arch_skip_instruction(struct sigcontext *context) +arch_skip_instruction(os_context_t *context) { int vlen, code; - DPRINTF(0, (stderr, "[arch_skip_inst at %x>]\n", context->sc_pc)); + DPRINTF(0, (stderr, "[arch_skip_inst at %x>]\n", SC_PC(context))); /* Get and skip the lisp error code. */ - code = *(char *) context->sc_pc++; + code = *(char *) SC_PC(context)++; switch (code) { case trap_Error: case trap_Cerror: /* Lisp error arg vector length */ - vlen = *(char *) context->sc_pc++; + vlen = *(char *) SC_PC(context)++; /* Skip lisp error arg data bytes */ while (vlen-- > 0) - ((char *) context->sc_pc)++; + SC_PC(context)++; break; case trap_Breakpoint: @@ -71,23 +72,23 @@ arch_skip_instruction(struct sigcontext *context) break; } - DPRINTF(0, (stderr, "[arch_skip_inst resuming at %x>]\n", context->sc_pc)); + DPRINTF(0, (stderr, "[arch_skip_inst resuming at %x>]\n", SC_PC(context))); } unsigned char * -arch_internal_error_arguments(struct sigcontext *context) +arch_internal_error_arguments(os_context_t *context) { - return (unsigned char *) (context->sc_pc + 1); + return (unsigned char *) (SC_PC(context) + 1); } boolean -arch_pseudo_atomic_atomic(struct sigcontext *context) +arch_pseudo_atomic_atomic(os_context_t *context) { return SymbolValue(PSEUDO_ATOMIC_ATOMIC); } void -arch_set_pseudo_atomic_interrupted(struct sigcontext *context) +arch_set_pseudo_atomic_interrupted(os_context_t *context) { SetSymbolValue(PSEUDO_ATOMIC_INTERRUPTED, make_fixnum(1)); } @@ -128,9 +129,9 @@ unsigned int single_step_save3; #endif void -arch_do_displaced_inst(struct sigcontext *context, unsigned long orig_inst) +arch_do_displaced_inst(os_context_t *context, unsigned long orig_inst) { - unsigned int *pc = (unsigned int *) context->sc_pc; + unsigned int *pc = (unsigned int *) SC_PC(context); /* * Put the original instruction back. @@ -139,8 +140,8 @@ arch_do_displaced_inst(struct sigcontext *context, unsigned long orig_inst) *((char *) pc) = orig_inst & 0xff; *((char *) pc + 1) = (orig_inst & 0xff00) >> 8; -#ifdef __linux__ - context->eflags |= 0x100; +#ifdef SC_EFLAGS + SC_EFLAGS(context) |= 0x100; #else /* @@ -159,7 +160,7 @@ arch_do_displaced_inst(struct sigcontext *context, unsigned long orig_inst) single_stepping = (unsigned int *) pc; #ifndef __linux__ - (unsigned int *) context->sc_pc = (char *) pc - 9; + (unsigned int *) SC_PC(context) = (char *) pc - 9; #endif } @@ -169,12 +170,9 @@ sigtrap_handler(HANDLER_ARGS) { unsigned int trap; -#ifdef __linux__ - GET_CONTEXT -#endif #if 0 fprintf(stderr, "x86sigtrap: %8x %x\n", - context->sc_pc, *(unsigned char *) (context->sc_pc - 1)); + SC_PC(context), *(unsigned char *) (SC_PC(context) - 1)); fprintf(stderr, "sigtrap(%d %d %x)\n", signal, code, context); #endif @@ -183,20 +181,21 @@ sigtrap_handler(HANDLER_ARGS) fprintf(stderr, "* Single step trap %x\n", single_stepping); #endif -#ifndef __linux__ +#ifdef SC_EFLAGS + /* Disable single-stepping */ + SC_EFLAGS(context) ^= 0x100; +#else /* Un-install single step helper instructions. */ *(single_stepping - 3) = single_step_save1; *(single_stepping - 2) = single_step_save2; *(single_stepping - 1) = single_step_save3; -#else - context->eflags ^= 0x100; #endif /* * Re-install the breakpoint if possible. */ - if ((int) context->sc_pc == (int) single_stepping + 1) + if ((int) SC_PC(context) == (int) single_stepping + 1) fprintf(stderr, "* Breakpoint not re-install\n"); else { char *ptr = (char *) single_stepping; @@ -210,21 +209,9 @@ sigtrap_handler(HANDLER_ARGS) } /* This is just for info in case monitor wants to print an approx */ - current_control_stack_pointer = (unsigned long *) context->sc_sp; - -#if defined(__linux__) && (defined(i386) || defined(__x86_64)) - /* - * Restore the FPU control word, setting the rounding mode to nearest. - */ - - if (contextstruct.fpstate) -#if defined(__x86_64) - setfpucw(contextstruct.fpstate->cwd & ~0xc00); -#else - setfpucw(contextstruct.fpstate->cw & ~0xc00); -#endif -#endif + current_control_stack_pointer = (unsigned long *) SC_SP(context); + RESTORE_FPU(context); /* * On entry %eip points just after the INT3 byte and aims at the * 'kind' value (eg trap_Cerror). For error-trap and Cerror-trap a @@ -232,7 +219,7 @@ sigtrap_handler(HANDLER_ARGS) * arguments to follow. */ - trap = *(unsigned char *) (context->sc_pc); + trap = *(unsigned char *) (SC_PC(context)); switch (trap) { case trap_PendingInterrupt: @@ -261,27 +248,23 @@ sigtrap_handler(HANDLER_ARGS) case trap_Error: case trap_Cerror: DPRINTF(0, (stderr, "<trap Error %d>\n", code)); -#ifdef __linux__ - interrupt_internal_error(signal, contextstruct, code == trap_Cerror); -#else - interrupt_internal_error(signal, code, context, code == trap_Cerror); -#endif + interrupt_internal_error(signal, code, context, CODE(code) == trap_Cerror); break; case trap_Breakpoint: #if 0 fprintf(stderr, "*C break\n"); #endif - (char *) context->sc_pc -= 1; - handle_breakpoint(signal, code, context); + SC_PC(context) -= 1; + handle_breakpoint(signal, CODE(code), context); #if 0 fprintf(stderr, "*C break return\n"); #endif break; case trap_FunctionEndBreakpoint: - (char *) context->sc_pc -= 1; - context->sc_pc = + SC_PC(context) -= 1; + SC_PC(context) = (int) handle_function_end_breakpoint(signal, code, context); break; @@ -303,11 +286,7 @@ 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 f01f1716e6fe97ea128e5378f3d369e4bf916b7a..bd6e11a5e4a1ad33bd3f2b003fd11ec8103276cc 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.10 2004/07/27 22:03:53 cwang Rel $ + * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/amd64-assem.S,v 1.11 2009/11/02 02:51:58 rtoy Exp $ * * 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 *%ebx + jmp *%rbx .size GNAME(call_into_c), . - GNAME(call_into_c) diff --git a/lisp/amd64-lispregs.h b/lisp/amd64-lispregs.h index 7cedf5bf3c30a13679d83db2c63379c4f6fb1a6b..1fb95cd8b3f26d409802d9a175943c08a0ca8ebf 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.4 2006/11/07 11:24:12 cshapiro Rel $ + * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/amd64-lispregs.h,v 1.5 2009/11/02 02:51:58 rtoy Exp $ */ /* These register names and offsets correspond to definitions @@ -52,7 +52,9 @@ * xxx-os.c handle it. */ -#define SC_REG(sc, n) (*sc_reg(sc,n)) -#define SC_PC(sc) ((sc)->sc_pc) +#define SC_REG(sc, n) (*os_sigcontext_reg(sc,n)) +#define SC_PC(sc) (*os_sigcontext_pc(sc)) +#define SC_EFLAGS(sc) ((sc)->uc_mcontext.gregs[REG_EFL]) +#define SC_SP(scp) SC_REG(scp, reg_RSP) #endif /* _AMD64_LISPREGS_H_ */ diff --git a/lisp/backtrace.c b/lisp/backtrace.c index 865ffab25185b26a59e787564a71aef64993bdfe..50489a508431e0333977accbcc119d2a11b47f58 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.17 2009/06/11 16:04:01 rtoy Rel $ +/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/backtrace.c,v 1.18 2009/11/02 02:51:58 rtoy Exp $ * * Simple backtrace facility. More or less from Rob's lisp version. */ @@ -497,8 +497,11 @@ backtrace(int nframes) unsigned long fp; int i; +#ifdef __x86_64 +#else __asm__("movl %%ebp,%0":"=g"(fp)); - +#endif + for (i = 0; i < nframes; ++i) { lispobj *p; unsigned long ra, next_fp; diff --git a/lisp/gencgc.c b/lisp/gencgc.c index 4c1fea5e4f796553989f24c02485244607a5e7f1..bc39798c5aa26890a217ad266bf0a2629d5882c0 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.99 2009/07/07 17:09:17 rtoy Rel $ + * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/gencgc.c,v 1.100 2009/11/02 02:51:58 rtoy Exp $ * */ @@ -3990,6 +3990,7 @@ 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)) @@ -4002,7 +4003,9 @@ scav_hash_entries(struct hash_table *hash_table, lispobj weak, int removep) if (removep) { free_hash_entry(hash_table, old_index, i); } - } else { + } else +#endif + { /* If the key is EQ-hashed and moves, schedule it for rehashing. */ scavenge(&kv_vector[2 * i], 2); #if 0 @@ -4069,6 +4072,7 @@ 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)) { @@ -4111,6 +4115,7 @@ scav_weak_entries(struct hash_table *hash_table) scavenged = 1; } } +#endif } return scavenged; diff --git a/lisp/gencgc.h b/lisp/gencgc.h index ea3023dd7186cd0863255359ad758ae0cd11e0c9..04989d5324f3715bc7f0cc065b45d4bf105b706e 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.14 2008/09/16 08:52:32 cshapiro Rel $ + * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/gencgc.h,v 1.15 2009/11/02 02:51:58 rtoy Exp $ * */ @@ -123,7 +123,7 @@ struct page { * write protected. */ -#if defined(i386) +#if defined(i386) || defined(__x86_64) #define PAGE_SIZE 4096 #elif defined(sparc) /* diff --git a/lisp/globals.h b/lisp/globals.h index 66a5766673b3d8b572134abe0a08795ca984c05f..4f3cee6c328188f54720152b742ccb8cd96fafbc 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.11 2009/01/05 22:26:27 rtoy Rel $ */ +/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/globals.h,v 1.12 2009/11/02 02:51:58 rtoy Exp $ */ #ifndef _GLOBALS_H_ #define _GLOBALS_H_ @@ -31,7 +31,7 @@ extern lispobj *control_stack_end; #endif extern lispobj *current_dynamic_space; -#if !defined(ibmrt) && !defined(i386) +#if !defined(ibmrt) && !defined(i386) && !defined(__x86_64) extern lispobj *current_dynamic_space_free_pointer; extern lispobj *current_auto_gc_trigger; #endif diff --git a/lisp/interrupt.c b/lisp/interrupt.c index 3ef79bde749425aa95dd9367363c036c74c19233..10f141cb665535e8499086d836f6cdc2394416b0 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.58 2009/07/07 17:06:54 rtoy Rel $ */ +/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/interrupt.c,v 1.59 2009/11/02 02:51:58 rtoy Exp $ */ /* Interrupt handling magic. */ @@ -22,6 +22,8 @@ #include "dynbind.h" #include "interr.h" +#include "bits/xopen_lim.h" + boolean internal_errors_enabled = 0; os_context_t *lisp_interrupt_contexts[MAX_INTERRUPTS]; diff --git a/tools/clean-target.sh b/tools/clean-target.sh index 6e5b074a77be0679c50e3bc5c55663fa94a8e31b..d994fc2e4c786d5c39371bbbbb389d875ff070d1 100755 --- a/tools/clean-target.sh +++ b/tools/clean-target.sh @@ -63,6 +63,7 @@ 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 b053290dab8f6a8f278a6a0312d08b499def50dc..d275638ea1c5b946fec8f5ced192e5422b7c9947 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") +(rename-package "X86" "OLD-X86" '("OLD-VM")) (setf (c:backend-name c:*native-backend*) "OLD-X86") (c::new-backend "AMD64" @@ -118,12 +118,25 @@ '(:x86 :i486 :pentium :x86-bootstrap :alpha :osf1 :mips :propagate-fun-type :propagate-float-type :constrain-float-type :openbsd :freebsd :glibc2 :linux :mp :heap-overflow-check - :long-float :new-random :small)) + :long-float :new-random :small + )) ;;; Compile the new backend. (pushnew :bootstrap *features*) (pushnew :building-cross-compiler *features*) +(in-package "VM") +(defconstant byte-bits 8 + "Number of bits per byte where a byte is the smallest addressable object.") + +(defconstant char-bits #-unicode 8 #+unicode 16 + "Number of bits needed to represent a character") + +(defconstant char-bytes (truncate char-bits byte-bits) + "Number of bytes needed to represent a character") + +(export '(byte-bits char-bits char-bytes) "VM") + (in-package :cl-user) (load "target:tools/comcom") @@ -204,30 +217,41 @@ (macrolet ((frob (&rest syms) `(progn ,@(mapcar #'(lambda (sym) `(defconstant ,sym - (symbol-value - (find-symbol ,(symbol-name sym) - :vm)))) + (symbol-value + (find-symbol ,(symbol-name sym) + :vm)))) syms)))) - (frob OLD-X86:BYTE-BITS - #+long-float OLD-X86:SIMPLE-ARRAY-LONG-FLOAT-TYPE - OLD-X86:SIMPLE-ARRAY-DOUBLE-FLOAT-TYPE - OLD-X86:SIMPLE-ARRAY-SINGLE-FLOAT-TYPE - #+long-float OLD-X86:SIMPLE-ARRAY-COMPLEX-LONG-FLOAT-TYPE - OLD-X86:SIMPLE-ARRAY-COMPLEX-DOUBLE-FLOAT-TYPE - OLD-X86:SIMPLE-ARRAY-COMPLEX-SINGLE-FLOAT-TYPE - OLD-X86:SIMPLE-ARRAY-UNSIGNED-BYTE-2-TYPE - OLD-X86:SIMPLE-ARRAY-UNSIGNED-BYTE-4-TYPE - OLD-X86:SIMPLE-ARRAY-UNSIGNED-BYTE-8-TYPE - OLD-X86:SIMPLE-ARRAY-UNSIGNED-BYTE-16-TYPE - OLD-X86:SIMPLE-ARRAY-UNSIGNED-BYTE-32-TYPE - OLD-X86:SIMPLE-ARRAY-SIGNED-BYTE-8-TYPE - OLD-X86:SIMPLE-ARRAY-SIGNED-BYTE-16-TYPE - OLD-X86:SIMPLE-ARRAY-SIGNED-BYTE-30-TYPE - OLD-X86:SIMPLE-ARRAY-SIGNED-BYTE-32-TYPE - OLD-X86:SIMPLE-BIT-VECTOR-TYPE - OLD-X86:SIMPLE-STRING-TYPE OLD-X86:SIMPLE-VECTOR-TYPE - OLD-X86:SIMPLE-ARRAY-TYPE OLD-X86:VECTOR-DATA-OFFSET - )) + (frob OLD-VM:BYTE-BITS OLD-VM:WORD-BITS + OLD-VM:CHAR-BITS + #+long-float OLD-VM:SIMPLE-ARRAY-LONG-FLOAT-TYPE + OLD-VM:SIMPLE-ARRAY-DOUBLE-FLOAT-TYPE + OLD-VM:SIMPLE-ARRAY-SINGLE-FLOAT-TYPE + #+long-float OLD-VM:SIMPLE-ARRAY-COMPLEX-LONG-FLOAT-TYPE + OLD-VM:SIMPLE-ARRAY-COMPLEX-DOUBLE-FLOAT-TYPE + OLD-VM:SIMPLE-ARRAY-COMPLEX-SINGLE-FLOAT-TYPE + OLD-VM:SIMPLE-ARRAY-UNSIGNED-BYTE-2-TYPE + OLD-VM:SIMPLE-ARRAY-UNSIGNED-BYTE-4-TYPE + OLD-VM:SIMPLE-ARRAY-UNSIGNED-BYTE-8-TYPE + OLD-VM:SIMPLE-ARRAY-UNSIGNED-BYTE-16-TYPE + OLD-VM:SIMPLE-ARRAY-UNSIGNED-BYTE-32-TYPE + OLD-VM:SIMPLE-ARRAY-SIGNED-BYTE-8-TYPE + OLD-VM:SIMPLE-ARRAY-SIGNED-BYTE-16-TYPE + OLD-VM:SIMPLE-ARRAY-SIGNED-BYTE-30-TYPE + OLD-VM:SIMPLE-ARRAY-SIGNED-BYTE-32-TYPE + OLD-VM:SIMPLE-BIT-VECTOR-TYPE + OLD-VM:SIMPLE-STRING-TYPE OLD-VM:SIMPLE-VECTOR-TYPE + OLD-VM:SIMPLE-ARRAY-TYPE OLD-VM:VECTOR-DATA-OFFSET + OLD-VM:DOUBLE-FLOAT-EXPONENT-BYTE + OLD-VM:DOUBLE-FLOAT-NORMAL-EXPONENT-MAX + OLD-VM:DOUBLE-FLOAT-SIGNIFICAND-BYTE + OLD-VM:SINGLE-FLOAT-EXPONENT-BYTE + OLD-VM:SINGLE-FLOAT-NORMAL-EXPONENT-MAX + OLD-VM:SINGLE-FLOAT-SIGNIFICAND-BYTE + ) + #+double-double + (frob OLD-VM:SIMPLE-ARRAY-COMPLEX-DOUBLE-DOUBLE-FLOAT-TYPE + OLD-VM:SIMPLE-ARRAY-DOUBLE-DOUBLE-FLOAT-TYPE + OLD-VM:DOUBLE-DOUBLE-FLOAT-DIGITS)) (let ((function (symbol-function 'kernel:error-number-or-lose))) (let ((*info-environment* (c:backend-info-environment c:*target-backend*))) @@ -277,3 +301,4 @@ (let ((ht (c::backend-sc-names c::*target-backend*))) (setf (gethash 'old-x86::any-reg ht) (gethash 'amd64::any-reg ht))) +