X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcompiler%2Fir1util.lisp;h=4e4b031ab9a3d4ddce0c62725962fb44cdae7353;hb=15d6e7c9a2c3234f95dfe278046fa2fee1b0c007;hp=a8d177c0d3860f9aad6b80c8016d76b3ce3196c9;hpb=084168e1524a6493bc0f9d1697753d31239b158d;p=sbcl.git diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index a8d177c..4e4b031 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,8 +316,9 @@ (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)) @@ -342,6 +354,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) @@ -494,6 +511,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) @@ -506,7 +527,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))))) @@ -534,6 +555,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))) @@ -546,7 +570,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 @@ -575,6 +600,8 @@ (lexenv-type-restrictions lexenv) ; XXX nil nil + (lexenv-handled-conditions lexenv) + (lexenv-disabled-package-locks lexenv) (lexenv-policy lexenv)))) ;;;; flow/DFO/component hackery @@ -684,7 +711,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 @@ -699,7 +726,10 @@ (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. @@ -1149,8 +1179,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)) @@ -1374,8 +1410,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)))))) @@ -1466,8 +1502,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))))) @@ -1601,13 +1636,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