X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fsrctran.lisp;h=fb6f0f765e890259d4cc72ccef13062fe1fdbb69;hb=b42068e9080417a073dcb709cdd2e0315599b3df;hp=943e291163ca3ae614cc277bfde8a0295fa6a81e;hpb=5f1f553ecde8995aae8d9f9fbe1cd2b2cfb7db48;p=sbcl.git diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index 943e291..fb6f0f7 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -2440,34 +2440,62 @@ (logior (logand new mask) (logand int (lognot mask))))) -;;; 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) @@ -2858,8 +2886,8 @@ ;;; 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)) @@ -3249,7 +3277,19 @@ ;;;; 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))) @@ -3261,9 +3301,9 @@ (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. @@ -3271,24 +3311,23 @@ ;; 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)) @@ -3305,6 +3344,60 @@ (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) @@ -3584,5 +3677,5 @@ (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))))