Newer
Older
;;; For now, if the result is other than one value, we don't fold it.
;;;
(defun constant-fold-call (call)
(declare (type combination call))
(let* ((args (mapcar #'continuation-value (combination-args call)))
(ref (continuation-use (combination-fun call)))
(fun (leaf-name (ref-leaf ref))))
(multiple-value-bind (values win)
(careful-call fun args call "constant folding")
(cond
((not win)
(setf (ref-inlinep ref) :notinline)
(setf (combination-kind call) :full))
((= (length values) 1)
(with-ir1-environment call
(when (producing-fasl-file)
(maybe-emit-make-load-forms (first values)))
(let* ((leaf (find-constant (first values)))
(node (make-ref (leaf-type leaf)
leaf
nil))
(dummy (make-continuation))
(cont (node-cont call))
(block (node-block call))
(next (continuation-next cont)))
(push node (leaf-refs leaf))
(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)))))))))
1046
1047
1048
1049
1050
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
(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))
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
(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
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
;;;
;;; Return true if the value of Ref will always be the same (and is thus
;;; legal to substitute.)
;;;
(defun constant-reference-p (ref)
(declare (type ref ref))
(let ((leaf (ref-leaf ref)))
(typecase leaf
(constant t)
(functional t)
(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))
t)))))
((and (null (rest (leaf-refs var)))
(substitute-single-use-continuation arg var)))
(t
(propagate-to-refs var (continuation-type arg))))))
(when (every #'null (combination-args call))
(delete-let fun))
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
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
(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))
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
;;; 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))
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
(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)))
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
(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))
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
;;; 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))