(define-source-transform logorc1 (x y) `(logior (lognot ,x) ,y))
(define-source-transform logorc2 (x y) `(logior ,x (lognot ,y)))
(define-source-transform logtest (x y) `(not (zerop (logand ,x ,y))))
-(define-source-transform logbitp (index integer)
- `(not (zerop (logand (ash 1 ,index) ,integer))))
+
+(deftransform logbitp
+ ((index integer) (unsigned-byte (or (signed-byte #.sb!vm:n-word-bits)
+ (unsigned-byte #.sb!vm:n-word-bits))))
+ `(if (>= index #.sb!vm:n-word-bits)
+ (minusp integer)
+ (not (zerop (logand integer (ash 1 index))))))
+
(define-source-transform byte (size position)
`(cons ,size ,position))
(define-source-transform byte-size (spec) `(car ,spec))
(member (first members))
(member-type (type-of member)))
(aver (not (rest members)))
- (specifier-type `(,(if (subtypep member-type 'integer)
- 'integer
- member-type)
- ,member ,member))))
+ (specifier-type (cond ((typep member 'integer)
+ `(integer ,member ,member))
+ ((memq member-type '(short-float single-float
+ double-float long-float))
+ `(,member-type ,member ,member))
+ (t
+ member-type)))))
;;; This is used in defoptimizers for computing the resulting type of
;;; a function.
;;;
;;; Given the continuation ARG, derive the resulting type using the
-;;; DERIVE-FCN. DERIVE-FCN takes exactly one argument which is some
+;;; DERIVE-FUN. DERIVE-FUN takes exactly one argument which is some
;;; "atomic" continuation type like numeric-type or member-type
;;; (containing just one element). It should return the resulting
;;; type, which can be a list of types.
;;;
-;;; For the case of member types, if a member-fcn is given it is
+;;; For the case of member types, if a MEMBER-FUN is given it is
;;; called to compute the result otherwise the member type is first
-;;; converted to a numeric type and the derive-fcn is call.
-(defun one-arg-derive-type (arg derive-fcn member-fcn
+;;; converted to a numeric type and the DERIVE-FUN is called.
+(defun one-arg-derive-type (arg derive-fun member-fun
&optional (convert-type t))
- (declare (type function derive-fcn)
- (type (or null function) member-fcn))
+ (declare (type function derive-fun)
+ (type (or null function) member-fun))
(let ((arg-list (prepare-arg-for-derive-type (continuation-type arg))))
(when arg-list
(flet ((deriver (x)
(typecase x
(member-type
- (if member-fcn
+ (if member-fun
(with-float-traps-masked
(:underflow :overflow :divide-by-zero)
(make-member-type
:members (list
- (funcall member-fcn
+ (funcall member-fun
(first (member-type-members x))))))
;; Otherwise convert to a numeric type.
(let ((result-type-list
- (funcall derive-fcn (convert-member-type x))))
+ (funcall derive-fun (convert-member-type x))))
(if convert-type
(convert-back-numeric-type-list result-type-list)
result-type-list))))
(numeric-type
(if convert-type
(convert-back-numeric-type-list
- (funcall derive-fcn (convert-numeric-type x)))
- (funcall derive-fcn x)))
+ (funcall derive-fun (convert-numeric-type x)))
+ (funcall derive-fun x)))
(t
*universal-type*))))
;; Run down the list of args and derive the type of each one,
(first results)))))))
;;; Same as ONE-ARG-DERIVE-TYPE, except we assume the function takes
-;;; two arguments. DERIVE-FCN takes 3 args in this case: the two
+;;; two arguments. DERIVE-FUN takes 3 args in this case: the two
;;; original args and a third which is T to indicate if the two args
;;; really represent the same continuation. This is useful for
;;; deriving the type of things like (* x x), which should always be
;;; positive. If we didn't do this, we wouldn't be able to tell.
-(defun two-arg-derive-type (arg1 arg2 derive-fcn fcn
+(defun two-arg-derive-type (arg1 arg2 derive-fun fun
&optional (convert-type t))
- (declare (type function derive-fcn fcn))
+ (declare (type function derive-fun fun))
(flet ((deriver (x y same-arg)
(cond ((and (member-type-p x) (member-type-p y))
(let* ((x (first (member-type-members x)))
(result (with-float-traps-masked
(:underflow :overflow :divide-by-zero
:invalid)
- (funcall fcn x y))))
+ (funcall fun x y))))
(cond ((null result))
((and (floatp result) (float-nan-p result))
(make-numeric-type :class 'float
((and (member-type-p x) (numeric-type-p y))
(let* ((x (convert-member-type x))
(y (if convert-type (convert-numeric-type y) y))
- (result (funcall derive-fcn x y same-arg)))
+ (result (funcall derive-fun x y same-arg)))
(if convert-type
(convert-back-numeric-type-list result)
result)))
((and (numeric-type-p x) (member-type-p y))
(let* ((x (if convert-type (convert-numeric-type x) x))
(y (convert-member-type y))
- (result (funcall derive-fcn x y same-arg)))
+ (result (funcall derive-fun x y same-arg)))
(if convert-type
(convert-back-numeric-type-list result)
result)))
((and (numeric-type-p x) (numeric-type-p y))
(let* ((x (if convert-type (convert-numeric-type x) x))
(y (if convert-type (convert-numeric-type y) y))
- (result (funcall derive-fcn x y same-arg)))
+ (result (funcall derive-fun x y same-arg)))
(if convert-type
(convert-back-numeric-type-list result)
result)))
(t
(specifier-type 'integer))))))
-(macrolet ((deffrob (logfcn)
- (let ((fcn-aux (symbolicate logfcn "-DERIVE-TYPE-AUX")))
- `(defoptimizer (,logfcn derive-type) ((x y))
- (two-arg-derive-type x y #',fcn-aux #',logfcn)))))
+(macrolet ((deffrob (logfun)
+ (let ((fun-aux (symbolicate logfun "-DERIVE-TYPE-AUX")))
+ `(defoptimizer (,logfun derive-type) ((x y))
+ (two-arg-derive-type x y #',fun-aux #',logfun)))))
(deffrob logand)
(deffrob logior)
(deffrob logxor))
(specifier-type 'unsigned-byte)))
*universal-type*)))
-(defoptimizer (%dpb derive-type) ((newbyte size posn int))
+(defun %deposit-field-derive-type-aux (size posn int)
(let ((size (continuation-type size))
(posn (continuation-type posn))
(int (continuation-type int)))
- (if (and (numeric-type-p size)
- (csubtypep size (specifier-type 'integer))
- (numeric-type-p posn)
- (csubtypep posn (specifier-type 'integer))
- (numeric-type-p int)
- (csubtypep int (specifier-type 'integer)))
- (let ((size-high (numeric-type-high size))
- (posn-high (numeric-type-high posn))
- (high (numeric-type-high int))
- (low (numeric-type-low int)))
- (if (and size-high posn-high high low
- (<= (+ size-high posn-high) sb!vm:n-word-bits))
- (specifier-type
- (list (if (minusp low) 'signed-byte 'unsigned-byte)
- (max (integer-length high)
- (integer-length low)
- (+ size-high posn-high))))
- *universal-type*))
- *universal-type*)))
+ (when (and (numeric-type-p size)
+ (numeric-type-p posn)
+ (numeric-type-p int))
+ (let ((size-high (numeric-type-high size))
+ (posn-high (numeric-type-high posn))
+ (high (numeric-type-high int))
+ (low (numeric-type-low int)))
+ (when (and size-high posn-high high low
+ (<= (+ size-high posn-high) sb!vm:n-word-bits))
+ (let ((raw-bit-count (max (integer-length high)
+ (integer-length low)
+ (+ size-high posn-high))))
+ (specifier-type
+ (if (minusp low)
+ `(signed-byte ,(1+ raw-bit-count))
+ `(unsigned-byte ,raw-bit-count)))))))))
+
+(defoptimizer (%dpb derive-type) ((newbyte size posn int))
+ (%deposit-field-derive-type-aux size posn int))
(defoptimizer (%deposit-field derive-type) ((newbyte size posn int))
- (let ((size (continuation-type size))
- (posn (continuation-type posn))
- (int (continuation-type int)))
- (if (and (numeric-type-p size)
- (csubtypep size (specifier-type 'integer))
- (numeric-type-p posn)
- (csubtypep posn (specifier-type 'integer))
- (numeric-type-p int)
- (csubtypep int (specifier-type 'integer)))
- (let ((size-high (numeric-type-high size))
- (posn-high (numeric-type-high posn))
- (high (numeric-type-high int))
- (low (numeric-type-low int)))
- (if (and size-high posn-high high low
- (<= (+ size-high posn-high) sb!vm:n-word-bits))
- (specifier-type
- (list (if (minusp low) 'signed-byte 'unsigned-byte)
- (max (integer-length high)
- (integer-length low)
- (+ size-high posn-high))))
- *universal-type*))
- *universal-type*)))
+ (%deposit-field-derive-type-aux size posn int))
(deftransform %ldb ((size posn int)
(fixnum fixnum integer)
(logior (logand new mask)
(logand int (lognot mask)))))
\f
-;;; modular functions
+;;; Modular functions
-;;; Try to cut all uses of the continuation CONT to WIDTH bits.
+;;; (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 ((cut-node (node)
+ (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-name (find-modular-version fun-name width)))
- (when modular-fun-name
- (change-ref-leaf fun-ref
- (find-free-fun modular-fun-name
- "in a strange place"))
- (setf (combination-kind node) :full)
- (setf (node-derived-type node)
- (values-specifier-type `(values (unsigned-byte ,width)
- &optional)))
- (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)
+ (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))
- (cut-continuation arg))))))
- (cut-continuation (cont)
+ (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)
- (cut-node node))))
+ (when (cut-node node)
+ (setq did-something t)))
+ did-something))
(cut-continuation cont)))
(defoptimizer (logand optimizer) ((x y) node)
`(- (ash x ,len))
`(ash x ,len))))
-;;; If both arguments and the result are (UNSIGNED-BYTE 32), try to
-;;; come up with a ``better'' multiplication using multiplier
-;;; recoding. There are two different ways the multiplier can be
-;;; recoded. The more obvious is to shift X by the correct amount for
-;;; each bit set in Y and to sum the results. But if there is a string
-;;; of bits that are all set, you can add X shifted by one more then
-;;; the bit position of the first set bit and subtract X shifted by
-;;; the bit position of the last set bit. We can't use this second
-;;; method when the high order bit is bit 31 because shifting by 32
-;;; doesn't work too well.
-(deftransform * ((x y)
- ((unsigned-byte 32) (unsigned-byte 32))
- (unsigned-byte 32))
- "recode as shift and add"
- (unless (constant-continuation-p y)
- (give-up-ir1-transform))
- (let ((y (continuation-value y))
- (result nil)
- (first-one nil))
- (labels ((tub32 (x) `(truly-the (unsigned-byte 32) ,x))
- (add (next-factor)
- (setf result
- (tub32
- (if result
- `(+ ,result ,(tub32 next-factor))
- next-factor)))))
- (declare (inline add))
- (dotimes (bitpos 32)
- (if first-one
- (when (not (logbitp bitpos y))
- (add (if (= (1+ first-one) bitpos)
- ;; There is only a single bit in the string.
- `(ash x ,first-one)
- ;; There are at least two.
- `(- ,(tub32 `(ash x ,bitpos))
- ,(tub32 `(ash x ,first-one)))))
- (setf first-one nil))
- (when (logbitp bitpos y)
- (setf first-one bitpos))))
- (when first-one
- (cond ((= first-one 31))
- ((= first-one 30)
- (add '(ash x 30)))
- (t
- (add `(- ,(tub32 '(ash x 31)) ,(tub32 `(ash x ,first-one))))))
- (add '(ash x 31))))
- (or result 0)))
-
;;; If arg is a constant power of two, turn FLOOR into a shift and
;;; mask. If CEILING, add in (1- (ABS Y)), do FLOOR and correct a
;;; remainder.
;; multiplication and division for small integral powers.
(unless (not-more-contagious y x)
(give-up-ir1-transform))
- (cond ((zerop val) '(float 1 x))
+ (cond ((zerop val)
+ (let ((x-type (continuation-type x)))
+ (cond ((csubtypep x-type (specifier-type '(or rational
+ (complex rational))))
+ '1)
+ ((csubtypep x-type (specifier-type 'real))
+ `(if (rationalp x)
+ 1
+ (float 1 x)))
+ ((csubtypep x-type (specifier-type 'complex))
+ ;; both parts are float
+ `(1+ (* x ,val)))
+ (t (give-up-ir1-transform)))))
((= val 2) '(* x x))
((= val -2) '(/ (* x x)))
((= val 3) '(* x x x))
;;; 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))
;;;; 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.
-(defun check-format-args (string args)
+;;; 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)))
(let ((nargs (length args)))
(cond
((< nargs min)
- (compiler-warn "Too few arguments (~D) to FORMAT ~S: ~
+ (compiler-warn "Too few arguments (~D) to ~S ~S: ~
requires at least ~D."
- nargs string min))
+ nargs fun string min))
((> nargs max)
(;; to get warned about probably bogus code at
;; cross-compile time.
;; ANSI saith that too many arguments doesn't cause a
;; run-time error.
#-sb-xc-host compiler-style-warn
- "Too many arguments (~D) to FORMAT ~S: uses at most ~D."
- nargs string max)))))))
+ "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) *
- :node node)
+(defoptimizer (format optimizer) ((dest control &rest args))
+ (when (constant-continuation-p control)
+ (let ((x (continuation-value control)))
+ (when (stringp x)
+ (check-format-args x args 'format)))))
- (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)
- (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))
- (give-up-ir1-transform))))
+(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))))
(deftransform format ((stream control &rest args) (stream function &rest t) *
:policy (> speed space))
(funcall control *standard-output* ,@arg-names)
nil)))
+(macrolet
+ ((def (name)
+ `(defoptimizer (,name optimizer) ((control &rest args))
+ (when (constant-continuation-p control)
+ (let ((x (continuation-value control)))
+ (when (stringp x)
+ (check-format-args x args ',name)))))))
+ (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)))
+
+(defoptimizer (cerror optimizer) ((report control &rest args))
+ (when (and (constant-continuation-p control)
+ (constant-continuation-p report))
+ (let ((x (continuation-value control))
+ (y (continuation-value report)))
+ (when (and (stringp x) (stringp y))
+ (multiple-value-bind (min1 max1)
+ (handler-case
+ (sb!format:%compiler-walk-format-string x 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 y 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 y x (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 y x (max max1 max2)))))))))))))
+
(defoptimizer (coerce derive-type) ((value type))
(cond
((constant-continuation-p type)
(format t "/(CONTINUATION-VALUE X)=~S~%" (continuation-value x)))
(format t "/MESSAGE=~S~%" (continuation-value message))
(give-up-ir1-transform "not a real transform"))
- (defun /report-continuation (&rest rest)
- (declare (ignore rest))))
+ (defun /report-continuation (x message)
+ (declare (ignore x message))))