;;;; continuation use hacking
;;; Return a list of all the nodes which use Cont.
-(declaim (ftype (function (continuation) list) find-uses))
+(declaim (ftype (sfunction (continuation) list) find-uses))
(defun find-uses (cont)
(ecase (continuation-kind cont)
((:block-start :deleted-block-start)
;;; Note: if you call this function, you may have to do a
;;; REOPTIMIZE-CONTINUATION to inform IR1 optimization that something
;;; has changed.
-(declaim (ftype (function (node) (values)) delete-continuation-use))
+(declaim (ftype (sfunction (node) (values)) delete-continuation-use))
(defun delete-continuation-use (node)
(let* ((cont (node-cont node))
(block (continuation-block cont)))
;;; Note: if you call this function, you may have to do a
;;; REOPTIMIZE-CONTINUATION to inform IR1 optimization that something
;;; has changed.
-(declaim (ftype (function (node continuation) (values)) add-continuation-use))
+(declaim (ftype (sfunction (node continuation) (values)) add-continuation-use))
(defun add-continuation-use (node cont)
(aver (not (node-cont node)))
(let ((block (continuation-block cont)))
(when (eq (lambda-home fun) fun)
(return fun))))
+(declaim (ftype (sfunction (node) cblock) node-block))
(defun node-block (node)
- (declare (type node node))
- (the cblock (continuation-block (node-prev node))))
+ (continuation-block (node-prev node)))
+(declaim (ftype (sfunction (node) component) node-component))
(defun node-component (node)
- (declare (type node node))
(block-component (node-block node)))
+(declaim (ftype (sfunction (node) physenv) node-physenv))
(defun node-physenv (node)
- (declare (type node node))
- (the physenv (lambda-physenv (node-home-lambda node))))
+ (lambda-physenv (node-home-lambda node)))
+(declaim (ftype (sfunction (clambda) cblock) lambda-block))
(defun lambda-block (clambda)
- (declare (type clambda clambda))
(node-block (lambda-bind clambda)))
+(declaim (ftype (sfunction (clambda) component) lambda-component))
(defun lambda-component (clambda)
(block-component (lambda-block clambda)))
nil))))
;;; Return the non-LET LAMBDA that holds BLOCK's code.
+(declaim (ftype (sfunction (cblock) clambda) block-home-lambda))
(defun block-home-lambda (block)
- (the clambda
- (block-home-lambda-or-null block)))
+ (block-home-lambda-or-null block))
;;; Return the IR1 physical environment for BLOCK.
+(declaim (ftype (sfunction (cblock) physenv) block-physenv))
(defun block-physenv (block)
- (declare (type cblock block))
(lambda-physenv (block-home-lambda block)))
;;; Return the Top Level Form number of PATH, i.e. the ordinal number
(bug "confused about home lambda for ~S"))))
;;; Return the LAMBDA that is CONT's home.
+(declaim (ftype (sfunction (continuation) clambda)
+ continuation-home-lambda))
(defun continuation-home-lambda (cont)
- (the clambda
- (continuation-home-lambda-or-null cont)))
+ (continuation-home-lambda-or-null cont))
#!-sb-fluid (declaim (inline continuation-single-value-p))
(defun continuation-single-value-p (cont)
(mv-combination
(eq (basic-combination-fun dest) cont))
(cast
- #+nil
(locally
(declare (notinline continuation-single-value-p))
(and (not (values-type-p (cast-asserted-type dest)))
for dest = (continuation-dest prev)
while (cast-p dest)
finally (return (values dest prev))))
+
+(defun principal-continuation-single-valuify (cont)
+ (loop for prev = cont then (node-cont dest)
+ for dest = (continuation-dest prev)
+ while (cast-p dest)
+ do (setf (node-derived-type dest)
+ (make-short-values-type (list (single-value-type
+ (node-derived-type dest)))))
+ (reoptimize-continuation prev)))
\f
;;; Return a new LEXENV just like DEFAULT except for the specified
;;; slot values. Values for the alist slots are NCONCed to the
;;; Unlink a block from the next/prev chain. We also null out the
;;; COMPONENT.
-(declaim (ftype (function (cblock) (values)) remove-from-dfo))
+(declaim (ftype (sfunction (cblock) (values)) remove-from-dfo))
(defun remove-from-dfo (block)
(let ((next (block-next block))
(prev (block-prev block)))
;;; Set the FLAG for all the blocks in COMPONENT to NIL, except for
;;; the head and tail which are set to T.
-(declaim (ftype (function (component) (values)) clear-flags))
+(declaim (ftype (sfunction (component) (values)) clear-flags))
(defun clear-flags (component)
(let ((head (component-head component))
(tail (component-tail component)))
;;; Make a component with no blocks in it. The BLOCK-FLAG is initially
;;; true in the head and tail blocks.
-(declaim (ftype (function nil component) make-empty-component))
+(declaim (ftype (sfunction () component) make-empty-component))
(defun make-empty-component ()
(let* ((head (make-block-key :start nil :component nil))
(tail (make-block-key :start nil :component nil))
(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))))
+ (compiler-notify "deleting unused function~:[.~;~:*~% ~S~]"
+ (leaf-debug-name clambda))))
(unless (block-delete-p bind-block)
(unlink-blocks (component-head component) bind-block))
(when (and return-block (not (block-delete-p return-block)))
;;; We mark the START as has having no next and remove the last node
;;; from its CONT's uses. We also flush the DEST for all continuations
;;; whose values are received by nodes in the block.
-(defun delete-block (block)
+(defun delete-block (block &optional silent)
(declare (type cblock block))
(aver (block-component block)) ; else block is already deleted!
- (note-block-deletion block)
+ (unless silent
+ (note-block-deletion block))
(setf (block-delete-p block) t)
- (let* ((last (block-last block))
- (cont (node-cont last)))
- (delete-continuation-use last)
- (if (eq (continuation-kind cont) :unused)
- (delete-continuation cont)
- (reoptimize-continuation cont)))
+ (let ((last (block-last block)))
+ (when last
+ (let ((cont (node-cont last)))
+ (delete-continuation-use last)
+ (acond ((eq (continuation-kind cont) :unused)
+ (delete-continuation cont))
+ ((and (null (find-uses cont))
+ (continuation-dest cont))
+ (mark-for-deletion (node-block it)))
+ ((reoptimize-continuation cont))))))
(dolist (b (block-pred block))
(unlink-blocks b block)
(dolist (b (block-succ block))
(unlink-blocks block b))
- (do-nodes (node cont block)
+ (do-nodes-carefully (node cont block)
(typecase node
(ref (delete-ref node))
(cif
;; careful that this LET has not already been partially deleted.
(basic-combination
(when (and (eq (basic-combination-kind node) :local)
- ;; Guards COMBINATION-LAMBDA agains the REF being deleted.
- (continuation-use (basic-combination-fun node)))
- (let ((fun (combination-lambda node)))
- ;; If our REF was the second-to-last ref, and has been
- ;; deleted, then FUN may be a LET for some other
- ;; combination.
- (when (and (functional-letlike-p fun)
- (eq (let-combination fun) node))
- (delete-lambda fun))))
+ ;; Guards COMBINATION-LAMBDA agains the REF being deleted.
+ (continuation-use (basic-combination-fun node)))
+ (let ((fun (combination-lambda node)))
+ ;; If our REF was the second-to-last ref, and has been
+ ;; deleted, then FUN may be a LET for some other
+ ;; combination.
+ (when (and (functional-letlike-p fun)
+ (eq (let-combination fun) node))
+ (delete-lambda fun))))
(flush-dest (basic-combination-fun node))
(dolist (arg (basic-combination-args node))
- (when arg (flush-dest arg))))
+ (when arg (flush-dest arg))))
(bind
(let ((lambda (bind-lambda node)))
- (unless (eq (functional-kind lambda) :deleted)
- (delete-lambda lambda))))
+ (unless (eq (functional-kind lambda) :deleted)
+ (delete-lambda lambda))))
(exit
(let ((value (exit-value node))
- (entry (exit-entry node)))
- (when value
- (flush-dest value))
- (when entry
- (setf (entry-exits entry)
- (delete node (entry-exits entry))))))
+ (entry (exit-entry node)))
+ (when value
+ (flush-dest value))
+ (when entry
+ (setf (entry-exits entry)
+ (delete node (entry-exits entry))))))
(creturn
(flush-dest (return-result node))
(delete-return node))
(cset
(flush-dest (set-value node))
(let ((var (set-var node)))
- (setf (basic-var-sets var)
- (delete node (basic-var-sets var)))))
+ (setf (basic-var-sets var)
+ (delete node (basic-var-sets var)))))
(cast
(flush-dest (cast-value node))))
0)))
(unless (return-p node)
(let ((*compiler-error-context* node))
- (compiler-note "deleting unreachable code")))
+ (compiler-notify "deleting unreachable code")))
(return))))))
(values))
\f
;;;; functional hackery
-(declaim (ftype (function (functional) clambda) main-entry))
+(declaim (ftype (sfunction (functional) clambda) main-entry))
(defun main-entry (functional)
(etypecase functional
(clambda functional)
;;; MV-BIND when it appears in an MV-CALL. All fixed arguments must be
;;; optional with null default and no SUPPLIED-P. There must be a
;;; &REST arg with no references.
-(declaim (ftype (function (functional) boolean) looks-like-an-mv-bind))
+(declaim (ftype (sfunction (functional) boolean) looks-like-an-mv-bind))
(defun looks-like-an-mv-bind (functional)
(and (optional-dispatch-p functional)
(do ((arg (optional-dispatch-arglist functional) (cdr arg)))
;; compiler to be able to use WITH-COMPILATION-UNIT on
;; arbitrarily huge blocks of code. -- WHN)
(let ((*compiler-error-context* node))
- (compiler-note "*INLINE-EXPANSION-LIMIT* (~W) was exceeded, ~
- probably trying to~% ~
- inline a recursive function."
- *inline-expansion-limit*))
+ (compiler-notify "*INLINE-EXPANSION-LIMIT* (~W) was exceeded, ~
+ probably trying to~% ~
+ inline a recursive function."
+ *inline-expansion-limit*))
nil)
(t t))))
+
+;;; Make sure that FUNCTIONAL is not let-converted or deleted.
+(defun assure-functional-live-p (functional)
+ (declare (type functional functional))
+ (when (and (or
+ ;; looks LET-converted
+ (functional-somewhat-letlike-p functional)
+ ;; It's possible for a LET-converted function to end up
+ ;; deleted later. In that case, for the purposes of this
+ ;; analysis, it is LET-converted: LET-converted functionals
+ ;; are too badly trashed to expand them inline, and deleted
+ ;; LET-converted functionals are even worse.
+ (eql (functional-kind functional) :deleted)))
+ (throw 'locall-already-let-converted functional)))
\f
;;;; careful call
;;; 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)
+(declaim (ftype (sfunction ((or symbol function) list node function string)
(values list boolean))
careful-call))
(defun careful-call (function args node warn-fun context)
`(progn
(defun ,careful (specifier)
(handler-case (,basic specifier)
+ (sb!kernel::arg-count-error (condition)
+ (values nil (list (format nil "~A" condition))))
(simple-error (condition)
(values nil (list* (simple-condition-format-control condition)
(simple-condition-format-arguments condition))))))
;;; list of continuations ARGS. It returns the continuation if the
;;; keyword is present, or NIL otherwise. The legality and
;;; constantness of the keywords should already have been checked.
-(declaim (ftype (function (list keyword) (or continuation null))
+(declaim (ftype (sfunction (list keyword) (or continuation null))
find-keyword-continuation))
(defun find-keyword-continuation (args key)
(do ((arg args (cddr arg)))
;;; This function is used by the result of PARSE-DEFTRANSFORM to
;;; verify that alternating continuations in ARGS are constant and
;;; that there is an even number of args.
-(declaim (ftype (function (list) boolean) check-key-args-constant))
+(declaim (ftype (sfunction (list) boolean) check-key-args-constant))
(defun check-key-args-constant (args)
(do ((arg args (cddr arg)))
((null arg) t)
;;; verify that the list of continuations ARGS is a well-formed &KEY
;;; arglist and that only keywords present in the list KEYS are
;;; supplied.
-(declaim (ftype (function (list list) boolean) check-transform-keys))
+(declaim (ftype (sfunction (list list) boolean) check-transform-keys))
(defun check-transform-keys (args keys)
(and (check-key-args-constant args)
(do ((arg args (cddr arg)))
;;;; miscellaneous
;;; Called by the expansion of the EVENT macro.
-(declaim (ftype (function (event-info (or node null)) *) %event))
+(declaim (ftype (sfunction (event-info (or node null)) *) %event))
(defun %event (info node)
(incf (event-info-count info))
(when (and (>= (event-info-level info) *event-note-threshold*)
(policy (or node *lexenv*)
(= inhibit-warnings 0)))
(let ((*compiler-error-context* node))
- (compiler-note (event-info-description info))))
+ (compiler-notify (event-info-description info))))
(let ((action (event-info-action info)))
(when action (funcall action node))))
projects / sbcl.git / blobdiff