X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1util.lisp;h=eb1531d602a79542aa427b4c474e8e10c88a839c;hb=619ee68faffc3990c5108611762ef54bf8cbbd1e;hp=2e1d354fcafce5e2a44ef205d2b0ae20a6e01d71;hpb=34dd23563d2f5cf05c72b971da0d0b065a09bf2a;p=sbcl.git diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index 2e1d354..eb1531d 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -151,7 +151,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 @@ -386,7 +387,8 @@ ;;; 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 +403,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 +501,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))))) @@ -554,7 +589,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 +603,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 +682,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,15 +702,17 @@ ;; referenced, we give a note. (let* ((bind-block (node-block bind)) (component (block-component bind-block)) - (return (lambda-return clambda))) - (aver (null (leaf-refs 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) @@ -789,6 +832,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) @@ -805,11 +849,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 @@ -844,9 +894,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) @@ -877,7 +929,14 @@ (reoptimize-continuation cont))) (dolist (b (block-pred block)) - (unlink-blocks b block)) + (unlink-blocks b block) + ;; In bug 147 the almost-all-blocks-have-a-successor invariant was + ;; broken when successors were deleted without setting the + ;; BLOCK-DELETE-P flags of their predececessors. Make sure that + ;; doesn't happen again. + (aver (not (and (null (block-succ b)) + (not (block-delete-p b)) + (not (eq b (component-head (block-component b)))))))) (dolist (b (block-succ block)) (unlink-blocks block b)) @@ -907,7 +966,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)) @@ -1165,7 +1223,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)) @@ -1175,6 +1234,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 @@ -1353,22 +1413,45 @@ ;;; Apply a function to some arguments, returning a list of the values ;;; resulting of the evaluation. If an error is signalled during the -;;; application, then we print a warning message and return NIL as our -;;; second value to indicate this. Node is used as the error context -;;; for any error message, and Context is a string that is spliced -;;; into the warning. -(declaim (ftype (function ((or symbol function) list node string) +;;; application, then we produce a warning message using WARN-FUN and +;;; return NIL as our second value to indicate this. NODE is used as +;;; the error context for any error message, and CONTEXT is a string +;;; that is spliced into the warning. +(declaim (ftype (function ((or symbol function) list node function string) (values list boolean)) careful-call)) -(defun careful-call (function args node context) +(defun careful-call (function args node warn-fun context) (values (multiple-value-list (handler-case (apply function args) (error (condition) (let ((*compiler-error-context* node)) - (compiler-warn "Lisp error during ~A:~%~A" context condition) + (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