X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1util.lisp;h=789d7e17d0899117c2e9a0243734b5e5df0368ad;hb=1b650be8b800cf96e2c268ae317fb26d0bf36827;hp=19da60e3f382af92da7dc0e87ed95e7cf9f94adf;hpb=8871a1f72225f959a454a1b77f7a0e85642ba427;p=sbcl.git diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index 19da60e..789d7e1 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -54,7 +54,7 @@ ;;;; continuation use hacking ;;; Return a list of all the nodes which use Cont. -(declaim (ftype (function (continuation) list) find-uses)) +(declaim (ftype (sfunction (continuation) list) find-uses)) (defun find-uses (cont) (ecase (continuation-kind cont) ((:block-start :deleted-block-start) @@ -77,7 +77,7 @@ ;;; Note: if you call this function, you may have to do a ;;; REOPTIMIZE-CONTINUATION to inform IR1 optimization that something ;;; has changed. -(declaim (ftype (function (node) (values)) delete-continuation-use)) +(declaim (ftype (sfunction (node) (values)) delete-continuation-use)) (defun delete-continuation-use (node) (let* ((cont (node-cont node)) (block (continuation-block cont))) @@ -103,7 +103,7 @@ ;;; Note: if you call this function, you may have to do a ;;; REOPTIMIZE-CONTINUATION to inform IR1 optimization that something ;;; has changed. -(declaim (ftype (function (node continuation) (values)) add-continuation-use)) +(declaim (ftype (sfunction (node continuation) (values)) add-continuation-use)) (defun add-continuation-use (node cont) (aver (not (node-cont node))) (let ((block (continuation-block cont))) @@ -366,19 +366,20 @@ (when (eq (lambda-home fun) fun) (return fun)))) +(declaim (ftype (sfunction (node) cblock) node-block)) (defun node-block (node) - (declare (type node node)) - (the cblock (continuation-block (node-prev node)))) + (continuation-block (node-prev node))) +(declaim (ftype (sfunction (node) component) node-component)) (defun node-component (node) - (declare (type node node)) (block-component (node-block node))) +(declaim (ftype (sfunction (node) physenv) node-physenv)) (defun node-physenv (node) - (declare (type node node)) - (the physenv (lambda-physenv (node-home-lambda node)))) + (lambda-physenv (node-home-lambda node))) +(declaim (ftype (sfunction (clambda) cblock) lambda-block)) (defun lambda-block (clambda) - (declare (type clambda clambda)) (node-block (lambda-bind clambda))) +(declaim (ftype (sfunction (clambda) component) lambda-component)) (defun lambda-component (clambda) (block-component (lambda-block clambda))) @@ -430,13 +431,13 @@ nil)))) ;;; Return the non-LET LAMBDA that holds BLOCK's code. +(declaim (ftype (sfunction (cblock) clambda) block-home-lambda)) (defun block-home-lambda (block) - (the clambda - (block-home-lambda-or-null block))) + (block-home-lambda-or-null block)) ;;; Return the IR1 physical environment for BLOCK. +(declaim (ftype (sfunction (cblock) physenv) block-physenv)) (defun block-physenv (block) - (declare (type cblock block)) (lambda-physenv (block-home-lambda block))) ;;; Return the Top Level Form number of PATH, i.e. the ordinal number @@ -499,12 +500,13 @@ ((continuation-block cont) (block-home-lambda-or-null (continuation-block cont))) (t - (bug "confused about home lambda for ~S")))) + (bug "confused about home lambda for ~S" cont)))) ;;; Return the LAMBDA that is CONT's home. +(declaim (ftype (sfunction (continuation) clambda) + continuation-home-lambda)) (defun continuation-home-lambda (cont) - (the clambda - (continuation-home-lambda-or-null cont))) + (continuation-home-lambda-or-null cont)) #!-sb-fluid (declaim (inline continuation-single-value-p)) (defun continuation-single-value-p (cont) @@ -542,7 +544,7 @@ ;;; beginning of the current value, rather than replacing it entirely. (defun make-lexenv (&key (default *lexenv*) funs vars blocks tags - type-restrictions weakend-type-restrictions + type-restrictions (lambda (lexenv-lambda default)) (cleanup (lexenv-cleanup default)) (policy (lexenv-policy default))) @@ -557,7 +559,6 @@ (frob blocks lexenv-blocks) (frob tags lexenv-tags) (frob type-restrictions lexenv-type-restrictions) - (frob weakend-type-restrictions lexenv-weakend-type-restrictions) lambda cleanup policy))) ;;; Makes a LEXENV, suitable for using in a MACROLET introduced @@ -585,7 +586,6 @@ nil nil (lexenv-type-restrictions lexenv) ; XXX - (lexenv-weakend-type-restrictions lexenv) nil nil (lexenv-policy lexenv)))) @@ -667,7 +667,7 @@ ;;; Unlink a block from the next/prev chain. We also null out the ;;; COMPONENT. -(declaim (ftype (function (cblock) (values)) remove-from-dfo)) +(declaim (ftype (sfunction (cblock) (values)) remove-from-dfo)) (defun remove-from-dfo (block) (let ((next (block-next block)) (prev (block-prev block))) @@ -692,7 +692,7 @@ ;;; Set the FLAG for all the blocks in COMPONENT to NIL, except for ;;; the head and tail which are set to T. -(declaim (ftype (function (component) (values)) clear-flags)) +(declaim (ftype (sfunction (component) (values)) clear-flags)) (defun clear-flags (component) (let ((head (component-head component)) (tail (component-tail component))) @@ -704,7 +704,7 @@ ;;; Make a component with no blocks in it. The BLOCK-FLAG is initially ;;; true in the head and tail blocks. -(declaim (ftype (function nil component) make-empty-component)) +(declaim (ftype (sfunction () component) make-empty-component)) (defun make-empty-component () (let* ((head (make-block-key :start nil :component nil)) (tail (make-block-key :start nil :component nil)) @@ -860,8 +860,9 @@ (return-block (and return (node-block return)))) (unless (leaf-ever-used clambda) (let ((*compiler-error-context* bind)) - (compiler-note "deleting unused function~:[.~;~:*~% ~S~]" - (leaf-debug-name clambda)))) + (compiler-notify 'code-deletion-note + :format-control "deleting unused function~:[.~;~:*~% ~S~]" + :format-arguments (list (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))) @@ -1068,18 +1069,23 @@ ;;; We mark the START as has having no next and remove the last node ;;; from its CONT's uses. We also flush the DEST for all continuations ;;; whose values are received by nodes in the block. -(defun delete-block (block) +(defun delete-block (block &optional silent) (declare (type cblock block)) (aver (block-component block)) ; else block is already deleted! - (note-block-deletion block) + (unless silent + (note-block-deletion block)) (setf (block-delete-p block) t) - (let* ((last (block-last block)) - (cont (node-cont last))) - (delete-continuation-use last) - (if (eq (continuation-kind cont) :unused) - (delete-continuation cont) - (reoptimize-continuation cont))) + (let ((last (block-last block))) + (when last + (let ((cont (node-cont last))) + (delete-continuation-use last) + (acond ((eq (continuation-kind cont) :unused) + (delete-continuation cont)) + ((and (null (find-uses cont)) + (continuation-dest cont)) + (mark-for-deletion (node-block it))) + ((reoptimize-continuation cont)))))) (dolist (b (block-pred block)) (unlink-blocks b block) @@ -1093,7 +1099,7 @@ (dolist (b (block-succ block)) (unlink-blocks block b)) - (do-nodes (node cont block) + (do-nodes-carefully (node cont block) (typecase node (ref (delete-ref node)) (cif @@ -1104,38 +1110,38 @@ ;; careful that this LET has not already been partially deleted. (basic-combination (when (and (eq (basic-combination-kind node) :local) - ;; Guards COMBINATION-LAMBDA agains the REF being deleted. - (continuation-use (basic-combination-fun node))) - (let ((fun (combination-lambda node))) - ;; 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)))) + ;; Guards COMBINATION-LAMBDA agains the REF being deleted. + (continuation-use (basic-combination-fun node))) + (let ((fun (combination-lambda node))) + ;; 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)) (dolist (arg (basic-combination-args node)) - (when arg (flush-dest arg)))) + (when arg (flush-dest arg)))) (bind (let ((lambda (bind-lambda node))) - (unless (eq (functional-kind lambda) :deleted) - (delete-lambda lambda)))) + (unless (eq (functional-kind lambda) :deleted) + (delete-lambda lambda)))) (exit (let ((value (exit-value node)) - (entry (exit-entry node))) - (when value - (flush-dest value)) - (when entry - (setf (entry-exits entry) - (delete node (entry-exits entry)))))) + (entry (exit-entry node))) + (when value + (flush-dest value)) + (when entry + (setf (entry-exits entry) + (delete node (entry-exits entry)))))) (creturn (flush-dest (return-result node)) (delete-return node)) (cset (flush-dest (set-value node)) (let ((var (set-var node))) - (setf (basic-var-sets var) - (delete node (basic-var-sets var))))) + (setf (basic-var-sets var) + (delete node (basic-var-sets var))))) (cast (flush-dest (cast-value node)))) @@ -1238,7 +1244,9 @@ 0))) (unless (return-p node) (let ((*compiler-error-context* node)) - (compiler-note "deleting unreachable code"))) + (compiler-notify 'code-deletion-note + :format-control "deleting unreachable code" + :format-arguments nil))) (return)))))) (values)) @@ -1490,7 +1498,7 @@ ;;;; functional hackery -(declaim (ftype (function (functional) clambda) main-entry)) +(declaim (ftype (sfunction (functional) clambda) main-entry)) (defun main-entry (functional) (etypecase functional (clambda functional) @@ -1501,7 +1509,7 @@ ;;; MV-BIND when it appears in an MV-CALL. All fixed arguments must be ;;; optional with null default and no SUPPLIED-P. There must be a ;;; &REST arg with no references. -(declaim (ftype (function (functional) boolean) looks-like-an-mv-bind)) +(declaim (ftype (sfunction (functional) boolean) looks-like-an-mv-bind)) (defun looks-like-an-mv-bind (functional) (and (optional-dispatch-p functional) (do ((arg (optional-dispatch-arglist functional) (cdr arg))) @@ -1592,12 +1600,26 @@ ;; 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* (~W) was exceeded, ~ - probably trying to~% ~ - inline a recursive function." - *inline-expansion-limit*)) + (compiler-notify "*INLINE-EXPANSION-LIMIT* (~W) was exceeded, ~ + probably trying to~% ~ + inline a recursive function." + *inline-expansion-limit*)) nil) (t t)))) + +;;; Make sure that FUNCTIONAL is not let-converted or deleted. +(defun assure-functional-live-p (functional) + (declare (type functional functional)) + (when (and (or + ;; looks LET-converted + (functional-somewhat-letlike-p functional) + ;; It's possible for a LET-converted function to end up + ;; deleted later. In that case, for the purposes of this + ;; analysis, it is LET-converted: LET-converted functionals + ;; are too badly trashed to expand them inline, and deleted + ;; LET-converted functionals are even worse. + (eql (functional-kind functional) :deleted))) + (throw 'locall-already-let-converted functional))) ;;;; careful call @@ -1607,7 +1629,7 @@ ;;; 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) +(declaim (ftype (sfunction ((or symbol function) list node function string) (values list boolean)) careful-call)) (defun careful-call (function args node warn-fun context) @@ -1652,7 +1674,7 @@ ;;; list of continuations ARGS. It returns the continuation if the ;;; keyword is present, or NIL otherwise. The legality and ;;; constantness of the keywords should already have been checked. -(declaim (ftype (function (list keyword) (or continuation null)) +(declaim (ftype (sfunction (list keyword) (or continuation null)) find-keyword-continuation)) (defun find-keyword-continuation (args key) (do ((arg args (cddr arg))) @@ -1663,7 +1685,7 @@ ;;; This function is used by the result of PARSE-DEFTRANSFORM to ;;; verify that alternating continuations in ARGS are constant and ;;; that there is an even number of args. -(declaim (ftype (function (list) boolean) check-key-args-constant)) +(declaim (ftype (sfunction (list) boolean) check-key-args-constant)) (defun check-key-args-constant (args) (do ((arg args (cddr arg))) ((null arg) t) @@ -1675,7 +1697,7 @@ ;;; verify that the list of continuations ARGS is a well-formed &KEY ;;; arglist and that only keywords present in the list KEYS are ;;; supplied. -(declaim (ftype (function (list list) boolean) check-transform-keys)) +(declaim (ftype (sfunction (list list) boolean) check-transform-keys)) (defun check-transform-keys (args keys) (and (check-key-args-constant args) (do ((arg args (cddr arg))) @@ -1686,14 +1708,14 @@ ;;;; miscellaneous ;;; Called by the expansion of the EVENT macro. -(declaim (ftype (function (event-info (or node null)) *) %event)) +(declaim (ftype (sfunction (event-info (or node null)) *) %event)) (defun %event (info node) (incf (event-info-count info)) (when (and (>= (event-info-level info) *event-note-threshold*) (policy (or node *lexenv*) (= inhibit-warnings 0))) (let ((*compiler-error-context* node)) - (compiler-note (event-info-description info)))) + (compiler-notify (event-info-description info)))) (let ((action (event-info-action info))) (when action (funcall action node))))