(let* ((fun (combination-fun dest))
(args (combination-args dest))
(fun-type (continuation-type fun)))
+ (setf (continuation-%externally-checkable-type fun) *wild-type*)
(if (or (not (fun-type-p fun-type))
;; FUN-TYPE might be (AND FUNCTION (SATISFIES ...)).
(fun-type-wild-args fun-type))
;;;; interface routines used by optimizers
;;; This function is called by optimizers to indicate that something
-;;; interesting has happened to the value of Cont. Optimizers must
+;;; interesting has happened to the value of CONT. Optimizers must
;;; make sure that they don't call for reoptimization when nothing has
;;; happened, since optimization will fail to terminate.
;;;
;;; is deleted (in which case we do nothing.)
;;;
;;; Since this can get called during IR1 conversion, we have to be
-;;; careful not to fly into space when the Dest's Prev is missing.
+;;; careful not to fly into space when the DEST's PREV is missing.
(defun reoptimize-continuation (cont)
(declare (type continuation cont))
(unless (member (continuation-kind cont) '(:deleted :unused))
(derive-node-type node (continuation-derived-type value)))))
(cset
(ir1-optimize-set node)))))
+
(values))
;;; Try to join with a successor block. If we succeed, we return true,
;;; all functions in the tail set to be equivalent, this amounts to
;;; bringing the entire tail set up to date. We iterate over the
;;; returns for all the functions in the tail set, reanalyzing them
-;;; all (not treating Node specially.)
+;;; all (not treating NODE specially.)
;;;
;;; When we are done, we check whether the new type is different from
;;; the old TAIL-SET-TYPE. If so, we set the type and also reoptimize
(values))
;;; Replace a call to a foldable function of constant arguments with
-;;; the result of evaluating the form. We insert the resulting
-;;; constant node after the call, stealing the call's continuation. We
-;;; give the call a continuation with no DEST, which should cause it
-;;; and its arguments to go away. If there is an error during the
+;;; the result of evaluating the form. If there is an error during the
;;; evaluation, we give a warning and leave the call alone, making the
;;; call a :ERROR call.
;;;
;;; If there is more than one value, then we transform the call into a
;;; VALUES form.
+;;;
+;;; An old commentary also said:
+;;;
+;;; We insert the resulting constant node after the call, stealing
+;;; the call's continuation. We give the call a continuation with no
+;;; DEST, which should cause it and its arguments to go away.
+;;;
+;;; This seems to be more efficient, than the current code. Maybe we
+;;; should really implement it? -- APD, 2002-12-23
(defun constant-fold-call (call)
(let ((args (mapcar #'continuation-value (combination-args call)))
(fun-name (combination-fun-source-name call)))
;; when the compiler tries to constant-fold (<=
;; END SIZE).
;;
- ;; So, with or without bug 173, it'd be
+ ;; So, with or without bug 173, it'd be
;; unnecessarily evil to do a full
;; COMPILER-WARNING (and thus return FAILURE-P=T
;; from COMPILE-FILE) for legal code, so we we
;; use a wimpier COMPILE-STYLE-WARNING instead.
#'compiler-style-warn
"constant folding")
- (if (not win)
- (setf (combination-kind call) :error)
- (let ((dummies (make-gensym-list (length args))))
- (transform-call
- call
- `(lambda ,dummies
- (declare (ignore ,@dummies))
- (values ,@(mapcar (lambda (x) `',x) values)))
- fun-name)))))
+ (cond ((not win)
+ (setf (combination-kind call) :error))
+ ((and (proper-list-of-length-p values 1)
+ (eq (continuation-kind (node-cont call)) :inside-block))
+ (with-ir1-environment-from-node call
+ (let* ((cont (node-cont call))
+ (next (continuation-next cont))
+ (prev (make-continuation)))
+ (delete-continuation-use call)
+ (add-continuation-use call prev)
+ (reference-constant prev cont (first values))
+ (setf (continuation-next cont) next)
+ ;; FIXME: type checking?
+ (reoptimize-continuation cont)
+ (reoptimize-continuation prev))))
+ (t (let ((dummies (make-gensym-list (length args))))
+ (transform-call
+ call
+ `(lambda ,dummies
+ (declare (ignore ,@dummies))
+ (values ,@(mapcar (lambda (x) `',x) values)))
+ fun-name))))))
(values))
\f
;;;; local call optimization
(values))))
;;; Figure out the type of a LET variable that has sets. We compute
-;;; the union of the initial value Type and the types of all the set
+;;; the union of the initial value TYPE and the types of all the set
;;; values and to a PROPAGATE-TO-REFS with this type.
(defun propagate-from-sets (var type)
(collect ((res type type-union))
(dolist (set (basic-var-sets var))
- (res (continuation-type (set-value set)))
- (setf (node-reoptimize set) nil))
+ (let ((type (continuation-type (set-value set))))
+ (res type)
+ (when (node-reoptimize set)
+ (derive-node-type set type)
+ (setf (node-reoptimize set) nil))))
(propagate-to-refs var (res)))
(values))
(null (lambda-var-sets leaf)))
(defined-fun
(not (eq (defined-fun-inlinep leaf) :notinline)))
- #!+(and (not sb-fluid) (not sb-xc-host))
(global-var
(case (global-var-kind leaf)
- (:global-function (eq (symbol-package (leaf-source-name leaf))
- *cl-package*)))))))
+ (:global-function
+ (let ((name (leaf-source-name leaf)))
+ (or #-sb-xc-host
+ (eq (symbol-package (fun-name-block-name name))
+ *cl-package*)
+ (info :function :info name)))))))))
;;; If we have a non-set LET var with a single use, then (if possible)
;;; replace the variable reference's CONT with the arg continuation.
;;; -- either continuation has a funky TYPE-CHECK annotation.
;;; -- the continuations have incompatible assertions, so the new asserted type
;;; would be NIL.
-;;; -- the var's DEST has a different policy than the ARG's (think safety).
+;;; -- the VAR's DEST has a different policy than the ARG's (think safety).
;;;
;;; We change the REF to be a reference to NIL with unused value, and
;;; let it be flushed as dead code. A side effect of this substitution
(dest (continuation-dest cont)))
(when (and (eq (continuation-use cont) ref)
dest
- (not (typep dest '(or creturn exit mv-combination)))
+ (continuation-single-value-p cont)
(eq (node-home-lambda ref)
(lambda-home (lambda-var-home var)))
(member (continuation-type-check arg) '(t nil))
;;; If the function has an XEP, then we don't do anything, since we
;;; won't discover anything.
;;;
-;;; We can clear the Continuation-Reoptimize flags for arguments in
-;;; all calls corresponding to changed arguments in Call, since the
-;;; only use in IR1 optimization of the Reoptimize flag for local call
+;;; We can clear the CONTINUATION-REOPTIMIZE flags for arguments in
+;;; all calls corresponding to changed arguments in CALL, since the
+;;; only use in IR1 optimization of the REOPTIMIZE flag for local call
;;; args is right here.
(defun propagate-local-call-args (call fun)
(declare (type combination call) (type clambda fun))
(return-from ir1-optimize-mv-call)))
(let ((count (cond (total-nvals)
- ((and (policy node (zerop safety))
+ ((and (policy node (zerop verify-arg-count))
(eql min max))
min)
(t nil))))
(setf (node-prev use) nil)
(setf (continuation-next node-prev) nil)
(collect ((res vals))
- (loop as cont = (make-continuation use)
+ (loop for cont = (make-continuation use)
and prev = node-prev then cont
repeat (- nvars nvals)
do (reference-constant prev cont nil)
;;; CONVERT-MV-BIND-TO-LET. We grab the args of LIST and make them
;;; args of the VALUES-LIST call, flushing the old argument
;;; continuation (allowing the LIST to be flushed.)
+;;;
+;;; FIXME: Thus we lose possible type assertions on (LIST ...).
(defoptimizer (values-list optimizer) ((list) node)
(let ((use (continuation-use list)))
(when (and (combination-p use)
;;; to a PROG1. This allows the computation of the additional values
;;; to become dead code.
(deftransform values ((&rest vals) * * :node node)
- (when (typep (continuation-dest (node-cont node))
- '(or creturn exit mv-combination))
+ (unless (continuation-single-value-p (node-cont node))
(give-up-ir1-transform))
(setf (node-derived-type node) *wild-type*)
(if vals
projects / sbcl.git / blobdiff