(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
;;; 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)))
(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))))
\f
;;;; flow/DFO/component hackery
`(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)))))
(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)
\f
;;;; 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))
(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.)
;; 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)
(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)
;;; 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
(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)
(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))
(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))
(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))))))
\f
;;;; leaf hackery
(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)
(let ((action (event-info-action info)))
(when action (funcall action node))))
+
+;;; It should be in locall.lisp, but is used before in ir1opt.lisp.
+(define-optimization-quality verify-arg-count
+ (if (zerop safety) 0 3)
+ ("no" "maybe" "yes" "yes"))
projects / sbcl.git / blobdiff