X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1util.lisp;h=946c32b4ae9d8ed20338524525f3c82f0378f49d;hb=b0642df835dc2fca3e4cf47aff978ecdc88799d5;hp=7dd4459e41c442f23c5d074374f73add79dcadc2;hpb=9347abeb5f42dc83d372c19b14e86204a6a588dd;p=sbcl.git diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index 7dd4459..946c32b 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 @@ -469,7 +508,10 @@ `(when (eq (,slot last) old) (setf (,slot last) new)))) (frob if-consequent) - (frob if-alternative)))) + (frob if-alternative) + (when (eq (if-consequent last) + (if-alternative last)) + (setf (component-reoptimize (block-component block)) t))))) (t (unless (member new (block-succ block) :test #'eq) (link-blocks block new))))) @@ -519,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) @@ -554,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) @@ -568,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)) @@ -647,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.) @@ -661,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) @@ -791,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) @@ -807,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 @@ -846,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) @@ -916,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)) @@ -1174,7 +1230,8 @@ (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)) @@ -1184,6 +1241,7 @@ (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)))))) ;;;; leaf hackery @@ -1195,6 +1253,7 @@ (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) (setf (node-derived-type ref) ltype) @@ -1378,6 +1437,29 @@ (funcall warn-fun "Lisp error during ~A:~%~A" context condition) (return-from careful-call (values nil nil)))))) t)) + +;;; Variations of SPECIFIER-TYPE for parsing possibly wrong +;;; specifiers. +(macrolet + ((deffrob (basic careful compiler transform) + `(progn + (defun ,careful (specifier) + (handler-case (,basic specifier) + (simple-error (condition) + (values nil (list* (simple-condition-format-control condition) + (simple-condition-format-arguments condition)))))) + (defun ,compiler (specifier) + (multiple-value-bind (type error-args) (,careful specifier) + (or type + (apply #'compiler-error error-args)))) + (defun ,transform (specifier) + (multiple-value-bind (type error-args) (,careful specifier) + (or type + (apply #'give-up-ir1-transform + error-args))))))) + (deffrob specifier-type careful-specifier-type compiler-specifier-type ir1-transform-specifier-type) + (deffrob values-specifier-type careful-values-specifier-type compiler-values-specifier-type ir1-transform-values-specifier-type)) + ;;;; utilities used at run-time for parsing &KEY args in IR1