X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1util.lisp;h=690cc2a4394c1913bc05882b02b1e356f961f6e4;hb=98a76d4426660876dec6649b1e228d2e5b47f579;hp=2832443b19167d0dd98ff20ac51cdcb79a0cc017;hpb=416152f084604094445a758ff399871132dff2bd;p=sbcl.git diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index 2832443..690cc2a 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -36,18 +36,20 @@ (declare (type cblock block1 block2) (type node node) (type (or cleanup null) cleanup)) (setf (component-reanalyze (block-component block1)) t) - (with-ir1-environment node - (let* ((start (make-continuation)) - (block (continuation-starts-block start)) - (cont (make-continuation)) - (*lexenv* (if cleanup - (make-lexenv :cleanup cleanup) - *lexenv*))) - (change-block-successor block1 block2 block) - (link-blocks block block2) - (ir1-convert start cont form) - (setf (block-last block) (continuation-use cont)) - block))) + (with-ir1-environment-from-node node + (with-component-last-block (*current-component* + (block-next (component-head *current-component*))) + (let* ((start (make-continuation)) + (block (continuation-starts-block start)) + (cont (make-continuation)) + (*lexenv* (if cleanup + (make-lexenv :cleanup cleanup) + *lexenv*))) + (change-block-successor block1 block2 block) + (link-blocks block block2) + (ir1-convert start cont form) + (setf (block-last block) (continuation-use cont)) + block)))) ;;;; continuation use hacking @@ -151,7 +153,8 @@ (nsubst new old (basic-combination-args dest)))))) (flush-dest old) - (setf (continuation-dest new) dest)) + (setf (continuation-dest new) dest) + (setf (continuation-%externally-checkable-type new) nil)) (values)) ;;; Replace all uses of OLD with uses of NEW, where NEW has an @@ -189,27 +192,28 @@ (ecase (continuation-kind cont) (:unused (aver (not (continuation-block cont))) - (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) + (let* ((next (component-last-block *current-component*)) + (prev (block-prev next)) + (new-block (make-block cont))) + (setf (block-next new-block) next + (block-prev new-block) prev + (block-prev next) new-block + (block-next prev) new-block + (continuation-block cont) new-block + (continuation-use cont) nil + (continuation-kind cont) :block-start) new-block)) (:block-start (continuation-block cont)))) -;;; Ensure that Cont is the start of a block (or deleted) so that the use -;;; set can be freely manipulated. -;;; -- If the continuation is :Unused or is :Inside-Block and the Cont of Last -;;; in its block, then we make it the start of a new deleted block. -;;; -- If the continuation is :Inside-Block inside a block, then we split the -;;; block using Node-Ends-Block, which makes the continuation be a -;;; :Block-Start. +;;; Ensure that CONT is the start of a block (or deleted) so that +;;; the use set can be freely manipulated. +;;; -- If the continuation is :UNUSED or is :INSIDE-BLOCK and the +;;; CONT of LAST in its block, then we make it the start of a new +;;; deleted block. +;;; -- If the continuation is :INSIDE-BLOCK inside a block, then we +;;; split the block using NODE-ENDS-BLOCK, which makes the +;;; continuation be a :BLOCK-START. (defun ensure-block-start (cont) (declare (type continuation cont)) (let ((kind (continuation-kind cont))) @@ -230,10 +234,10 @@ ;;;; miscellaneous shorthand functions -;;; Return the home (i.e. enclosing non-let) lambda for Node. Since the -;;; LEXENV-LAMBDA may be deleted, we must chain up the LAMBDA-CALL-LEXENV -;;; thread until we find a lambda that isn't deleted, and then return its home. -(declaim (maybe-inline node-home-lambda)) +;;; Return the home (i.e. enclosing non-LET) CLAMBDA for NODE. Since +;;; 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. (defun node-home-lambda (node) (declare (type node node)) (do ((fun (lexenv-lambda (node-lexenv node)) @@ -243,18 +247,24 @@ (when (eq (lambda-home fun) fun) (return fun)))) -#!-sb-fluid (declaim (inline node-block node-tlf-number)) -(declaim (maybe-inline node-environment)) (defun node-block (node) (declare (type node node)) (the cblock (continuation-block (node-prev node)))) -(defun node-environment (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 environment (lambda-environment (node-home-lambda node)))) + (the physenv (lambda-physenv (node-home-lambda node)))) -;;; Return the enclosing cleanup for environment of the first or last node -;;; in BLOCK. +(defun lambda-block (clambda) + (declare (type clambda clambda)) + (node-block (lambda-bind clambda))) +(defun lambda-component (clambda) + (block-component (lambda-block clambda))) + +;;; Return the enclosing cleanup for environment of the first or last +;;; node in BLOCK. (defun block-start-cleanup (block) (declare (type cblock block)) (node-enclosing-cleanup (continuation-next (block-start block)))) @@ -262,20 +272,56 @@ (declare (type cblock block)) (node-enclosing-cleanup (block-last 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)) + (if (node-p (block-last block)) + ;; This is the old CMU CL way of doing it. + (node-home-lambda (block-last 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) - (declare (type cblock block)) - #!-sb-fluid (declare (inline node-home-lambda)) - (node-home-lambda (block-last block))) + (the clambda + (block-home-lambda-or-null block))) -;;; Return the IR1 environment for BLOCK. -(defun block-environment (block) +;;; Return the IR1 physical environment for BLOCK. +(defun block-physenv (block) (declare (type cblock block)) - #!-sb-fluid (declare (inline node-home-lambda)) - (lambda-environment (node-home-lambda (block-last block)))) + (lambda-physenv (block-home-lambda block))) ;;; Return the Top Level Form number of PATH, i.e. the ordinal number -;;; of its original source's top-level form in its compilation unit. +;;; of its original source's top level form in its compilation unit. (defun source-path-tlf-number (path) (declare (list path)) (car (last path))) @@ -315,13 +361,41 @@ (if use (values (node-source-form use) t) (values nil nil)))) + +;;; 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 work; then if that + ;; fails, BLOCK-HOME-LAMBDA of CONTINUATION-BLOCK works, given that + ;; 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-or-null (continuation-block cont))) + (t + (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))) + +#!-sb-fluid (declaim (inline continuation-single-value-p)) +(defun continuation-single-value-p (cont) + (not (typep (continuation-dest cont) + '(or creturn exit mv-combination)))) ;;; 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 weakend-type-restrictions (lambda (lexenv-lambda default)) (cleanup (lexenv-cleanup default)) (policy (lexenv-policy default))) @@ -331,18 +405,47 @@ (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) - lambda cleanup policy - (frob options lexenv-options)))) + (frob weakend-type-restrictions lexenv-weakend-type-restrictions) + lambda cleanup policy))) + +;;; Makes a LEXENV, suitable for using in a MACROLET introduced +;;; macroexpander +(defun make-restricted-lexenv (lexenv) + (flet ((fun-good-p (fun) + (destructuring-bind (name . thing) fun + (declare (ignore name)) + (etypecase thing + (functional nil) + (global-var t) + (cons (aver (eq (car thing) 'macro)) + t)))) + (var-good-p (var) + (destructuring-bind (name . thing) var + (declare (ignore name)) + (etypecase thing + (leaf nil) + (cons (aver (eq (car thing) 'macro)) + t) + (heap-alien-info nil))))) + (internal-make-lexenv + (remove-if-not #'fun-good-p (lexenv-funs lexenv)) + (remove-if-not #'var-good-p (lexenv-vars lexenv)) + nil + nil + (lexenv-type-restrictions lexenv) ; XXX + (lexenv-weakend-type-restrictions lexenv) + nil + nil + (lexenv-policy lexenv)))) ;;;; 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) @@ -405,7 +508,10 @@ `(when (eq (,slot last) old) (setf (,slot last) new)))) (frob if-consequent) - (frob if-alternative)))) + (frob if-alternative) + (when (eq (if-consequent last) + (if-alternative last)) + (setf (component-reoptimize (block-component block)) t))))) (t (unless (member new (block-succ block) :test #'eq) (link-blocks block new))))) @@ -424,7 +530,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)) @@ -455,7 +561,7 @@ (defun make-empty-component () (let* ((head (make-block-key :start nil :component nil)) (tail (make-block-key :start nil :component nil)) - (res (make-component :head head :tail tail))) + (res (make-component head tail))) (setf (block-flag head) t) (setf (block-flag tail) t) (setf (block-component head) res) @@ -490,7 +596,7 @@ (link-blocks block new-block) (add-to-dfo new-block block) (setf (component-reanalyze (block-component block)) t) - + (do ((cont start (node-cont (continuation-next cont)))) ((eq cont last-cont) (when (eq (continuation-kind last-cont) :inside-block) @@ -504,18 +610,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)) @@ -530,17 +632,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 @@ -558,65 +665,75 @@ ;;; DELETE-REF will handle the deletion. (defun delete-functional (fun) (aver (and (null (leaf-refs fun)) - (not (functional-entry-function fun)))) + (not (functional-entry-fun fun)))) (etypecase fun (optional-dispatch (delete-optional-dispatch fun)) (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-FUNCTION in its -;;; ENTRY-FUNCTION 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 :top-level)))) - (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)))) + ;; LET may be deleted if its BIND is unreachable. Autonomous + ;; function may be deleted if it has no reachable references. + (unless (member original-kind '(:let :mv-let :assignment)) + (dolist (ref (lambda-refs clambda)) + (mark-for-deletion (node-block ref)))) + + ;; (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)) + (return-block (and return (node-block return)))) + (unless (leaf-ever-used clambda) (let ((*compiler-error-context* bind)) (compiler-note "deleting unused function~:[.~;~:*~% ~S~]" - (leaf-name leaf)))) - (unlink-blocks (component-head component) bind-block) - (when return - (unlink-blocks (node-block return) (component-tail component))) + (leaf-debug-name clambda)))) + (unless (block-delete-p bind-block) + (unlink-blocks (component-head component) bind-block)) + (when (and return-block (not (block-delete-p return-block))) + (mark-for-deletion return-block) + (unlink-blocks return-block (component-tail component))) (setf (component-reanalyze component) t) - (let ((tails (lambda-tail-set leaf))) - (setf (tail-set-functions tails) - (delete leaf (tail-set-functions tails))) - (setf (lambda-tail-set leaf) nil)) + (let ((tails (lambda-tail-set clambda))) + (setf (tail-set-funs tails) + (delete clambda (tail-set-funs tails))) + (setf (lambda-tail-set clambda) nil)) (setf (component-lambdas component) - (delete leaf (component-lambdas component))))) - - (when (eq kind :external) - (let ((fun (functional-entry-function leaf))) - (setf (functional-entry-function fun) nil) + (delete clambda (component-lambdas component))))) + + ;; 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))))) @@ -635,14 +752,14 @@ ;;; 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-function leaf))) + (let ((entry (functional-entry-fun leaf))) (unless (and entry (leaf-refs entry)) (aver (or (not entry) (eq (functional-kind entry) :deleted))) (setf (functional-kind leaf) :deleted) @@ -681,11 +798,12 @@ (cond ((null refs) (typecase leaf - (lambda-var (delete-lambda-var leaf)) + (lambda-var + (delete-lambda-var leaf)) (clambda (ecase (functional-kind leaf) ((nil :let :mv-let :assignment :escape :cleanup) - (aver (not (functional-entry-function leaf))) + (aver (null (functional-entry-fun leaf))) (delete-lambda leaf)) (:external (delete-lambda leaf)) @@ -710,7 +828,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 @@ -721,6 +839,7 @@ (unless (eq (continuation-kind cont) :deleted) (aver (continuation-dest cont)) (setf (continuation-dest cont) nil) + (setf (continuation-%externally-checkable-type cont) nil) (do-uses (use cont) (let ((prev (node-prev use))) (unless (eq (continuation-kind prev) :deleted) @@ -737,11 +856,17 @@ ;;; blocks with the DELETE-P flag. (defun mark-for-deletion (block) (declare (type cblock block)) - (unless (block-delete-p block) - (setf (block-delete-p block) t) - (setf (component-reanalyze (block-component block)) t) - (dolist (pred (block-pred block)) - (mark-for-deletion pred))) + (let* ((component (block-component block)) + (head (component-head component))) + (labels ((helper (block) + (setf (block-delete-p block) t) + (dolist (pred (block-pred block)) + (unless (or (block-delete-p pred) + (eq pred head)) + (helper pred))))) + (unless (block-delete-p block) + (helper block) + (setf (component-reanalyze component) t)))) (values)) ;;; Delete CONT, eliminating both control and value semantics. We set @@ -776,9 +901,11 @@ (setf (continuation-kind cont) :deleted) (setf (continuation-dest cont) nil) + (setf (continuation-%externally-checkable-type cont) nil) (setf (continuation-next cont) nil) (setf (continuation-asserted-type cont) *empty-type*) (setf (continuation-%derived-type cont) *empty-type*) + (setf (continuation-type-to-check cont) *empty-type*) (setf (continuation-use cont) nil) (setf (continuation-block cont) nil) (setf (continuation-reoptimize cont) nil) @@ -809,7 +936,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)) @@ -827,9 +961,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)) @@ -838,7 +973,6 @@ (bind (let ((lambda (bind-lambda node))) (unless (eq (functional-kind lambda) :deleted) - (aver (member (functional-kind lambda) '(:let :mv-let :assignment))) (delete-lambda lambda)))) (exit (let ((value (exit-value node)) @@ -881,10 +1015,10 @@ (let ((*compiler-error-context* (lambda-bind fun))) (unless (policy *compiler-error-context* (= inhibit-warnings 3)) ;; ANSI section "3.2.5 Exceptional Situations in the Compiler" - ;; requires this to be a STYLE-WARNING. - (compiler-style-warning "The variable ~S is defined but never used." - (leaf-name var))) - (setf (leaf-ever-used var) t)))) + ;; requires this to be no more than a STYLE-WARNING. + (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)) (defvar *deletion-ignored-objects* '(t nil)) @@ -946,8 +1080,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))) @@ -998,7 +1132,10 @@ (setf (continuation-next prev) nil)) (t (setf (continuation-next prev) next) - (setf (node-prev next) prev))) + (setf (node-prev next) prev) + (when (and (if-p next) ; AOP wanted + (eq prev (if-test next))) + (reoptimize-continuation prev)))) (setf (node-prev node) nil) nil) (t @@ -1009,11 +1146,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) @@ -1045,17 +1182,17 @@ (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-functions component))) + (aver (null (component-new-functionals component))) (setf (component-kind component) :deleted) (do-blocks (block component) (setf (block-delete-p block) t)) (dolist (fun (component-lambdas component)) (setf (functional-kind fun) nil) - (setf (functional-entry-function fun) nil) + (setf (functional-entry-fun fun) nil) (setf (leaf-refs fun) nil) (delete-functional fun)) (do-blocks (block component) @@ -1072,7 +1209,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 @@ -1086,7 +1223,7 @@ (unless (combination-p inside) (give-up-ir1-transform)) (let ((inside-fun (combination-fun inside))) - (unless (eq (continuation-function-name inside-fun) fun) + (unless (eq (continuation-fun-name inside-fun) fun) (give-up-ir1-transform)) (let ((inside-args (combination-args inside))) (unless (= (length inside-args) num-args) @@ -1096,29 +1233,45 @@ (before-args (subseq outside-args 0 arg-position)) (after-args (subseq outside-args (1+ arg-position)))) (dolist (arg inside-args) - (setf (continuation-dest arg) outside)) + (setf (continuation-dest arg) outside) + (setf (continuation-%externally-checkable-type arg) nil)) (setf (combination-args inside) nil) (setf (combination-args outside) (append before-args inside-args after-args)) (change-ref-leaf (continuation-use inside-fun) - (find-free-function 'list "???")) - (setf (combination-kind inside) :full) + (find-free-fun 'list "???")) + (setf (combination-kind inside) + (info :function :info 'list)) (setf (node-derived-type inside) *wild-type*) (flush-dest cont) (setf (continuation-asserted-type cont) *wild-type*) + (setf (continuation-type-to-check cont) *wild-type*) (values)))))) + +(defun flush-combination (combination) + (declare (type combination combination)) + (flush-dest (combination-fun combination)) + (dolist (arg (combination-args combination)) + (flush-dest arg)) + (unlink-node combination) + (values)) + ;;;; leaf hackery -;;; Change the Leaf that a Ref refers to. +;;; Change the LEAF that a REF refers to. (defun change-ref-leaf (ref leaf) (declare (type ref ref) (type leaf leaf)) (unless (eq (ref-leaf ref) leaf) (push ref (leaf-refs leaf)) (delete-ref ref) (setf (ref-leaf ref) leaf) + (setf (leaf-ever-used leaf) t) (let ((ltype (leaf-type leaf))) - (if (function-type-p ltype) + (if (let* ((cont (node-cont ref)) + (dest (continuation-dest cont))) + (and (basic-combination-p dest) + (eq cont (basic-combination-fun dest)))) (setf (node-derived-type ref) ltype) (derive-node-type ref ltype))) (reoptimize-continuation (node-cont ref))) @@ -1131,8 +1284,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)) @@ -1143,26 +1296,43 @@ ;;; Return a LEAF which represents the specified constant object. If ;;; the object is not in *CONSTANTS*, then we create a new constant ;;; LEAF and enter it. -#!-sb-fluid (declaim (maybe-inline find-constant)) (defun find-constant (object) - (if (typep object '(or symbol number character instance)) - (or (gethash object *constants*) - (setf (gethash object *constants*) - (make-constant :value object - :name nil - :type (ctype-of object) - :where-from :defined))) - (make-constant :value object - :name nil - :type (ctype-of object) - :where-from :defined))) + (if (typep object + ;; FIXME: What is the significance of this test? ("things + ;; that are worth uniquifying"?) + '(or symbol number character instance)) + (or (gethash object *constants*) + (setf (gethash object *constants*) + (make-constant :value object + :%source-name '.anonymous. + :type (ctype-of object) + :where-from :defined))) + (make-constant :value object + :%source-name '.anonymous. + :type (ctype-of object) + :where-from :defined))) +;;; Return true if VAR would have to be closed over if environment +;;; analysis ran now (i.e. if there are any uses that have a different +;;; home lambda than VAR's home.) +(defun closure-var-p (var) + (declare (type lambda-var var)) + (let ((home (lambda-var-home var))) + (cond ((eq (functional-kind home) :deleted) + nil) + (t (let ((home (lambda-home home))) + (flet ((frob (l) + (find home l :key #'node-home-lambda + :test-not #'eq))) + (or (frob (leaf-refs var)) + (frob (basic-var-sets var))))))))) + ;;; If there is a non-local exit noted in ENTRY's environment that ;;; exits to CONT in that entry, then return it, otherwise return NIL. (defun find-nlx-info (entry cont) (declare (type entry entry) (type continuation cont)) (let ((entry-cleanup (entry-cleanup entry))) - (dolist (nlx (environment-nlx-info (node-environment entry)) nil) + (dolist (nlx (physenv-nlx-info (node-physenv entry)) nil) (when (and (eq (nlx-info-continuation nlx) cont) (eq (nlx-info-cleanup nlx) entry-cleanup)) (return nlx))))) @@ -1196,33 +1366,40 @@ (t (return nil))))))) -;;; Return true if function is an XEP. This is true of normal XEPs -;;; (:EXTERNAL kind) and top-level lambdas (:TOP-LEVEL 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 :top-level))))) + (not (null (member (functional-kind fun) '(:external :toplevel))))) ;;; If CONT's only use is a non-notinline global function reference, ;;; then return the referenced symbol, otherwise NIL. If NOTINLINE-OK ;;; is true, then we don't care if the leaf is NOTINLINE. -(defun continuation-function-name (cont &optional notinline-ok) +(defun continuation-fun-name (cont &optional notinline-ok) (declare (type continuation cont)) (let ((use (continuation-use cont))) (if (ref-p use) (let ((leaf (ref-leaf use))) (if (and (global-var-p leaf) (eq (global-var-kind leaf) :global-function) - (or (not (defined-function-p leaf)) - (not (eq (defined-function-inlinep leaf) :notinline)) + (or (not (defined-fun-p leaf)) + (not (eq (defined-fun-inlinep leaf) :notinline)) notinline-ok)) - (leaf-name leaf) + (leaf-source-name leaf) 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 @@ -1233,8 +1410,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)) @@ -1265,538 +1441,56 @@ ;; 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*)) nil) (t t)))) -;;;; compiler error context determination - -(declaim (special *current-path*)) - -;;; We bind print level and length when printing out messages so that -;;; we don't dump huge amounts of garbage. -;;; -;;; FIXME: It's not possible to get the defaults right for everyone. -;;; So: Should these variables be in the SB-EXT package? Or should we -;;; just get rid of them completely and just use the bare -;;; CL:*PRINT-FOO* variables instead? -(declaim (type (or unsigned-byte null) - *compiler-error-print-level* - *compiler-error-print-length* - *compiler-error-print-lines*)) -(defvar *compiler-error-print-level* 5 - #!+sb-doc - "the value for *PRINT-LEVEL* when printing compiler error messages") -(defvar *compiler-error-print-length* 10 - #!+sb-doc - "the value for *PRINT-LENGTH* when printing compiler error messages") -(defvar *compiler-error-print-lines* 12 - #!+sb-doc - "the value for *PRINT-LINES* when printing compiler error messages") - -(defvar *enclosing-source-cutoff* 1 - #!+sb-doc - "The maximum number of enclosing non-original source forms (i.e. from - macroexpansion) that we print in full. For additional enclosing forms, we - print only the CAR.") -(declaim (type unsigned-byte *enclosing-source-cutoff*)) - -;;; We separate the determination of compiler error contexts from the -;;; actual signalling of those errors by objectifying the error -;;; context. This allows postponement of the determination of how (and -;;; if) to signal the error. -;;; -;;; We take care not to reference any of the IR1 so that pending -;;; potential error messages won't prevent the IR1 from being GC'd. To -;;; this end, we convert source forms to strings so that source forms -;;; that contain IR1 references (e.g. %DEFUN) don't hold onto the IR. -(defstruct (compiler-error-context - #-no-ansi-print-object - (:print-object (lambda (x stream) - (print-unreadable-object (x stream :type t)))) - (:copier nil)) - ;; a list of the stringified CARs of the enclosing non-original source forms - ;; exceeding the *enclosing-source-cutoff* - (enclosing-source nil :type list) - ;; a list of stringified enclosing non-original source forms - (source nil :type list) - ;; the stringified form in the original source that expanded into SOURCE - (original-source (required-argument) :type simple-string) - ;; a list of prefixes of "interesting" forms that enclose original-source - (context nil :type list) - ;; the FILE-INFO-NAME for the relevant FILE-INFO - (file-name (required-argument) - :type (or pathname (member :lisp :stream))) - ;; the file position at which the top-level form starts, if applicable - (file-position nil :type (or index null)) - ;; the original source part of the source path - (original-source-path nil :type list)) - -;;; If true, this is the node which is used as context in compiler warning -;;; messages. -(declaim (type (or null compiler-error-context node) *compiler-error-context*)) -(defvar *compiler-error-context* nil) - -;;; a hashtable mapping macro names to source context parsers. Each parser -;;; function returns the source-context list for that form. -(defvar *source-context-methods* (make-hash-table)) - -;;; documentation originally from cmu-user.tex: -;;; This macro defines how to extract an abbreviated source context from -;;; the \var{name}d form when it appears in the compiler input. -;;; \var{lambda-list} is a \code{defmacro} style lambda-list used to -;;; parse the arguments. The \var{body} should return a list of -;;; subforms that can be printed on about one line. There are -;;; predefined methods for \code{defstruct}, \code{defmethod}, etc. If -;;; no method is defined, then the first two subforms are returned. -;;; Note that this facility implicitly determines the string name -;;; associated with anonymous functions. -;;; So even though SBCL itself only uses this macro within this file, -;;; it's a reasonable thing to put in SB-EXT in case some dedicated -;;; user wants to do some heavy tweaking to make SBCL give more -;;; informative output about his code. -(defmacro def-source-context (name lambda-list &body body) - #!+sb-doc - "DEF-SOURCE-CONTEXT Name Lambda-List Form* - This macro defines how to extract an abbreviated source context from the - Named form when it appears in the compiler input. Lambda-List is a DEFMACRO - style lambda-list used to parse the arguments. The Body should return a - list of subforms suitable for a \"~{~S ~}\" format string." - (let ((n-whole (gensym))) - `(setf (gethash ',name *source-context-methods*) - #'(lambda (,n-whole) - (destructuring-bind ,lambda-list ,n-whole ,@body))))) - -(def-source-context defstruct (name-or-options &rest slots) - (declare (ignore slots)) - `(defstruct ,(if (consp name-or-options) - (car name-or-options) - name-or-options))) - -(def-source-context function (thing) - (if (and (consp thing) (eq (first thing) 'lambda) (consp (rest thing))) - `(lambda ,(second thing)) - `(function ,thing))) - -;;; Return the first two elements of FORM if FORM is a list. Take the -;;; CAR of the second form if appropriate. -(defun source-form-context (form) - (cond ((atom form) nil) - ((>= (length form) 2) - (funcall (gethash (first form) *source-context-methods* - #'(lambda (x) - (declare (ignore x)) - (list (first form) (second form)))) - (rest form))) - (t - form))) - -;;; Given a source path, return the original source form and a -;;; description of the interesting aspects of the context in which it -;;; appeared. The context is a list of lists, one sublist per context -;;; form. The sublist is a list of some of the initial subforms of the -;;; context form. -;;; -;;; For now, we use the first two subforms of each interesting form. A -;;; form is interesting if the first element is a symbol beginning -;;; with "DEF" and it is not the source form. If there is no -;;; DEF-mumble, then we use the outermost containing form. If the -;;; second subform is a list, then in some cases we return the CAR of -;;; that form rather than the whole form (i.e. don't show DEFSTRUCT -;;; options, etc.) -(defun find-original-source (path) - (declare (list path)) - (let* ((rpath (reverse (source-path-original-source path))) - (tlf (first rpath)) - (root (find-source-root tlf *source-info*))) - (collect ((context)) - (let ((form root) - (current (rest rpath))) - (loop - (when (atom form) - (aver (null current)) - (return)) - (let ((head (first form))) - (when (symbolp head) - (let ((name (symbol-name head))) - (when (and (>= (length name) 3) (string= name "DEF" :end1 3)) - (context (source-form-context form)))))) - (when (null current) (return)) - (setq form (nth (pop current) form))) - - (cond ((context) - (values form (context))) - ((and path root) - (let ((c (source-form-context root))) - (values form (if c (list c) nil)))) - (t - (values '(unable to locate source) - '((some strange place))))))))) - -;;; Convert a source form to a string, suitably formatted for use in -;;; compiler warnings. -(defun stringify-form (form &optional (pretty t)) - (let ((*print-level* *compiler-error-print-level*) - (*print-length* *compiler-error-print-length*) - (*print-lines* *compiler-error-print-lines*) - (*print-pretty* pretty)) - (if pretty - (format nil "~<~@; ~S~:>" (list form)) - (prin1-to-string form)))) - -;;; Return a COMPILER-ERROR-CONTEXT structure describing the current -;;; error context, or NIL if we can't figure anything out. ARGS is a -;;; list of things that are going to be printed out in the error -;;; message, and can thus be blown off when they appear in the source -;;; context. -(defun find-error-context (args) - (let ((context *compiler-error-context*)) - (if (compiler-error-context-p context) - context - (let ((path (or (and (boundp '*current-path*) *current-path*) - (if context - (node-source-path context) - nil)))) - (when (and *source-info* path) - (multiple-value-bind (form src-context) (find-original-source path) - (collect ((full nil cons) - (short nil cons)) - (let ((forms (source-path-forms path)) - (n 0)) - (dolist (src (if (member (first forms) args) - (rest forms) - forms)) - (if (>= n *enclosing-source-cutoff*) - (short (stringify-form (if (consp src) - (car src) - src) - nil)) - (full (stringify-form src))) - (incf n))) - - (let* ((tlf (source-path-tlf-number path)) - (file-info (source-info-file-info *source-info*))) - (make-compiler-error-context - :enclosing-source (short) - :source (full) - :original-source (stringify-form form) - :context src-context - :file-name (file-info-name file-info) - :file-position - (multiple-value-bind (ignore pos) - (find-source-root tlf *source-info*) - (declare (ignore ignore)) - pos) - :original-source-path - (source-path-original-source path)))))))))) - -;;;; printing error messages - -;;; We save the context information that we printed out most recently -;;; so that we don't print it out redundantly. - -;;; The last COMPILER-ERROR-CONTEXT that we printed. -(defvar *last-error-context* nil) -(declaim (type (or compiler-error-context null) *last-error-context*)) - -;;; The format string and args for the last error we printed. -(defvar *last-format-string* nil) -(defvar *last-format-args* nil) -(declaim (type (or string null) *last-format-string*)) -(declaim (type list *last-format-args*)) - -;;; The number of times that the last error message has been emitted, -;;; so that we can compress duplicate error messages. -(defvar *last-message-count* 0) -(declaim (type index *last-message-count*)) - -;;; If the last message was given more than once, then print out an -;;; indication of how many times it was repeated. We reset the message -;;; count when we are done. -(defun note-message-repeats (&optional (terpri t)) - (cond ((= *last-message-count* 1) - (when terpri (terpri *error-output*))) - ((> *last-message-count* 1) - (format *error-output* "~&; [Last message occurs ~D times.]~2%" - *last-message-count*))) - (setq *last-message-count* 0)) - -;;; Print out the message, with appropriate context if we can find it. -;;; If the context is different from the context of the last message -;;; we printed, then we print the context. If the original source is -;;; different from the source we are working on, then we print the -;;; current source in addition to the original source. -;;; -;;; We suppress printing of messages identical to the previous, but -;;; record the number of times that the message is repeated. -(defun print-compiler-message (format-string format-args) - - (declare (type simple-string format-string)) - (declare (type list format-args)) - - (let ((stream *error-output*) - (context (find-error-context format-args))) - (cond - (context - (let ((file (compiler-error-context-file-name context)) - (in (compiler-error-context-context context)) - (form (compiler-error-context-original-source context)) - (enclosing (compiler-error-context-enclosing-source context)) - (source (compiler-error-context-source context)) - (last *last-error-context*)) - - (unless (and last - (equal file (compiler-error-context-file-name last))) - (when (pathnamep file) - (note-message-repeats) - (setq last nil) - (format stream "~2&; file: ~A~%" (namestring file)))) - - (unless (and last - (equal in (compiler-error-context-context last))) - (note-message-repeats) - (setq last nil) - (format stream "~&") - (pprint-logical-block (stream nil :per-line-prefix "; ") - (format stream "in:~{~<~% ~4:;~{ ~S~}~>~^ =>~}" in)) - (format stream "~%")) - - - (unless (and last - (string= form - (compiler-error-context-original-source last))) - (note-message-repeats) - (setq last nil) - (format stream "~&") - (pprint-logical-block (stream nil :per-line-prefix "; ") - (format stream " ~A" form)) - (format stream "~&")) - - (unless (and last - (equal enclosing - (compiler-error-context-enclosing-source last))) - (when enclosing - (note-message-repeats) - (setq last nil) - (format stream "~&; --> ~{~<~%; --> ~1:;~A~> ~}~%" enclosing))) - - (unless (and last - (equal source (compiler-error-context-source last))) - (setq *last-format-string* nil) - (when source - (note-message-repeats) - (dolist (src source) - (format stream "~&") - (write-string "; ==>" stream) - (format stream "~&") - (pprint-logical-block (stream nil :per-line-prefix "; ") - (write-string src stream))))))) - (t - (format stream "~&") - (note-message-repeats) - (setq *last-format-string* nil) - (format stream "~&"))) - - (setq *last-error-context* context) - - (unless (and (equal format-string *last-format-string*) - (tree-equal format-args *last-format-args*)) - (note-message-repeats nil) - (setq *last-format-string* format-string) - (setq *last-format-args* format-args) - (let ((*print-level* *compiler-error-print-level*) - (*print-length* *compiler-error-print-length*) - (*print-lines* *compiler-error-print-lines*)) - (format stream "~&") - (pprint-logical-block (stream nil :per-line-prefix "; ") - (format stream "~&~?" format-string format-args)) - (format stream "~&")))) - - (incf *last-message-count*) - (values)) - -(defun print-compiler-condition (condition) - (declare (type condition condition)) - (let (;; These different classes of conditions have different - ;; effects on the return codes of COMPILE-FILE, so it's nice - ;; for users to be able to pick them out by lexical search - ;; through the output. - (what (etypecase condition - (style-warning 'style-warning) - (warning 'warning) - (error 'error)))) - (multiple-value-bind (format-string format-args) - (if (typep condition 'simple-condition) - (values (simple-condition-format-control condition) - (simple-condition-format-arguments condition)) - (values "~A" - (list (with-output-to-string (s) - (princ condition s))))) - (print-compiler-message (format nil - "caught ~S:~% ~A" - what - format-string) - format-args))) - (values)) - -;;; COMPILER-NOTE is vaguely like COMPILER-ERROR and the other -;;; condition-signalling functions, but it just writes some output -;;; instead of signalling. (In CMU CL, it did signal a condition, but -;;; this didn't seem to work all that well; it was weird to have -;;; COMPILE-FILE return with WARNINGS-P set when the only problem was -;;; that the compiler couldn't figure out how to compile something as -;;; efficiently as it liked.) -(defun compiler-note (format-string &rest format-args) - (unless (if *compiler-error-context* - (policy *compiler-error-context* (= inhibit-warnings 3)) - (policy *lexenv* (= inhibit-warnings 3))) - (incf *compiler-note-count*) - (print-compiler-message (format nil "note: ~A" format-string) - format-args)) - (values)) - -;;; Issue a note when we might or might not be in the compiler. -(defun maybe-compiler-note (&rest rest) - (if (boundp '*lexenv*) ; if we're in the compiler - (apply #'compiler-note rest) - (let ((stream *error-output*)) - (pprint-logical-block (stream nil :per-line-prefix ";") - - (format stream " note: ~3I~_") - (pprint-logical-block (stream nil) - (apply #'format stream rest))) - (fresh-line stream)))) ; (outside logical block, no per-line-prefix) - -;;; The politically correct way to print out progress messages and -;;; such like. We clear the current error context so that we know that -;;; it needs to be reprinted, and we also Force-Output so that the -;;; message gets seen right away. -(declaim (ftype (function (string &rest t) (values)) compiler-mumble)) -(defun compiler-mumble (format-string &rest format-args) - (note-message-repeats) - (setq *last-error-context* nil) - (apply #'format *error-output* format-string format-args) - (force-output *error-output*) - (values)) - -;;; Return a string that somehow names the code in COMPONENT. We use -;;; the source path for the bind node for an arbitrary entry point to -;;; find the source context, then return that as a string. -(declaim (ftype (function (component) simple-string) find-component-name)) -(defun find-component-name (component) - (let ((ep (first (block-succ (component-head component))))) - (aver ep) ; else no entry points?? - (multiple-value-bind (form context) - (find-original-source - (node-source-path (continuation-next (block-start ep)))) - (declare (ignore form)) - (let ((*print-level* 2) - (*print-pretty* nil)) - (format nil "~{~{~S~^ ~}~^ => ~}" context))))) - -;;;; condition system interface - -;;; Keep track of how many times each kind of condition happens. -(defvar *compiler-error-count*) -(defvar *compiler-warning-count*) -(defvar *compiler-style-warning-count*) -(defvar *compiler-note-count*) - -;;; Keep track of whether any surrounding COMPILE or COMPILE-FILE call -;;; should return WARNINGS-P or FAILURE-P. -(defvar *failure-p*) -(defvar *warnings-p*) - -;;; condition handlers established by the compiler. We re-signal the -;;; condition, then if it isn't handled, we increment our warning -;;; counter and print the error message. -(defun compiler-error-handler (condition) - (signal condition) - (incf *compiler-error-count*) - (setf *warnings-p* t - *failure-p* t) - (print-compiler-condition condition) - (continue condition)) -(defun compiler-warning-handler (condition) - (signal condition) - (incf *compiler-warning-count*) - (setf *warnings-p* t - *failure-p* t) - (print-compiler-condition condition) - (muffle-warning condition)) -(defun compiler-style-warning-handler (condition) - (signal condition) - (incf *compiler-style-warning-count*) - (setf *warnings-p* t) - (print-compiler-condition condition) - (muffle-warning condition)) - -;;;; undefined warnings - -(defvar *undefined-warning-limit* 3 - #!+sb-doc - "If non-null, then an upper limit on the number of unknown function or type - warnings that the compiler will print for any given name in a single - compilation. This prevents excessive amounts of output when the real - problem is a missing definition (as opposed to a typo in the use.)") - -;;; Make an entry in the *UNDEFINED-WARNINGS* describing a reference -;;; to NAME of the specified KIND. If we have exceeded the warning -;;; limit, then just increment the count, otherwise note the current -;;; error context. -;;; -;;; Undefined types are noted by a condition handler in -;;; WITH-COMPILATION-UNIT, which can potentially be invoked outside -;;; the compiler, hence the BOUNDP check. -(defun note-undefined-reference (name kind) - (unless (and - ;; Check for boundness so we don't blow up if we're called - ;; when IR1 conversion isn't going on. - (boundp '*lexenv*) - ;; FIXME: I'm pretty sure the INHIBIT-WARNINGS test below - ;; isn't a good idea; we should have INHIBIT-WARNINGS - ;; affect compiler notes, not STYLE-WARNINGs. And I'm not - ;; sure what the BOUNDP '*LEXENV* test above is for; it's - ;; likely a good idea, but it probably deserves an - ;; explanatory comment. - (policy *lexenv* (= inhibit-warnings 3))) - (let* ((found (dolist (warning *undefined-warnings* nil) - (when (and (equal (undefined-warning-name warning) name) - (eq (undefined-warning-kind warning) kind)) - (return warning)))) - (res (or found - (make-undefined-warning :name name :kind kind)))) - (unless found (push res *undefined-warnings*)) - (when (or (not *undefined-warning-limit*) - (< (undefined-warning-count res) *undefined-warning-limit*)) - (push (find-error-context (list name)) - (undefined-warning-warnings res))) - (incf (undefined-warning-count res)))) - (values)) - ;;;; careful call ;;; 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)) + +;;; Variations of SPECIFIER-TYPE for parsing possibly wrong +;;; specifiers. +(macrolet + ((deffrob (basic careful compiler transform) + `(progn + (defun ,careful (specifier) + (handler-case (,basic specifier) + (simple-error (condition) + (values nil (list* (simple-condition-format-control condition) + (simple-condition-format-arguments condition)))))) + (defun ,compiler (specifier) + (multiple-value-bind (type error-args) (,careful specifier) + (or type + (apply #'compiler-error error-args)))) + (defun ,transform (specifier) + (multiple-value-bind (type error-args) (,careful specifier) + (or type + (apply #'give-up-ir1-transform + error-args))))))) + (deffrob specifier-type careful-specifier-type compiler-specifier-type ir1-transform-specifier-type) + (deffrob values-specifier-type careful-values-specifier-type compiler-values-specifier-type ir1-transform-values-specifier-type)) + ;;;; utilities used at run-time for parsing &KEY args in IR1