(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)
;;; 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))))
projects / sbcl.git / blobdiff