diff --git a/code/exports.lisp b/code/exports.lisp index c7e59f4edd2e395be32100377e330cf68fd5ba39..6f02e0dde6871dd2b065dce6f3d040ed9b73b9a0 100644 --- a/code/exports.lisp +++ b/code/exports.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/exports.lisp,v 1.140 1998/02/05 18:51:10 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.141 1998/02/19 10:52:10 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -1242,8 +1242,9 @@ "REMOVE-PORT-OBJECT" "REMOVE-XWINDOW-OBJECT" "RESOLVE-LOADED-ASSEMBLER-REFERENCES" "SAP+" "SAP-" "SAP-INT" "SAP-REF-16" "SAP-REF-32" "SAP-REF-8" "SAP-REF-DESCRIPTOR" - "SAP-REF-DOUBLE" "SAP-REF-SAP" "SAP-REF-SINGLE" "SAP<" "SAP<=" - "SAP=" "SAP>" "SAP>=" "SCRUB-CONTROL-STACK" "SERVE-ALL-EVENTS" + "SAP-REF-DOUBLE" "SAP-REF-LONG" "SAP-REF-SAP" "SAP-REF-SINGLE" + "SAP<" "SAP<=" "SAP=" "SAP>" "SAP>=" + "SCRUB-CONTROL-STACK" "SERVE-ALL-EVENTS" "SERVE-EVENT" "SERVER" "SERVER-MESSAGE" "SHORT-FLOAT-RADIX" "SIGNED-SAP-REF-16" "SIGNED-SAP-REF-32" "SIGNED-SAP-REF-8" "SINGLE-FLOAT-RADIX" "SYMBOL-MACRO-LET" "SYSTEM-AREA-POINTER" diff --git a/code/sap.lisp b/code/sap.lisp index 5bd6344c06a9afe6fa65520baad1629b8100f303..920a0148dd7235c91b59ae0b9cf042599587c2d0 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.13 1997/04/25 20:49:42 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/sap.lisp,v 1.14 1998/02/19 10:52:12 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -85,135 +85,164 @@ (defun sap-ref-8 (sap offset) "Returns the 8-bit byte at OFFSET bytes from SAP." (declare (type system-area-pointer sap) - #+(or x86 sparc) (fixnum offset) #-(or x86 sparc) (type index offset)) + #+(or x86 sparc) (fixnum offset) + #-(or x86 sparc) (type index offset)) (sap-ref-8 sap offset)) (defun sap-ref-16 (sap offset) "Returns the 16-bit word at OFFSET bytes from SAP." (declare (type system-area-pointer sap) - #+(or x86 sparc) (fixnum offset) #-(or x86 sparc) (type index offset)) + #+(or x86 sparc) (fixnum offset) + #-(or x86 sparc) (type index offset)) (sap-ref-16 sap offset)) (defun sap-ref-32 (sap offset) "Returns the 32-bit dualword at OFFSET bytes from SAP." (declare (type system-area-pointer sap) - #+(or x86 sparc) (fixnum offset) #-(or x86 sparc) (type index offset)) + #+(or x86 sparc) (fixnum offset) + #-(or x86 sparc) (type index offset)) (sap-ref-32 sap offset)) #+alpha (defun sap-ref-64 (sap offset) "Returns the 64-bit quadword at OFFSET bytes from SAP." (declare (type system-area-pointer sap) - #+(or x86 sparc) (fixnum offset) #-(or x86 sparc) (type index offset)) + #+(or x86 sparc) (fixnum offset) + #-(or x86 sparc) (type index offset)) (sap-ref-64 sap offset)) (defun sap-ref-sap (sap offset) "Returns the 32-bit system-area-pointer at OFFSET bytes from SAP." (declare (type system-area-pointer sap) - #+(or x86 sparc) (fixnum offset) #-(or x86 sparc) (type index offset)) + #+(or x86 sparc) (fixnum offset) + #-(or x86 sparc) (type index offset)) (sap-ref-sap sap offset)) (defun sap-ref-single (sap offset) "Returns the 32-bit single-float at OFFSET bytes from SAP." (declare (type system-area-pointer sap) - #+(or x86 sparc) (fixnum offset) #-(or x86 sparc) (type index offset)) + #+(or x86 sparc) (fixnum offset) + #-(or x86 sparc) (type index offset)) (sap-ref-single sap offset)) (defun sap-ref-double (sap offset) "Returns the 64-bit double-float at OFFSET bytes from SAP." (declare (type system-area-pointer sap) - #+(or x86 sparc) (fixnum offset) #-(or x86 sparc) (type index offset)) + #+(or x86 sparc) (fixnum offset) + #-(or x86 sparc) (type index offset)) (sap-ref-double sap offset)) +#+x86 +(defun sap-ref-long (sap offset) + "Returns the long-float at OFFSET bytes from SAP." + (declare (type system-area-pointer sap) + (fixnum offset)) + (sap-ref-long sap offset)) + (defun signed-sap-ref-8 (sap offset) "Returns the signed 8-bit byte at OFFSET bytes from SAP." (declare (type system-area-pointer sap) - #+(or x86 sparc) (fixnum offset) #-(or x86 sparc) (type index offset)) + #+(or x86 sparc) (fixnum offset) + #-(or x86 sparc) (type index offset)) (signed-sap-ref-8 sap offset)) (defun signed-sap-ref-16 (sap offset) "Returns the signed 16-bit word at OFFSET bytes from SAP." (declare (type system-area-pointer sap) - #+(or x86 sparc) (fixnum offset) #-(or x86 sparc) (type index offset)) + #+(or x86 sparc) (fixnum offset) + #-(or x86 sparc) (type index offset)) (signed-sap-ref-16 sap offset)) (defun signed-sap-ref-32 (sap offset) "Returns the signed 32-bit dualword at OFFSET bytes from SAP." (declare (type system-area-pointer sap) - #+(or x86 sparc) (fixnum offset) #-(or x86 sparc) (type index offset)) + #+(or x86 sparc) (fixnum offset) + #-(or x86 sparc) (type index offset)) (signed-sap-ref-32 sap offset)) #+alpha (defun signed-sap-ref-64 (sap offset) "Returns the signed 64-bit quadword at OFFSET bytes from SAP." (declare (type system-area-pointer sap) - #+(or x86 sparc) (fixnum offset) #-(or x86 sparc) (type index offset)) + #+(or x86 sparc) (fixnum offset) + #-(or x86 sparc) (type index offset)) (signed-sap-ref-64 sap offset)) (defun %set-sap-ref-8 (sap offset new-value) (declare (type system-area-pointer sap) - #+(or x86 sparc) (fixnum offset) #-(or x86 sparc) (type index offset) + #+(or x86 sparc) (fixnum offset) + #-(or x86 sparc) (type index offset) (type (unsigned-byte 8) new-value)) (setf (sap-ref-8 sap offset) new-value)) (defun %set-sap-ref-16 (sap offset new-value) (declare (type system-area-pointer sap) - #+(or x86 sparc) (fixnum offset) #-(or x86 sparc) (type index offset) + #+(or x86 sparc) (fixnum offset) + #-(or x86 sparc) (type index offset) (type (unsigned-byte 16) new-value)) (setf (sap-ref-16 sap offset) new-value)) (defun %set-sap-ref-32 (sap offset new-value) (declare (type system-area-pointer sap) - #+(or x86 sparc) (fixnum offset) #-(or x86 sparc) (type index offset) + #+(or x86 sparc) (fixnum offset) + #-(or x86 sparc) (type index offset) (type (unsigned-byte 32) new-value)) (setf (sap-ref-32 sap offset) new-value)) #+alpha (defun %set-sap-ref-64 (sap offset new-value) (declare (type system-area-pointer sap) - #+(or x86 sparc) (fixnum offset) #-(or x86 sparc) (type index offset) + #+(or x86 sparc) (fixnum offset) + #-(or x86 sparc) (type index offset) (type (unsigned-byte 64) new-value)) (setf (sap-ref-64 sap offset) new-value)) (defun %set-signed-sap-ref-8 (sap offset new-value) (declare (type system-area-pointer sap) - #+(or x86 sparc) (fixnum offset) #-(or x86 sparc) (type index offset) + #+(or x86 sparc) (fixnum offset) + #-(or x86 sparc) (type index offset) (type (signed-byte 8) new-value)) (setf (signed-sap-ref-8 sap offset) new-value)) (defun %set-signed-sap-ref-16 (sap offset new-value) (declare (type system-area-pointer sap) - #+(or x86 sparc) (fixnum offset) #-(or x86 sparc) (type index offset) + #+(or x86 sparc) (fixnum offset) + #-(or x86 sparc) (type index offset) (type (signed-byte 16) new-value)) (setf (signed-sap-ref-16 sap offset) new-value)) (defun %set-signed-sap-ref-32 (sap offset new-value) (declare (type system-area-pointer sap) - #+(or x86 sparc) (fixnum offset) #-(or x86 sparc) (type index offset) + #+(or x86 sparc) (fixnum offset) + #-(or x86 sparc) (type index offset) (type (signed-byte 32) new-value)) (setf (signed-sap-ref-32 sap offset) new-value)) #+alpha (defun %set-signed-sap-ref-64 (sap offset new-value) (declare (type system-area-pointer sap) - #+(or x86 sparc) (fixnum offset) #-(or x86 sparc) (type index offset) + #+(or x86 sparc) (fixnum offset) + #-(or x86 sparc) (type index offset) (type (signed-byte 64) new-value)) (setf (signed-sap-ref-64 sap offset) new-value)) (defun %set-sap-ref-sap (sap offset new-value) (declare (type system-area-pointer sap new-value) - #+(or x86 sparc) (fixnum offset) #-(or x86 sparc) (type index offset)) + #+(or x86 sparc) (fixnum offset) + #-(or x86 sparc) (type index offset)) (setf (sap-ref-sap sap offset) new-value)) (defun %set-sap-ref-single (sap offset new-value) (declare (type system-area-pointer sap) - #+(or x86 sparc) (fixnum offset) #-(or x86 sparc) (type index offset) + #+(or x86 sparc) (fixnum offset) + #-(or x86 sparc) (type index offset) (type single-float new-value)) (setf (sap-ref-single sap offset) new-value)) (defun %set-sap-ref-double (sap offset new-value) (declare (type system-area-pointer sap) - #+(or x86 sparc) (fixnum offset) #-(or x86 sparc) (type index offset) + #+(or x86 sparc) (fixnum offset) + #-(or x86 sparc) (type index offset) (type double-float new-value)) (setf (sap-ref-double sap offset) new-value)) diff --git a/code/x86-vm.lisp b/code/x86-vm.lisp index 387f5ecf0941962767931d5702642d0d14cc7ab3..b870031ef9d9e0673863365aab7023b0e30d9cb9 100644 --- a/code/x86-vm.lisp +++ b/code/x86-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/code/x86-vm.lisp,v 1.12 1998/01/16 07:22:13 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/x86-vm.lisp,v 1.13 1998/02/19 10:52:13 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -293,8 +293,7 @@ (#.edx-offset (slot scp 'sc-edx)) (#.ebx-offset (slot scp 'sc-ebx)) (#.esp-offset (slot scp 'sc-sp)) -#-linux (#.ebp-offset (slot scp 'sc-fp)) -#+linux (#.ebp-offset (slot scp 'ebp)) + (#.ebp-offset (slot scp #-linux 'sc-fp #+linux 'ebp)) (#.esi-offset (slot scp 'sc-esi)) (#.edi-offset (slot scp 'sc-edi))))) @@ -308,8 +307,7 @@ (#.edx-offset (setf (slot scp 'sc-edx) new)) (#.ebx-offset (setf (slot scp 'sc-ebx) new)) (#.esp-offset (setf (slot scp 'sc-sp) new)) -#-linux (#.ebp-offset (setf (slot scp 'sc-fp) new)) -#+linux (#.ebp-offset (setf (slot scp 'ebp) new)) + (#.ebp-offset (setf (slot scp #-linux 'sc-fp #+linux 'ebp) new)) (#.esi-offset (setf (slot scp 'sc-esi) new)) (#.edi-offset (setf (slot scp 'sc-edi) new)))) new) @@ -321,48 +319,23 @@ ;;; ;;; Like SIGCONTEXT-REGISTER, but returns the value of a float register. ;;; Format is the type of float to return. -;;; XXX -#-linux -(defun sigcontext-float-register (scp index format) - (declare (type (alien (* sigcontext)) scp)) - (with-alien ((scp (* sigcontext) scp)) - ;; fp regs not in sigcontext -- need new vop or c support - (let ((sap #+nil (alien-sap (slot scp 'sc-fpregs)))) - (declare (ignore sap)) - index - (ecase format - (single-float 0s0 - #+nil (system:sap-ref-single sap (* index vm:word-bytes))) - (double-float 0d0 - #+nil(system:sap-ref-double sap (* index vm:word-bytes))))))) - +;;; #+linux (defun sigcontext-float-register (scp index format) (declare (type (alien (* sigcontext)) scp)) (with-alien ((scp (* sigcontext) scp)) - ;; fp regs in sigcontext !!! (let ((reg-sap (alien-sap (deref (slot (deref (slot scp 'fpstate) 0) - 'fpreg) + 'fpreg) index)))) - (ecase format - (single-float - (system:sap-ref-single reg-sap 0)) - (double-float - (system:sap-ref-double reg-sap 0)))))) + (coerce (sys:sap-ref-long reg-sap 0) format)))) + +;;; Not supported on FreeBSD because the floating point state is not +;;; saved. +#+FreeBSD +(defun sigcontext-float-register (scp index format) + (declare (ignore scp index)) + (coerce 0l0 format)) -;;; -#-linux -(defun %set-sigcontext-float-register (scp index format new-value) - (declare (type (alien (* sigcontext)) scp)) - scp index format new-value - #+nil - (with-alien ((scp (* sigcontext) scp)) - (let ((sap (alien-sap (slot scp 'fpregs)))) - (ecase format - (single-float - (setf (sap-ref-single sap (* index vm:word-bytes)) new-value)) - (double-float - (setf (sap-ref-double sap (* index vm:word-bytes)) new-value)))))) #+linux (defun %set-sigcontext-float-register (scp index format new-value) (declare (type (alien (* sigcontext)) scp)) @@ -370,14 +343,17 @@ (let ((reg-sap (alien-sap (deref (slot (deref (slot scp 'fpstate) 0) 'fpreg) index)))) - (ecase format - (single-float - (setf (system:sap-ref-single reg-sap 0) new-value)) - (double-float - (setf (system:sap-ref-double reg-sap 0)new-value)))))) + #+not-yet + (setf (sys:sap-ref-long reg-sap 0) (coerce new-value 'long-float)) + (coerce new-value format)))) -;;; +;;; Not supported on FreeBSD. +#+FreeBSD +(defun %set-sigcontext-float-register (scp index format new-value) + (declare (ignore scp index)) + (coerce new-value format)) +;;; (defsetf sigcontext-float-register %set-sigcontext-float-register) ;;; SIGCONTEXT-FLOATING-POINT-MODES -- Interface diff --git a/compiler/saptran.lisp b/compiler/saptran.lisp index c91ad5f95d36cd1fd683028dd907cc62871ffd22..d5cc5507ecc635f6a66cf65bc093f17c0879a86f 100644 --- a/compiler/saptran.lisp +++ b/compiler/saptran.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/saptran.lisp,v 1.7 1997/04/25 20:49:43 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/saptran.lisp,v 1.8 1998/02/19 10:52:19 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -102,6 +102,9 @@ (flushable)) (defknown sap-ref-double (system-area-pointer #+(or x86 sparc) fixnum #-(or x86 sparc) index) double-float (flushable)) +#+x86 +(defknown sap-ref-long (system-area-pointer fixnum) long-float + (flushable)) (defknown %set-sap-ref-single (system-area-pointer #+(or x86 sparc) fixnum #-(or x86 sparc) index single-float) single-float @@ -138,7 +141,8 @@ signed-sap-ref-32 %set-signed-sap-ref-32 sap-ref-sap %set-sap-ref-sap sap-ref-single %set-sap-ref-single - sap-ref-double %set-sap-ref-double)) + sap-ref-double %set-sap-ref-double + #+x86 sap-ref-long)) (deftransform fun ((sap offset) '* '* :eval-name t) (extract-function-args sap 'sap+ 2) `(lambda (sap offset1 offset2) diff --git a/compiler/x86/sap.lisp b/compiler/x86/sap.lisp index 30f8ac1e3bc993e1500fcacbd9ec1be64f59152e..7b64352df20ae1cee09c20659ab9ec3e4c2d1b9e 100644 --- a/compiler/x86/sap.lisp +++ b/compiler/x86/sap.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/x86/sap.lisp,v 1.6 1997/11/19 03:00:39 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/sap.lisp,v 1.7 1998/02/19 10:52:16 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -441,6 +441,32 @@ (inst fst result)) (inst fxch value))))))) + +;;; Sap-Ref-Long +(define-vop (sap-ref-long) + (:translate sap-ref-long) + (:policy :fast-safe) + (:args (sap :scs (sap-reg)) + (offset :scs (signed-reg))) + (:arg-types system-area-pointer signed-num) + (:results (result :scs (#+long-float long-reg #-long-float double-reg))) + (:result-types #+long-float long-float #-long-float double-float) + (:generator 5 + (with-empty-tn@fp-top(result) + (inst fldl (make-ea :dword :base sap :index offset))))) + +(define-vop (sap-ref-long-c) + (:translate sap-ref-long) + (:policy :fast-safe) + (:args (sap :scs (sap-reg))) + (:arg-types system-area-pointer (:constant (signed-byte 32))) + (:info offset) + (:results (result :scs (#+long-float long-reg #-long-float double-reg))) + (:result-types #+long-float long-float #-long-float double-float) + (:generator 4 + (with-empty-tn@fp-top(result) + (inst fldl (make-ea :dword :base sap :disp offset))))) + ;;; Noise to convert normal lisp data objects into SAPs.