arrange_return_to_lisp_function(), but this looked hard to do in
general without suffering from memory leaks.
-378: floating-point exceptions not signalled on x86-64
- Floating point traps are currently not enabled on the x86-64 port.
- This is true for at least overflow detection (as tested in
- float.pure.lisp) and divide-by-zero.
-
379: TRACE :ENCAPSULATE NIL broken on ppc/darwin
See commented-out test-case in debug.impure.lisp.
* Check that the host lisp you're building with is known to work
as an SBCL build host, and the your OS is supported.
+
+ * Try to do a build without loading any initialization files
+ for the cross-compilation host (for example
+ "sh make.sh 'sbcl --userinit /dev/null --sysinit /dev/null'").
* Some GCC versions are known to have bugs that affect SBCL
compilation: if the error you're encountering seems related to
or more runtime options were provided to the sbcl binary.
* compiled code is not steppable if COMPILATION-SPEED >= DEBUG.
* contrib improvement: implement SB-POSIX:MKSTEMP (Yannick Gingras)
- * optimization: There's now a fast-path for fixnum arguments in the
+ * optimization: there's now a fast-path for fixnum arguments in the
generic subtraction routines on x86/x86-64. (Thanks to Lutz Euler)
+ * optimization: the code generated on x86-64 is more compact thanks
+ to not outputting unneccessary prefix bytes. (Thanks to Lutz Euler)
+ * bug fix: floating-point exception handling now works on x86-64.
+ (Thanks to James Knight)
* fixed some bugs revealed by Paul Dietz' test suite:
** the type-error signalled from WARN has a filled-in DATUM slot.
** the type-error required when a stream is not associated with
build_started=`date`
echo "//starting build: $build_started"
-SBCL_XC_HOST="${1:-sbcl --disable-debugger}"
+SBCL_XC_HOST="${1:-sbcl --disable-debugger --userinit /dev/null --sysinit /dev/null}"
export SBCL_XC_HOST
echo //SBCL_XC_HOST=\"$SBCL_XC_HOST\"
;;; Given a signal context, return the floating point modes word in
;;; the same format as returned by FLOATING-POINT-MODES.
+#!-linux
(defun context-floating-point-modes (context)
(declare (ignore context)) ; stub!
(warn "stub CONTEXT-FLOATING-POINT-MODES")
0)
+#!+linux
+(define-alien-routine ("os_context_fp_control" context-floating-point-modes)
+ (sb!alien:unsigned 32)
+ (context (* os-context-t)))
\f
;;;; INTERNAL-ERROR-ARGS
(sc-offsets sc-offset)))
(values error-number (sc-offsets)))))))
\f
-;;; This is used in error.lisp to insure that floating-point exceptions
-;;; are properly trapped. The compiler translates this to a VOP.
-(defun float-wait ()
- (float-wait))
-
-;;; float constants
-;;;
-;;; These are used by the FP MOVE-FROM-{SINGLE|DOUBLE} VOPs rather
-;;; than the i387 load constant instructions to avoid consing in some
-;;; cases. Note these are initialized by GENESIS as they are needed
-;;; early.
-(defvar *fp-constant-0f0*)
-(defvar *fp-constant-1f0*)
-(defvar *fp-constant-0d0*)
-(defvar *fp-constant-1d0*)
-;;; the long-float constants
-(defvar *fp-constant-0l0*)
-(defvar *fp-constant-1l0*)
-(defvar *fp-constant-pi*)
-(defvar *fp-constant-l2t*)
-(defvar *fp-constant-l2e*)
-(defvar *fp-constant-lg2*)
-(defvar *fp-constant-ln2*)
;;; the current alien stack pointer; saved/restored for non-local exits
(defvar *alien-stack*)
-
-;;; Support for the MT19937 random number generator. The update
-;;; function is implemented as an assembly routine. This definition is
-;;; transformed to a call to the assembly routine allowing its use in
-;;; interpreted code.
-#+nil
-(defun random-mt19937 (state)
- (declare (type (simple-array (unsigned-byte 32) (627)) state))
- (random-mt19937 state))
(defun ea-for-df-stack (tn)
(ea-for-xf-stack tn :double)))
-;;; Telling the FPU to wait is required in order to make signals occur
-;;; at the expected place, but naturally slows things down.
-;;;
-;;; NODE is the node whose compilation policy controls the decision
-;;; whether to just blast through carelessly or carefully emit wait
-;;; instructions and whatnot.
-;;;
-;;; NOTE-NEXT-INSTRUCTION, if supplied, is to be passed to
-;;; #'NOTE-NEXT-INSTRUCTION.
-(defun maybe-fp-wait (node &optional note-next-instruction)
- (when (policy node (or (= debug 3) (> safety speed))))
- (when note-next-instruction
- (note-next-instruction note-next-instruction :internal-error))
- #+nil
- (inst wait))
-
;;; complex float stack EAs
(macrolet ((ea-for-cxf-stack (tn kind slot &optional base)
(declare (ignore kind))
(define-move-vop move-from-double :move
(double-reg) (descriptor-reg))
-#+nil
-(define-vop (move-from-fp-constant)
- (:args (x :scs (fp-constant)))
- (:results (y :scs (descriptor-reg)))
- (:generator 2
- (ecase (sb!c::constant-value (sb!c::tn-leaf x))
- (0f0 (load-symbol-value y *fp-constant-0f0*))
- (1f0 (load-symbol-value y *fp-constant-1f0*))
- (0d0 (load-symbol-value y *fp-constant-0d0*))
- (1d0 (load-symbol-value y *fp-constant-1d0*)))))
-#+nil
-(define-move-vop move-from-fp-constant :move
- (fp-constant) (descriptor-reg))
-
;;; Move from a descriptor to a float register.
(define-vop (move-to-single)
(:args (x :scs (descriptor-reg) :target tmp))
(frob %single-float/signed %single-float cvtsi2ss single-reg single-float)
(frob %double-float/signed %double-float cvtsi2sd double-reg double-float))
-#+nil
-(macrolet ((frob (name translate inst to-sc to-type)
- `(define-vop (,name)
- (:args (x :scs (unsigned-reg)))
- (:results (y :scs (,to-sc)))
- (:arg-types unsigned-num)
- (:result-types ,to-type)
- (:policy :fast-safe)
- (:note "inline float coercion")
- (:translate ,translate)
- (:vop-var vop)
- (:save-p :compute-only)
- (:generator 6
- (inst ,inst y x)))))
- (frob %single-float/unsigned %single-float cvtsi2ss single-reg single-float)
- (frob %double-float/unsigned %double-float cvtsi2sd double-reg double-float))
-
(macrolet ((frob (name translate inst from-sc from-type to-sc to-type)
`(define-vop (,name)
(:args (x :scs (,from-sc) :target y))
(frob %unary-round cvtss2si single-reg single-float t)
(frob %unary-round cvtsd2si double-reg double-float t))
-#+nil ;; will we need this?
-(macrolet ((frob (trans from-sc from-type round-p)
- `(define-vop (,(symbolicate trans "/" from-type "=>UNSIGNED"))
- (:args (x :scs (,from-sc) :target fr0))
- (:temporary (:sc double-reg :offset fr0-offset
- :from :argument :to :result) fr0)
- ,@(unless round-p
- '((:temporary (:sc unsigned-stack) stack-temp)
- (:temporary (:sc unsigned-stack) scw)
- (:temporary (:sc any-reg) rcw)))
- (:results (y :scs (unsigned-reg)))
- (:arg-types ,from-type)
- (:result-types unsigned-num)
- (:translate ,trans)
- (:policy :fast-safe)
- (:note "inline float truncate")
- (:vop-var vop)
- (:save-p :compute-only)
- (:generator 5
- ,@(unless round-p
- '((note-this-location vop :internal-error)
- ;; Catch any pending FPE exceptions.
- (inst wait)))
- ;; Normal mode (for now) is "round to best".
- (unless (zerop (tn-offset x))
- (copy-fp-reg-to-fr0 x))
- ,@(unless round-p
- '((inst fnstcw scw) ; save current control word
- (move rcw scw) ; into 16-bit register
- (inst or rcw (ash #b11 10)) ; CHOP
- (move stack-temp rcw)
- (inst fldcw stack-temp)))
- (inst sub rsp-tn 8)
- (inst fistpl (make-ea :dword :base rsp-tn))
- (inst pop y)
- (inst fld fr0) ; copy fr0 to at least restore stack.
- (inst add rsp-tn 8)
- ,@(unless round-p
- '((inst fldcw scw)))))))
- (frob %unary-truncate single-reg single-float nil)
- (frob %unary-truncate double-reg double-float nil)
- (frob %unary-round single-reg single-float t)
- (frob %unary-round double-reg double-float t))
-
(define-vop (make-single-float)
(:args (bits :scs (signed-reg) :target res
:load-if (not (or (and (sc-is bits signed-stack)
(sc-is res single-stack)
(location= bits res))))))
(:results (res :scs (single-reg single-stack)))
- ; (:temporary (:sc signed-stack) stack-temp)
(:arg-types signed-num)
(:result-types single-float)
(:translate make-single-float)
(defparameter *byte-reg-names*
#(al cl dl bl spl bpl sil dil r8b r9b r10b r11b r12b r13b r14b r15b))
+(defparameter *high-byte-reg-names*
+ #(ah ch dh bh))
(defparameter *word-reg-names*
#(ax cx dx bx sp bp si di r8w r9w r10w r11w r12w r13w r14w r15w))
(defparameter *dword-reg-names*
:word
:qword))
+;;; Print to STREAM the name of the general purpose register encoded by
+;;; VALUE and of size WIDTH. For robustness, the high byte registers
+;;; (AH, BH, CH, DH) are correctly detected, too, although the compiler
+;;; does not use them.
(defun print-reg-with-width (value width stream dstate)
(declare (type full-reg value)
(type stream stream)
- (ignore dstate))
- (princ (aref (ecase width
- (:byte *byte-reg-names*)
- (:word *word-reg-names*)
- (:dword *dword-reg-names*)
- (:qword *qword-reg-names*))
- value)
+ (type sb!disassem:disassem-state dstate))
+ (princ (if (and (eq width :byte)
+ (<= 4 value 7)
+ (not (sb!disassem:dstate-get-inst-prop dstate 'rex)))
+ (aref *high-byte-reg-names* (- value 4))
+ (aref (ecase width
+ (:byte *byte-reg-names*)
+ (:word *word-reg-names*)
+ (:dword *dword-reg-names*)
+ (:qword *qword-reg-names*))
+ value))
stream)
;; XXX plus should do some source-var notes
)
(defstruct (ea (:constructor make-ea (size &key base index scale disp))
(:copier nil))
- ;; note that we can represent an EA qith a QWORD size, but EMIT-EA
+ ;; note that we can represent an EA with a QWORD size, but EMIT-EA
;; can't actually emit it on its own: caller also needs to emit REX
;; prefix
(size nil :type (member :byte :word :dword :qword))
(eq size +default-operand-size+))
(emit-byte segment +operand-size-prefix-byte+)))
+;;; A REX prefix must be emitted if at least one of the following
+;;; conditions is true:
+;; 1. The operand size is :QWORD and the default operand size of the
+;; instruction is not :QWORD.
+;;; 2. The instruction references an extended register.
+;;; 3. The instruction references one of the byte registers SIL, DIL,
+;;; SPL or BPL.
+
+;;; Emit a REX prefix if necessary. OPERAND-SIZE is used to determine
+;;; whether to set REX.W. Callers pass it explicitly as :DO-NOT-SET if
+;;; this should not happen, for example because the instruction's
+;;; default operand size is qword. R, X and B are NIL or TNs specifying
+;;; registers the encodings of which are extended with the REX.R, REX.X
+;;; and REX.B bit, respectively. To determine whether one of the byte
+;;; registers is used that can only be accessed using a REX prefix, we
+;;; need only to test R and B, because X is only used for the index
+;;; register of an effective address and therefore never byte-sized.
+;;; For R we can avoid to calculate the size of the TN because it is
+;;; always OPERAND-SIZE. The size of B must be calculated here because
+;;; B can be address-sized (if it is the base register of an effective
+;;; address), of OPERAND-SIZE (if the instruction operates on two
+;;; registers) or of some different size (in the instructions that
+;;; combine arguments of different sizes: MOVZX, MOVSX, MOVSXD).
+;;; We don't distinguish between general purpose and floating point
+;;; registers for this cause because only general purpose registers can
+;;; be byte-sized at all.
(defun maybe-emit-rex-prefix (segment operand-size r x b)
+ (declare (type (member nil :byte :word :dword :qword :float :double
+ :do-not-set)
+ operand-size)
+ (type (or null tn) r x b))
(labels ((if-hi (r)
(if (and r (> (tn-offset r)
;; offset of r8 is 16, offset of xmm8 is 8
7
15)))
1
- 0)))
+ 0))
+ (reg-4-7-p (r)
+ ;; Assuming R is a TN describing a general purpose
+ ;; register, return true if it references register
+ ;; 4 upto 7.
+ (<= 8 (tn-offset r) 15)))
(let ((rex-w (if (eq operand-size :qword) 1 0))
(rex-r (if-hi r))
(rex-x (if-hi x))
(rex-b (if-hi b)))
- (when (or (eq operand-size :byte) ;; REX needed to access SIL/DIL
- (not (zerop (logior rex-w rex-r rex-x rex-b))))
+ (when (or (not (zerop (logior rex-w rex-r rex-x rex-b)))
+ (and r
+ (eq operand-size :byte)
+ (reg-4-7-p r))
+ (and b
+ (eq (operand-size b) :byte)
+ (reg-4-7-p b)))
(emit-rex-byte segment #b0100 rex-w rex-r rex-x rex-b)))))
-(defun maybe-emit-rex-for-ea (segment ea reg &key operand-size)
- (let ((ea-p (ea-p ea))) ;emit-ea can also be called with a tn
+;;; Emit a REX prefix if necessary. The operand size is determined from
+;;; THING or can be overwritten by OPERAND-SIZE. This and REG are always
+;;; passed to MAYBE-EMIT-REX-PREFIX. Additionally, if THING is an EA we
+;;; pass its index and base registers, if it is a register TN, we pass
+;;; only itself.
+;;; In contrast to EMIT-EA above, neither stack TNs nor fixups need to
+;;; be treated specially here: If THING is a stack TN, neither it nor
+;;; any of its components are passed to MAYBE-EMIT-REX-PREFIX which
+;;; works correctly because stack references always use RBP as the base
+;;; register and never use an index register so no extended registers
+;;; need to be accessed. Fixups are assembled using an addressing mode
+;;; of displacement-only or RIP-plus-displacement (see EMIT-EA), so may
+;;; not reference an extended register. The displacement-only addressing
+;;; mode requires that REX.X is 0, which is ensured here.
+(defun maybe-emit-rex-for-ea (segment thing reg &key operand-size)
+ (declare (type (or ea tn fixup) thing)
+ (type (or null tn) reg)
+ (type (member nil :byte :word :dword :qword :float :double
+ :do-not-set)
+ operand-size))
+ (let ((ea-p (ea-p thing)))
(maybe-emit-rex-prefix segment
- (or operand-size (operand-size ea))
+ (or operand-size (operand-size thing))
reg
- (and ea-p (ea-index ea))
- (cond (ea-p (ea-base ea))
- ((and (tn-p ea)
- (member (sb-name (sc-sb (tn-sc ea)))
+ (and ea-p (ea-index thing))
+ (cond (ea-p (ea-base thing))
+ ((and (tn-p thing)
+ (member (sb-name (sc-sb (tn-sc thing)))
'(float-registers registers)))
- ea)
+ thing)
(t nil)))))
(defun operand-size (thing)
(:word
(aver (eq src-size :byte))
(maybe-emit-operand-size-prefix segment :word)
+ ;; REX prefix is needed if SRC is SIL, DIL, SPL or BPL.
+ (maybe-emit-rex-for-ea segment src dst :operand-size :word)
(emit-byte segment #b00001111)
(emit-byte segment opcode)
(emit-ea segment src (reg-tn-encoding dst)))
((:dword :qword)
(ecase src-size
(:byte
- (maybe-emit-operand-size-prefix segment :dword)
- (maybe-emit-rex-for-ea segment src dst
- :operand-size (operand-size dst))
+ (maybe-emit-rex-for-ea segment src dst :operand-size dst-size)
(emit-byte segment #b00001111)
(emit-byte segment opcode)
(emit-ea segment src (reg-tn-encoding dst)))
(:word
- (maybe-emit-rex-for-ea segment src dst
- :operand-size (operand-size dst))
+ (maybe-emit-rex-for-ea segment src dst :operand-size dst-size)
(emit-byte segment #b00001111)
(emit-byte segment (logior opcode 1))
(emit-ea segment src (reg-tn-encoding dst)))
(emit-byte segment #b01101010)
(emit-byte segment src))
(t
- ;; AMD64 manual says no REX needed but is unclear
- ;; whether it expects 32 or 64 bit immediate here
+ ;; A REX-prefix is not needed because the operand size
+ ;; defaults to 64 bits. The size of the immediate is 32
+ ;; bits and it is sign-extended.
(emit-byte segment #b01101000)
(emit-dword segment src))))
(t
(let ((size (operand-size src)))
(aver (not (eq size :byte)))
(maybe-emit-operand-size-prefix segment size)
- (maybe-emit-rex-for-ea segment src nil)
+ (maybe-emit-rex-for-ea segment src nil :operand-size :do-not-set)
(cond ((register-p src)
(emit-byte-with-reg segment #b01010 (reg-tn-encoding src)))
(t
(let ((size (operand-size dst)))
(aver (not (eq size :byte)))
(maybe-emit-operand-size-prefix segment size)
- (maybe-emit-rex-for-ea segment dst nil)
+ (maybe-emit-rex-for-ea segment dst nil :operand-size :do-not-set)
(cond ((register-p dst)
(emit-byte-with-reg segment #b01011 (reg-tn-encoding dst)))
(t
(:emitter
(typecase where
(label
- (maybe-emit-rex-for-ea segment where nil)
(emit-byte segment #b11101000) ; 32 bit relative
(emit-back-patch segment
4
(- (label-position where)
(+ posn 4))))))
(fixup
- (maybe-emit-rex-for-ea segment where nil)
(emit-byte segment #b11101000)
(emit-relative-fixup segment where))
(t
- (maybe-emit-rex-for-ea segment where nil)
+ (maybe-emit-rex-for-ea segment where nil :operand-size :do-not-set)
(emit-byte segment #b11111111)
(emit-ea segment where #b010)))))
(error "don't know what to do with ~A" where))
;; near jump defaults to 64 bit
;; w-bit in rex prefix is unnecessary
- (maybe-emit-rex-for-ea segment where nil :operand-size :dword)
+ (maybe-emit-rex-for-ea segment where nil :operand-size :do-not-set)
(emit-byte segment #b11111111)
(emit-ea segment where #b100)))))
(in-package "SB!VM")
-;;; We can load/store into fp registers through the top of stack
-;;; %st(0) (fr0 here). Loads imply a push to an empty register which
-;;; then changes all the reg numbers. These macros help manage that.
-
-;;; Use this when we don't have to load anything. It preserves old tos
-;;; value, but probably destroys tn with operation.
-(defmacro with-tn@fp-top((tn) &body body)
- `(progn
- (unless (zerop (tn-offset ,tn))
- (inst fxch ,tn))
- ,@body
- (unless (zerop (tn-offset ,tn))
- (inst fxch ,tn))))
-
-;;; Use this to prepare for load of new value from memory. This
-;;; changes the register numbering so the next instruction had better
-;;; be a FP load from memory; a register load from another register
-;;; will probably be loading the wrong register!
-(defmacro with-empty-tn@fp-top((tn) &body body)
- `(progn
- (inst fstp ,tn)
- ,@body
- (unless (zerop (tn-offset ,tn))
- (inst fxch ,tn)))) ; save into new dest and restore st(0)
-\f
;;;; instruction-like macros
(defmacro move (dst src)
*fp-constant-1d0*
*fp-constant-0f0*
*fp-constant-1f0*
- ;; The following are all long-floats.
- *fp-constant-0l0*
- *fp-constant-1l0*
- *fp-constant-pi*
- *fp-constant-l2t*
- *fp-constant-l2e*
- *fp-constant-lg2*
- *fp-constant-ln2*
;; The ..SLOT-UNBOUND.. symbol is static in order to optimise the
;; common slot unbound check.
sb!kernel:two-arg-xor
sb!kernel:two-arg-gcd
sb!kernel:two-arg-lcm))
-\f
-;;;; stuff added by jrd
-
-;;; FIXME: Is this used? Delete it or document it.
-;;; cf the sparc PARMS.LISP
-(defparameter *assembly-unit-length* 8)
unsigned long
os_context_fp_control(os_context_t *context)
{
-#if 0
- return ((((context->uc_mcontext.fpregs->cw) & 0xffff) ^ 0x3f) |
- (((context->uc_mcontext.fpregs->sw) & 0xffff) << 16));
-#else
- return 0;
-#endif
+ int mxcsr = context->uc_mcontext.fpregs->mxcsr;
+ return ((mxcsr & 0x3F) << 16 | ((mxcsr >> 7) & 0x3F)) ^ 0x3F;
}
sigset_t *
void
os_restore_fp_control(os_context_t *context)
{
-#if 0
- asm ("fldcw %0" : : "m" (context->uc_mcontext.fpregs->cw));
-#endif
+ asm ("ldmxcsr %0" : : "m" (context->uc_mcontext.fpregs->mxcsr));
}
void
least-positive-double-float))
(assert (= 0.0 (scale-float 1.0 most-negative-fixnum)))
(assert (= 0.0d0 (scale-float 1.0d0 (1- most-negative-fixnum))))
-#-(or darwin x86-64) ;; bug 372 / 378
+#-(or darwin) ;; bug 372
(progn
(assert (raises-error? (scale-float 1.0 most-positive-fixnum)
floating-point-overflow))
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.9.0.36"
+"0.9.0.37"
projects / sbcl.git / commitdiff