Newer
Older
(setf (leaf-ever-used leaf) t)
(delete-continuation-use call)
(add-continuation-use call dummy)
(prev-link node dummy)
(add-continuation-use node cont)
(setf (continuation-next cont) next)
(when (eq call (block-last block))
(setf (block-last block) node))
(reoptimize-continuation cont))))
(t
(let ((dummies (loop repeat (length args)
collect (gensym))))
(transform-call
call
`(lambda ,dummies
(declare (ignore ,@dummies))
(values ,@(mapcar #'(lambda (x) `',x) values)))))))))
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
(undefined-value))
;;;; Local call optimization:
;;; Propagate-To-Refs -- Internal
;;;
;;; Propagate Type to Leaf and its Refs, marking things changed. If the
;;; leaf type is a function type, then just leave it alone, since TYPE is never
;;; going to be more specific than that (and TYPE-INTERSECTION would choke.)
;;;
(defun propagate-to-refs (leaf type)
(declare (type leaf leaf) (type ctype type))
(let ((var-type (leaf-type leaf)))
(unless (function-type-p var-type)
(let ((int (type-intersection var-type type)))
(when (type/= int var-type)
(setf (leaf-type leaf) int)
(dolist (ref (leaf-refs leaf))
(derive-node-type ref int))))
(undefined-value))))
;;; PROPAGATE-FROM-SETS -- Internal
;;;
;;; Figure out the type of a LET variable that has sets. We compute the
;;; union of the initial value Type and the types of all the set values and to
;;; a PROPAGATE-TO-REFS with this type.
;;;
(defun propagate-from-sets (var type)
(collect ((res type type-union))
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
(dolist (set (basic-var-sets var))
(res (continuation-type (set-value set)))
(setf (node-reoptimize set) nil))
(propagate-to-refs var (res)))
(undefined-value))
;;; IR1-OPTIMIZE-SET -- Internal
;;;
;;; If a let variable, find the initial value's type and do
;;; PROPAGATE-FROM-SETS. We also derive the VALUE's type as the node's type.
;;;
(defun ir1-optimize-set (node)
(declare (type cset node))
(let ((var (set-var node)))
(when (and (lambda-var-p var) (leaf-refs var))
(let ((home (lambda-var-home var)))
(when (eq (functional-kind home) :let)
(let ((iv (let-var-initial-value var)))
(setf (continuation-reoptimize iv) nil)
(propagate-from-sets var (continuation-type iv)))))))
(derive-node-type node (continuation-type (set-value node)))
(undefined-value))
;;; CONSTANT-REFERENCE-P -- Interface
;;;
;;; Return true if the value of Ref will always be the same (and is thus
;;; legal to substitute.) Even though the value of a FUNCTIONAL really can't
;;; change, we consider it non-constant when it is marker :NOTINLINE, since
;;; this is used as a flag to inhibit local call conversion, and must not be
;;; lost.
;;;
(defun constant-reference-p (ref)
(declare (type ref ref))
(let ((leaf (ref-leaf ref)))
(typecase leaf
(constant t)
(functional
(not (eq (ref-inlinep ref) :notinline)))
(lambda-var
(null (lambda-var-sets leaf)))
(global-var
(case (global-var-kind leaf)
(:global-function
(not (eq (ref-inlinep ref) :notinline)))
(:constant t))))))
;;; SUBSTITUTE-SINGLE-USE-CONTINUATION -- Internal
;;;
;;; If we have a non-set let var with a single use, then (if possible)
;;; replace the variable reference's CONT with the arg continuation. This is
;;; inhibited when:
;;; -- CONT has other uses, or
;;; -- CONT receives multiple values, or
;;; -- the reference is in a different environment from the variable, or
;;; -- either continuation has a funky TYPE-CHECK annotation.
;;; -- the continuations have incompatible assertions, so the new asserted type
;;; would be NIL.
;;; -- the var's DEST has a different policy than the ARG's (think safety).
;;;
;;; We change the Ref to be a reference to NIL with unused value, and let it
;;; be flushed as dead code. A side-effect of this substitution is to delete
;;; the variable.
;;;
(defun substitute-single-use-continuation (arg var)
(declare (type continuation arg) (type lambda-var var))
(let* ((ref (first (leaf-refs var)))
(cont (node-cont ref))
(cont-atype (continuation-asserted-type cont))
(dest (continuation-dest cont)))
(when (and (eq (continuation-use cont) ref)
dest
(not (typep dest '(or creturn exit mv-combination)))
(eq (node-home-lambda ref)
(lambda-home (lambda-var-home var)))
(member (continuation-type-check arg) '(t nil))
(member (continuation-type-check cont) '(t nil))
(not (eq (values-type-intersection
cont-atype
(continuation-asserted-type arg))
*empty-type*))
(eq (lexenv-cookie (node-lexenv dest))
(lexenv-cookie (node-lexenv (continuation-dest arg)))))
(assert (member (continuation-kind arg)
'(:block-start :deleted-block-start :inside-block)))
(assert-continuation-type arg cont-atype)
(setf (node-derived-type ref) *wild-type*)
(change-ref-leaf ref (find-constant nil))
(substitute-continuation arg cont)
(reoptimize-continuation arg)
t)))
;;; DELETE-LET -- Interface
;;;
;;; Delete a Let, removing the call and bind nodes, and warning about any
;;; unreferenced variables. Note that FLUSH-DEAD-CODE will come along right
;;; away and delete the REF and then the lambda, since we flush the FUN
;;; continuation.
;;;
(defun delete-let (fun)
(declare (type clambda fun))
(assert (member (functional-kind fun) '(:let :mv-let)))
(note-unreferenced-vars fun)
(let ((call (let-combination fun)))
(flush-dest (basic-combination-fun call))
(unlink-node call)
(unlink-node (lambda-bind fun))
(setf (lambda-bind fun) nil))
(undefined-value))
;;; Propagate-Let-Args -- Internal
;;;
;;; This function is called when one of the arguments to a LET changes. We
;;; look at each changed argument. If the corresponding variable is set, then
;;; we call PROPAGATE-FROM-SETS. Otherwise, we consider substituting for the
;;; variable, and also propagate derived-type information for the arg to all
;;; the Var's refs.
;;;
;;; Substitution is inhibited when the arg leaf's derived type isn't a
;;; subtype of the argument's asserted type. This prevents type checking from
;;; being defeated, and also ensures that the best representation for the
;;; variable can be used.
;;; Substitution of individual references is inhibited if the reference is
;;; in a different component from the home. This can only happen with closures
;;; over top-level lambda vars. In such cases, the references may have already
;;; been compiled, and thus can't be retroactively modified.
;;;
;;; If all of the variables are deleted (have no references) when we are
;;; done, then we delete the let.
;;;
;;; Note that we are responsible for clearing the Continuation-Reoptimize
;;; flags.
;;;
(defun propagate-let-args (call fun)
(declare (type combination call) (type clambda fun))
(loop for arg in (combination-args call)
and var in (lambda-vars fun) do
(when (and arg (continuation-reoptimize arg))
(setf (continuation-reoptimize arg) nil)
(cond
((lambda-var-sets var)
(propagate-from-sets var (continuation-type arg)))
((let ((use (continuation-use arg)))
(when (ref-p use)
(let ((leaf (ref-leaf use)))
(when (and (constant-reference-p use)
(values-subtypep (leaf-type leaf)
(continuation-asserted-type arg)))
(propagate-to-refs var (continuation-type arg))
(let ((this-comp (block-component (node-block use))))
(substitute-leaf-if
#'(lambda (ref)
(cond ((eq (block-component (node-block ref))
this-comp)
t)
(t
(assert (eq (functional-kind (lambda-home fun))
:top-level))
nil)))
leaf var))
(not *byte-compiling*)
(substitute-single-use-continuation arg var)))
(t
(propagate-to-refs var (continuation-type arg))))))
(when (every #'null (combination-args call))
(delete-let fun))
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
(undefined-value))
;;; Propagate-Local-Call-Args -- Internal
;;;
;;; This function is called when one of the args to a non-let local call
;;; changes. For each changed argument corresponding to an unset variable, we
;;; compute the union of the types across all calls and propagate this type
;;; information to the var's refs.
;;;
;;; If the function has an XEP, then we don't do anything, since we won't
;;; discover anything.
;;;
;;; We can clear the Continuation-Reoptimize flags for arguments in all calls
;;; corresponding to changed arguments in Call, since the only use in IR1
;;; optimization of the Reoptimize flag for local call args is right here.
;;;
(defun propagate-local-call-args (call fun)
(declare (type combination call) (type clambda fun))
(unless (functional-entry-function fun)
(let* ((vars (lambda-vars fun))
(union (mapcar #'(lambda (arg var)
(when (and arg
(continuation-reoptimize arg)
(null (basic-var-sets var)))
(continuation-type arg)))
(basic-combination-args call)
vars))
(this-ref (continuation-use (basic-combination-fun call))))
(dolist (arg (basic-combination-args call))
(when arg
(setf (continuation-reoptimize arg) nil)))
(dolist (ref (leaf-refs fun))
(unless (eq ref this-ref)
(setq union
(mapcar #'(lambda (this-arg old)
(when old
(setf (continuation-reoptimize this-arg) nil)
(type-union (continuation-type this-arg) old)))
(basic-combination-args
(continuation-dest (node-cont ref)))
union))))
(mapc #'(lambda (var type)
(when type
(propagate-to-refs var type)))
vars union)))
(undefined-value))
;;; IR1-OPTIMIZE-MV-COMBINATION -- Internal
;;;
;;; Do stuff to notice a change to a MV combination node. There are two
;;; main branches here:
;;; -- If the call is local, then it is already a MV let, or should become one.
;;; Note that although all :LOCAL MV calls must eventually be converted to
;;; :MV-LETs, there can be a window when the call is local, but has not
;;; been let converted yet. This is because the entry-point lambdas may
;;; have stray references (in other entry points) that have not been
;;; deleted yet.
;;; -- The call is full. This case is somewhat similar to the non-MV
;;; combination optimization: we propagate return type information and
;;; notice non-returning calls. We also have an optimization
;;; which tries to convert MV-CALLs into MV-binds.
;;;
(defun ir1-optimize-mv-combination (node)
(cond
((eq (basic-combination-kind node) :local)
(let ((fun (basic-combination-fun node)))
(when (continuation-reoptimize fun)
(setf (continuation-reoptimize fun) nil)
(maybe-let-convert (combination-lambda node))))
(setf (continuation-reoptimize (first (basic-combination-args node))) nil)
(when (eq (functional-kind (combination-lambda node)) :mv-let)
(unless (convert-mv-bind-to-let node)
(ir1-optimize-mv-bind node))))
(t
(let* ((fun (basic-combination-fun node))
(fun-changed (continuation-reoptimize fun))
(args (basic-combination-args node)))
(when fun-changed
(setf (continuation-reoptimize fun) nil)
(let ((type (continuation-type fun)))
(when (function-type-p type)
(derive-node-type node (function-type-returns type))))
(maybe-terminate-block node nil)
(let ((use (continuation-use fun)))
(when (and (ref-p use) (functional-p (ref-leaf use))
(not (eq (ref-inlinep use) :notinline)))
(convert-call-if-possible use node)
(maybe-let-convert (ref-leaf use)))))
(unless (or (eq (basic-combination-kind node) :local)
(eq (continuation-function-name fun) '%throw))
(ir1-optimize-mv-call node))
(dolist (arg args)
(setf (continuation-reoptimize arg) nil)))))
(undefined-value))
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
;;; IR1-OPTIMIZE-MV-BIND -- Internal
;;;
;;; Propagate derived type info from the values continuation to the vars.
;;;
(defun ir1-optimize-mv-bind (node)
(declare (type mv-combination node))
(let ((arg (first (basic-combination-args node)))
(vars (lambda-vars (combination-lambda node))))
(multiple-value-bind (types nvals)
(values-types (continuation-derived-type arg))
(unless (eq nvals :unknown)
(mapc #'(lambda (var type)
(if (basic-var-sets var)
(propagate-from-sets var type)
(propagate-to-refs var type)))
vars
(append types
(make-list (max (- (length vars) nvals) 0)
:initial-element *null-type*)))))
(setf (continuation-reoptimize arg) nil))
(undefined-value))
;;; IR1-OPTIMIZE-MV-CALL -- Internal
;;;
;;; If possible, convert a general MV call to an MV-BIND. We can do this
;;; if:
;;; -- The call has only one argument, and
;;; -- The function has a known fixed number of arguments, or
;;; -- The argument yields a known fixed number of values.
;;;
;;; What we do is change the function in the MV-CALL to be a lambda that "looks
;;; like an MV bind", which allows IR1-OPTIMIZE-MV-COMBINATION to notice that
;;; this call can be converted (the next time around.) This new lambda just
;;; calls the actual function with the MV-BIND variables as arguments. Note
;;; that this new MV bind is not let-converted immediately, as there are going
;;; to be stray references from the entry-point functions until they get
;;; deleted.
;;;
;;; In order to avoid loss of argument count checking, we only do the
;;; transformation according to a known number of expected argument if safety
;;; is unimportant. We can always convert if we know the number of actual
;;; values, since the normal call that we build will still do any appropriate
;;; argument count checking.
;;;
;;; We only attempt the transformation if the called function is a constant
;;; reference. This allows us to just splice the leaf into the new function,
;;; instead of trying to somehow bind the function expression. The leaf must
;;; be constant because we are evaluating it again in a different place. This
;;; also has the effect of squelching multiple warnings when there is an
;;; argument count error.
;;;
(defun ir1-optimize-mv-call (node)
(let ((fun (basic-combination-fun node))
(*compiler-error-context* node)
(ref (continuation-use (basic-combination-fun node)))
(args (basic-combination-args node)))
(unless (and (ref-p ref) (constant-reference-p ref)
args (null (rest args)))
(return-from ir1-optimize-mv-call))
(multiple-value-bind (min max)
(function-type-nargs (continuation-type fun))
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
(let ((total-nvals
(multiple-value-bind
(types nvals)
(values-types (continuation-derived-type (first args)))
(declare (ignore types))
(if (eq nvals :unknown) nil nvals))))
(when total-nvals
(when (and min (< total-nvals min))
(compiler-warning
"MULTIPLE-VALUE-CALL with ~R values when the function expects ~
at least ~R."
total-nvals min)
(setf (ref-inlinep ref) :notinline)
(return-from ir1-optimize-mv-call))
(when (and max (> total-nvals max))
(compiler-warning
"MULTIPLE-VALUE-CALL with ~R values when the function expects ~
at most ~R."
total-nvals max)
(setf (ref-inlinep ref) :notinline)
(return-from ir1-optimize-mv-call)))
(let ((count (cond (total-nvals)
((and (policy node (zerop safety)) (eql min max))
min)
(t nil))))
(when count
(with-ir1-environment node
(let* ((dums (loop repeat count collect (gensym)))
(ignore (gensym))
(fun (ir1-convert-lambda
`(lambda (&optional ,@dums &rest ,ignore)
(declare (ignore ,ignore))
(funcall ,(ref-leaf ref) ,@dums)))))
(change-ref-leaf ref fun)
(assert (eq (basic-combination-kind node) :full))
(local-call-analyze *current-component*)
(assert (eq (basic-combination-kind node) :local)))))))))
(undefined-value))
;;; CONVERT-MV-BIND-TO-LET -- Internal
;;;
;;; If we see:
;;; (multiple-value-bind (x y)
;;; (values xx yy)
;;; ...)
;;; Convert to:
;;; (let ((x xx)
;;; (y yy))
;;; ...)
;;;
;;; What we actually do is convert the VALUES combination into a normal let
;;; combination calling the original :MV-LET lambda. If there are extra args to
;;; VALUES, discard the corresponding continuations. If there are insufficient
;;; args, insert references to NIL.
;;;
(defun convert-mv-bind-to-let (call)
(declare (type mv-combination call))
(let* ((arg (first (basic-combination-args call)))
(use (continuation-use arg)))
(when (and (combination-p use)
(eq (continuation-function-name (combination-fun use))
'values))
(let* ((fun (combination-lambda call))
(vals (combination-args use))
(nvars (length vars))
(nvals (length vals)))
(cond ((> nvals nvars)
(mapc #'flush-dest (subseq vals nvars))
(setq vals (subseq vals 0 nvars)))
((< nvals nvars)
(with-ir1-environment use
(let ((node-prev (node-prev use)))
(setf (node-prev use) nil)
(setf (continuation-next node-prev) nil)
(collect ((res vals))
(loop as cont = (make-continuation use)
and prev = node-prev then cont
repeat (- nvars nvals)
do (reference-constant prev cont nil)
(res cont))
(setq vals (res)))
(prev-link use (car (last vals)))))))
(setf (combination-args use) vals)
(flush-dest (combination-fun use))
(let ((fun-cont (basic-combination-fun call)))
(setf (continuation-dest fun-cont) use)
(setf (combination-fun use) fun-cont))
(setf (combination-kind use) :local)
(flush-dest (first (basic-combination-args call)))
(unlink-node call)
(reoptimize-continuation (first vals)))
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
(propagate-to-args use fun))
t)))
;;; VALUES-LIST IR1 optimizer -- Internal
;;;
;;; If we see:
;;; (values-list (list x y z))
;;;
;;; Convert to:
;;; (values x y z)
;;;
;;; In implementation, this is somewhat similar to CONVERT-MV-BIND-TO-LET. We
;;; grab the args of LIST and make them args of the VALUES-LIST call, flushing
;;; the old argument continuation (allowing the LIST to be flushed.)
;;;
(defoptimizer (values-list optimizer) ((list) node)
(let ((use (continuation-use list)))
(when (and (combination-p use)
(eq (continuation-function-name (combination-fun use))
'list))
(change-ref-leaf (continuation-use (combination-fun node))
(find-free-function 'values "in a strange place"))
(setf (combination-kind node) :full)
(let ((args (combination-args use)))
(dolist (arg args)
(setf (continuation-dest arg) node))
(setf (combination-args use) nil)
(flush-dest list)
(setf (combination-args node) args))
t)))
;;; VALUES IR1 transform -- Internal
;;;
;;; If VALUES appears in a non-MV context, then effectively convert it to a
;;; PROG1. This allows the computation of the additional values to become dead
;;; code.
;;;
(deftransform values ((&rest vals) * * :node node)
(when (typep (continuation-dest (node-cont node))
'(or creturn exit mv-combination))
(give-up))
(setf (node-derived-type node) *wild-type*)
(if vals
(let ((dummies (loop repeat (1- (length vals))
`(lambda (val ,@dummies)
(declare (ignore ,@dummies))
val))
'nil))
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
;;; Flush-Dead-Code -- Internal
;;;
;;; Delete any nodes in Block whose value is unused and have no
;;; side-effects. We can delete sets of lexical variables when the set
;;; variable has no references.
;;;
;;; [### For now, don't delete potentially flushable calls when they have the
;;; Call attribute. Someday we should look at the funcitonal args to determine
;;; if they have any side-effects.]
;;;
(defun flush-dead-code (block)
(declare (type cblock block))
(do-nodes-backwards (node cont block)
(unless (continuation-dest cont)
(typecase node
(ref
(delete-ref node)
(unlink-node node))
(combination
(let ((info (combination-kind node)))
(when (function-info-p info)
(let ((attr (function-info-attributes info)))
(when (and (ir1-attributep attr flushable)
(not (ir1-attributep attr call)))
(flush-dest (combination-fun node))
(dolist (arg (combination-args node))
(flush-dest arg))
(unlink-node node))))))
(mv-combination
(when (eq (basic-combination-kind node) :local)
(let ((fun (combination-lambda node)))
(when (dolist (var (lambda-vars fun) t)
(when (or (leaf-refs var)
(lambda-var-sets var))
(return nil)))
(flush-dest (first (basic-combination-args node)))
(delete-let fun)))))
(exit
(let ((value (exit-value node)))
(when value
(flush-dest value)
(setf (exit-value node) nil))))
(cset
(let ((var (set-var node)))
(when (and (lambda-var-p var)
(null (leaf-refs var)))
(flush-dest (set-value node))
(setf (basic-var-sets var)
(delete node (basic-var-sets var)))
(unlink-node node)))))))
(setf (block-flush-p block) nil)
(undefined-value))