(values))
;;; Replace all uses of OLD with uses of NEW, where NEW has an
-;;; arbitary number of uses.
-(defun substitute-lvar-uses (new old)
+;;; arbitary number of uses. NEW is supposed to be "later" than OLD.
+(defun substitute-lvar-uses (new old propagate-dx)
(declare (type lvar old)
- (type (or lvar null) new))
-
- (cond (new (do-uses (node old)
- (%delete-lvar-use node)
- (add-lvar-use node new))
- (reoptimize-lvar new))
+ (type (or lvar null) new)
+ (type boolean propagate-dx))
+
+ (cond (new
+ (do-uses (node old)
+ (%delete-lvar-use node)
+ (add-lvar-use node new))
+ (reoptimize-lvar new)
+ (awhen (and propagate-dx (lvar-dynamic-extent old))
+ (setf (lvar-dynamic-extent old) nil)
+ (unless (lvar-dynamic-extent new)
+ (setf (lvar-dynamic-extent new) it)
+ (setf (cleanup-info it) (substitute new old (cleanup-info it)))))
+ (when (lvar-dynamic-extent new)
+ (do-uses (node new)
+ (node-ends-block node))))
(t (flush-dest old)))
+
(values))
\f
;;;; block starting/creation
((:inside-block)
(node-ends-block (ctran-use ctran)))))
(values))
+
+;;; CTRAN must be the last ctran in an incomplete block; finish the
+;;; block and start a new one if necessary.
+(defun start-block (ctran)
+ (declare (type ctran ctran))
+ (aver (not (ctran-next ctran)))
+ (ecase (ctran-kind ctran)
+ (:inside-block
+ (let ((block (ctran-block ctran))
+ (node (ctran-use ctran)))
+ (aver (not (block-last block)))
+ (aver node)
+ (setf (block-last block) node)
+ (setf (node-next node) nil)
+ (setf (ctran-use ctran) nil)
+ (setf (ctran-kind ctran) :unused)
+ (setf (ctran-block ctran) nil)
+ (link-blocks block (ctran-starts-block ctran))))
+ (:block-start)))
\f
;;;;
(when (and (basic-combination-p use)
(eq (basic-combination-kind use) :local))
(merges use))))
+ (substitute-lvar-uses lvar value
+ (and lvar (eq (lvar-uses lvar) node)))
(%delete-lvar-use node)
- (substitute-lvar-uses lvar value)
(prog1
(unlink-node node)
(dolist (merge (merges))
(merge-tail-sets merge)))))
(t (flush-dest value)
(unlink-node node))))
+
+;;; Make a CAST and insert it into IR1 before node NEXT.
+(defun insert-cast-before (next lvar type policy)
+ (declare (type node next) (type lvar lvar) (type ctype type))
+ (with-ir1-environment-from-node next
+ (let* ((ctran (node-prev next))
+ (cast (make-cast lvar type policy))
+ (internal-ctran (make-ctran)))
+ (setf (ctran-next ctran) cast
+ (node-prev cast) ctran)
+ (use-ctran cast internal-ctran)
+ (link-node-to-previous-ctran next internal-ctran)
+ (setf (lvar-dest lvar) cast)
+ (reoptimize-lvar lvar)
+ (when (return-p next)
+ (node-ends-block cast))
+ (setf (block-attributep (block-flags (node-block cast))
+ type-check type-asserted)
+ t)
+ cast)))
\f
;;;; miscellaneous shorthand functions
(defun node-dest (node)
(awhen (node-lvar node) (lvar-dest it)))
+#!-sb-fluid (declaim (inline node-stack-allocate-p))
+(defun node-stack-allocate-p (node)
+ (awhen (node-lvar node)
+ (lvar-dynamic-extent it)))
+
(declaim (inline block-to-be-deleted-p))
(defun block-to-be-deleted-p (block)
(or (block-delete-p block)
(defun ctran-home-lambda (ctran)
(ctran-home-lambda-or-null ctran))
+(declaim (inline cast-single-value-p))
+(defun cast-single-value-p (cast)
+ (not (values-type-p (cast-asserted-type cast))))
+
#!-sb-fluid (declaim (inline lvar-single-value-p))
(defun lvar-single-value-p (lvar)
(or (not lvar)
(cast
(locally
(declare (notinline lvar-single-value-p))
- (and (not (values-type-p (cast-asserted-type dest)))
+ (and (cast-single-value-p dest)
(lvar-single-value-p (node-lvar dest)))))
(t
t)))))
type-restrictions
(lambda (lexenv-lambda default))
(cleanup (lexenv-cleanup default))
+ (handled-conditions (lexenv-handled-conditions default))
+ (disabled-package-locks
+ (lexenv-disabled-package-locks default))
(policy (lexenv-policy default)))
(macrolet ((frob (var slot)
`(let ((old (,slot default)))
(frob blocks lexenv-blocks)
(frob tags lexenv-tags)
(frob type-restrictions lexenv-type-restrictions)
- lambda cleanup policy)))
+ lambda cleanup handled-conditions
+ disabled-package-locks policy)))
;;; Makes a LEXENV, suitable for using in a MACROLET introduced
;;; macroexpander
(lexenv-type-restrictions lexenv) ; XXX
nil
nil
+ (lexenv-handled-conditions lexenv)
+ (lexenv-disabled-package-locks lexenv)
(lexenv-policy lexenv))))
\f
;;;; flow/DFO/component hackery
(frob if-alternative)
(when (eq (if-consequent last)
(if-alternative last))
- (setf (component-reoptimize (block-component block)) t)))))
+ (reoptimize-component (block-component block) :maybe)))))
(t
(unless (memq new (block-succ block))
(link-blocks block new)))))
(setf (block-prev next) block))
(values))
+;;; List all NLX-INFOs which BLOCK can exit to.
+;;;
+;;; We hope that no cleanup actions are performed in the middle of
+;;; BLOCK, so it is enough to look only at cleanups in the block
+;;; end. The tricky thing is a special cleanup block; all its nodes
+;;; have the same cleanup info, corresponding to the start, so the
+;;; same approach returns safe result.
+(defun map-block-nlxes (fun block &optional dx-cleanup-fun)
+ (loop for cleanup = (block-end-cleanup block)
+ then (node-enclosing-cleanup (cleanup-mess-up cleanup))
+ while cleanup
+ do (let ((mess-up (cleanup-mess-up cleanup)))
+ (case (cleanup-kind cleanup)
+ ((:block :tagbody)
+ (aver (entry-p mess-up))
+ (loop for exit in (entry-exits mess-up)
+ for nlx-info = (find-nlx-info exit)
+ do (funcall fun nlx-info)))
+ ((:catch :unwind-protect)
+ (aver (combination-p mess-up))
+ (let* ((arg-lvar (first (basic-combination-args mess-up)))
+ (nlx-info (constant-value (ref-leaf (lvar-use arg-lvar)))))
+ (funcall fun nlx-info)))
+ ((:dynamic-extent)
+ (when dx-cleanup-fun
+ (funcall dx-cleanup-fun cleanup)))))))
+
;;; Set the FLAG for all the blocks in COMPONENT to NIL, except for
;;; the head and tail which are set to T.
(declaim (ftype (sfunction (component) (values)) clear-flags))
(when (optional-dispatch-more-entry leaf)
(frob (optional-dispatch-more-entry leaf)))
(let ((main (optional-dispatch-main-entry leaf)))
+ (when entry
+ (setf (functional-entry-fun entry) main)
+ (setf (functional-entry-fun main) entry))
(when (eq (functional-kind main) :optional)
(frob main))))))
(do-uses (use lvar)
(let ((prev (node-prev use)))
(let ((block (ctran-block prev)))
- (setf (component-reoptimize (block-component block)) t)
+ (reoptimize-component (block-component block) t)
(setf (block-attributep (block-flags block)
flush-p type-asserted type-check)
t)))
(unless (policy *compiler-error-context* (= inhibit-warnings 3))
;; ANSI section "3.2.5 Exceptional Situations in the Compiler"
;; requires this to be no more than a STYLE-WARNING.
+ #-sb-xc-host
(compiler-style-warn "The variable ~S is defined but never used."
- (leaf-debug-name var)))
+ (leaf-debug-name var))
+ ;; There's no reason to accept this kind of equivocation
+ ;; when compiling our own code, though.
+ #+sb-xc-host
+ (warn "The variable ~S is defined but never used."
+ (leaf-debug-name var)))
(setf (leaf-ever-used var) t)))) ; to avoid repeated warnings? -- WHN
(values))
(setf (node-prev node) nil)
t)))))))
+;;; Return true if CTRAN has been deleted, false if it is still a valid
+;;; part of IR1.
+(defun ctran-deleted-p (ctran)
+ (declare (type ctran ctran))
+ (let ((block (ctran-block ctran)))
+ (or (not (block-component block))
+ (block-delete-p block))))
+
;;; Return true if NODE has been deleted, false if it is still a valid
;;; part of IR1.
(defun node-deleted (node)
(declare (type node node))
(let ((prev (node-prev node)))
- (not (and prev
- (let ((block (ctran-block prev)))
- (and (block-component block)
- (not (block-delete-p block))))))))
+ (or (not prev)
+ (ctran-deleted-p prev))))
;;; Delete all the blocks and functions in COMPONENT. We scan first
;;; marking the blocks as DELETE-P to prevent weird stuff from being
(append before-args inside-args after-args))
(change-ref-leaf (lvar-uses inside-fun)
(find-free-fun 'list "???"))
- (setf (combination-kind inside)
- (info :function :info 'list))
+ (setf (combination-fun-info inside) (info :function :info 'list)
+ (combination-kind inside) :known)
(setf (node-derived-type inside) *wild-type*)
(flush-dest lvar)
(values))))))
(flet ((frob (l)
(find home l
:key #'node-home-lambda
- :test-not #'eq)))
+ :test #'neq)))
(or (frob (leaf-refs var))
(frob (basic-var-sets var)))))))))
;;; exits to CONT in that entry, then return it, otherwise return NIL.
(defun find-nlx-info (exit)
(declare (type exit exit))
- (let* ((entry (exit-entry exit))
- (entry-cleanup (entry-cleanup entry)))
+ (let ((entry (exit-entry exit)))
(dolist (nlx (physenv-nlx-info (node-physenv entry)) nil)
(when (eq (nlx-info-exit nlx) exit)
(return nlx)))))
;; arbitrarily huge blocks of code. -- WHN)
(let ((*compiler-error-context* node))
(compiler-notify "*INLINE-EXPANSION-LIMIT* (~W) was exceeded, ~
- probably trying to~% ~
- inline a recursive function."
+ probably trying to~% ~
+ inline a recursive function."
*inline-expansion-limit*))
nil)
(t t))))
(declare (type combination call))
(let ((kind (basic-combination-kind call)))
(or (eq kind :full)
- (and (fun-info-p kind)
- (not (fun-info-ir2-convert kind))
- (dolist (template (fun-info-templates kind) t)
- (when (eq (template-ltn-policy template) :fast-safe)
- (multiple-value-bind (val win)
- (valid-fun-use call (template-type template))
- (when (or val (not win)) (return nil)))))))))
+ (and (eq kind :known)
+ (let ((info (basic-combination-fun-info call)))
+ (and
+ (not (fun-info-ir2-convert info))
+ (dolist (template (fun-info-templates info) t)
+ (when (eq (template-ltn-policy template) :fast-safe)
+ (multiple-value-bind (val win)
+ (valid-fun-use call (template-type template))
+ (when (or val (not win)) (return nil)))))))))))
\f
;;;; careful call
(do-uses (node lvar)
(setf (node-reoptimize node) t)
(setf (block-reoptimize (node-block node)) t)
- (setf (component-reoptimize (node-component node)) t)))))))
+ (reoptimize-component (node-component node) :maybe)))))))
projects / sbcl.git / blobdiff