From: Daniel Barlow Date: Mon, 5 Apr 2004 23:16:18 +0000 (+0000) Subject: 0.8.9.18 X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=7646aefa188758e2892fea2ad02be4f29b3938f2;p=sbcl.git 0.8.9.18 Some cosmetic cleanups to make this a better place to start a new x86-64 branch ... remove large chunks of long-float: it didn't work anyway ... parms.lisp happens fractionally earlier so that we can defconstant nil-value slightly more cleanly some raw 3s and 4s get made into functions of n-lowtag-bits --- diff --git a/build-order.lisp-expr b/build-order.lisp-expr index 3b5b727..0274a1d 100644 --- a/build-order.lisp-expr +++ b/build-order.lisp-expr @@ -100,9 +100,9 @@ ;; for various constants e.g. SB!XC:MOST-POSITIVE-FIXNUM and ;; SB!VM:N-LOWTAG-BITS, needed by "early-objdef" and others + ("src/compiler/target/parms") ("src/compiler/generic/early-vm") ("src/compiler/generic/early-objdef") - ("src/compiler/target/parms") ("src/code/early-array") ; needs "early-vm" numbers ("src/code/early-extensions") ; on host for COLLECT, SYMBOLICATE, etc. @@ -227,6 +227,7 @@ #!+sparc ("src/code/sparc-vm" :not-host) #!+hppa ("src/code/hppa-vm" :not-host) #!+x86 ("src/code/x86-vm" :not-host) + #!+x86-64("src/code/x86-64-vm" :not-host) #!+ppc ("src/code/ppc-vm" :not-host) #!+alpha ("src/code/alpha-vm" :not-host) #!+mips ("src/code/mips-vm" :not-host) diff --git a/src/code/cold-init.lisp b/src/code/cold-init.lisp index a360161..62f72e8 100644 --- a/src/code/cold-init.lisp +++ b/src/code/cold-init.lisp @@ -289,17 +289,7 @@ instead (which is another name for the same thing).")) ;; disabled by default. Joe User can explicitly enable them if ;; desired. (set-floating-point-modes :traps '(:overflow :invalid :divide-by-zero)) - (sb!thread::maybe-install-futex-functions) - - ;; Clear pseudo atomic in case this core wasn't compiled with - ;; support. - ;; - ;; FIXME: In SBCL our cores are always compiled with support. So - ;; we don't need to do this, do we? At least not for this - ;; reason.. (Perhaps we should do it anyway in case someone - ;; manages to save an image from within a pseudo-atomic-atomic - ;; operation?) - #!+x86 (setf *pseudo-atomic-atomic* 0))) + (sb!thread::maybe-install-futex-functions))) (gc-on) (gc)) diff --git a/src/code/early-float.lisp b/src/code/early-float.lisp index 35d3d15..edddac1 100644 --- a/src/code/early-float.lisp +++ b/src/code/early-float.lisp @@ -103,21 +103,13 @@ (defconstant most-positive-double-float (double-from-bits 0 sb!vm:double-float-normal-exponent-max (ldb (byte sb!vm:double-float-digits 0) -1))) -#!-long-float + (defconstant most-positive-long-float most-positive-double-float) -#!+(and long-float x86) -(defconstant most-positive-long-float - (long-from-bits 0 sb!vm:long-float-normal-exponent-max - (ldb (byte sb!vm:long-float-digits 0) -1))) + (defconstant most-negative-double-float (double-from-bits 1 sb!vm:double-float-normal-exponent-max (ldb (byte sb!vm:double-float-digits 0) -1))) -#!-long-float (defconstant most-negative-long-float most-negative-double-float) -#!+(and long-float x86) -(defconstant most-negative-long-float - (long-from-bits 1 sb!vm:long-float-normal-exponent-max - (ldb (byte sb!vm:long-float-digits 0) -1))) ;;; We don't want to do these DEFCONSTANTs at cross-compilation time, ;;; because the cross-compilation host might not support floating diff --git a/src/code/fop.lisp b/src/code/fop.lisp index 2612386..20f7ad7 100644 --- a/src/code/fop.lisp +++ b/src/code/fop.lisp @@ -292,14 +292,7 @@ '(make-single-float (fast-read-s-integer 4))) (fast-read-double-float () '(let ((lo (fast-read-u-integer 4))) - (make-double-float (fast-read-s-integer 4) lo))) - #!+long-float - (fast-read-long-float () - '(let ((lo (fast-read-u-integer 4)) - #!+sparc (mid (fast-read-u-integer 4)) - (hi (fast-read-u-integer 4)) ; XXX - (exp (fast-read-s-integer #!+x86 2 #!+sparc 4))) - (make-long-float exp hi #!+sparc mid lo)))) + (make-double-float (fast-read-s-integer 4) lo)))) (macrolet ((define-complex-fop (name fop-code type) (let ((reader (symbolicate "FAST-READ-" type))) `(define-fop (,name ,fop-code) @@ -404,16 +397,6 @@ (read-n-bytes *fasl-input-stream* result 0 (* length sb!vm:n-word-bytes 2)) result)) -#!+long-float -(define-fop (fop-long-float-vector 88) - (let* ((length (read-arg 4)) - (result (make-array length :element-type 'long-float))) - (read-n-bytes *fasl-input-stream* - result - 0 - (* length sb!vm:n-word-bytes #!+x86 3 #!+sparc 4)) - result)) - (define-fop (fop-complex-single-float-vector 86) (let* ((length (read-arg 4)) (result (make-array length :element-type '(complex single-float)))) @@ -429,14 +412,6 @@ (* length sb!vm:n-word-bytes 2 2)) result)) -#!+long-float -(define-fop (fop-complex-long-float-vector 89) - (let* ((length (read-arg 4)) - (result (make-array length :element-type '(complex long-float)))) - (read-n-bytes *fasl-input-stream* result 0 - (* length sb!vm:n-word-bytes #!+x86 3 #!+sparc 4 2)) - result)) - ;;; CMU CL comment: ;;; *** NOT *** the FOP-INT-VECTOR as currently documented in rtguts. ;;; Size must be a directly supported I-vector element size, with no diff --git a/src/code/host-alieneval.lisp b/src/code/host-alieneval.lisp index e9fe96a..cca16ed 100644 --- a/src/code/host-alieneval.lisp +++ b/src/code/host-alieneval.lisp @@ -760,19 +760,6 @@ (declare (ignore type)) `(sap-ref-double ,sap (/ ,offset sb!vm:n-byte-bits))) -#!+long-float -(define-alien-type-class (long-float :include (float (bits #!+x86 96 - #!+sparc 128)) - :include-args (type))) - -#!+long-float -(define-alien-type-translator long-float () - (make-alien-long-float-type :type 'long-float)) - -#!+long-float -(define-alien-type-method (long-float :extract-gen) (type sap offset) - (declare (ignore type)) - `(sap-ref-long ,sap (/ ,offset sb!vm:n-byte-bits))) ;;;; the POINTER type diff --git a/src/code/target-load.lisp b/src/code/target-load.lisp index 2e687c5..07703d9 100644 --- a/src/code/target-load.lisp +++ b/src/code/target-load.lisp @@ -261,7 +261,7 @@ tto) (format t " loading to the dynamic space~%")) - (let ((code (%primitive sb!c:allocate-dynamic-code-object + (let ((code (%primitive sb!c:allocate-code-object box-num code-length)) (index (+ sb!vm:code-trace-table-offset-slot box-num))) diff --git a/src/code/target-random.lisp b/src/code/target-random.lisp index e7a65a7..aa87cad 100644 --- a/src/code/target-random.lisp +++ b/src/code/target-random.lisp @@ -61,7 +61,7 @@ of the default random state. If STATE is a random state, then return a copy of it. If STATE is T then return a random state generated from the universal time." - (/show0 "entering !RANDOM-COLD-INIT") + (/show0 "entering MAKE-RANDOM-STATE") (flet ((copy-random-state (state) (/show0 "entering COPY-RANDOM-STATE") (let ((state (random-state-state state)) @@ -213,35 +213,6 @@ (sb!vm::random-mt19937 state-vector)) 1d0)))) -#!+long-float -(declaim #!-sb-fluid (inline %random-long-float)) -#!+long-float -(declaim (ftype (function ((long-float (0l0)) random-state) (long-float 0l0)) - %random-long-float)) - -;;; using a faster inline VOP -#!+(and long-float x86) -(defun %random-long-float (arg state) - (declare (type (long-float (0l0)) arg) - (type random-state state)) - (let ((state-vector (random-state-state state))) - (* arg - (- (sb!impl::make-long-float - (sb!impl::long-float-exp-bits 1l0) - (logior (sb!vm::random-mt19937 state-vector) - sb!vm:long-float-hidden-bit) - (sb!vm::random-mt19937 state-vector)) - 1l0)))) - -#!+(and long-float sparc) -(defun %random-long-float (arg state) - (declare (type (long-float (0l0)) arg) - (type random-state state)) - (* arg - (- (sb!impl::make-long-float - (sb!impl::long-float-exp-bits 1l0) ; X needs more work - (random-chunk state) (random-chunk state) (random-chunk state)) - 1l0))) ;;;; random integers diff --git a/src/compiler/assem.lisp b/src/compiler/assem.lisp index 716496c..ba5c68e 100644 --- a/src/compiler/assem.lisp +++ b/src/compiler/assem.lisp @@ -1270,8 +1270,7 @@ (setf (segment-postits segment) (segment-postits other-segment)) (dolist (postit postits) (emit-back-patch segment 0 postit))) - #!-x86 (emit-alignment segment nil max-alignment) - #!+x86 (emit-alignment segment nil max-alignment #x90) + (emit-alignment segment nil max-alignment #!+(or x86-64 x86) #x90) (let ((segment-current-index-0 (segment-current-index segment)) (segment-current-posn-0 (segment-current-posn segment))) (incf (segment-current-index segment) diff --git a/src/compiler/early-assem.lisp b/src/compiler/early-assem.lisp index 13e756a..2450168 100644 --- a/src/compiler/early-assem.lisp +++ b/src/compiler/early-assem.lisp @@ -45,7 +45,8 @@ ;;; the maximum alignment we can guarantee given the object format. If ;;; the loader only loads objects 8-byte aligned, we can't do any ;;; better then that ourselves. -(def!constant max-alignment 3) +(def!constant max-alignment sb!vm:n-lowtag-bits) + (deftype alignment () `(integer 0 ,max-alignment)) diff --git a/src/compiler/generic/early-objdef.lisp b/src/compiler/generic/early-objdef.lisp index ef6563c..c99e7a8 100644 --- a/src/compiler/generic/early-objdef.lisp +++ b/src/compiler/generic/early-objdef.lisp @@ -18,20 +18,22 @@ ;;; out the full names. Or even define them in DEF EVEN-FIXNUM-LOWTAG ;;; style so searches like 'def.*even-fixnum-lowtag' can find them. -;;; Tags for the main low-level types are stored in the low three +;;; Tags for the main low-level types are stored in the low n (usually three) ;;; bits to identify the type of a machine word. Certain constraints ;;; apply: ;;; * EVEN-FIXNUM-LOWTAG and ODD-FIXNUM-LOWTAG must be 0 and 4: code ;;; which shifts left two places to convert raw integers to tagged ;;; fixnums is ubiquitous. -;;; * LIST-POINTER-LOWTAG + 4 = OTHER-POINTER-LOWTAG: NIL is both a -;;; cons and a symbol (at the same address) and depends on this. +;;; * LIST-POINTER-LOWTAG + N-WORD-BYTES = OTHER-POINTER-LOWTAG: NIL +;;; is both a cons and a symbol (at the same address) and depends on this. ;;; See the definition of SYMBOL in objdef.lisp ;;; * OTHER-POINTER-LOWTAG > 4: Some code in the SPARC backend, ;;; which uses bit 2 of the ALLOC register to indicate that ;;; PSEUDO-ATOMIC is on, doesn't strip the low bits of reg_ALLOC ;;; before ORing in OTHER-POINTER-LOWTAG within a PSEUDO-ATOMIC ;;; section. +;;; * OTHER-IMMEDIATE-0-LOWTAG are spaced 4 apart: various code wants to +;;; iterate through these ;;; (These are just the ones we know about as of sbcl-0.7.1.22. There ;;; might easily be more, since these values have stayed highly ;;; constrained for more than a decade, an inviting target for @@ -40,13 +42,23 @@ ;; The EVAL-WHEN is necessary (at least for Lispworks), because the ;; second DEFENUM uses the value of OTHER-IMMEDIATE-0-LOWTAG, which is ;; defined in the first DEFENUM. -- AL 20000216 + #!+x86-64 + (defenum (:suffix -lowtag) + even-fixnum + instance-pointer + other-immediate-0 + pad0 pad1 pad2 + other-immediate-1 + list-pointer + odd-fixnum + fun-pointer + other-immediate-2 + pad3 pad4 pad5 + other-immediate-3 + other-pointer) + #!-x86-64 (defenum (:suffix -lowtag) even-fixnum - ;; Note: CMU CL, and SBCL < 0.pre7.39, had FUN-POINTER-LOWTAG - ;; here. We swapped FUN-POINTER-LOWTAG and - ;; INSTANCE-POINTER-LOWTAG in sbcl-0.pre7.39 in order to help with a - ;; low-level pun in the function call sequence on the PPC port. - ;; For more information, see the PPC port code. -- WHN 2001-10-03 instance-pointer other-immediate-0 list-pointer @@ -55,6 +67,9 @@ other-immediate-1 other-pointer)) +(def!constant nil-value + (+ static-space-start n-word-bytes other-pointer-lowtag)) + ;;; the heap types, stored in 8 bits of the header of an object on the ;;; heap, to identify the type of the heap object (which'll be at ;;; least two machine words, often more) @@ -95,16 +110,14 @@ ;;; rather than two separate tests and jumps (defenum (:suffix -widetag :start (+ (ash 1 n-lowtag-bits) other-immediate-0-lowtag) - :step (ash 1 (1- n-lowtag-bits))) + :step 4) bignum ratio single-float double-float - #!+long-float long-float complex complex-single-float complex-double-float - #!+long-float complex-long-float code-header simple-fun-header @@ -129,13 +142,11 @@ unused05 unused06 unused07 - #!-long-float unused08 - #!-long-float unused09 + unused08 + unused09 - #!+long-float simple-array-long-float - #!+long-float simple-array-complex-long-float - #!-long-float unused10 - #!-long-float unused11 + unused10 + unused11 simple-array-unsigned-byte-2 simple-array-unsigned-byte-4 diff --git a/src/compiler/generic/early-vm.lisp b/src/compiler/generic/early-vm.lisp index 79321a6..afc7dfc 100644 --- a/src/compiler/generic/early-vm.lisp +++ b/src/compiler/generic/early-vm.lisp @@ -11,7 +11,7 @@ ;;; the number of bits at the low end of a pointer used for type ;;; information -(def!constant n-lowtag-bits 3) +(def!constant n-lowtag-bits #!+x86-64 4 #!-x86-64 3) ;;; a mask to extract the low tag bits from a pointer (def!constant lowtag-mask (1- (ash 1 n-lowtag-bits))) ;;; the exclusive upper bound on the value of the low tag bits from a @@ -24,9 +24,11 @@ ;;; a mask to extract the type from a data block header word (def!constant widetag-mask (1- (ash 1 n-widetag-bits))) -(def!constant sb!xc:most-positive-fixnum (1- (ash 1 29)) +(def!constant sb!xc:most-positive-fixnum + (1- (ash 1 (- n-word-bits n-lowtag-bits))) #!+sb-doc "the fixnum closest in value to positive infinity") -(def!constant sb!xc:most-negative-fixnum (ash -1 29) +(def!constant sb!xc:most-negative-fixnum + (ash -1 (- n-word-bits n-lowtag-bits)) #!+sb-doc "the fixnum closest in value to negative infinity") diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index 301d162..dac2900 100644 --- a/src/compiler/generic/genesis.lisp +++ b/src/compiler/generic/genesis.lisp @@ -186,20 +186,26 @@ (ldb (byte 8 ,(- n 8 (* i 8))) new-value))))) `(progn (defun ,name (bigvec byte-index) - (aver (= sb!vm:n-word-bits 32)) - (aver (= sb!vm:n-byte-bits 8)) (logior ,@(ecase sb!c:*backend-byte-order* (:little-endian ash-list-le) (:big-endian ash-list-be)))) (defun (setf ,name) (new-value bigvec byte-index) - (aver (= sb!vm:n-word-bits 32)) - (aver (= sb!vm:n-byte-bits 8)) (setf ,@(ecase sb!c:*backend-byte-order* (:little-endian setf-list-le) (:big-endian setf-list-be)))))))) (make-bvref-n 8) (make-bvref-n 16) - (make-bvref-n 32)) + (make-bvref-n 32) + (make-bvref-n 64)) + +;; lispobj-sized word, whatever that may be +(defun bvref-word (bytes index) + #!+x86-64 (bvref-64 bytes index) + #!-x86-64 (bvref-32 bytes index)) + +(defun (setf bvref-word) (new-val bytes index) + #!+x86-64 (setf (bvref-64 bytes index) new-val) + #!-x86-64 (setf (bvref-32 bytes index) new-val)) ;;;; representation of spaces in the core @@ -356,8 +362,9 @@ ;; it's hard to see how it could have been wrong, since CMU CL ;; genesis worked. It would be nice to understand how this came ;; to be.. -- WHN 19990901 - (logior (ash bits -2) (ash -1 (- sb!vm:n-word-bits 2))) - (ash bits -2)))) + (logior (ash bits (- 1 sb!vm:n-lowtag-bits)) + (ash -1 (- sb!vm:n-word-bits (1- sb!vm:n-lowtag-bits)))) + (ash bits (- 1 sb!vm:n-lowtag-bits))))) ;;; common idioms (defun descriptor-bytes (des) @@ -490,7 +497,7 @@ (bytes (gspace-bytes gspace)) (byte-index (ash (+ index (descriptor-word-offset address)) sb!vm:word-shift)) - (value (bvref-32 bytes byte-index))) + (value (bvref-word bytes byte-index))) (make-random-descriptor value))) (declaim (ftype (function (descriptor) descriptor) read-memory)) @@ -533,7 +540,7 @@ (let* ((bytes (gspace-bytes (descriptor-intuit-gspace address))) (byte-index (ash (+ index (descriptor-word-offset address)) sb!vm:word-shift))) - (setf (bvref-32 bytes byte-index) + (setf (bvref-word bytes byte-index) (descriptor-bits value))))) (declaim (ftype (function (descriptor descriptor)) write-memory)) @@ -675,23 +682,6 @@ (:big-endian (write-wordindexed des sb!vm:double-float-value-slot high-bits) (write-wordindexed des (1+ sb!vm:double-float-value-slot) low-bits))) - des)) - #!+(and long-float x86) - (long-float - (let ((des (allocate-unboxed-object *dynamic* - sb!vm:n-word-bits - (1- sb!vm:long-float-size) - sb!vm:long-float-widetag)) - (exp-bits (make-random-descriptor (long-float-exp-bits x))) - (high-bits (make-random-descriptor (long-float-high-bits x))) - (low-bits (make-random-descriptor (long-float-low-bits x)))) - (ecase sb!c:*backend-byte-order* - (:little-endian - (write-wordindexed des sb!vm:long-float-value-slot low-bits) - (write-wordindexed des (1+ sb!vm:long-float-value-slot) high-bits) - (write-wordindexed des (+ 2 sb!vm:long-float-value-slot) exp-bits)) - (:big-endian - (error "LONG-FLOAT is not supported for big-endian byte order."))) des)))) (defun complex-single-float-to-core (num) @@ -747,7 +737,8 @@ ;;; Copy the given number to the core. (defun number-to-core (number) (typecase number - (integer (if (< (integer-length number) 30) + (integer (if (< (integer-length number) + (- (1+ sb!vm:n-word-bits) sb!vm:n-lowtag-bits)) (make-fixnum-descriptor number) (bignum-to-core number))) (ratio (number-pair-to-core (number-to-core (numerator number)) @@ -1350,26 +1341,12 @@ (cold-set '*!reversed-cold-toplevels* *current-reversed-cold-toplevels*) - #!+x86 + #!+(or x86 x86-64) (progn (cold-set 'sb!vm::*fp-constant-0d0* (number-to-core 0d0)) (cold-set 'sb!vm::*fp-constant-1d0* (number-to-core 1d0)) (cold-set 'sb!vm::*fp-constant-0f0* (number-to-core 0f0)) - (cold-set 'sb!vm::*fp-constant-1f0* (number-to-core 1f0)) - #!+long-float - (progn - (cold-set 'sb!vm::*fp-constant-0l0* (number-to-core 0L0)) - (cold-set 'sb!vm::*fp-constant-1l0* (number-to-core 1L0)) - ;; FIXME: Why is initialization of PI conditional on LONG-FLOAT? - ;; (ditto LG2, LN2, L2E, etc.) - (cold-set 'sb!vm::*fp-constant-pi* (number-to-core pi)) - (cold-set 'sb!vm::*fp-constant-l2t* (number-to-core (log 10L0 2L0))) - (cold-set 'sb!vm::*fp-constant-l2e* - (number-to-core (log 2.718281828459045235360287471352662L0 2L0))) - (cold-set 'sb!vm::*fp-constant-lg2* (number-to-core (log 2L0 10L0))) - (cold-set 'sb!vm::*fp-constant-ln2* - (number-to-core - (log 2L0 2.718281828459045235360287471352662L0)))))) + (cold-set 'sb!vm::*fp-constant-1f0* (number-to-core 1f0)))) ;;; Make a cold list that can be used as the arg list to MAKE-PACKAGE in order ;;; to make a package that is similar to PKG. @@ -1641,10 +1618,10 @@ ;;; The x86 port needs to store code fixups along with code objects if ;;; they are to be moved, so fixups for code objects in the dynamic ;;; heap need to be noted. -#!+x86 +#!+(or x86 x86-64) (defvar *load-time-code-fixups*) -#!+x86 +#!+(or x86 x86-64) (defun note-load-time-code-fixup (code-object offset value kind) ;; If CODE-OBJECT might be moved (when (= (gspace-identifier (descriptor-intuit-gspace code-object)) @@ -1653,7 +1630,7 @@ (push (list code-object offset value kind) *load-time-code-fixups*)) (values)) -#!+x86 +#!+(or x86 x86-64) (defun output-load-time-code-fixups () (dolist (fixups *load-time-code-fixups*) (let ((code-object (first fixups)) @@ -1809,8 +1786,8 @@ (dpb (ldb (byte 10 0) value) (byte 10 0) (bvref-32 gspace-bytes gspace-byte-offset)))))) - (:x86 - (let* ((un-fixed-up (bvref-32 gspace-bytes + ((:x86 :x86-64) + (let* ((un-fixed-up (bvref-word gspace-bytes gspace-byte-offset)) (code-object-start-addr (logandc2 (descriptor-bits code-object) sb!vm:lowtag-mask))) @@ -1840,7 +1817,7 @@ (let ((fixed-up (- (+ value un-fixed-up) gspace-byte-address gspace-byte-offset - sb!vm:n-word-bytes))) ; length of CALL argument + 4))) ; "length of CALL argument" (setf (bvref-32 gspace-bytes gspace-byte-offset) fixed-up) ;; Note relative fixups that point outside the code @@ -2244,117 +2221,6 @@ (define-cold-number-fop fop-complex-single-float) (define-cold-number-fop fop-complex-double-float) -#!+long-float -(define-cold-fop (fop-long-float) - (ecase +backend-fasl-file-implementation+ - (:x86 ; (which has 80-bit long-float format) - (prepare-for-fast-read-byte *fasl-input-stream* - (let* ((des (allocate-unboxed-object *dynamic* sb!vm:n-word-bits - (1- sb!vm:long-float-size) - sb!vm:long-float-widetag)) - (low-bits (make-random-descriptor (fast-read-u-integer 4))) - (high-bits (make-random-descriptor (fast-read-u-integer 4))) - (exp-bits (make-random-descriptor (fast-read-s-integer 2)))) - (done-with-fast-read-byte) - (write-wordindexed des sb!vm:long-float-value-slot low-bits) - (write-wordindexed des (1+ sb!vm:long-float-value-slot) high-bits) - (write-wordindexed des (+ 2 sb!vm:long-float-value-slot) exp-bits) - des))) - ;; This was supported in CMU CL, but isn't currently supported in - ;; SBCL. - #+nil - (#.sb!c:sparc-fasl-file-implementation ; 128 bit long-float format - (prepare-for-fast-read-byte *fasl-input-stream* - (let* ((des (allocate-unboxed-object *dynamic* sb!vm:n-word-bits - (1- sb!vm:long-float-size) - sb!vm:long-float-widetag)) - (low-bits (make-random-descriptor (fast-read-u-integer 4))) - (mid-bits (make-random-descriptor (fast-read-u-integer 4))) - (high-bits (make-random-descriptor (fast-read-u-integer 4))) - (exp-bits (make-random-descriptor (fast-read-s-integer 4)))) - (done-with-fast-read-byte) - (write-wordindexed des sb!vm:long-float-value-slot exp-bits) - (write-wordindexed des (1+ sb!vm:long-float-value-slot) high-bits) - (write-wordindexed des (+ 2 sb!vm:long-float-value-slot) mid-bits) - (write-wordindexed des (+ 3 sb!vm:long-float-value-slot) low-bits) - des))))) - -#!+long-float -(define-cold-fop (fop-complex-long-float) - (ecase +backend-fasl-file-implementation+ - (:x86 ; (which has 80-bit long-float format) - (prepare-for-fast-read-byte *fasl-input-stream* - (let* ((des (allocate-unboxed-object *dynamic* sb!vm:n-word-bits - (1- sb!vm:complex-long-float-size) - sb!vm:complex-long-float-widetag)) - (real-low-bits (make-random-descriptor (fast-read-u-integer 4))) - (real-high-bits (make-random-descriptor (fast-read-u-integer 4))) - (real-exp-bits (make-random-descriptor (fast-read-s-integer 2))) - (imag-low-bits (make-random-descriptor (fast-read-u-integer 4))) - (imag-high-bits (make-random-descriptor (fast-read-u-integer 4))) - (imag-exp-bits (make-random-descriptor (fast-read-s-integer 2)))) - (done-with-fast-read-byte) - (write-wordindexed des - sb!vm:complex-long-float-real-slot - real-low-bits) - (write-wordindexed des - (1+ sb!vm:complex-long-float-real-slot) - real-high-bits) - (write-wordindexed des - (+ 2 sb!vm:complex-long-float-real-slot) - real-exp-bits) - (write-wordindexed des - sb!vm:complex-long-float-imag-slot - imag-low-bits) - (write-wordindexed des - (1+ sb!vm:complex-long-float-imag-slot) - imag-high-bits) - (write-wordindexed des - (+ 2 sb!vm:complex-long-float-imag-slot) - imag-exp-bits) - des))) - ;; This was supported in CMU CL, but isn't currently supported in SBCL. - #+nil - (#.sb!c:sparc-fasl-file-implementation ; 128 bit long-float format - (prepare-for-fast-read-byte *fasl-input-stream* - (let* ((des (allocate-unboxed-object *dynamic* sb!vm:n-word-bits - (1- sb!vm:complex-long-float-size) - sb!vm:complex-long-float-widetag)) - (real-low-bits (make-random-descriptor (fast-read-u-integer 4))) - (real-mid-bits (make-random-descriptor (fast-read-u-integer 4))) - (real-high-bits (make-random-descriptor (fast-read-u-integer 4))) - (real-exp-bits (make-random-descriptor (fast-read-s-integer 4))) - (imag-low-bits (make-random-descriptor (fast-read-u-integer 4))) - (imag-mid-bits (make-random-descriptor (fast-read-u-integer 4))) - (imag-high-bits (make-random-descriptor (fast-read-u-integer 4))) - (imag-exp-bits (make-random-descriptor (fast-read-s-integer 4)))) - (done-with-fast-read-byte) - (write-wordindexed des - sb!vm:complex-long-float-real-slot - real-exp-bits) - (write-wordindexed des - (1+ sb!vm:complex-long-float-real-slot) - real-high-bits) - (write-wordindexed des - (+ 2 sb!vm:complex-long-float-real-slot) - real-mid-bits) - (write-wordindexed des - (+ 3 sb!vm:complex-long-float-real-slot) - real-low-bits) - (write-wordindexed des - sb!vm:complex-long-float-real-slot - imag-exp-bits) - (write-wordindexed des - (1+ sb!vm:complex-long-float-real-slot) - imag-high-bits) - (write-wordindexed des - (+ 2 sb!vm:complex-long-float-real-slot) - imag-mid-bits) - (write-wordindexed des - (+ 3 sb!vm:complex-long-float-real-slot) - imag-low-bits) - des))))) - (define-cold-fop (fop-ratio) (let ((den (pop-stack))) (number-pair-to-core (pop-stack) den sb!vm:ratio-widetag))) @@ -2973,11 +2839,12 @@ initially undefined function references:~2%") (defun write-word (num) (ecase sb!c:*backend-byte-order* (:little-endian - (dotimes (i 4) + (dotimes (i sb!vm:n-word-bytes) (write-byte (ldb (byte 8 (* i 8)) num) *core-file*))) (:big-endian - (dotimes (i 4) - (write-byte (ldb (byte 8 (* (- 3 i) 8)) num) *core-file*)))) + (dotimes (i sb!vm:n-word-bytes) + (write-byte (ldb (byte 8 (* (- (1- sb!vm:n-word-bytes) i) 8)) num) + *core-file*)))) num) (defun advance-to-page () diff --git a/src/compiler/generic/late-type-vops.lisp b/src/compiler/generic/late-type-vops.lisp index 42bf108..0563804 100644 --- a/src/compiler/generic/late-type-vops.lisp +++ b/src/compiler/generic/late-type-vops.lisp @@ -16,7 +16,7 @@ :variant simple ;; we can save a couple of instructions and a branch on the ppc. ;; FIXME: make this be FIXNUM-MASK - :mask 3) + :mask (ash lowtag-mask -1)) (!define-type-vops functionp check-fun function object-not-fun-error (fun-pointer-lowtag) @@ -57,11 +57,6 @@ object-not-complex-double-float-error (complex-double-float-widetag)) -#!+long-float -(!define-type-vops complex-long-float-p check-complex-long-float complex-long-float - object-not-complex-long-float-error - (complex-long-float-widetag)) - (!define-type-vops single-float-p check-single-float single-float object-not-single-float-error (single-float-widetag)) @@ -70,11 +65,6 @@ object-not-double-float-error (double-float-widetag)) -#!+long-float -(!define-type-vops long-float-p check-long-float long-float - object-not-long-float-error - (long-float-widetag)) - (!define-type-vops simple-string-p check-simple-string nil object-not-simple-string-error (simple-base-string-widetag simple-array-nil-widetag)) diff --git a/src/compiler/generic/objdef.lisp b/src/compiler/generic/objdef.lisp index 590d146..57a4831 100644 --- a/src/compiler/generic/objdef.lisp +++ b/src/compiler/generic/objdef.lisp @@ -355,14 +355,6 @@ (real :c-type "double" :length 2) (imag :c-type "double" :length 2)) -#!+long-float -(define-primitive-object (complex-long-float - :lowtag other-pointer-lowtag - :widetag complex-long-float-widetag) - #!+sparc (filler) - (real :c-type "long double" :length #!+x86 3 #!+sparc 4) - (imag :c-type "long double" :length #!+x86 3 #!+sparc 4)) - ;;; this isn't actually a lisp object at all, it's a c structure that lives ;;; in c-land. However, we need sight of so many parts of it from Lisp that ;;; it makes sense to define it here anyway, so that the GENESIS machinery diff --git a/src/compiler/generic/primtype.lisp b/src/compiler/generic/primtype.lisp index 1178b6a..7aec24b 100644 --- a/src/compiler/generic/primtype.lisp +++ b/src/compiler/generic/primtype.lisp @@ -86,17 +86,14 @@ (!def-primitive-type single-float (single-reg descriptor-reg)) (/show0 "about to !DEF-PRIMITIVE-TYPE DOUBLE-FLOAT") (!def-primitive-type double-float (double-reg descriptor-reg)) -#!+long-float -(!def-primitive-type long-float (long-reg descriptor-reg)) + (/show0 "about to !DEF-PRIMITIVE-TYPE COMPLEX-SINGLE-FLOAT") (!def-primitive-type complex-single-float (complex-single-reg descriptor-reg) :type (complex single-float)) (/show0 "about to !DEF-PRIMITIVE-TYPE COMPLEX-DOUBLE-FLOAT") (!def-primitive-type complex-double-float (complex-double-reg descriptor-reg) :type (complex double-float)) -#!+long-float -(!def-primitive-type complex-long-float (complex-long-reg descriptor-reg) - :type (complex long-float)) + ;;; primitive other-pointer array types (/show0 "primtype.lisp 96") @@ -228,8 +225,8 @@ (return (values (primitive-type-or-lose type) (and (= lo min) (= hi max)))))))) - ((or (and hi (< hi most-negative-fixnum)) - (and lo (> lo most-positive-fixnum))) + ((or (and hi (< hi sb!xc:most-negative-fixnum)) + (and lo (> lo sb!xc:most-positive-fixnum))) (part-of bignum)) (t (any)))) @@ -239,13 +236,9 @@ ((short-float single-float) (values (primitive-type-or-lose 'single-float) exact)) - ((double-float #!-long-float long-float) + ((double-float) (values (primitive-type-or-lose 'double-float) exact)) - #!+long-float - (long-float - (values (primitive-type-or-lose 'long-float) - exact)) (t (any))))) (t @@ -257,13 +250,9 @@ ((short-float single-float) (values (primitive-type-or-lose 'complex-single-float) exact)) - ((double-float #!-long-float long-float) + ((double-float long-float) (values (primitive-type-or-lose 'complex-double-float) exact)) - #!+long-float - (long-float - (values (primitive-type-or-lose 'complex-long-float) - exact)) (t (part-of complex)))) (part-of complex))) diff --git a/src/compiler/generic/target-core.lisp b/src/compiler/generic/target-core.lisp index c4e021d..622bd23 100644 --- a/src/compiler/generic/target-core.lisp +++ b/src/compiler/generic/target-core.lisp @@ -53,10 +53,8 @@ (code-obj ;; FIXME: In CMU CL the X86 behavior here depended on ;; *ENABLE-DYNAMIC-SPACE-CODE*, but in SBCL we always use - ;; dynamic space code, so we could make - ;; ALLOCATE-DYNAMIC-CODE-OBJECT more parallel with - ;; ALLOCATE-CODE-OBJECT and remove this confusing - ;; read-macro conditionalization. + ;; dynamic space code, so we shoudl just rename the + ;; allocate-dynamic-code-object vop and lose this #+ stuff #!+x86 (%primitive allocate-dynamic-code-object box-num total-length) #!-x86 diff --git a/src/compiler/generic/utils.lisp b/src/compiler/generic/utils.lisp index 38fa31c..bbe98d2 100644 --- a/src/compiler/generic/utils.lisp +++ b/src/compiler/generic/utils.lisp @@ -14,8 +14,8 @@ ;;; Make a fixnum out of NUM. (I.e. shift by two bits if it will fit.) (defun fixnumize (num) - (if (<= #x-20000000 num #x1fffffff) - (ash num 2) + (if (fixnump num) + (ash num (1- n-lowtag-bits)) (error "~W is too big for a fixnum." num))) ;;;; routines for dealing with static symbols diff --git a/src/compiler/generic/vm-array.lisp b/src/compiler/generic/vm-array.lisp index dcf0092..fac3d72 100644 --- a/src/compiler/generic/vm-array.lisp +++ b/src/compiler/generic/vm-array.lisp @@ -75,9 +75,6 @@ :importance 6) (double-float 0.0d0 64 simple-array-double-float :importance 5) - #!+long-float - (long-float 0.0l0 #!+x86 96 #!+sparc 128 simple-array-long-float - :importance 4) (bit 0 1 simple-bit-vector :complex-typecode #.sb!vm:complex-bit-vector-widetag :importance 16) diff --git a/src/compiler/generic/vm-fndb.lisp b/src/compiler/generic/vm-fndb.lisp index f9ee134..f3903c2 100644 --- a/src/compiler/generic/vm-fndb.lisp +++ b/src/compiler/generic/vm-fndb.lisp @@ -113,19 +113,14 @@ (foldable flushable)) (defknown %raw-ref-complex-double (raw-vector index) (complex double-float) (foldable flushable)) -#!+long-float -(defknown %raw-ref-complex-long (raw-vector index) (complex long-float) - (foldable flushable)) + (defknown %raw-set-complex-single (raw-vector index (complex single-float)) (complex single-float) (unsafe)) (defknown %raw-set-complex-double (raw-vector index (complex double-float)) (complex double-float) (unsafe)) -#!+long-float -(defknown %raw-set-complex-long (raw-vector index (complex long-float)) - (complex long-float) - (unsafe)) + (defknown %raw-bits (t fixnum) (unsigned-byte 32) (foldable flushable)) diff --git a/src/compiler/generic/vm-type.lisp b/src/compiler/generic/vm-type.lisp index 7782457..a900222 100644 --- a/src/compiler/generic/vm-type.lisp +++ b/src/compiler/generic/vm-type.lisp @@ -33,7 +33,7 @@ `(single-float ,low ,high)) ;;; an index into an integer -(sb!xc:deftype bit-index () `(integer 0 ,most-positive-fixnum)) +(sb!xc:deftype bit-index () `(integer 0 ,sb!xc:most-positive-fixnum)) ;;; worst-case values for float attributes (sb!xc:deftype float-exponent () diff --git a/src/runtime/coreparse.c b/src/runtime/coreparse.c index 5cb6c64..a84bc6c 100644 --- a/src/runtime/coreparse.c +++ b/src/runtime/coreparse.c @@ -90,10 +90,7 @@ process_directory(int fd, u32 *ptr, int count) lose("warning: core/runtime address mismatch: DYNAMIC_SPACE_START"); } #endif -/* FIXME: Should the conditional here be reg_ALLOC instead of - * defined(LISP_FEATURE_X86) - * ? */ -#if defined(LISP_FEATURE_X86) +#if defined(ALLOCATION_POINTER) SetSymbolValue(ALLOCATION_POINTER, (lispobj)free_pointer,0); #else dynamic_space_free_pointer = free_pointer; @@ -127,7 +124,7 @@ process_directory(int fd, u32 *ptr, int count) lispobj load_core_file(char *file) { - u32 *header, val, len, *ptr, remaining_len; + lispobj *header, val, len, *ptr, remaining_len; int fd = open(file, O_RDONLY), count; lispobj initial_function = NIL; diff --git a/src/runtime/dynbind.c b/src/runtime/dynbind.c index 024b2fd..1c3a6ab 100644 --- a/src/runtime/dynbind.c +++ b/src/runtime/dynbind.c @@ -22,7 +22,7 @@ #include "genesis/binding.h" #include "genesis/thread.h" -#if defined(LISP_FEATURE_X86) +#if defined(BINDING_STACK_POINTER) #define GetBSP() ((struct binding *)SymbolValue(BINDING_STACK_POINTER,thread)) #define SetBSP(value) SetSymbolValue(BINDING_STACK_POINTER, (lispobj)(value),thread) #else diff --git a/src/runtime/linux-os.c b/src/runtime/linux-os.c index a958224..7dcad35 100644 --- a/src/runtime/linux-os.c +++ b/src/runtime/linux-os.c @@ -222,7 +222,7 @@ void sigsegv_handler(int signal, siginfo_t *info, void* void_context) { os_context_t *context = arch_os_get_context(&void_context); - void* fault_addr = (void*)context->uc_mcontext.cr2; + void* fault_addr = (void*)info->si_addr; if (!gencgc_handle_wp_violation(fault_addr)) if(!handle_control_stack_guard_triggered(context,fault_addr)) interrupt_handle_now(signal, info, void_context); diff --git a/src/runtime/purify.c b/src/runtime/purify.c index 8f7a44e..cc8496e 100644 --- a/src/runtime/purify.c +++ b/src/runtime/purify.c @@ -35,9 +35,12 @@ #define PRINTNOISE -#if defined(LISP_FEATURE_X86) -/* again, what's so special about the x86 that this is differently - * visible there than on other platforms? -dan 20010125 +#if defined(LISP_FEATURE_GENCGC) +/* this is another artifact of the poor integration between gencgc and + * the rest of the runtime: on cheney gc there is a global + * dynamic_space_free_pointer which is valid whenever foreign function + * call is active, but in gencgc there's no such variable and we have + * to keep our own */ static lispobj *dynamic_space_free_pointer; #endif @@ -1480,7 +1483,7 @@ purify(lispobj static_roots, lispobj read_only_roots) SetSymbolValue(READ_ONLY_SPACE_FREE_POINTER, (lispobj)read_only_free,0); SetSymbolValue(STATIC_SPACE_FREE_POINTER, (lispobj)static_free,0); -#if !defined(LISP_FEATURE_X86) +#if !defined(ALLOCATION_POINTER) dynamic_space_free_pointer = current_dynamic_space; set_auto_gc_trigger(bytes_consed_between_gcs); #else diff --git a/tools-for-build/grovel-headers.c b/tools-for-build/grovel-headers.c index ff81d11..e76237d 100644 --- a/tools-for-build/grovel-headers.c +++ b/tools-for-build/grovel-headers.c @@ -160,8 +160,7 @@ main(int argc, char *argv[]) DEFSIGNAL(SIGBUS); DEFSIGNAL(SIGCHLD); DEFSIGNAL(SIGCONT); -/* FIXME: Maybe #ifdef SIGEMT would be a smarter conditional? */ -#if (!(defined LISP_FEATURE_LINUX) || !((defined LISP_FEATURE_PPC) || (defined LISP_FEATURE_X86))) +#ifdef SIGEMT DEFSIGNAL(SIGEMT); #endif DEFSIGNAL(SIGFPE); diff --git a/version.lisp-expr b/version.lisp-expr index 1d131b1..962effc 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; 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.8.9.18" +"0.8.9.19"