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
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.
* 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
* 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:
("src/code/defbangstruct")
+ ("src/code/unportable-float")
+
("src/code/funutils" :not-host)
;; This needs DEF!STRUCT, and is itself needed early so that structure
;; 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
;; 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
(host-cload-stem "src/compiler/generic/genesis")
(sb!vm:genesis :c-header-dir-name "src/runtime/genesis")
#+cmu (ext:quit)
+ #+clisp (ext:quit)
EOF
(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
(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
"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"
(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))))
\f
(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)))
(ash 1 52))
(expt 0.5d0 52))))
(* sign (kludge-opaque-expt 2.0d0 expt) mant)))))
+
;; 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
;;; 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))
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
;;; 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)))
\f
;;;; typed (non-class) structures
\f
;;;; 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
(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.
;;; 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)
(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)
;; 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)
\f
;;;; 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)
;;; 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)
,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)
(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
\f
;;;; 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.
;; 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)))
(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)
(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)
((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))
name))))
(progn
(def (:load-toplevel :execute) #-sb-xc-host t #+sb-xc-host nil)
- (def (:compile-toplevel) nil)))
+ #-sb-xc (def (:compile-toplevel) nil)))
\f
;;;; 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
;;; 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))
\f
;;;; 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
(/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
\f
;;;; 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
;;; 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?
;;; 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))
\f
;;;; entry point for the float printer
;; 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)
;;;; 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))
(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))
(: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
;;; 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
;; 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)))
\f
;;;; CMU CL issues
"SB!PRETTY"
"SB!PROFILE"
"SB!SYS"
+ "SB!THREAD"
"SB!UNIX"
"SB!VM"
"SB!WALKER"))
(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))
(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)
(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
(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
(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)
,(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
(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.
;;;; 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.
;;; 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.
;;; 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)
: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))
;;; 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
(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))))
;;; 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))
\f
;;;; complex float move functions
: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))
,@forms))
\f
;;;; 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
(: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~)"
;;; 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))
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_ */
;;; 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"
projects / sbcl.git / commitdiff