X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1util.lisp;h=c1c1db8304b53ef47fd154536c2431b67c0cb3ed;hb=88fbde7b3c6e6e66bdde408348337e97068f2568;hp=2d2d687e7d57975ed97b7386686db5627a726a2c;hpb=177cea359afa4b73abf43ce687aa34e47be9538a;p=sbcl.git diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index 2d2d687..c1c1db8 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -36,7 +36,7 @@ (declare (type cblock block1 block2) (type node node) (type (or cleanup null) cleanup)) (setf (component-reanalyze (block-component block1)) t) - (with-ir1-environment node + (with-ir1-environment-from-node node (let* ((start (make-continuation)) (block (continuation-starts-block start)) (cont (make-continuation)) @@ -192,13 +192,13 @@ (let* ((head (component-head *current-component*)) (next (block-next head)) (new-block (make-block cont))) - (setf (block-next new-block) next) - (setf (block-prev new-block) head) - (setf (block-prev next) new-block) - (setf (block-next head) new-block) - (setf (continuation-block cont) new-block) - (setf (continuation-use cont) nil) - (setf (continuation-kind cont) :block-start) + (setf (block-next new-block) next + (block-prev new-block) head + (block-prev next) new-block + (block-next head) new-block + (continuation-block cont) new-block + (continuation-use cont) nil + (continuation-kind cont) :block-start) new-block)) (:block-start (continuation-block cont)))) @@ -235,7 +235,6 @@ ;;; the LEXENV-LAMBDA may be deleted, we must chain up the ;;; LAMBDA-CALL-LEXENV thread until we find a CLAMBDA that isn't ;;; deleted, and then return its home. -(declaim (maybe-inline node-home-lambda)) (defun node-home-lambda (node) (declare (type node node)) (do ((fun (lexenv-lambda (node-lexenv node)) @@ -245,22 +244,20 @@ (when (eq (lambda-home fun) fun) (return fun)))) -#!-sb-fluid (declaim (inline node-block node-tlf-number)) -(declaim (maybe-inline node-physenv)) (defun node-block (node) (declare (type node node)) (the cblock (continuation-block (node-prev node)))) +(defun node-component (node) + (declare (type node node)) + (block-component (node-block node))) (defun node-physenv (node) (declare (type node node)) - #!-sb-fluid (declare (inline node-home-lambda)) (the physenv (lambda-physenv (node-home-lambda node)))) -#!-sb-fluid (declaim (maybe-inline lambda-block)) (defun lambda-block (clambda) (declare (type clambda clambda)) (node-block (lambda-bind clambda))) (defun lambda-component (clambda) - (declare (inline lambda-block)) (block-component (lambda-block clambda))) ;;; Return the enclosing cleanup for environment of the first or last @@ -272,31 +269,52 @@ (declare (type cblock block)) (node-enclosing-cleanup (block-last block))) -;;; Return the non-LET LAMBDA that holds BLOCK's code. -(defun block-home-lambda (block) +;;; Return the non-LET LAMBDA that holds BLOCK's code, or NIL +;;; if there is none. +;;; +;;; There can legitimately be no home lambda in dead code early in the +;;; IR1 conversion process, e.g. when IR1-converting the SETQ form in +;;; (BLOCK B (RETURN-FROM B) (SETQ X 3)) +;;; where the block is just a placeholder during parsing and doesn't +;;; actually correspond to code which will be written anywhere. +(defun block-home-lambda-or-null (block) (declare (type cblock block)) - #!-sb-fluid (declare (inline node-home-lambda)) (if (node-p (block-last block)) ;; This is the old CMU CL way of doing it. (node-home-lambda (block-last block)) - ;; The CMU CL approach sometimes fails, e.g. in IR1-CONVERT of - ;; one of the legs of an IF, now that SBCL uses this operation - ;; more aggressively than CMU CL did. - ;; - ;; In this case we reason that previous-in-target-execution-order - ;; blocks should be in the same lambda, and that they seem in - ;; practice to be previous-in-compilation-order blocks too, - ;; so we look back to find one which is sufficiently - ;; initialized to tell us what the home lambda is. We could - ;; get fancy about this, flooding the graph of all the - ;; previous blocks, but in practice it seems to work just - ;; to grab the first previous block and use it. - (node-home-lambda (block-last (first (block-pred block)))))) + ;; Now that SBCL uses this operation more aggressively than CMU + ;; CL did, the old CMU CL way of doing it can fail in two ways. + ;; 1. It can fail in a few cases even when a meaningful home + ;; lambda exists, e.g. in IR1-CONVERT of one of the legs of + ;; an IF. + ;; 2. It can fail when converting a form which is born orphaned + ;; so that it never had a meaningful home lambda, e.g. a form + ;; which follows a RETURN-FROM or GO form. + (let ((pred-list (block-pred block))) + ;; To deal with case 1, we reason that + ;; previous-in-target-execution-order blocks should be in the + ;; same lambda, and that they seem in practice to be + ;; previous-in-compilation-order blocks too, so we look back + ;; to find one which is sufficiently initialized to tell us + ;; what the home lambda is. + (if pred-list + ;; We could get fancy about this, flooding through the + ;; graph of all the previous blocks, but in practice it + ;; seems to work just to grab the first previous block and + ;; use it. + (node-home-lambda (block-last (first pred-list))) + ;; In case 2, we end up with an empty PRED-LIST and + ;; have to punt: There's no home lambda. + nil)))) + +;;; Return the non-LET LAMBDA that holds BLOCK's code. +(defun block-home-lambda (block) + (the clambda + (block-home-lambda-or-null block))) ;;; Return the IR1 physical environment for BLOCK. (defun block-physenv (block) (declare (type cblock block)) - #!-sb-fluid (declare (inline node-home-lambda)) (lambda-physenv (block-home-lambda block))) ;;; Return the Top Level Form number of PATH, i.e. the ordinal number @@ -341,29 +359,34 @@ (values (node-source-form use) t) (values nil nil)))) -;;; Return the LAMBDA that is CONT's home. -(defun continuation-home-lambda (cont) +;;; Return the LAMBDA that is CONT's home, or NIL if there is none. +(defun continuation-home-lambda-or-null (cont) ;; KLUDGE: This function is a post-CMU-CL hack by WHN, and this ;; implementation might not be quite right, or might be uglier than ;; necessary. It appears that the original Python never found a need ;; to do this operation. The obvious things based on - ;; NODE-HOME-LAMBDA of CONTINUATION-USE usually works; then if that + ;; NODE-HOME-LAMBDA of CONTINUATION-USE usually work; then if that ;; fails, BLOCK-HOME-LAMBDA of CONTINUATION-BLOCK works, given that - ;; generalize it enough to grovel harder when the simple CMU CL - ;; approach fails. -- WHN 2001-12-02 + ;; we generalize it enough to grovel harder when the simple CMU CL + ;; approach fails, and furthermore realize that in some exceptional + ;; cases it might return NIL. -- WHN 2001-12-04 (cond ((continuation-use cont) (node-home-lambda (continuation-use cont))) ((continuation-block cont) - (block-home-lambda (continuation-block cont))) + (block-home-lambda-or-null (continuation-block cont))) (t - (error "internal error: can't find home lambda for ~S")))) + (bug "confused about home lambda for ~S")))) + +;;; Return the LAMBDA that is CONT's home. +(defun continuation-home-lambda (cont) + (the clambda + (continuation-home-lambda-or-null cont))) ;;; Return a new LEXENV just like DEFAULT except for the specified ;;; slot values. Values for the alist slots are NCONCed to the ;;; beginning of the current value, rather than replacing it entirely. (defun make-lexenv (&key (default *lexenv*) - functions variables blocks tags type-restrictions - options + funs vars blocks tags type-restrictions options (lambda (lexenv-lambda default)) (cleanup (lexenv-cleanup default)) (policy (lexenv-policy default))) @@ -373,8 +396,8 @@ (nconc ,var old) old)))) (internal-make-lexenv - (frob functions lexenv-functions) - (frob variables lexenv-variables) + (frob funs lexenv-funs) + (frob vars lexenv-vars) (frob blocks lexenv-blocks) (frob tags lexenv-tags) (frob type-restrictions lexenv-type-restrictions) @@ -384,7 +407,6 @@ ;;;; flow/DFO/component hackery ;;; Join BLOCK1 and BLOCK2. -#!-sb-fluid (declaim (inline link-blocks)) (defun link-blocks (block1 block2) (declare (type cblock block1 block2)) (setf (block-succ block1) @@ -466,7 +488,7 @@ (values)) ;;; Add BLOCK to the next/prev chain following AFTER. We also set the -;;; Component to be the same as for AFTER. +;;; COMPONENT to be the same as for AFTER. (defun add-to-dfo (block after) (declare (type cblock block after)) (let ((next (block-next after)) @@ -546,18 +568,14 @@ ;;;; deleting stuff -;;; Deal with deleting the last (read) reference to a LAMBDA-VAR. We -;;; iterate over all local calls flushing the corresponding argument, -;;; allowing the computation of the argument to be deleted. We also -;;; mark the let for reoptimization, since it may be that we have -;;; deleted the last variable. -;;; -;;; The LAMBDA-VAR may still have some SETs, but this doesn't cause -;;; too much difficulty, since we can efficiently implement write-only -;;; variables. We iterate over the sets, marking their blocks for dead -;;; code flushing, since we can delete sets whose value is unused. +;;; Deal with deleting the last (read) reference to a LAMBDA-VAR. (defun delete-lambda-var (leaf) (declare (type lambda-var leaf)) + + ;; Iterate over all local calls flushing the corresponding argument, + ;; allowing the computation of the argument to be deleted. We also + ;; mark the LET for reoptimization, since it may be that we have + ;; deleted its last variable. (let* ((fun (lambda-var-home leaf)) (n (position leaf (lambda-vars fun)))) (dolist (ref (leaf-refs fun)) @@ -572,17 +590,22 @@ (flush-dest arg) (setf (elt args n) nil)))))) + ;; The LAMBDA-VAR may still have some SETs, but this doesn't cause + ;; too much difficulty, since we can efficiently implement + ;; write-only variables. We iterate over the SETs, marking their + ;; blocks for dead code flushing, since we can delete SETs whose + ;; value is unused. (dolist (set (lambda-var-sets leaf)) (setf (block-flush-p (node-block set)) t)) (values)) -;;; Note that something interesting has happened to VAR. We only deal -;;; with LET variables, marking the corresponding initial value arg as -;;; needing to be reoptimized. +;;; Note that something interesting has happened to VAR. (defun reoptimize-lambda-var (var) (declare (type lambda-var var)) (let ((fun (lambda-var-home var))) + ;; We only deal with LET variables, marking the corresponding + ;; initial value arg as needing to be reoptimized. (when (and (eq (functional-kind fun) :let) (leaf-refs var)) (do ((args (basic-combination-args @@ -606,58 +629,60 @@ (clambda (delete-lambda fun))) (values)) -;;; Deal with deleting the last reference to a LAMBDA. Since there is -;;; only one way into a LAMBDA, deleting the last reference to a -;;; LAMBDA ensures that there is no way to reach any of the code in +;;; Deal with deleting the last reference to a CLAMBDA. Since there is +;;; only one way into a CLAMBDA, deleting the last reference to a +;;; CLAMBDA ensures that there is no way to reach any of the code in ;;; it. So we just set the FUNCTIONAL-KIND for FUN and its LETs to ;;; :DELETED, causing IR1 optimization to delete blocks in that -;;; lambda. -;;; -;;; If the function isn't a LET, we unlink the function head and tail -;;; from the component head and tail to indicate that the code is -;;; unreachable. We also delete the function from COMPONENT-LAMBDAS -;;; (it won't be there before local call analysis, but no matter.) If -;;; the lambda was never referenced, we give a note. -;;; -;;; If the lambda is an XEP, then we null out the ENTRY-FUN in its -;;; ENTRY-FUN so that people will know that it is not an entry point -;;; anymore. -(defun delete-lambda (leaf) - (declare (type clambda leaf)) - (let ((kind (functional-kind leaf)) - (bind (lambda-bind leaf))) - (aver (not (member kind '(:deleted :optional :toplevel)))) - (aver (not (functional-has-external-references-p leaf))) - (setf (functional-kind leaf) :deleted) - (setf (lambda-bind leaf) nil) - (dolist (let (lambda-lets leaf)) +;;; CLAMBDA. +(defun delete-lambda (clambda) + (declare (type clambda clambda)) + (let ((original-kind (functional-kind clambda)) + (bind (lambda-bind clambda))) + (aver (not (member original-kind '(:deleted :optional :toplevel)))) + (aver (not (functional-has-external-references-p clambda))) + (setf (functional-kind clambda) :deleted) + (setf (lambda-bind clambda) nil) + (dolist (let (lambda-lets clambda)) (setf (lambda-bind let) nil) (setf (functional-kind let) :deleted)) - (if (member kind '(:let :mv-let :assignment)) - (let ((home (lambda-home leaf))) - (setf (lambda-lets home) (delete leaf (lambda-lets home)))) + ;; (The IF test is (FUNCTIONAL-SOMEWHAT-LETLIKE-P CLAMBDA), except + ;; that we're using the old value of the KIND slot, not the + ;; current slot value, which has now been set to :DELETED.) + (if (member original-kind '(:let :mv-let :assignment)) + (let ((home (lambda-home clambda))) + (setf (lambda-lets home) (delete clambda (lambda-lets home)))) + ;; If the function isn't a LET, we unlink the function head + ;; and tail from the component head and tail to indicate that + ;; the code is unreachable. We also delete the function from + ;; COMPONENT-LAMBDAS (it won't be there before local call + ;; analysis, but no matter.) If the lambda was never + ;; referenced, we give a note. (let* ((bind-block (node-block bind)) (component (block-component bind-block)) - (return (lambda-return leaf))) - (aver (null (leaf-refs leaf))) - (unless (leaf-ever-used leaf) + (return (lambda-return clambda))) + (aver (null (leaf-refs clambda))) + (unless (leaf-ever-used clambda) (let ((*compiler-error-context* bind)) (compiler-note "deleting unused function~:[.~;~:*~% ~S~]" - (leaf-debug-name leaf)))) + (leaf-debug-name clambda)))) (unlink-blocks (component-head component) bind-block) (when return (unlink-blocks (node-block return) (component-tail component))) (setf (component-reanalyze component) t) - (let ((tails (lambda-tail-set leaf))) + (let ((tails (lambda-tail-set clambda))) (setf (tail-set-funs tails) - (delete leaf (tail-set-funs tails))) - (setf (lambda-tail-set leaf) nil)) + (delete clambda (tail-set-funs tails))) + (setf (lambda-tail-set clambda) nil)) (setf (component-lambdas component) - (delete leaf (component-lambdas component))))) + (delete clambda (component-lambdas component))))) - (when (eq kind :external) - (let ((fun (functional-entry-fun leaf))) + ;; If the lambda is an XEP, then we null out the ENTRY-FUN in its + ;; ENTRY-FUN so that people will know that it is not an entry + ;; point anymore. + (when (eq original-kind :external) + (let ((fun (functional-entry-fun clambda))) (setf (functional-entry-fun fun) nil) (when (optional-dispatch-p fun) (delete-optional-dispatch fun))))) @@ -677,11 +702,11 @@ ;;; entry-points, making them be normal lambdas, and then deleting the ;;; ones with no references. This deletes any e-p lambdas that were ;;; either never referenced, or couldn't be deleted when the last -;;; deference was deleted (due to their :OPTIONAL kind.) +;;; reference was deleted (due to their :OPTIONAL kind.) ;;; -;;; Note that the last optional ep may alias the main entry, so when -;;; we process the main entry, its kind may have been changed to NIL -;;; or even converted to a let. +;;; Note that the last optional entry point may alias the main entry, +;;; so when we process the main entry, its KIND may have been changed +;;; to NIL or even converted to a LETlike value. (defun delete-optional-dispatch (leaf) (declare (type optional-dispatch leaf)) (let ((entry (functional-entry-fun leaf))) @@ -728,7 +753,7 @@ (clambda (ecase (functional-kind leaf) ((nil :let :mv-let :assignment :escape :cleanup) - (aver (not (functional-entry-fun leaf))) + (aver (null (functional-entry-fun leaf))) (delete-lambda leaf)) (:external (delete-lambda leaf)) @@ -753,7 +778,7 @@ ;;; containing uses of CONT and set COMPONENT-REOPTIMIZE. If the PREV ;;; of the use is deleted, then we blow off reoptimization. ;;; -;;; If the continuation is :Deleted, then we don't do anything, since +;;; If the continuation is :DELETED, then we don't do anything, since ;;; all semantics have already been flushed. :DELETED-BLOCK-START ;;; start continuations are treated just like :BLOCK-START; it is ;;; possible that the continuation may be given a new dest (e.g. by @@ -852,7 +877,14 @@ (reoptimize-continuation cont))) (dolist (b (block-pred block)) - (unlink-blocks b block)) + (unlink-blocks b block) + ;; In bug 147 the almost-all-blocks-have-a-successor invariant was + ;; broken when successors were deleted without setting the + ;; BLOCK-DELETE-P flags of their predececessors. Make sure that + ;; doesn't happen again. + (aver (not (and (null (block-succ b)) + (not (block-delete-p b)) + (not (eq b (component-head (block-component b)))))))) (dolist (b (block-succ block)) (unlink-blocks block b)) @@ -870,9 +902,10 @@ ;; Guards COMBINATION-LAMBDA agains the REF being deleted. (continuation-use (basic-combination-fun node))) (let ((fun (combination-lambda node))) - ;; If our REF was the 2'nd to last ref, and has been deleted, then - ;; Fun may be a LET for some other combination. - (when (and (member (functional-kind fun) '(:let :mv-let)) + ;; If our REF was the second-to-last ref, and has been + ;; deleted, then FUN may be a LET for some other + ;; combination. + (when (and (functional-letlike-p fun) (eq (let-combination fun) node)) (delete-lambda fun)))) (flush-dest (basic-combination-fun node)) @@ -881,7 +914,7 @@ (bind (let ((lambda (bind-lambda node))) (unless (eq (functional-kind lambda) :deleted) - (aver (member (functional-kind lambda) '(:let :mv-let :assignment))) + (aver (functional-somewhat-letlike-p lambda)) (delete-lambda lambda)))) (exit (let ((value (exit-value node)) @@ -925,8 +958,8 @@ (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. - (compiler-style-warning "The variable ~S is defined but never used." - (leaf-debug-name var))) + (compiler-style-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)) @@ -989,8 +1022,8 @@ (not (eq pkg (symbol-package :end)))))) (not (member first *deletion-ignored-objects*)) (not (typep first '(or fixnum character))) - (every #'(lambda (x) - (present-in-form first x 0)) + (every (lambda (x) + (present-in-form first x 0)) (source-path-forms path)) (present-in-form first (find-original-source path) 0))) @@ -1052,11 +1085,11 @@ (aver (and succ (null (cdr succ)))) (cond ((member block succ) - (with-ir1-environment node + (with-ir1-environment-from-node node (let ((exit (make-exit)) (dummy (make-continuation))) (setf (continuation-next prev) nil) - (prev-link exit prev) + (link-node-to-previous-continuation exit prev) (add-continuation-use exit dummy) (setf (block-last block) exit))) (setf (node-prev node) nil) @@ -1088,11 +1121,11 @@ (not (block-delete-p block)))))))) ;;; Delete all the blocks and functions in COMPONENT. We scan first -;;; marking the blocks as delete-p to prevent weird stuff from being +;;; marking the blocks as DELETE-P to prevent weird stuff from being ;;; triggered by deletion. (defun delete-component (component) (declare (type component component)) - (aver (null (component-new-funs component))) + (aver (null (component-new-functionals component))) (setf (component-kind component) :deleted) (do-blocks (block component) (setf (block-delete-p block) t)) @@ -1115,7 +1148,7 @@ ;;; of arguments changes, the transform must be prepared to return a ;;; lambda with a new lambda-list with the correct number of ;;; arguments. -(defun extract-function-args (cont fun num-args) +(defun extract-fun-args (cont fun num-args) #!+sb-doc "If CONT is a call to FUN with NUM-ARGS args, change those arguments to feed directly to the continuation-dest of CONT, which must be @@ -1144,7 +1177,7 @@ (setf (combination-args outside) (append before-args inside-args after-args)) (change-ref-leaf (continuation-use inside-fun) - (find-free-function 'list "???")) + (find-free-fun 'list "???")) (setf (combination-kind inside) :full) (setf (node-derived-type inside) *wild-type*) (flush-dest cont) @@ -1174,8 +1207,8 @@ (change-ref-leaf ref new-leaf)) (values)) -;;; Like SUBSITUTE-LEAF, only there is a predicate on the REF to tell -;;; whether to substitute. +;;; like SUBSITUTE-LEAF, only there is a predicate on the REF to tell +;;; whether to substitute (defun substitute-leaf-if (test new-leaf old-leaf) (declare (type leaf new-leaf old-leaf) (type function test)) (dolist (ref (leaf-refs old-leaf)) @@ -1241,9 +1274,10 @@ (t (return nil))))))) -;;; Return true if function is an XEP. This is true of normal XEPs -;;; (:EXTERNAL kind) and top level lambdas (:TOPLEVEL kind.) -(defun external-entry-point-p (fun) +;;; Return true if function is an external entry point. This is true +;;; of normal XEPs (:EXTERNAL kind) and also of top level lambdas +;;; (:TOPLEVEL kind.) +(defun xep-p (fun) (declare (type functional fun)) (not (null (member (functional-kind fun) '(:external :toplevel))))) @@ -1264,10 +1298,16 @@ nil)) nil))) +;;; Return the source name of a combination. (This is an idiom +;;; which was used in CMU CL. I gather it always works. -- WHN) +(defun combination-fun-source-name (combination) + (let ((ref (continuation-use (combination-fun combination)))) + (leaf-source-name (ref-leaf ref)))) + ;;; Return the COMBINATION node that is the call to the LET FUN. (defun let-combination (fun) (declare (type clambda fun)) - (aver (member (functional-kind fun) '(:let :mv-let))) + (aver (functional-letlike-p fun)) (continuation-dest (node-cont (first (leaf-refs fun))))) ;;; Return the initial value continuation for a LET variable, or NIL @@ -1278,8 +1318,7 @@ (elt (combination-args (let-combination fun)) (position-or-lose var (lambda-vars fun))))) -;;; Return the LAMBDA that is called by the local Call. -#!-sb-fluid (declaim (inline combination-lambda)) +;;; Return the LAMBDA that is called by the local CALL. (defun combination-lambda (call) (declare (type basic-combination call)) (aver (eq (basic-combination-kind call) :local)) @@ -1310,7 +1349,7 @@ ;; compiler to be able to use WITH-COMPILATION-UNIT on ;; arbitrarily huge blocks of code. -- WHN) (let ((*compiler-error-context* node)) - (compiler-note "*INLINE-EXPANSION-LIMIT* (~D) was exceeded, ~ + (compiler-note "*INLINE-EXPANSION-LIMIT* (~W) was exceeded, ~ probably trying to~% ~ inline a recursive function." *inline-expansion-limit*)) @@ -1321,20 +1360,20 @@ ;;; Apply a function to some arguments, returning a list of the values ;;; resulting of the evaluation. If an error is signalled during the -;;; application, then we print a warning message and return NIL as our -;;; second value to indicate this. Node is used as the error context -;;; for any error message, and Context is a string that is spliced -;;; into the warning. -(declaim (ftype (function ((or symbol function) list node string) +;;; application, then we produce a warning message using WARN-FUN and +;;; return NIL as our second value to indicate this. NODE is used as +;;; the error context for any error message, and CONTEXT is a string +;;; that is spliced into the warning. +(declaim (ftype (function ((or symbol function) list node function string) (values list boolean)) careful-call)) -(defun careful-call (function args node context) +(defun careful-call (function args node warn-fun context) (values (multiple-value-list (handler-case (apply function args) (error (condition) (let ((*compiler-error-context* node)) - (compiler-warning "Lisp error during ~A:~%~A" context condition) + (funcall warn-fun "Lisp error during ~A:~%~A" context condition) (return-from careful-call (values nil nil)))))) t))