;;;; 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))
(setf (component-reoptimize component) nil)
(do-blocks (block component)
(cond
- ((or (block-delete-p block)
- (null (block-pred block)))
- (delete-block block))
- ((eq (functional-kind (block-home-lambda block)) :deleted)
- ;; Preserve the BLOCK-SUCC invariant that almost every block has
- ;; one successor (and a block with DELETE-P set is an acceptable
- ;; exception).
- (labels ((mark-blocks (block)
- (dolist (pred (block-pred block))
- (unless (or (block-delete-p pred)
- (eq (component-head (block-component pred))
- pred))
- (setf (block-delete-p pred) t)
- (mark-blocks pred)))))
- (mark-blocks block)
- (delete-block block)))
- (t
- (loop
- (let ((succ (block-succ block)))
- (unless (and succ (null (rest succ)))
- (return)))
-
- (let ((last (block-last block)))
- (typecase last
- (cif
- (flush-dest (if-test last))
- (when (unlink-node last)
- (return)))
- (exit
- (when (maybe-delete-exit last)
- (return)))))
-
- (unless (join-successor-if-possible block)
- (return)))
-
- (when (and (block-reoptimize block) (block-component block))
- (aver (not (block-delete-p block)))
- (ir1-optimize-block block))
-
;; We delete blocks when there is either no predecessor or the
;; block is in a lambda that has been deleted. These blocks
;; would eventually be deleted by DFO recomputation, but doing
;; it here immediately makes the effect available to IR1
;; optimization.
- (when (and (block-flush-p block) (block-component block))
- (aver (not (block-delete-p block)))
- (flush-dead-code block)))))
+ ((or (block-delete-p block)
+ (null (block-pred block)))
+ (delete-block block))
+ ((eq (functional-kind (block-home-lambda block)) :deleted)
+ ;; Preserve the BLOCK-SUCC invariant that almost every block has
+ ;; one successor (and a block with DELETE-P set is an acceptable
+ ;; exception).
+ (mark-for-deletion block)
+ (delete-block block))
+ (t
+ (loop
+ (let ((succ (block-succ block)))
+ (unless (and succ (null (rest succ)))
+ (return)))
+
+ (let ((last (block-last block)))
+ (typecase last
+ (cif
+ (flush-dest (if-test last))
+ (when (unlink-node last)
+ (return)))
+ (exit
+ (when (maybe-delete-exit last)
+ (return)))))
+
+ (unless (join-successor-if-possible block)
+ (return)))
+
+ (when (and (block-reoptimize block) (block-component block))
+ (aver (not (block-delete-p block)))
+ (ir1-optimize-block block))
+
+ (cond ((block-delete-p block)
+ (delete-block block))
+ ((and (block-flush-p block) (block-component block))
+ (flush-dead-code block))))))
(values))
(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,
(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 t))))))
+ (:global-function (let ((name (leaf-source-name leaf)))
+ (eq (symbol-package (fun-name-block-name name))
+ *cl-package*))))))))
;;; 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.
projects / sbcl.git / blobdiff