X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1util.lisp;h=5d74523af8a4ada18b832eff22d42fefa6b2e1c3;hb=fae139755a81c0431e7f12f2af9b5f3abc1326dc;hp=5d228d52259abcf86414d1b51aba16f06f1231a7;hpb=0c25cf1e8e49095969378ab356a5516f29d4c139;p=sbcl.git diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index 5d228d5..5d74523 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 @@ -220,6 +231,25 @@ ((:inside-block) (node-ends-block (ctran-use ctran))))) (values)) + +;;; CTRAN must be the last ctran in an incomplete block; finish the +;;; block and start a new one if necessary. +(defun start-block (ctran) + (declare (type ctran ctran)) + (aver (not (ctran-next ctran))) + (ecase (ctran-kind ctran) + (:inside-block + (let ((block (ctran-block ctran)) + (node (ctran-use ctran))) + (aver (not (block-last block))) + (aver node) + (setf (block-last block) node) + (setf (node-next node) nil) + (setf (ctran-use ctran) nil) + (setf (ctran-kind ctran) :unused) + (setf (ctran-block ctran) nil) + (link-blocks block (ctran-starts-block ctran)))) + (:block-start))) ;;;; @@ -286,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 @@ -323,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) @@ -475,6 +531,10 @@ (defun ctran-home-lambda (ctran) (ctran-home-lambda-or-null ctran)) +(declaim (inline cast-single-value-p)) +(defun cast-single-value-p (cast) + (not (values-type-p (cast-asserted-type cast)))) + #!-sb-fluid (declaim (inline lvar-single-value-p)) (defun lvar-single-value-p (lvar) (or (not lvar) @@ -487,7 +547,7 @@ (cast (locally (declare (notinline lvar-single-value-p)) - (and (not (values-type-p (cast-asserted-type dest))) + (and (cast-single-value-p dest) (lvar-single-value-p (node-lvar dest))))) (t t))))) @@ -515,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))) @@ -527,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 @@ -556,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 @@ -626,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))))) @@ -658,6 +724,33 @@ (setf (block-prev next) block)) (values)) +;;; List all NLX-INFOs which BLOCK can exit to. +;;; +;;; We hope that no cleanup actions are performed in the middle of +;;; BLOCK, so it is enough to look only at cleanups in the block +;;; 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 &optional dx-cleanup-fun) + (loop for cleanup = (block-end-cleanup block) + then (node-enclosing-cleanup (cleanup-mess-up cleanup)) + while cleanup + do (let ((mess-up (cleanup-mess-up cleanup))) + (case (cleanup-kind cleanup) + ((:block :tagbody) + (aver (entry-p mess-up)) + (loop for exit in (entry-exits mess-up) + for nlx-info = (find-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))) + ((: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. (declaim (ftype (sfunction (component) (values)) clear-flags)) @@ -814,7 +907,16 @@ (let ((bind-block (node-block bind))) (mark-for-deletion bind-block)) (let ((home (lambda-home clambda))) - (setf (lambda-lets home) (delete clambda (lambda-lets home))))) + (setf (lambda-lets home) (delete clambda (lambda-lets home)))) + ;; KLUDGE: In presence of NLEs we cannot always understand that + ;; LET's BIND dominates its body [for a LET "its" body is not + ;; quite its]; let's delete too dangerous for IR2 stuff. -- + ;; APD, 2004-01-01 + (dolist (var (lambda-vars clambda)) + (flet ((delete-node (node) + (mark-for-deletion (node-block node)))) + (mapc #'delete-node (leaf-refs var)) + (mapc #'delete-node (lambda-var-sets var))))) (t ;; Function has no reachable references. (dolist (ref (lambda-refs clambda)) @@ -902,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)))))) @@ -954,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))) @@ -1097,8 +1202,14 @@ (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. + #-sb-xc-host (compiler-style-warn "The variable ~S is defined but never used." - (leaf-debug-name var))) + (leaf-debug-name var)) + ;; There's no reason to accept this kind of equivocation + ;; when compiling our own code, though. + #+sb-xc-host + (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)) @@ -1242,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 @@ -1322,8 +1439,8 @@ (append before-args inside-args after-args)) (change-ref-leaf (lvar-uses inside-fun) (find-free-fun 'list "???")) - (setf (combination-kind inside) - (info :function :info 'list)) + (setf (combination-fun-info inside) (info :function :info 'list) + (combination-kind inside) :known) (setf (node-derived-type inside) *wild-type*) (flush-dest lvar) (values)))))) @@ -1406,7 +1523,7 @@ (flet ((frob (l) (find home l :key #'node-home-lambda - :test-not #'eq))) + :test #'neq))) (or (frob (leaf-refs var)) (frob (basic-var-sets var))))))))) @@ -1414,8 +1531,7 @@ ;;; 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)) - (entry-cleanup (entry-cleanup entry))) + (let ((entry (exit-entry exit))) (dolist (nlx (physenv-nlx-info (node-physenv entry)) nil) (when (eq (nlx-info-exit nlx) exit) (return nlx))))) @@ -1525,8 +1641,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)))) @@ -1549,13 +1665,15 @@ (declare (type combination call)) (let ((kind (basic-combination-kind call))) (or (eq kind :full) - (and (fun-info-p kind) - (not (fun-info-ir2-convert kind)) - (dolist (template (fun-info-templates kind) t) - (when (eq (template-ltn-policy template) :fast-safe) - (multiple-value-bind (val win) - (valid-fun-use call (template-type template)) - (when (or val (not win)) (return nil))))))))) + (and (eq kind :known) + (let ((info (basic-combination-fun-info call))) + (and + (not (fun-info-ir2-convert info)) + (dolist (template (fun-info-templates info) t) + (when (eq (template-ltn-policy template) :fast-safe) + (multiple-value-bind (val win) + (valid-fun-use call (template-type template)) + (when (or val (not win)) (return nil))))))))))) ;;;; careful call @@ -1684,4 +1802,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)))))))