X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1util.lisp;h=690cc2a4394c1913bc05882b02b1e356f961f6e4;hb=98a76d4426660876dec6649b1e228d2e5b47f579;hp=e6637c174fd4265b1375ffd2328f173a0668e10e;hpb=b8fe7c0afeb9901091ce781ba351d0513f2ee86d;p=sbcl.git diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index e6637c1..690cc2a 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -37,17 +37,19 @@ (type (or cleanup null) cleanup)) (setf (component-reanalyze (block-component block1)) t) (with-ir1-environment-from-node node - (let* ((start (make-continuation)) - (block (continuation-starts-block start)) - (cont (make-continuation)) - (*lexenv* (if cleanup - (make-lexenv :cleanup cleanup) - *lexenv*))) - (change-block-successor block1 block2 block) - (link-blocks block block2) - (ir1-convert start cont form) - (setf (block-last block) (continuation-use cont)) - block))) + (with-component-last-block (*current-component* + (block-next (component-head *current-component*))) + (let* ((start (make-continuation)) + (block (continuation-starts-block start)) + (cont (make-continuation)) + (*lexenv* (if cleanup + (make-lexenv :cleanup cleanup) + *lexenv*))) + (change-block-successor block1 block2 block) + (link-blocks block block2) + (ir1-convert start cont form) + (setf (block-last block) (continuation-use cont)) + block)))) ;;;; continuation use hacking @@ -151,7 +153,8 @@ (nsubst new old (basic-combination-args dest)))))) (flush-dest old) - (setf (continuation-dest new) dest)) + (setf (continuation-dest new) dest) + (setf (continuation-%externally-checkable-type new) nil)) (values)) ;;; Replace all uses of OLD with uses of NEW, where NEW has an @@ -189,16 +192,16 @@ (ecase (continuation-kind cont) (:unused (aver (not (continuation-block cont))) - (let* ((head (component-head *current-component*)) - (next (block-next head)) - (new-block (make-block cont))) + (let* ((next (component-last-block *current-component*)) + (prev (block-prev next)) + (new-block (make-block cont))) (setf (block-next new-block) next - (block-prev new-block) head - (block-prev next) new-block - (block-next head) new-block - (continuation-block cont) new-block - (continuation-use cont) nil - (continuation-kind cont) :block-start) + (block-prev new-block) prev + (block-prev next) new-block + (block-next prev) new-block + (continuation-block cont) new-block + (continuation-use cont) nil + (continuation-kind cont) :block-start) new-block)) (:block-start (continuation-block cont)))) @@ -209,7 +212,7 @@ ;;; CONT of LAST in its block, then we make it the start of a new ;;; deleted block. ;;; -- If the continuation is :INSIDE-BLOCK inside a block, then we -;;; split the block using Node-Ends-Block, which makes the +;;; split the block using NODE-ENDS-BLOCK, which makes the ;;; continuation be a :BLOCK-START. (defun ensure-block-start (cont) (declare (type continuation cont)) @@ -381,12 +384,18 @@ (defun continuation-home-lambda (cont) (the clambda (continuation-home-lambda-or-null cont))) + +#!-sb-fluid (declaim (inline continuation-single-value-p)) +(defun continuation-single-value-p (cont) + (not (typep (continuation-dest cont) + '(or creturn exit mv-combination)))) ;;; Return a new LEXENV just like DEFAULT except for the specified ;;; slot values. Values for the alist slots are NCONCed to the ;;; beginning of the current value, rather than replacing it entirely. (defun make-lexenv (&key (default *lexenv*) - funs vars blocks tags type-restrictions options + funs vars blocks tags + type-restrictions weakend-type-restrictions (lambda (lexenv-lambda default)) (cleanup (lexenv-cleanup default)) (policy (lexenv-policy default))) @@ -401,8 +410,38 @@ (frob blocks lexenv-blocks) (frob tags lexenv-tags) (frob type-restrictions lexenv-type-restrictions) - lambda cleanup policy - (frob options lexenv-options)))) + (frob weakend-type-restrictions lexenv-weakend-type-restrictions) + lambda cleanup policy))) + +;;; Makes a LEXENV, suitable for using in a MACROLET introduced +;;; macroexpander +(defun make-restricted-lexenv (lexenv) + (flet ((fun-good-p (fun) + (destructuring-bind (name . thing) fun + (declare (ignore name)) + (etypecase thing + (functional nil) + (global-var t) + (cons (aver (eq (car thing) 'macro)) + t)))) + (var-good-p (var) + (destructuring-bind (name . thing) var + (declare (ignore name)) + (etypecase thing + (leaf nil) + (cons (aver (eq (car thing) 'macro)) + t) + (heap-alien-info nil))))) + (internal-make-lexenv + (remove-if-not #'fun-good-p (lexenv-funs lexenv)) + (remove-if-not #'var-good-p (lexenv-vars lexenv)) + nil + nil + (lexenv-type-restrictions lexenv) ; XXX + (lexenv-weakend-type-restrictions lexenv) + nil + nil + (lexenv-policy lexenv)))) ;;;; flow/DFO/component hackery @@ -522,7 +561,7 @@ (defun make-empty-component () (let* ((head (make-block-key :start nil :component nil)) (tail (make-block-key :start nil :component nil)) - (res (make-component :head head :tail tail))) + (res (make-component head tail))) (setf (block-flag head) t) (setf (block-flag tail) t) (setf (block-component head) res) @@ -557,7 +596,7 @@ (link-blocks block new-block) (add-to-dfo new-block block) (setf (component-reanalyze (block-component block)) t) - + (do ((cont start (node-cont (continuation-next cont)))) ((eq cont last-cont) (when (eq (continuation-kind last-cont) :inside-block) @@ -571,7 +610,7 @@ ;;;; deleting stuff -;;; Deal with deleting the last (read) reference to a LAMBDA-VAR. +;;; Deal with deleting the last (read) reference to a LAMBDA-VAR. (defun delete-lambda-var (leaf) (declare (type lambda-var leaf)) @@ -650,6 +689,12 @@ (setf (lambda-bind let) nil) (setf (functional-kind let) :deleted)) + ;; LET may be deleted if its BIND is unreachable. Autonomous + ;; function may be deleted if it has no reachable references. + (unless (member original-kind '(:let :mv-let :assignment)) + (dolist (ref (lambda-refs clambda)) + (mark-for-deletion (node-block ref)))) + ;; (The IF test is (FUNCTIONAL-SOMEWHAT-LETLIKE-P CLAMBDA), except ;; that we're using the old value of the KIND slot, not the ;; current slot value, which has now been set to :DELETED.) @@ -664,17 +709,17 @@ ;; referenced, we give a note. (let* ((bind-block (node-block bind)) (component (block-component bind-block)) - (return (lambda-return clambda))) - (dolist (ref (lambda-refs clambda)) - (let ((home (node-home-lambda ref))) - (aver (eq home clambda)))) + (return (lambda-return clambda)) + (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)))) - (unlink-blocks (component-head component) bind-block) - (when return - (unlink-blocks (node-block return) (component-tail component))) + (unless (block-delete-p bind-block) + (unlink-blocks (component-head component) bind-block)) + (when (and return-block (not (block-delete-p return-block))) + (mark-for-deletion return-block) + (unlink-blocks return-block (component-tail component))) (setf (component-reanalyze component) t) (let ((tails (lambda-tail-set clambda))) (setf (tail-set-funs tails) @@ -794,6 +839,7 @@ (unless (eq (continuation-kind cont) :deleted) (aver (continuation-dest cont)) (setf (continuation-dest cont) nil) + (setf (continuation-%externally-checkable-type cont) nil) (do-uses (use cont) (let ((prev (node-prev use))) (unless (eq (continuation-kind prev) :deleted) @@ -810,11 +856,17 @@ ;;; blocks with the DELETE-P flag. (defun mark-for-deletion (block) (declare (type cblock block)) - (unless (block-delete-p block) - (setf (block-delete-p block) t) - (setf (component-reanalyze (block-component block)) t) - (dolist (pred (block-pred block)) - (mark-for-deletion pred))) + (let* ((component (block-component block)) + (head (component-head component))) + (labels ((helper (block) + (setf (block-delete-p block) t) + (dolist (pred (block-pred block)) + (unless (or (block-delete-p pred) + (eq pred head)) + (helper pred))))) + (unless (block-delete-p block) + (helper block) + (setf (component-reanalyze component) t)))) (values)) ;;; Delete CONT, eliminating both control and value semantics. We set @@ -849,9 +901,11 @@ (setf (continuation-kind cont) :deleted) (setf (continuation-dest cont) nil) + (setf (continuation-%externally-checkable-type cont) nil) (setf (continuation-next cont) nil) (setf (continuation-asserted-type cont) *empty-type*) (setf (continuation-%derived-type cont) *empty-type*) + (setf (continuation-type-to-check cont) *empty-type*) (setf (continuation-use cont) nil) (setf (continuation-block cont) nil) (setf (continuation-reoptimize cont) nil) @@ -919,7 +973,6 @@ (bind (let ((lambda (bind-lambda node))) (unless (eq (functional-kind lambda) :deleted) - (aver (functional-somewhat-letlike-p lambda)) (delete-lambda lambda)))) (exit (let ((value (exit-value node)) @@ -1079,7 +1132,10 @@ (setf (continuation-next prev) nil)) (t (setf (continuation-next prev) next) - (setf (node-prev next) prev))) + (setf (node-prev next) prev) + (when (and (if-p next) ; AOP wanted + (eq prev (if-test next))) + (reoptimize-continuation prev)))) (setf (node-prev node) nil) nil) (t @@ -1177,17 +1233,29 @@ (before-args (subseq outside-args 0 arg-position)) (after-args (subseq outside-args (1+ arg-position)))) (dolist (arg inside-args) - (setf (continuation-dest arg) outside)) + (setf (continuation-dest arg) outside) + (setf (continuation-%externally-checkable-type arg) nil)) (setf (combination-args inside) nil) (setf (combination-args outside) (append before-args inside-args after-args)) (change-ref-leaf (continuation-use inside-fun) (find-free-fun 'list "???")) - (setf (combination-kind inside) :full) + (setf (combination-kind inside) + (info :function :info 'list)) (setf (node-derived-type inside) *wild-type*) (flush-dest cont) (setf (continuation-asserted-type cont) *wild-type*) + (setf (continuation-type-to-check cont) *wild-type*) (values)))))) + +(defun flush-combination (combination) + (declare (type combination combination)) + (flush-dest (combination-fun combination)) + (dolist (arg (combination-args combination)) + (flush-dest arg)) + (unlink-node combination) + (values)) + ;;;; leaf hackery @@ -1198,8 +1266,12 @@ (push ref (leaf-refs leaf)) (delete-ref ref) (setf (ref-leaf ref) leaf) + (setf (leaf-ever-used leaf) t) (let ((ltype (leaf-type leaf))) - (if (fun-type-p ltype) + (if (let* ((cont (node-cont ref)) + (dest (continuation-dest cont))) + (and (basic-combination-p dest) + (eq cont (basic-combination-fun dest)))) (setf (node-derived-type ref) ltype) (derive-node-type ref ltype))) (reoptimize-continuation (node-cont ref))) @@ -1240,6 +1312,21 @@ :type (ctype-of object) :where-from :defined))) +;;; Return true if VAR would have to be closed over if environment +;;; analysis ran now (i.e. if there are any uses that have a different +;;; home lambda than VAR's home.) +(defun closure-var-p (var) + (declare (type lambda-var var)) + (let ((home (lambda-var-home var))) + (cond ((eq (functional-kind home) :deleted) + nil) + (t (let ((home (lambda-home home))) + (flet ((frob (l) + (find home l :key #'node-home-lambda + :test-not #'eq))) + (or (frob (leaf-refs var)) + (frob (basic-var-sets var))))))))) + ;;; If there is a non-local exit noted in ENTRY's environment that ;;; exits to CONT in that entry, then return it, otherwise return NIL. (defun find-nlx-info (entry cont)