X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1util.lisp;h=b62fb36b20659786f3c3aa9dc36911d114a9145e;hb=079ef9dad558ca07cb8178ef428bf738112174fa;hp=b86ce5314a35b90175a1806b67d38c24e67451b7;hpb=20caa346e7b57cf8876cf67e166711f574b8955a;p=sbcl.git diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index b86ce53..b62fb36 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -164,16 +164,27 @@ (values)) ;;; Replace all uses of OLD with uses of NEW, where NEW has an -;;; arbitary number of uses. -(defun substitute-lvar-uses (new old) +;;; arbitary number of uses. NEW is supposed to be "later" than OLD. +(defun substitute-lvar-uses (new old propagate-dx) (declare (type lvar old) - (type (or lvar null) new)) - - (cond (new (do-uses (node old) - (%delete-lvar-use node) - (add-lvar-use node new)) - (reoptimize-lvar new)) + (type (or lvar null) new) + (type boolean propagate-dx)) + + (cond (new + (do-uses (node old) + (%delete-lvar-use node) + (add-lvar-use node new)) + (reoptimize-lvar new) + (awhen (and propagate-dx (lvar-dynamic-extent old)) + (setf (lvar-dynamic-extent old) nil) + (unless (lvar-dynamic-extent new) + (setf (lvar-dynamic-extent new) it) + (setf (cleanup-info it) (substitute new old (cleanup-info it))))) + (when (lvar-dynamic-extent new) + (do-uses (node new) + (node-ends-block node)))) (t (flush-dest old))) + (values)) ;;;; block starting/creation @@ -305,14 +316,35 @@ (when (and (basic-combination-p use) (eq (basic-combination-kind use) :local)) (merges use)))) + (substitute-lvar-uses lvar value + (and lvar (eq (lvar-uses lvar) node))) (%delete-lvar-use node) - (substitute-lvar-uses lvar value) (prog1 (unlink-node node) (dolist (merge (merges)) (merge-tail-sets merge))))) (t (flush-dest value) (unlink-node node)))) + +;;; Make a CAST and insert it into IR1 before node NEXT. +(defun insert-cast-before (next lvar type policy) + (declare (type node next) (type lvar lvar) (type ctype type)) + (with-ir1-environment-from-node next + (let* ((ctran (node-prev next)) + (cast (make-cast lvar type policy)) + (internal-ctran (make-ctran))) + (setf (ctran-next ctran) cast + (node-prev cast) ctran) + (use-ctran cast internal-ctran) + (link-node-to-previous-ctran next internal-ctran) + (setf (lvar-dest lvar) cast) + (reoptimize-lvar lvar) + (when (return-p next) + (node-ends-block cast)) + (setf (block-attributep (block-flags (node-block cast)) + type-check type-asserted) + t) + cast))) ;;;; miscellaneous shorthand functions @@ -342,6 +374,11 @@ (defun node-dest (node) (awhen (node-lvar node) (lvar-dest it))) +#!-sb-fluid (declaim (inline node-stack-allocate-p)) +(defun node-stack-allocate-p (node) + (awhen (node-lvar node) + (lvar-dynamic-extent it))) + (declaim (inline block-to-be-deleted-p)) (defun block-to-be-deleted-p (block) (or (block-delete-p block) @@ -538,6 +575,9 @@ type-restrictions (lambda (lexenv-lambda default)) (cleanup (lexenv-cleanup default)) + (handled-conditions (lexenv-handled-conditions default)) + (disabled-package-locks + (lexenv-disabled-package-locks default)) (policy (lexenv-policy default))) (macrolet ((frob (var slot) `(let ((old (,slot default))) @@ -550,7 +590,8 @@ (frob blocks lexenv-blocks) (frob tags lexenv-tags) (frob type-restrictions lexenv-type-restrictions) - lambda cleanup policy))) + lambda cleanup handled-conditions + disabled-package-locks policy))) ;;; Makes a LEXENV, suitable for using in a MACROLET introduced ;;; macroexpander @@ -579,6 +620,8 @@ (lexenv-type-restrictions lexenv) ; XXX nil nil + (lexenv-handled-conditions lexenv) + (lexenv-disabled-package-locks lexenv) (lexenv-policy lexenv)))) ;;;; flow/DFO/component hackery @@ -649,7 +692,7 @@ (frob if-alternative) (when (eq (if-consequent last) (if-alternative last)) - (setf (component-reoptimize (block-component block)) t))))) + (reoptimize-component (block-component block) :maybe))))) (t (unless (memq new (block-succ block)) (link-blocks block new))))) @@ -688,7 +731,7 @@ ;;; end. The tricky thing is a special cleanup block; all its nodes ;;; have the same cleanup info, corresponding to the start, so the ;;; same approach returns safe result. -(defun map-block-nlxes (fun block) +(defun map-block-nlxes (fun block &optional dx-cleanup-fun) (loop for cleanup = (block-end-cleanup block) then (node-enclosing-cleanup (cleanup-mess-up cleanup)) while cleanup @@ -697,13 +740,16 @@ ((:block :tagbody) (aver (entry-p mess-up)) (loop for exit in (entry-exits mess-up) - for nlx-info = (find-nlx-info exit) + for nlx-info = (exit-nlx-info exit) do (funcall fun nlx-info))) ((:catch :unwind-protect) (aver (combination-p mess-up)) (let* ((arg-lvar (first (basic-combination-args mess-up))) (nlx-info (constant-value (ref-leaf (lvar-use arg-lvar))))) - (funcall fun nlx-info))))))) + (funcall fun nlx-info))) + ((:dynamic-extent) + (when dx-cleanup-fun + (funcall dx-cleanup-fun cleanup))))))) ;;; Set the FLAG for all the blocks in COMPONENT to NIL, except for ;;; the head and tail which are set to T. @@ -958,6 +1004,9 @@ (when (optional-dispatch-more-entry leaf) (frob (optional-dispatch-more-entry leaf))) (let ((main (optional-dispatch-main-entry leaf))) + (when entry + (setf (functional-entry-fun entry) main) + (setf (functional-entry-fun main) entry)) (when (eq (functional-kind main) :optional) (frob main)))))) @@ -1010,7 +1059,7 @@ (do-uses (use lvar) (let ((prev (node-prev use))) (let ((block (ctran-block prev))) - (setf (component-reoptimize (block-component block)) t) + (reoptimize-component (block-component block) t) (setf (block-attributep (block-flags block) flush-p type-asserted type-check) t))) @@ -1159,8 +1208,8 @@ ;; There's no reason to accept this kind of equivocation ;; when compiling our own code, though. #+sb-xc-host - (compiler-warn "The variable ~S is defined but never used." - (leaf-debug-name var))) + (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)) @@ -1304,15 +1353,21 @@ (setf (node-prev node) nil) t))))))) +;;; Return true if CTRAN has been deleted, false if it is still a valid +;;; part of IR1. +(defun ctran-deleted-p (ctran) + (declare (type ctran ctran)) + (let ((block (ctran-block ctran))) + (or (not (block-component block)) + (block-delete-p block)))) + ;;; Return true if NODE has been deleted, false if it is still a valid ;;; part of IR1. (defun node-deleted (node) (declare (type node node)) (let ((prev (node-prev node))) - (not (and prev - (let ((block (ctran-block prev))) - (and (block-component block) - (not (block-delete-p block)))))))) + (or (not prev) + (ctran-deleted-p prev)))) ;;; Delete all the blocks and functions in COMPONENT. We scan first ;;; marking the blocks as DELETE-P to prevent weird stuff from being @@ -1476,10 +1531,17 @@ ;;; exits to CONT in that entry, then return it, otherwise return NIL. (defun find-nlx-info (exit) (declare (type exit exit)) - (let ((entry (exit-entry exit))) + (let* ((entry (exit-entry exit)) + (cleanup (entry-cleanup entry)) + (block (first (block-succ (node-block exit))))) (dolist (nlx (physenv-nlx-info (node-physenv entry)) nil) - (when (eq (nlx-info-exit nlx) exit) + (when (and (eq (nlx-info-block nlx) block) + (eq (nlx-info-cleanup nlx) cleanup)) (return nlx))))) + +(defun nlx-info-lvar (nlx) + (declare (type nlx-info nlx)) + (node-lvar (block-last (nlx-info-target nlx)))) ;;;; functional hackery @@ -1586,8 +1648,8 @@ ;; arbitrarily huge blocks of code. -- WHN) (let ((*compiler-error-context* node)) (compiler-notify "*INLINE-EXPANSION-LIMIT* (~W) was exceeded, ~ - probably trying to~% ~ - inline a recursive function." + probably trying to~% ~ + inline a recursive function." *inline-expansion-limit*)) nil) (t t)))) @@ -1747,4 +1809,4 @@ (do-uses (node lvar) (setf (node-reoptimize node) t) (setf (block-reoptimize (node-block node)) t) - (setf (component-reoptimize (node-component node)) t))))))) + (reoptimize-component (node-component node) :maybe)))))))