From: Christophe Rhodes Date: Mon, 5 May 2003 14:09:03 +0000 (+0000) Subject: 0.8alpha.0.13: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=22b819c0cd0ca0ea5be52ba280b9e9e0b8e86210;p=sbcl.git 0.8alpha.0.13: CLISP build megapatch ... mostly putting #-SB-XC in front of :COMPILE-TOPLEVEL, because clisp gives a full warning for function and macro redefinition; ... workaround clisp's buggy pretty printer by not exercising it as much: use (INHIBIT-WARNINGS 3); ... explicit :INITIAL-ELEMENT 0 when we're using 0 to mean "uninitialized" in MAKE-ARRAY; ... SPECIAL-OPERATOR-P isn't a good test on the host for what can become a target macro; ... slightly more portable floating point logic: Explicitly set *READ-DEFAULT-FLOAT-FORMAT* so that we don't create host LONG-FLOATs by accident; LOAD-TIME-VALUE magic for negative floating point zeros; Minor associated text file frobbage ... braindump some unrelated TODO items Obligatory runtime code improvement ... fix one warning in gencgc.h --- diff --git a/INSTALL b/INSTALL index 464a644..5839336 100644 --- a/INSTALL +++ b/INSTALL @@ -55,6 +55,7 @@ This software has been built successfully on these systems: os = Debian GNU/Linux 2.1 with libc >= 2.1 host lisp = CMU CL 2.4.17 host lisp = SBCL itself + host lisp = CLISP CVS as of end of April os = RedHat Linux 6.2 host lisp = SBCL itself os = FreeBSD 3.4 or 4.0 @@ -77,9 +78,6 @@ This software has been built successfully on these systems: host lisp = OpenMCL 0.12 host lisp = SBCL itself -It is known not to build under CLISP (as of early June 2002) because -of bugs in the CLISP garbage collector. - Reports of other systems that it works on (or doesn't work on, for that matter), or help in making it run on more systems, would be appreciated. diff --git a/TODO b/TODO index 561c9bd..28e5af2 100644 --- a/TODO +++ b/TODO @@ -35,6 +35,8 @@ for early 0.8.x: * fixups now feasible because of pre7 changes ** ANSIfied DECLAIM INLINE stuff (deprecating MAYBE-INLINE, including e.g. on the man page) + ** (maybe) allow INLINE of a recursive function, so that the + body is inlined once * miscellaneous simple refactoring * belated renaming: ** renamed %PRIMITIVE to %VOP @@ -52,6 +54,16 @@ for early 0.8.x: * Either get rid of or at least rework the fdefinition/encapsulation system so that (SYMBOL-FUNCTION 'FOO) is identically equal to (FDEFINITION 'FOO). +* Make the system sources understandable to the system, so that + searching for sources doesn't error out quite so often + (e.g. in error handlers) + ** provided a location-independent way of referring to source + files in the target image, maybe a SYS: logical + pathname, and made the build system respect this. + ** provided a suitable readtable for reading in the source + files when necessary, and a mechanism for activating + this readtable rather than the standard one. + ======================================================================= for 0.9: diff --git a/build-order.lisp-expr b/build-order.lisp-expr index 7761ef2..05efd7b 100644 --- a/build-order.lisp-expr +++ b/build-order.lisp-expr @@ -129,6 +129,8 @@ ("src/code/defbangstruct") + ("src/code/unportable-float") + ("src/code/funutils" :not-host) ;; This needs DEF!STRUCT, and is itself needed early so that structure @@ -336,12 +338,16 @@ ;; defining types ("src/compiler/parse-lambda-list") + ;; The following two files trigger function/macro redefinition + ;; warnings in clisp during make-host-2; as a workaround, we ignore + ;; the failure values from COMPILE-FILE under clisp. + ;; for DEFSTRUCT ALIEN-TYPE, needed by host-type.lisp - ("src/code/host-alieneval") + ("src/code/host-alieneval" #+clisp :ignore-failure-p) ;; can't be done until definition of e.g. DEFINE-ALIEN-TYPE-CLASS in ;; host-alieneval.lisp - ("src/code/host-c-call") + ("src/code/host-c-call" #+clisp :ignore-failure-p) ;; SB!XC:DEFTYPE is needed in order to compile late-type ;; in the host Common Lisp, and in order to run, it needs diff --git a/make-genesis-2.sh b/make-genesis-2.sh index 38786ba..42efb07 100644 --- a/make-genesis-2.sh +++ b/make-genesis-2.sh @@ -51,6 +51,7 @@ $SBCL_XC_HOST <<-'EOF' || exit 1 ;; be very handy when debugging cold init problems. :map-file-name "output/cold-sbcl.map") #+cmu (ext:quit) + #+clisp (ext:quit) EOF echo //testing for consistency of first and second GENESIS passes diff --git a/make-host-1.sh b/make-host-1.sh index 01ba05b..1b6cf9b 100644 --- a/make-host-1.sh +++ b/make-host-1.sh @@ -45,4 +45,5 @@ $SBCL_XC_HOST <<-'EOF' || exit 1 (host-cload-stem "src/compiler/generic/genesis") (sb!vm:genesis :c-header-dir-name "src/runtime/genesis") #+cmu (ext:quit) + #+clisp (ext:quit) EOF diff --git a/make-host-2.sh b/make-host-2.sh index e266d77..c57fe2c 100644 --- a/make-host-2.sh +++ b/make-host-2.sh @@ -55,17 +55,22 @@ $SBCL_XC_HOST <<-'EOF' || exit 1 (load-or-cload-xcompiler #'host-load-stem) (defun proclaim-target-optimization () (let ((debug (if (position :sb-show *shebang-features*) 2 1))) - (sb-xc:proclaim `(optimize (compilation-speed 1) - (debug ,debug) - (sb!ext:inhibit-warnings 2) - ;; SAFETY = SPEED (and < 3) should - ;; reasonable safety, but might skip - ;; some unreasonably expensive stuff - ;; (e.g. %DETECT-STACK-EXHAUSTION - ;; in sbcl-0.7.2). - (safety 2) - (space 1) - (speed 2))))) + (sb-xc:proclaim + `(optimize + (compilation-speed 1) + (debug ,debug) + ;; CLISP's pretty-printer is fragile and tends to cause + ;; stack corruption or fail internal assertions, as of + ;; 2003-04-20; we therefore turn off as many notes as + ;; possible. + (sb!ext:inhibit-warnings #-clisp 2 + #+clisp 3) + ;; SAFETY = SPEED (and < 3) should provide reasonable + ;; safety, but might skip some unreasonably expensive + ;; stuff (e.g. %DETECT-STACK-EXHAUSTION in sbcl-0.7.2). + (safety 2) + (space 1) + (speed 2))))) (compile 'proclaim-target-optimization) (defun in-target-cross-compilation-mode (fun) "Call FUN with everything set up appropriately for cross-compiling @@ -122,8 +127,10 @@ $SBCL_XC_HOST <<-'EOF' || exit 1 (when (position :sb-after-xc-core *shebang-features*) #+cmu (ext:save-lisp "output/after-xc.core" :load-init-file nil) #+sbcl (sb-ext:save-lisp-and-die "output/after-xc.core") + #+clisp (ext:saveinitmem "output/after-xc.core") ) #+cmu (ext:quit) + #+clisp (ext:quit) EOF # Run GENESIS (again) in order to create cold-sbcl.core. (The first diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 84c86f8..03af7eb 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1128,6 +1128,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "MAKE-NULL-LEXENV" "MAKE-NULL-INTERACTIVE-LEXENV" "MAKE-NUMERIC-TYPE" "MAKE-SINGLE-FLOAT" "MAKE-SPECIALIZABLE-ARRAY" + "MAKE-UNPORTABLE-FLOAT" "%MAKE-INSTANCE" "MAKE-VALUE-CELL" "MAKE-VALUES-TYPE" diff --git a/src/code/class.lisp b/src/code/class.lisp index a0e26d9..0d19c7c 100644 --- a/src/code/class.lisp +++ b/src/code/class.lisp @@ -211,7 +211,7 @@ (layout-proper-name layout) (layout-invalid layout)))) -(eval-when (:compile-toplevel :load-toplevel :execute) +(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) (defun layout-proper-name (layout) (classoid-proper-name (layout-classoid layout)))) @@ -521,7 +521,11 @@ (when (> depth max-depth) (setf max-depth depth)))) (let* ((new-length (max (1+ max-depth) length)) - (inherits (make-array new-length))) + ;; KLUDGE: 0 here is the "uninitialized" element. We need + ;; to specify it explicitly for portability purposes, as + ;; elements can be read before being set [ see below, "(EQL + ;; OLD-LAYOUT 0)" ]. -- CSR, 2002-04-20 + (inherits (make-array new-length :initial-element 0))) (dotimes (i length) (let* ((layout (svref layouts i)) (depth (layout-depthoid layout))) diff --git a/src/code/cross-float.lisp b/src/code/cross-float.lisp index 72e6638..e0b2eb0 100644 --- a/src/code/cross-float.lisp +++ b/src/code/cross-float.lisp @@ -237,3 +237,4 @@ (ash 1 52)) (expt 0.5d0 52)))) (* sign (kludge-opaque-expt 2.0d0 expt) mant))))) + diff --git a/src/code/defbangstruct.lisp b/src/code/defbangstruct.lisp index ea2939e..7b9ba18 100644 --- a/src/code/defbangstruct.lisp +++ b/src/code/defbangstruct.lisp @@ -104,7 +104,7 @@ ;; DEF!STRUCT is made to work fully, this list is processed, then ;; made unbound, and should no longer be used. (defvar *delayed-def!structs* nil)) -(eval-when (:compile-toplevel :load-toplevel :execute) +(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) ;; Parse the arguments for a DEF!STRUCT call, and return ;; (VALUES NAME DEFSTRUCT-ARGS MAKE-LOAD-FORM-FUN DEF!STRUCT-SUPERTYPE), ;; where NAME is the name of the new type, DEFSTRUCT-ARGS is the diff --git a/src/code/defmacro.lisp b/src/code/defmacro.lisp index c80dcba..aec98f0 100644 --- a/src/code/defmacro.lisp +++ b/src/code/defmacro.lisp @@ -16,10 +16,18 @@ ;;; bootstrap idiom ;;; CL:DEFMACRO SB!XC:DEFMACRO ;;; SB!XC:DEFMACRO CL:DEFMACRO -(eval-when (:compile-toplevel :load-toplevel :execute) +(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) (defun %expander-for-defmacro (name lambda-list body) (unless (symbolp name) (error "The macro name ~S is not a symbol." name)) + ;; When we are building the cross-compiler, we could be in a host + ;; lisp which implements CL macros (e.g. CL:AND) as special + ;; operators (while still providing a macroexpansion for + ;; compliance): therefore can't use the host's SPECIAL-OPERATOR-P + ;; as a discriminator, but that's OK because the set of forms the + ;; cross-compiler compiles is tightly controlled. -- CSR, + ;; 2003-04-20 + #-sb-xc-host (when (special-operator-p name) (error "The special operator ~S can't be redefined as a macro." name)) @@ -92,7 +100,7 @@ name)))) (progn (def (:load-toplevel :execute) #-sb-xc-host t #+sb-xc-host nil) - (def (:compile-toplevel) nil))) + (def (#-sb-xc :compile-toplevel) nil))) ;;; Parse the definition and make an expander function. The actual ;;; definition is done by %DEFMACRO which we expand into. After the diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp index c020545..89a4edc 100644 --- a/src/code/defstruct.lisp +++ b/src/code/defstruct.lisp @@ -207,11 +207,14 @@ ;;; Return the name of a defstruct slot as a symbol. We store it as a ;;; string to avoid creating lots of worthless symbols at load time. +;;; +;;; FIXME: This has horrible package issues. In many ways, it would +;;; be very nice to treat the names of structure slots as strings, but +;;; unfortunately PCL requires slot names to be interned symbols. +;;; Maybe we want to resurrect something like the old +;;; SB-SLOT-ACCESSOR-NAME package? (defun dsd-name (dsd) - (intern (string (dsd-%name dsd)) - (if (dsd-accessor-name dsd) - (symbol-package (dsd-accessor-name dsd)) - (sane-package)))) + (intern (dsd-%name dsd))) ;;;; typed (non-class) structures @@ -223,7 +226,7 @@ ;;;; shared machinery for inline and out-of-line slot accessor functions -(eval-when (:compile-toplevel :load-toplevel :execute) +(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) ;; information about how a slot of a given DSD-RAW-TYPE is to be accessed (defstruct raw-slot-data @@ -1049,16 +1052,16 @@ (collect ((moved) (retyped)) (dolist (name (intersection onames nnames)) - (let ((os (find name oslots :key #'dsd-name)) - (ns (find name nslots :key #'dsd-name))) - (unless (subtypep (dsd-type ns) (dsd-type os)) + (let ((os (find name oslots :key #'dsd-name :test #'string=)) + (ns (find name nslots :key #'dsd-name :test #'string=))) + (unless (sb!xc:subtypep (dsd-type ns) (dsd-type os)) (retyped name)) (unless (and (= (dsd-index os) (dsd-index ns)) (eq (dsd-raw-type os) (dsd-raw-type ns))) (moved name)))) (values (moved) (retyped) - (set-difference onames nnames))))) + (set-difference onames nnames :test #'string=))))) ;;; If we are redefining a structure with different slots than in the ;;; currently loaded version, give a warning and return true. diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index d279677..1a62a86 100644 --- a/src/code/early-extensions.lisp +++ b/src/code/early-extensions.lisp @@ -161,7 +161,7 @@ ;;; COLLECT-LIST-EXPANDER handles the list collection case. N-TAIL ;;; is the pointer to the current tail of the list, or NIL if the list ;;; is empty. -(eval-when (:compile-toplevel :load-toplevel :execute) +(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) (defun collect-normal-expander (n-value fun forms) `(progn ,@(mapcar (lambda (form) `(setq ,n-value (,fun ,form ,n-value))) forms) @@ -616,7 +616,7 @@ (consp (cdr name)) (symbolp (cadr name)) (consp (cddr name)) - (symbolp (caddr name)) + (or (symbolp (caddr name)) (stringp (caddr name))) (consp (cdddr name)) (member (cadddr name) diff --git a/src/code/early-type.lisp b/src/code/early-type.lisp index 77698dd..5aace45 100644 --- a/src/code/early-type.lisp +++ b/src/code/early-type.lisp @@ -326,22 +326,22 @@ ;; canonicalize to (DOUBLE-FLOAT 0.0d0 0.0d0), because numeric ;; ranges are compared by arithmetic operators (while MEMBERship is ;; compared by EQL). -- CSR, 2003-04-23 - (let ((singlep (subsetp '(-0.0f0 0.0f0) members)) - (doublep (subsetp '(-0.0d0 0.0d0) members)) + (let ((singlep (subsetp `(,(load-time-value (make-unportable-float :single-float-negative-zero)) 0.0f0) members)) + (doublep (subsetp `(,(load-time-value (make-unportable-float :double-float-negative-zero)) 0.0d0) members)) #!+long-float - (longp (subsetp '(-0.0l0 0.0l0) members))) + (longp (subsetp `(,(load-time-value (make-unportable-float :long-float-negative-zero)) 0.0l0) members))) (if (or singlep doublep #!+long-float longp) (let (union-types) (when singlep (push (ctype-of 0.0f0) union-types) - (setf members (set-difference members '(-0.0f0 0.0f0)))) + (setf members (set-difference members `(,(load-time-value (make-unportable-float :single-float-negative-zero)) 0.0f0)))) (when doublep (push (ctype-of 0.0d0) union-types) - (setf members (set-difference members '(-0.0d0 0.0d0)))) + (setf members (set-difference members `(,(load-time-value (make-unportable-float :double-float-negative-zero)) 0.0d0)))) #!+long-float (when longp (push (ctype-of 0.0l0) union-types) - (setf members (set-difference members '(-0.0l0 0.0l0)))) + (setf members (set-difference members `(,(load-time-value (make-unportable-float :long-float-negative-zero)) 0.0l0)))) (aver (not (null union-types))) (make-union-type t (if (null members) diff --git a/src/code/host-alieneval.lisp b/src/code/host-alieneval.lisp index 766b241..413beba 100644 --- a/src/code/host-alieneval.lisp +++ b/src/code/host-alieneval.lisp @@ -30,7 +30,7 @@ ;;;; ALIEN-TYPE-INFO stuff -(eval-when (:compile-toplevel :execute :load-toplevel) +(eval-when (#-sb-xc :compile-toplevel :execute :load-toplevel) (defstruct (alien-type-class (:copier nil)) (name nil :type symbol) @@ -147,7 +147,7 @@ ;;; COMPILER-LET is no longer supported by ANSI or SBCL. Instead, we ;;; follow the suggestion in CLTL2 of using SYMBOL-MACROLET to achieve ;;; a similar effect. -(eval-when (:compile-toplevel :load-toplevel :execute) +(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) (defun auxiliary-type-definitions (env) (multiple-value-bind (result expanded-p) (sb!xc:macroexpand '&auxiliary-type-definitions& env) @@ -259,7 +259,7 @@ ,body)) (%define-alien-type-translator ',name #',defun-name ,docs)))))) -(eval-when (:compile-toplevel :load-toplevel :execute) +(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) (defun %define-alien-type-translator (name translator docs) (declare (ignore docs)) (setf (info :alien-type :kind name) :primitive) @@ -285,7 +285,7 @@ (deprecation-warning 'def-alien-type 'define-alien-type) `(define-alien-type ,@rest)) -(eval-when (:compile-toplevel :load-toplevel :execute) +(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) (defun %def-auxiliary-alien-types (types) (dolist (info types) (destructuring-bind (kind name defn) info diff --git a/src/code/irrat.lisp b/src/code/irrat.lisp index bab7661..fe13620 100644 --- a/src/code/irrat.lisp +++ b/src/code/irrat.lisp @@ -14,8 +14,9 @@ ;;;; miscellaneous constants, utility functions, and macros -(defconstant pi 3.14159265358979323846264338327950288419716939937511L0) -;(defconstant e 2.71828182845904523536028747135266249775724709369996L0) +(defconstant pi + #!+long-float 3.14159265358979323846264338327950288419716939937511l0 + #!-long-float 3.14159265358979323846264338327950288419716939937511d0) ;;; Make these INLINE, since the call to C is at least as compact as a ;;; Lisp call, and saves number consing to boot. @@ -903,13 +904,18 @@ ;; space 0 to get maybe-inline functions inlined (declare (optimize (speed 3) (space 0))) (cond ((> (abs x) - #-(or linux hpux) #.(/ (asinh most-positive-double-float) 4d0) - ;; This is more accurate under linux. - #+(or linux hpux) #.(/ (+ (log 2.0d0) - (log most-positive-double-float)) - 4d0)) - (coerce-to-complex-type (float-sign x) - (float-sign y) z)) + ;; FIXME: this form is hideously broken wrt + ;; cross-compilation portability. Much else in this + ;; file is too, of course, sometimes hidden by + ;; constant-folding, but this one in particular clearly + ;; depends on host and target + ;; MOST-POSITIVE-DOUBLE-FLOATs being equal. -- CSR, + ;; 2003-04-20 + #.(/ (+ (log 2.0d0) + (log most-positive-double-float)) + 4d0)) + (coerce-to-complex-type (float-sign x) + (float-sign y) z)) (t (let* ((tv (%tan y)) (beta (+ 1.0d0 (* tv tv))) diff --git a/src/code/late-format.lisp b/src/code/late-format.lisp index a0d204e..ee5deb1 100644 --- a/src/code/late-format.lisp +++ b/src/code/late-format.lisp @@ -327,7 +327,7 @@ (values (progn ,@body-without-decls) ,directives)))) -(eval-when (:compile-toplevel :load-toplevel :execute) +(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) (defun %set-format-directive-expander (char fn) (setf (aref *format-directive-expanders* (char-code (char-upcase char))) fn) diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index c74a081..ec42475 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -1321,8 +1321,10 @@ (let ((members (member-type-members not-type))) (if (some #'floatp members) (let (floats) - (dolist (pair '((0.0f0 . -0.0f0) (0.0d0 . -0.0d0) - #!+long-float (0.0l0 . -0.0l0))) + (dolist (pair `((0.0f0 . ,(load-time-value (make-unportable-float :single-float-negative-zero))) + (0.0d0 . ,(load-time-value (make-unportable-float :double-float-negative-zero))) + #!+long-float + (0.0l0 . ,(load-time-value (make-unportable-float :long-float-negative-zero))))) (when (member (car pair) members) (aver (not (member (cdr pair) members))) (push (cdr pair) floats) @@ -1547,17 +1549,17 @@ ((consp low-bound) (let ((low-value (car low-bound))) (or (eql low-value high-bound) - (and (eql low-value -0f0) (eql high-bound 0f0)) - (and (eql low-value 0f0) (eql high-bound -0f0)) - (and (eql low-value -0d0) (eql high-bound 0d0)) - (and (eql low-value 0d0) (eql high-bound -0d0))))) + (and (eql low-value (load-time-value (make-unportable-float :single-float-negative-zero))) (eql high-bound 0f0)) + (and (eql low-value 0f0) (eql high-bound (load-time-value (make-unportable-float :single-float-negative-zero)))) + (and (eql low-value (load-time-value (make-unportable-float :double-float-negative-zero))) (eql high-bound 0d0)) + (and (eql low-value 0d0) (eql high-bound (load-time-value (make-unportable-float :double-float-negative-zero))))))) ((consp high-bound) (let ((high-value (car high-bound))) (or (eql high-value low-bound) - (and (eql high-value -0f0) (eql low-bound 0f0)) - (and (eql high-value 0f0) (eql low-bound -0f0)) - (and (eql high-value -0d0) (eql low-bound 0d0)) - (and (eql high-value 0d0) (eql low-bound -0d0))))) + (and (eql high-value (load-time-value (make-unportable-float :single-float-negative-zero))) (eql low-bound 0f0)) + (and (eql high-value 0f0) (eql low-bound (load-time-value (make-unportable-float :single-float-negative-zero)))) + (and (eql high-value (load-time-value (make-unportable-float :double-float-negative-zero))) (eql low-bound 0d0)) + (and (eql high-value 0d0) (eql low-bound (load-time-value (make-unportable-float :double-float-negative-zero))))))) ((and (eq (numeric-type-class low) 'integer) (eq (numeric-type-class high) 'integer)) (eql (1+ low-bound) high-bound)) diff --git a/src/code/macros.lisp b/src/code/macros.lisp index 9f5a486..7e7783a 100644 --- a/src/code/macros.lisp +++ b/src/code/macros.lisp @@ -176,11 +176,11 @@ name)))) (progn (def (:load-toplevel :execute) #-sb-xc-host t #+sb-xc-host nil) - (def (:compile-toplevel) nil))) + #-sb-xc (def (:compile-toplevel) nil))) ;;;; CASE, TYPECASE, and friends -(eval-when (:compile-toplevel :load-toplevel :execute) +(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) ;;; CASE-BODY returns code for all the standard "case" macros. NAME is ;;; the macro name, and KEYFORM is the thing to case on. MULTI-P diff --git a/src/code/pathname.lisp b/src/code/pathname.lisp index da7e137..61195bd 100644 --- a/src/code/pathname.lisp +++ b/src/code/pathname.lisp @@ -54,15 +54,16 @@ ;;; A PATTERN is a list of entries and wildcards used for pattern ;;; matches of translations. -(sb!xc:defstruct (pattern (:constructor make-pattern (pieces))) +(def!struct (pattern (:constructor make-pattern (pieces))) (pieces nil :type list)) ;;;; PATHNAME structures ;;; the various magic tokens that are allowed to appear in pretty much ;;; all pathname components -(sb!xc:deftype pathname-component-tokens () - '(member nil :unspecific :wild)) +(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) + (def!type pathname-component-tokens () + '(member nil :unspecific :wild))) (sb!xc:defstruct (pathname (:conc-name %pathname-) (:constructor %make-pathname (host diff --git a/src/code/pred.lisp b/src/code/pred.lisp index 78a51c2..dd6ccb2 100644 --- a/src/code/pred.lisp +++ b/src/code/pred.lisp @@ -245,7 +245,7 @@ (/show0 "about to do test cases in pred.lisp") #!+sb-test -(let ((test-cases '((0.0 -0.0 t) +(let ((test-cases `((0.0 ,(load-time-value (make-unportable-float :single-float-negative-zero)) t) (0.0 1.0 nil) (#c(1 0) #c(1.0 0) t) (#c(1.1 0) #c(11/10 0) nil) ; due to roundoff error diff --git a/src/code/primordial-extensions.lisp b/src/code/primordial-extensions.lisp index 9edc6d9..4f25976 100644 --- a/src/code/primordial-extensions.lisp +++ b/src/code/primordial-extensions.lisp @@ -57,7 +57,7 @@ ;;;; DO-related stuff which needs to be visible on the cross-compilation host -(eval-when (:compile-toplevel :load-toplevel :execute) +(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) (defun frob-do-body (varlist endlist decls-and-code bind step name block) (let* ((r-inits nil) ; accumulator for reversed list (r-steps nil) ; accumulator for reversed list @@ -164,7 +164,7 @@ ;;; Concatenate together the names of some strings and symbols, ;;; producing a symbol in the current package. -(eval-when (:compile-toplevel :load-toplevel :execute) +(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) (defun symbolicate (&rest things) (let ((name (case (length things) ;; why isn't this just the value in the T branch? diff --git a/src/code/print.lisp b/src/code/print.lisp index 0acd176..a6539ee 100644 --- a/src/code/print.lisp +++ b/src/code/print.lisp @@ -1391,30 +1391,36 @@ ;;; part of the computation to avoid over/under flow. When ;;; denormalized, we must pull out a large factor, since there is more ;;; negative exponent range than positive range. + +(eval-when (:compile-toplevel :execute) + (setf *read-default-float-format* + #!+long-float 'long-float #!-long-float 'double-float)) (defun scale-exponent (original-x) (let* ((x (coerce original-x 'long-float))) (multiple-value-bind (sig exponent) (decode-float x) (declare (ignore sig)) - (if (= x 0.0l0) - (values (float 0.0l0 original-x) 1) - (let* ((ex (round (* exponent (log 2l0 10)))) + (if (= x 0.0e0) + (values (float 0.0e0 original-x) 1) + (let* ((ex (round (* exponent (log 2e0 10)))) (x (if (minusp ex) (if (float-denormalized-p x) #!-long-float - (* x 1.0l16 (expt 10.0l0 (- (- ex) 16))) + (* x 1.0e16 (expt 10.0e0 (- (- ex) 16))) #!+long-float - (* x 1.0l18 (expt 10.0l0 (- (- ex) 18))) - (* x 10.0l0 (expt 10.0l0 (- (- ex) 1)))) - (/ x 10.0l0 (expt 10.0l0 (1- ex)))))) - (do ((d 10.0l0 (* d 10.0l0)) + (* x 1.0e18 (expt 10.0e0 (- (- ex) 18))) + (* x 10.0e0 (expt 10.0e0 (- (- ex) 1)))) + (/ x 10.0e0 (expt 10.0e0 (1- ex)))))) + (do ((d 10.0e0 (* d 10.0e0)) (y x (/ x d)) (ex ex (1+ ex))) - ((< y 1.0l0) - (do ((m 10.0l0 (* m 10.0l0)) + ((< y 1.0e0) + (do ((m 10.0e0 (* m 10.0e0)) (z y (* y m)) (ex ex (1- ex))) - ((>= z 0.1l0) + ((>= z 0.1e0) (values (float z original-x) ex)))))))))) +(eval-when (:compile-toplevel :execute) + (setf *read-default-float-format* 'single-float)) ;;;; entry point for the float printer diff --git a/src/code/reader.lisp b/src/code/reader.lisp index 41226cb..49a0ba0 100644 --- a/src/code/reader.lisp +++ b/src/code/reader.lisp @@ -1220,22 +1220,19 @@ ;; while attempting to constant-fold. Maybe some sort ;; of load-time-form magic could be used instead? (case float-format - (short-float - (values - (log sb!xc:least-positive-normalized-short-float 10s0) - (log sb!xc:most-positive-short-float 10s0))) - (single-float + ((short-float single-float) (values (log sb!xc:least-positive-normalized-single-float 10f0) (log sb!xc:most-positive-single-float 10f0))) - (double-float + ((double-float #!-long-float long-float) (values (log sb!xc:least-positive-normalized-double-float 10d0) (log sb!xc:most-positive-double-float 10d0))) + #!+long-float (long-float (values - (log sb!xc:least-positive-normalized-long-float 10L0) - (log sb!xc:most-positive-long-float 10L0)))) + (log sb!xc:least-positive-normalized-long-float 10l0) + (log sb!xc:most-positive-long-float 10l0)))) (let ((correction (cond ((<= exponent min-expo) (ceiling (- min-expo exponent))) ((>= exponent max-expo) diff --git a/src/code/target-hash-table.lisp b/src/code/target-hash-table.lisp index cb9c502..0cdd509 100644 --- a/src/code/target-hash-table.lisp +++ b/src/code/target-hash-table.lisp @@ -15,7 +15,7 @@ ;;;; utilities (eval-when (:compile-toplevel :load-toplevel :execute) - (defconstant max-hash most-positive-fixnum)) + (defconstant max-hash sb!xc:most-positive-fixnum)) (deftype hash () `(integer 0 ,max-hash)) diff --git a/src/code/target-random.lisp b/src/code/target-random.lisp index af1e45f..28c4db4 100644 --- a/src/code/target-random.lisp +++ b/src/code/target-random.lisp @@ -263,12 +263,12 @@ (cond ((and (fixnump arg) (<= arg random-fixnum-max) (> arg 0)) (rem (random-chunk state) arg)) - ((and (typep arg 'single-float) (> arg 0.0S0)) + ((and (typep arg 'single-float) (> arg 0.0f0)) (%random-single-float arg state)) - ((and (typep arg 'double-float) (> arg 0.0D0)) + ((and (typep arg 'double-float) (> arg 0.0d0)) (%random-double-float arg state)) #!+long-float - ((and (typep arg 'long-float) (> arg 0.0L0)) + ((and (typep arg 'long-float) (> arg 0.0l0)) (%random-long-float arg state)) ((and (integerp arg) (> arg 0)) (%random-integer arg state)) diff --git a/src/code/type-class.lisp b/src/code/type-class.lisp index b703a60..d493d41 100644 --- a/src/code/type-class.lisp +++ b/src/code/type-class.lisp @@ -122,8 +122,8 @@ (:complex-= . type-class-complex-=) (:unparse . type-class-unparse)))) -(eval-when (:compile-toplevel :load-toplevel :execute) - +(declaim (ftype (function (type-class) type-class) copy-type-class-coldly)) +(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) ;;; Copy TYPE-CLASS object X, using only operations which will work ;;; early in cold load. (COPY-STRUCTURE won't work early in cold load, ;;; because it needs RAW-INDEX and RAW-LENGTH information from @@ -147,7 +147,6 @@ ;;; the positive effect of removing indirection could be cancelled by ;;; the negative effect of imposing an unnecessary GC write barrier on ;;; raw data which doesn't actually affect GC.) -(declaim (ftype (function (type-class) type-class) copy-type-class-coldly)) (defun copy-type-class-coldly (x) ;; KLUDGE: If the slots of TYPE-CLASS ever change in a way not ;; reflected in *TYPE-CLASS-FUN-SLOTS*, the slots here will diff --git a/src/cold/ansify.lisp b/src/cold/ansify.lisp index 50023dc..5bfa6d2 100644 --- a/src/cold/ansify.lisp +++ b/src/cold/ansify.lisp @@ -40,7 +40,10 @@ ;; These problems don't seem deep, and could probably be worked ;; around. #+nil (clisp-ouch "no (DOCUMENTATION X) when X is a PACKAGE") - #+nil (clisp-ouch "no (FUNCTION (SETF SYMBOL-FUNCTION))"))) + #+nil (clisp-ouch "no (FUNCTION (SETF SYMBOL-FUNCTION))")) + + (ext:without-package-lock ("SYSTEM") + (setf system::*inhibit-floating-point-underflow* t))) ;;;; CMU CL issues diff --git a/src/cold/defun-load-or-cload-xcompiler.lisp b/src/cold/defun-load-or-cload-xcompiler.lisp index 55bb02a..c61e18b 100644 --- a/src/cold/defun-load-or-cload-xcompiler.lisp +++ b/src/cold/defun-load-or-cload-xcompiler.lisp @@ -147,6 +147,7 @@ "SB!PRETTY" "SB!PROFILE" "SB!SYS" + "SB!THREAD" "SB!UNIX" "SB!VM" "SB!WALKER")) diff --git a/src/compiler/float-tran.lisp b/src/compiler/float-tran.lisp index 96f51b1..f4f65bf 100644 --- a/src/compiler/float-tran.lisp +++ b/src/compiler/float-tran.lisp @@ -538,9 +538,18 @@ (specifier-type `(or (,float-type ,(or lo '*) ,(or hi '*)) (complex ,float-type))))) +) ; PROGN + +(eval-when (:compile-toplevel :execute) + ;; So the problem with this hack is that it's actually broken. If + ;; the host does not have long floats, then setting *R-D-F-F* to + ;; LONG-FLOAT doesn't actually buy us anything. FIXME. + (setf *read-default-float-format* + #!+long-float 'long-float #!-long-float 'double-float)) ;;; Test whether the numeric-type ARG is within in domain specified by ;;; DOMAIN-LOW and DOMAIN-HIGH, consider negative and positive zero to -;;; be distinct. +;;; be distinct. +#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) (defun domain-subtypep (arg domain-low domain-high) (declare (type numeric-type arg) (type (or real null) domain-low domain-high)) @@ -552,11 +561,18 @@ (when (and arg-lo (floatp arg-lo-val) (zerop arg-lo-val) (consp arg-lo) (minusp (float-sign arg-lo-val))) (compiler-note "float zero bound ~S not correctly canonicalized?" arg-lo) - (setq arg-lo '(0l0) arg-lo-val 0l0)) + (setq arg-lo '(0e0) arg-lo-val 0e0)) (when (and arg-hi (zerop arg-hi-val) (floatp arg-hi-val) (consp arg-hi) (plusp (float-sign arg-hi-val))) (compiler-note "float zero bound ~S not correctly canonicalized?" arg-hi) - (setq arg-hi '(-0l0) arg-hi-val -0l0)) + (setq arg-hi `(,(ecase *read-default-float-format* + (double-float (load-time-value (make-unportable-float :double-float-negative-zero))) + #!+long-float + (long-float (load-time-value (make-unportable-float :long-float-negative-zero))))) + arg-hi-val (ecase *read-default-float-format* + (double-float (load-time-value (make-unportable-float :double-float-negative-zero))) + #!+long-float + (long-float (load-time-value (make-unportable-float :long-float-negative-zero)))))) (and (or (null domain-low) (and arg-lo (>= arg-lo-val domain-low) (not (and (zerop domain-low) (floatp domain-low) @@ -573,6 +589,11 @@ (if (consp arg-hi) (minusp (float-sign arg-hi-val)) (plusp (float-sign arg-hi-val)))))))))) +(eval-when (:compile-toplevel :execute) + (setf *read-default-float-format* 'single-float)) + +#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) +(progn ;;; Handle monotonic functions of a single variable whose domain is ;;; possibly part of the real line. ARG is the variable, FCN is the @@ -672,7 +693,7 @@ (frob atanh -1d0 1d0 -1 1) ;; Kahan says that (sqrt -0.0) is -0.0, so use a specifier that ;; includes -0.0. - (frob sqrt -0d0 nil 0 nil)) + (frob sqrt (load-time-value (make-unportable-float :double-float-negative-zero)) nil 0 nil)) ;;; Compute bounds for (expt x y). This should be easy since (expt x ;;; y) = (exp (* y (log x))). However, computations done this way diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index 9bfeeaa..5f91e0e 100644 --- a/src/compiler/generic/genesis.lisp +++ b/src/compiler/generic/genesis.lisp @@ -2021,7 +2021,7 @@ (defun cold-load-symbol (size package) (let ((string (make-string size))) (read-string-as-bytes *fasl-input-stream* string) - (cold-intern (intern string package) package))) + (cold-intern (intern string package)))) (macrolet ((frob (name pname-len package-len) `(define-cold-fop (,name) diff --git a/src/compiler/globaldb.lisp b/src/compiler/globaldb.lisp index ee434de..8a7a6ef 100644 --- a/src/compiler/globaldb.lisp +++ b/src/compiler/globaldb.lisp @@ -360,7 +360,7 @@ ,(do-compact-info name class type type-number value n-env body))))) -(eval-when (:compile-toplevel :load-toplevel :execute) +(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) ;;; Return code to iterate over a compact info environment. (defun do-compact-info (name-var class-var type-var type-number-var value-var diff --git a/src/compiler/macros.lisp b/src/compiler/macros.lisp index d30e87a..a86bbc9 100644 --- a/src/compiler/macros.lisp +++ b/src/compiler/macros.lisp @@ -133,7 +133,7 @@ (deftype attributes () 'fixnum) -(eval-when (:compile-toplevel :load-toplevel :execute) +(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) ;;; Given a list of attribute names and an alist that translates them ;;; to masks, return the OR of the masks. @@ -263,7 +263,7 @@ ;;;; to parse the IR1 representation of a function call using a ;;;; standard function lambda-list. -(eval-when (:compile-toplevel :load-toplevel :execute) +(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) ;;; Given a DEFTRANSFORM-style lambda-list, generate code that parses ;;; the arguments of a combination with respect to that lambda-list. @@ -707,7 +707,7 @@ ;;; experimentation, not for ordinary use, so it should probably ;;; become conditional on SB-SHOW. -(eval-when (:compile-toplevel :load-toplevel :execute) +(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) (defstruct (event-info (:copier nil)) ;; The name of this event. diff --git a/src/compiler/policy.lisp b/src/compiler/policy.lisp index ff543cc..9ec12e3 100644 --- a/src/compiler/policy.lisp +++ b/src/compiler/policy.lisp @@ -22,12 +22,18 @@ ;;; alists instead. (def!type policy () 'list) -(eval-when (#-sb-xc-host :compile-toplevel :load-toplevel :execute) - (defstruct policy-dependent-quality - name - expression - getter - values-documentation)) +;;; FIXME: the original implementation of this was protected by +;;; +;;; (eval-when (#-sb-xc-host :compile-toplevel :load-toplevel :execute) +;;; +;;; but I don't know why. This seems to work, but I don't understand +;;; why the original wasn't this in the first place. -- CSR, +;;; 2003-05-04 +(defstruct policy-dependent-quality + name + expression + getter + values-documentation) ;;; names of recognized optimization policy qualities (defvar *policy-qualities*) ; (initialized at cold init) diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index 648b31f..462e449 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -834,11 +834,11 @@ :low (if lo-float-zero-p (if (consp lo) (list (float 0.0 lo-val)) - (float -0.0 lo-val)) + (float (load-time-value (make-unportable-float :single-float-negative-zero)) lo-val)) lo) :high (if hi-float-zero-p (if (consp hi) - (list (float -0.0 hi-val)) + (list (float (load-time-value (make-unportable-float :single-float-negative-zero)) hi-val)) (float 0.0 hi-val)) hi)) type)) @@ -956,7 +956,9 @@ ;;; FIXME: MAKE-CANONICAL-UNION-TYPE and CONVERT-MEMBER-TYPE probably ;;; belong in the kernel's type logic, invoked always, instead of in -;;; the compiler, invoked only during some type optimizations. +;;; the compiler, invoked only during some type optimizations. (In +;;; fact, as of 0.pre8.100 or so they probably are, under +;;; MAKE-MEMBER-TYPE, so probably this code can be deleted) ;;; Take a list of types and return a canonical type specifier, ;;; combining any MEMBER types together. If both positive and negative @@ -971,15 +973,15 @@ (setf members (union members (member-type-members type))) (push type misc-types))) #!+long-float - (when (null (set-difference '(-0l0 0l0) members)) - (push (specifier-type '(long-float 0l0 0l0)) misc-types) - (setf members (set-difference members '(-0l0 0l0)))) - (when (null (set-difference '(-0d0 0d0) members)) - (push (specifier-type '(double-float 0d0 0d0)) misc-types) - (setf members (set-difference members '(-0d0 0d0)))) - (when (null (set-difference '(-0f0 0f0) members)) - (push (specifier-type '(single-float 0f0 0f0)) misc-types) - (setf members (set-difference members '(-0f0 0f0)))) + (when (null (set-difference `(,(load-time-value (make-unportable-float :long-float-negative-zero)) 0.0l0) members)) + (push (specifier-type '(long-float 0.0l0 0.0l0)) misc-types) + (setf members (set-difference members `(,(load-time-value (make-unportable-float :long-float-negative-zero)) 0.0l0)))) + (when (null (set-difference `(,(load-time-value (make-unportable-float :double-float-negative-zero)) 0.0d0) members)) + (push (specifier-type '(double-float 0.0d0 0.0d0)) misc-types) + (setf members (set-difference members `(,(load-time-value (make-unportable-float :double-float-negative-zero)) 0.0d0)))) + (when (null (set-difference `(,(load-time-value (make-unportable-float :single-float-negative-zero)) 0.0f0) members)) + (push (specifier-type '(single-float 0.0f0 0.0f0)) misc-types) + (setf members (set-difference members `(,(load-time-value (make-unportable-float :single-float-negative-zero)) 0.0f0)))) (if members (apply #'type-union (make-member-type :members members) misc-types) (apply #'type-union misc-types)))) diff --git a/src/compiler/x86/float.lisp b/src/compiler/x86/float.lisp index 3cc9def..3cf0cf0 100644 --- a/src/compiler/x86/float.lisp +++ b/src/compiler/x86/float.lisp @@ -177,26 +177,30 @@ ;;; stored in a more precise form on chip. Anyhow, might as well use ;;; the feature. It can be turned off by hacking the ;;; "immediate-constant-sc" in vm.lisp. +(eval-when (:compile-toplevel :execute) + (setf *read-default-float-format* + #!+long-float 'long-float #!-long-float 'double-float)) (define-move-fun (load-fp-constant 2) (vop x y) ((fp-constant) (single-reg double-reg #!+long-float long-reg)) (let ((value (sb!c::constant-value (sb!c::tn-leaf x)))) (with-empty-tn@fp-top(y) (cond ((zerop value) (inst fldz)) - ((= value 1l0) + ((= value 1e0) (inst fld1)) - ((= value pi) + ((= value (coerce pi *read-default-float-format*)) (inst fldpi)) - ((= value (log 10l0 2l0)) + ((= value (log 10e0 2e0)) (inst fldl2t)) - ((= value (log 2.718281828459045235360287471352662L0 2l0)) + ((= value (log 2.718281828459045235360287471352662e0 2e0)) (inst fldl2e)) - ((= value (log 2l0 10l0)) + ((= value (log 2e0 10e0)) (inst fldlg2)) - ((= value (log 2l0 2.718281828459045235360287471352662L0)) + ((= value (log 2e0 2.718281828459045235360287471352662e0)) (inst fldln2)) (t (warn "ignoring bogus i387 constant ~A" value)))))) - +(eval-when (:compile-toplevel :execute) + (setf *read-default-float-format* 'single-float)) ;;;; complex float move functions diff --git a/src/compiler/x86/insts.lisp b/src/compiler/x86/insts.lisp index 9febabb..514f116 100644 --- a/src/compiler/x86/insts.lisp +++ b/src/compiler/x86/insts.lisp @@ -286,7 +286,7 @@ :printer #'print-word-reg/mem) ;;; added by jrd -(eval-when (:compile-toplevel :load-toplevel :execute) +(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) (defun print-fp-reg (value stream dstate) (declare (ignore dstate)) (format stream "FR~D" value)) diff --git a/src/compiler/x86/macros.lisp b/src/compiler/x86/macros.lisp index 1af259d..d870e2f 100644 --- a/src/compiler/x86/macros.lisp +++ b/src/compiler/x86/macros.lisp @@ -253,7 +253,7 @@ ,@forms)) ;;;; error code -(eval-when (:compile-toplevel :load-toplevel :execute) +(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) (defun emit-error-break (vop kind code values) (let ((vector (gensym))) `((inst int 3) ; i386 breakpoint instruction diff --git a/src/compiler/x86/static-fn.lisp b/src/compiler/x86/static-fn.lisp index ba94709..9e080e4 100644 --- a/src/compiler/x86/static-fn.lisp +++ b/src/compiler/x86/static-fn.lisp @@ -22,7 +22,7 @@ (:temporary (:sc unsigned-reg :offset ecx-offset :from (:eval 0) :to (:eval 2)) ecx)) -(eval-when (:compile-toplevel :load-toplevel :execute) +(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) (defun static-fun-template-name (num-args num-results) (intern (format nil "~:@(~R-arg-~R-result-static-fun~)" diff --git a/src/compiler/x86/vm.lisp b/src/compiler/x86/vm.lisp index f0c102e..bb7a622 100644 --- a/src/compiler/x86/vm.lisp +++ b/src/compiler/x86/vm.lisp @@ -375,6 +375,18 @@ ;;; If value can be represented as an immediate constant, then return ;;; the appropriate SC number, otherwise return NIL. (!def-vm-support-routine immediate-constant-sc (value) + ;; KLUDGE: although this might not look different from the FIXNUM + ;; below, in the TYPECASE, SB-INT:FIXNUMP actually tests against the + ;; target FIXNUM type, as opposed to TYPECASE FIXNUM which tests + ;; against the host FIXNUM range. + #+sb-xc-host + (when (fixnump value) + ;; FIXME: this block name was not obvious. Also, since this idiom + ;; is presumably going to be repeated in all six (current) + ;; backends, it would be nice to wrap it up somewhat more nicely. + ;; -- CSR, 2003-04-20 + (return-from impl-of-vm-support-routine-immediate-constant-sc + (sc-number-or-lose 'immediate))) (typecase value ((or fixnum #-sb-xc-host system-area-pointer character) (sc-number-or-lose 'immediate)) diff --git a/src/runtime/gencgc.h b/src/runtime/gencgc.h index d9d4804..170fc09 100644 --- a/src/runtime/gencgc.h +++ b/src/runtime/gencgc.h @@ -93,4 +93,4 @@ void gc_alloc_update_page_tables(int unboxed, struct alloc_region *alloc_region); void gc_alloc_update_all_page_tables(void); void gc_set_region_empty(struct alloc_region *region); -#endif _GENCGC_H_ +#endif /* _GENCGC_H_ */ diff --git a/version.lisp-expr b/version.lisp-expr index 2344731..f99abeb 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.8alpha.0.12" +"0.8alpha.0.13"