X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1util.lisp;h=789d7e17d0899117c2e9a0243734b5e5df0368ad;hb=1b650be8b800cf96e2c268ae317fb26d0bf36827;hp=02797be11963c63bbbefc3f79d6f5475db4d458d;hpb=ff57884e206ac28660af6af34315bc9b81697f57;p=sbcl.git diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index 02797be..789d7e1 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -500,7 +500,7 @@ ((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) @@ -544,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))) @@ -559,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 @@ -587,7 +586,6 @@ nil nil (lexenv-type-restrictions lexenv) ; XXX - (lexenv-weakend-type-restrictions lexenv) nil nil (lexenv-policy lexenv)))) @@ -862,8 +860,9 @@ (return-block (and return (node-block return)))) (unless (leaf-ever-used clambda) (let ((*compiler-error-context* bind)) - (compiler-notify "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))) @@ -1070,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) @@ -1095,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 @@ -1106,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)))) @@ -1240,7 +1244,9 @@ 0))) (unless (return-p node) (let ((*compiler-error-context* node)) - (compiler-notify "deleting unreachable code"))) + (compiler-notify 'code-deletion-note + :format-control "deleting unreachable code" + :format-arguments nil))) (return)))))) (values)) @@ -1600,6 +1606,20 @@ *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