: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))))
(specifier-type 'base-char))
(defoptimizer (values derive-type) ((&rest values))
- (values-specifier-type
- `(values ,@(mapcar (lambda (x)
- (type-specifier (continuation-type x)))
- values))))
+ (make-values-type :required (mapcar #'continuation-type values)))
\f
;;;; byte operations
;;;;
(logior (logand new mask)
(logand int (lognot mask)))))
\f
+;;; Modular functions
+
+;;; (ldb (byte s 0) (foo x y ...)) =
+;;; (ldb (byte s 0) (foo (ldb (byte s 0) x) y ...))
+;;;
+;;; and similar for other arguments.
+
+;;; Try to recursively cut all uses of the continuation CONT to WIDTH
+;;; bits.
+;;;
+;;; For good functions, we just recursively cut arguments; their
+;;; "goodness" means that the result will not increase (in the
+;;; (unsigned-byte +infinity) sense). An ordinary modular function is
+;;; replaced with the version, cutting its result to WIDTH or more
+;;; bits. If we have changed anything, we need to flush old derived
+;;; types, because they have nothing in common with the new code.
+(defun cut-to-width (cont width)
+ (declare (type continuation cont) (type (integer 0) width))
+ (labels ((reoptimize-node (node name)
+ (setf (node-derived-type node)
+ (fun-type-returns
+ (info :function :type name)))
+ (setf (continuation-%derived-type (node-cont node)) nil)
+ (setf (node-reoptimize node) t)
+ (setf (block-reoptimize (node-block node)) t)
+ (setf (component-reoptimize (node-component node)) t))
+ (cut-node (node &aux did-something)
+ (when (and (combination-p node)
+ (fun-info-p (basic-combination-kind node)))
+ (let* ((fun-ref (continuation-use (combination-fun node)))
+ (fun-name (leaf-source-name (ref-leaf fun-ref)))
+ (modular-fun (find-modular-version fun-name width))
+ (name (and (modular-fun-info-p modular-fun)
+ (modular-fun-info-name modular-fun))))
+ (when (and modular-fun
+ (not (and (eq name 'logand)
+ (csubtypep
+ (single-value-type (node-derived-type node))
+ (specifier-type `(unsigned-byte ,width))))))
+ (unless (eq modular-fun :good)
+ (setq did-something t)
+ (change-ref-leaf
+ fun-ref
+ (find-free-fun name "in a strange place"))
+ (setf (combination-kind node) :full))
+ (dolist (arg (basic-combination-args node))
+ (when (cut-continuation arg)
+ (setq did-something t)))
+ (when did-something
+ (reoptimize-node node fun-name))
+ did-something))))
+ (cut-continuation (cont &aux did-something)
+ (do-uses (node cont)
+ (when (cut-node node)
+ (setq did-something t)))
+ did-something))
+ (cut-continuation cont)))
+
+(defoptimizer (logand optimizer) ((x y) node)
+ (let ((result-type (single-value-type (node-derived-type node))))
+ (when (numeric-type-p result-type)
+ (let ((low (numeric-type-low result-type))
+ (high (numeric-type-high result-type)))
+ (when (and (numberp low)
+ (numberp high)
+ (>= low 0))
+ (let ((width (integer-length high)))
+ (when (some (lambda (x) (<= width x))
+ *modular-funs-widths*)
+ ;; FIXME: This should be (CUT-TO-WIDTH NODE WIDTH).
+ (cut-to-width x width)
+ (cut-to-width y width)
+ nil ; After fixing above, replace with T.
+ )))))))
+\f
;;; miscellanous numeric transforms
;;; If a constant appears as the first arg, swap the args.
(def logxor -1 (lognot x))
(def logxor 0 x))
+(deftransform logand ((x y) (* (constant-arg t)) *)
+ "fold identity operation"
+ (let ((y (continuation-value y)))
+ (unless (and (plusp y)
+ (= y (1- (ash 1 (integer-length y)))))
+ (give-up-ir1-transform))
+ (unless (csubtypep (continuation-type x)
+ (specifier-type `(integer 0 ,y)))
+ (give-up-ir1-transform))
+ 'x))
+
;;; These are restricted to rationals, because (- 0 0.0) is 0.0, not -0.0, and
;;; (* 0 -4.0) is -0.0.
(deftransform - ((x y) ((constant-arg (member 0)) rational) *)
;;; change.
(defun same-leaf-ref-p (x y)
(declare (type continuation x y))
- (let ((x-use (continuation-use x))
- (y-use (continuation-use y)))
+ (let ((x-use (principal-continuation-use x))
+ (y-use (principal-continuation-use y)))
(and (ref-p x-use)
(ref-p y-use)
(eq (ref-leaf x-use) (ref-leaf y-use))
#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
(deftransform > ((x y) (float float) *)
(ir1-transform-< y x x y '<))
+
+(defun ir1-transform-char< (x y first second inverse)
+ (cond
+ ((same-leaf-ref-p x y) nil)
+ ;; If we had interval representation of character types, as we
+ ;; might eventually have to to support 2^21 characters, then here
+ ;; we could do some compile-time computation as in IR1-TRANSFORM-<
+ ;; above. -- CSR, 2003-07-01
+ ((and (constant-continuation-p first)
+ (not (constant-continuation-p second)))
+ `(,inverse y x))
+ (t (give-up-ir1-transform))))
+
+(deftransform char< ((x y) (character character) *)
+ (ir1-transform-char< x y x y 'char>))
+
+(deftransform char> ((x y) (character character) *)
+ (ir1-transform-char< y x x y 'char<))
\f
;;;; converting N-arg comparisons
;;;;
;;; negated test as appropriate. If it is a degenerate one-arg call,
;;; then we transform to code that returns true. Otherwise, we bind
;;; all the arguments and expand into a bunch of IFs.
-(declaim (ftype (function (symbol list boolean) *) multi-compare))
-(defun multi-compare (predicate args not-p)
+(declaim (ftype (function (symbol list boolean t) *) multi-compare))
+(defun multi-compare (predicate args not-p type)
(let ((nargs (length args)))
(cond ((< nargs 1) (values nil t))
- ((= nargs 1) `(progn ,@args t))
+ ((= nargs 1) `(progn (the ,type ,@args) t))
((= nargs 2)
(if not-p
`(if (,predicate ,(first args) ,(second args)) nil t)
`(if (,predicate ,current ,last)
,result nil))))
((zerop i)
- `((lambda ,vars ,result) . ,args)))))))
-
-(define-source-transform = (&rest args) (multi-compare '= args nil))
-(define-source-transform < (&rest args) (multi-compare '< args nil))
-(define-source-transform > (&rest args) (multi-compare '> args nil))
-(define-source-transform <= (&rest args) (multi-compare '> args t))
-(define-source-transform >= (&rest args) (multi-compare '< args t))
-
-(define-source-transform char= (&rest args) (multi-compare 'char= args nil))
-(define-source-transform char< (&rest args) (multi-compare 'char< args nil))
-(define-source-transform char> (&rest args) (multi-compare 'char> args nil))
-(define-source-transform char<= (&rest args) (multi-compare 'char> args t))
-(define-source-transform char>= (&rest args) (multi-compare 'char< args t))
+ `((lambda ,vars (declare (type ,type ,@vars)) ,result)
+ ,@args)))))))
+
+(define-source-transform = (&rest args) (multi-compare '= args nil 'number))
+(define-source-transform < (&rest args) (multi-compare '< args nil 'real))
+(define-source-transform > (&rest args) (multi-compare '> args nil 'real))
+(define-source-transform <= (&rest args) (multi-compare '> args t 'real))
+(define-source-transform >= (&rest args) (multi-compare '< args t 'real))
+
+(define-source-transform char= (&rest args) (multi-compare 'char= args nil
+ 'character))
+(define-source-transform char< (&rest args) (multi-compare 'char< args nil
+ 'character))
+(define-source-transform char> (&rest args) (multi-compare 'char> args nil
+ 'character))
+(define-source-transform char<= (&rest args) (multi-compare 'char> args t
+ 'character))
+(define-source-transform char>= (&rest args) (multi-compare 'char< args t
+ 'character))
(define-source-transform char-equal (&rest args)
- (multi-compare 'char-equal args nil))
+ (multi-compare 'char-equal args nil 'character))
(define-source-transform char-lessp (&rest args)
- (multi-compare 'char-lessp args nil))
+ (multi-compare 'char-lessp args nil 'character))
(define-source-transform char-greaterp (&rest args)
- (multi-compare 'char-greaterp args nil))
+ (multi-compare 'char-greaterp args nil 'character))
(define-source-transform char-not-greaterp (&rest args)
- (multi-compare 'char-greaterp args t))
+ (multi-compare 'char-greaterp args t 'character))
(define-source-transform char-not-lessp (&rest args)
- (multi-compare 'char-lessp args t))
+ (multi-compare 'char-lessp args t 'character))
;;; This function does source transformation of N-arg inequality
;;; functions such as /=. This is similar to MULTI-COMPARE in the <3
;;; arg cases. If there are more than two args, then we expand into
;;; the appropriate n^2 comparisons only when speed is important.
-(declaim (ftype (function (symbol list) *) multi-not-equal))
-(defun multi-not-equal (predicate args)
+(declaim (ftype (function (symbol list t) *) multi-not-equal))
+(defun multi-not-equal (predicate args type)
(let ((nargs (length args)))
(cond ((< nargs 1) (values nil t))
- ((= nargs 1) `(progn ,@args t))
+ ((= nargs 1) `(progn (the ,type ,@args) t))
((= nargs 2)
`(if (,predicate ,(first args) ,(second args)) nil t))
((not (policy *lexenv*
(next (cdr vars) (cdr next))
(result t))
((null next)
- `((lambda ,vars ,result) . ,args))
+ `((lambda ,vars (declare (type ,type ,@vars)) ,result)
+ ,@args))
(let ((v1 (first var)))
(dolist (v2 next)
(setq result `(if (,predicate ,v1 ,v2) nil ,result))))))))))
-(define-source-transform /= (&rest args) (multi-not-equal '= args))
-(define-source-transform char/= (&rest args) (multi-not-equal 'char= args))
+(define-source-transform /= (&rest args)
+ (multi-not-equal '= args 'number))
+(define-source-transform char/= (&rest args)
+ (multi-not-equal 'char= args 'character))
(define-source-transform char-not-equal (&rest args)
- (multi-not-equal 'char-equal args))
-
-;;; FIXME: can go away once bug 194 is fixed and we can use (THE REAL X)
-;;; as God intended
-(defun error-not-a-real (x)
- (error 'simple-type-error
- :datum x
- :expected-type 'real
- :format-control "not a REAL: ~S"
- :format-arguments (list x)))
+ (multi-not-equal 'char-equal args 'character))
;;; Expand MAX and MIN into the obvious comparisons.
(define-source-transform max (arg0 &rest rest)
;;;; or T and the control string is a function (i.e. FORMATTER), then
;;;; convert the call to FORMAT to just a FUNCALL of that function.
+;;; for compile-time argument count checking.
+;;;
+;;; FIXME I: this is currently called from DEFTRANSFORMs, the vast
+;;; majority of which are not going to transform the code, but instead
+;;; are going to GIVE-UP-IR1-TRANSFORM unconditionally. It would be
+;;; nice to make this explicit, maybe by implementing a new
+;;; "optimizer" (say, DEFOPTIMIZER CONSISTENCY-CHECK).
+;;;
+;;; FIXME II: In some cases, type information could be correlated; for
+;;; instance, ~{ ... ~} requires a list argument, so if the
+;;; continuation-type of a corresponding argument is known and does
+;;; not intersect the list type, a warning could be signalled.
+(defun check-format-args (string args fun)
+ (declare (type string string))
+ (unless (typep string 'simple-string)
+ (setq string (coerce string 'simple-string)))
+ (multiple-value-bind (min max)
+ (handler-case (sb!format:%compiler-walk-format-string string args)
+ (sb!format:format-error (c)
+ (compiler-warn "~A" c)))
+ (when min
+ (let ((nargs (length args)))
+ (cond
+ ((< nargs min)
+ (compiler-warn "Too few arguments (~D) to ~S ~S: ~
+ requires at least ~D."
+ nargs fun string min))
+ ((> nargs max)
+ (;; to get warned about probably bogus code at
+ ;; cross-compile time.
+ #+sb-xc-host compiler-warn
+ ;; ANSI saith that too many arguments doesn't cause a
+ ;; run-time error.
+ #-sb-xc-host compiler-style-warn
+ "Too many arguments (~D) to ~S ~S: uses at most ~D."
+ nargs fun string max)))))))
+
(deftransform format ((dest control &rest args) (t simple-string &rest t) *
- :policy (> speed space))
- (unless (constant-continuation-p control)
- (give-up-ir1-transform "The control string is not a constant."))
- (let ((arg-names (make-gensym-list (length args))))
- `(lambda (dest control ,@arg-names)
- (declare (ignore control))
- (format dest (formatter ,(continuation-value control)) ,@arg-names))))
+ :node node)
+
+ (cond
+ ((policy node (> speed space))
+ (unless (constant-continuation-p control)
+ (give-up-ir1-transform "The control string is not a constant."))
+ (check-format-args (continuation-value control) args 'format)
+ (let ((arg-names (make-gensym-list (length args))))
+ `(lambda (dest control ,@arg-names)
+ (declare (ignore control))
+ (format dest (formatter ,(continuation-value control)) ,@arg-names))))
+ (t (when (constant-continuation-p control)
+ (check-format-args (continuation-value control) args 'format))
+ (give-up-ir1-transform))))
(deftransform format ((stream control &rest args) (stream function &rest t) *
:policy (> speed space))
(funcall control *standard-output* ,@arg-names)
nil)))
+(macrolet
+ ((def (name)
+ `(deftransform ,name
+ ((control &rest args) (simple-string &rest t) *)
+ (when (constant-continuation-p control)
+ (check-format-args (continuation-value control) args ',name))
+ (give-up-ir1-transform))))
+ (def error)
+ (def warn)
+ #+sb-xc-host ; Only we should be using these
+ (progn
+ (def style-warn)
+ (def compiler-abort)
+ (def compiler-error)
+ (def compiler-warn)
+ (def compiler-style-warn)
+ (def compiler-notify)
+ (def maybe-compiler-notify)
+ (def bug)))
+
+(deftransform cerror ((report control &rest args)
+ (simple-string simple-string &rest t) *)
+ (unless (and (constant-continuation-p control)
+ (constant-continuation-p report))
+ (give-up-ir1-transform))
+ (multiple-value-bind (min1 max1)
+ (handler-case (sb!format:%compiler-walk-format-string
+ (continuation-value control) args)
+ (sb!format:format-error (c)
+ (compiler-warn "~A" c)))
+ (when min1
+ (multiple-value-bind (min2 max2)
+ (handler-case (sb!format:%compiler-walk-format-string
+ (continuation-value report) args)
+ (sb!format:format-error (c)
+ (compiler-warn "~A" c)))
+ (when min2
+ (let ((nargs (length args)))
+ (cond
+ ((< nargs (min min1 min2))
+ (compiler-warn "Too few arguments (~D) to ~S ~S ~S: ~
+ requires at least ~D."
+ nargs 'cerror report control (min min1 min2)))
+ ((> nargs (max max1 max2))
+ (;; to get warned about probably bogus code at
+ ;; cross-compile time.
+ #+sb-xc-host compiler-warn
+ ;; ANSI saith that too many arguments doesn't cause a
+ ;; run-time error.
+ #-sb-xc-host compiler-style-warn
+ "Too many arguments (~D) to ~S ~S ~S: uses at most ~D."
+ nargs 'cerror report control (max max1 max2)))))))))
+ (give-up-ir1-transform))
+
(defoptimizer (coerce derive-type) ((value type))
(cond
((constant-continuation-p type)
(error "can't understand type ~S~%" element-type))))))
(cond ((array-type-p array-type)
(get-element-type array-type))
- ((union-type-p array-type)
+ ((union-type-p array-type)
(apply #'type-union
(mapcar #'get-element-type (union-type-types array-type))))
(t
(loop for i of-type index
from (ash current-heap-size -1) downto 1 do
(%heapify i))
- (loop
+ (loop
(when (< current-heap-size 2)
(return))
(rotatef (%elt 1) (%elt current-heap-size))
projects / sbcl.git / blobdiff