Menu
▾
▴
[Sbcl-commits] CVS: sbcl/src/compiler float-tran.lisp,1.22,1.23 globaldb.lisp,1.31,1.32 macros.lisp,1.37,1.38 policy.lisp,1.11,1.12 srctran.lisp,1.61,1.62
|
From: Christophe R. <cr...@us...> - 2003-05-05 14:09:45
|
Update of /cvsroot/sbcl/sbcl/src/compiler
In directory sc8-pr-cvs1:/tmp/cvs-serv26337/src/compiler
Modified Files:
float-tran.lisp globaldb.lisp macros.lisp policy.lisp
srctran.lisp
Log Message:
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
Index: float-tran.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/float-tran.lisp,v
retrieving revision 1.22
retrieving revision 1.23
diff -u -d -r1.22 -r1.23
--- float-tran.lisp 3 May 2003 15:32:28 -0000 1.22
+++ float-tran.lisp 5 May 2003 14:09:10 -0000 1.23
@@ -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
Index: globaldb.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/globaldb.lisp,v
retrieving revision 1.31
retrieving revision 1.32
diff -u -d -r1.31 -r1.32
--- globaldb.lisp 3 May 2003 18:26:53 -0000 1.31
+++ globaldb.lisp 5 May 2003 14:09:11 -0000 1.32
@@ -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
Index: macros.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/macros.lisp,v
retrieving revision 1.37
retrieving revision 1.38
diff -u -d -r1.37 -r1.38
--- macros.lisp 3 May 2003 18:26:54 -0000 1.37
+++ macros.lisp 5 May 2003 14:09:12 -0000 1.38
@@ -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.
Index: policy.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/policy.lisp,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -d -r1.11 -r1.12
--- policy.lisp 29 Jan 2003 11:29:13 -0000 1.11
+++ policy.lisp 5 May 2003 14:09:12 -0000 1.12
@@ -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)
Index: srctran.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/srctran.lisp,v
retrieving revision 1.61
retrieving revision 1.62
diff -u -d -r1.61 -r1.62
--- srctran.lisp 3 May 2003 18:26:54 -0000 1.61
+++ srctran.lisp 5 May 2003 14:09:12 -0000 1.62
@@ -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))))
|