[3d19a6]: src / compiler / ir1opt.lisp Maximize Restore History

Download this file

ir1opt.lisp    1797 lines (1690 with data), 72.5 kB

   1
   2
   3
   4
   5
   6
   7
   8
   9
  10
  11
  12
  13
  14
  15
  16
  17
  18
  19
  20
  21
  22
  23
  24
  25
  26
  27
  28
  29
  30
  31
  32
  33
  34
  35
  36
  37
  38
  39
  40
  41
  42
  43
  44
  45
  46
  47
  48
  49
  50
  51
  52
  53
  54
  55
  56
  57
  58
  59
  60
  61
  62
  63
  64
  65
  66
  67
  68
  69
  70
  71
  72
  73
  74
  75
  76
  77
  78
  79
  80
  81
  82
  83
  84
  85
  86
  87
  88
  89
  90
  91
  92
  93
  94
  95
  96
  97
  98
  99
 100
 101
 102
 103
 104
 105
 106
 107
 108
 109
 110
 111
 112
 113
 114
 115
 116
 117
 118
 119
 120
 121
 122
 123
 124
 125
 126
 127
 128
 129
 130
 131
 132
 133
 134
 135
 136
 137
 138
 139
 140
 141
 142
 143
 144
 145
 146
 147
 148
 149
 150
 151
 152
 153
 154
 155
 156
 157
 158
 159
 160
 161
 162
 163
 164
 165
 166
 167
 168
 169
 170
 171
 172
 173
 174
 175
 176
 177
 178
 179
 180
 181
 182
 183
 184
 185
 186
 187
 188
 189
 190
 191
 192
 193
 194
 195
 196
 197
 198
 199
 200
 201
 202
 203
 204
 205
 206
 207
 208
 209
 210
 211
 212
 213
 214
 215
 216
 217
 218
 219
 220
 221
 222
 223
 224
 225
 226
 227
 228
 229
 230
 231
 232
 233
 234
 235
 236
 237
 238
 239
 240
 241
 242
 243
 244
 245
 246
 247
 248
 249
 250
 251
 252
 253
 254
 255
 256
 257
 258
 259
 260
 261
 262
 263
 264
 265
 266
 267
 268
 269
 270
 271
 272
 273
 274
 275
 276
 277
 278
 279
 280
 281
 282
 283
 284
 285
 286
 287
 288
 289
 290
 291
 292
 293
 294
 295
 296
 297
 298
 299
 300
 301
 302
 303
 304
 305
 306
 307
 308
 309
 310
 311
 312
 313
 314
 315
 316
 317
 318
 319
 320
 321
 322
 323
 324
 325
 326
 327
 328
 329
 330
 331
 332
 333
 334
 335
 336
 337
 338
 339
 340
 341
 342
 343
 344
 345
 346
 347
 348
 349
 350
 351
 352
 353
 354
 355
 356
 357
 358
 359
 360
 361
 362
 363
 364
 365
 366
 367
 368
 369
 370
 371
 372
 373
 374
 375
 376
 377
 378
 379
 380
 381
 382
 383
 384
 385
 386
 387
 388
 389
 390
 391
 392
 393
 394
 395
 396
 397
 398
 399
 400
 401
 402
 403
 404
 405
 406
 407
 408
 409
 410
 411
 412
 413
 414
 415
 416
 417
 418
 419
 420
 421
 422
 423
 424
 425
 426
 427
 428
 429
 430
 431
 432
 433
 434
 435
 436
 437
 438
 439
 440
 441
 442
 443
 444
 445
 446
 447
 448
 449
 450
 451
 452
 453
 454
 455
 456
 457
 458
 459
 460
 461
 462
 463
 464
 465
 466
 467
 468
 469
 470
 471
 472
 473
 474
 475
 476
 477
 478
 479
 480
 481
 482
 483
 484
 485
 486
 487
 488
 489
 490
 491
 492
 493
 494
 495
 496
 497
 498
 499
 500
 501
 502
 503
 504
 505
 506
 507
 508
 509
 510
 511
 512
 513
 514
 515
 516
 517
 518
 519
 520
 521
 522
 523
 524
 525
 526
 527
 528
 529
 530
 531
 532
 533
 534
 535
 536
 537
 538
 539
 540
 541
 542
 543
 544
 545
 546
 547
 548
 549
 550
 551
 552
 553
 554
 555
 556
 557
 558
 559
 560
 561
 562
 563
 564
 565
 566
 567
 568
 569
 570
 571
 572
 573
 574
 575
 576
 577
 578
 579
 580
 581
 582
 583
 584
 585
 586
 587
 588
 589
 590
 591
 592
 593
 594
 595
 596
 597
 598
 599
 600
 601
 602
 603
 604
 605
 606
 607
 608
 609
 610
 611
 612
 613
 614
 615
 616
 617
 618
 619
 620
 621
 622
 623
 624
 625
 626
 627
 628
 629
 630
 631
 632
 633
 634
 635
 636
 637
 638
 639
 640
 641
 642
 643
 644
 645
 646
 647
 648
 649
 650
 651
 652
 653
 654
 655
 656
 657
 658
 659
 660
 661
 662
 663
 664
 665
 666
 667
 668
 669
 670
 671
 672
 673
 674
 675
 676
 677
 678
 679
 680
 681
 682
 683
 684
 685
 686
 687
 688
 689
 690
 691
 692
 693
 694
 695
 696
 697
 698
 699
 700
 701
 702
 703
 704
 705
 706
 707
 708
 709
 710
 711
 712
 713
 714
 715
 716
 717
 718
 719
 720
 721
 722
 723
 724
 725
 726
 727
 728
 729
 730
 731
 732
 733
 734
 735
 736
 737
 738
 739
 740
 741
 742
 743
 744
 745
 746
 747
 748
 749
 750
 751
 752
 753
 754
 755
 756
 757
 758
 759
 760
 761
 762
 763
 764
 765
 766
 767
 768
 769
 770
 771
 772
 773
 774
 775
 776
 777
 778
 779
 780
 781
 782
 783
 784
 785
 786
 787
 788
 789
 790
 791
 792
 793
 794
 795
 796
 797
 798
 799
 800
 801
 802
 803
 804
 805
 806
 807
 808
 809
 810
 811
 812
 813
 814
 815
 816
 817
 818
 819
 820
 821
 822
 823
 824
 825
 826
 827
 828
 829
 830
 831
 832
 833
 834
 835
 836
 837
 838
 839
 840
 841
 842
 843
 844
 845
 846
 847
 848
 849
 850
 851
 852
 853
 854
 855
 856
 857
 858
 859
 860
 861
 862
 863
 864
 865
 866
 867
 868
 869
 870
 871
 872
 873
 874
 875
 876
 877
 878
 879
 880
 881
 882
 883
 884
 885
 886
 887
 888
 889
 890
 891
 892
 893
 894
 895
 896
 897
 898
 899
 900
 901
 902
 903
 904
 905
 906
 907
 908
 909
 910
 911
 912
 913
 914
 915
 916
 917
 918
 919
 920
 921
 922
 923
 924
 925
 926
 927
 928
 929
 930
 931
 932
 933
 934
 935
 936
 937
 938
 939
 940
 941
 942
 943
 944
 945
 946
 947
 948
 949
 950
 951
 952
 953
 954
 955
 956
 957
 958
 959
 960
 961
 962
 963
 964
 965
 966
 967
 968
 969
 970
 971
 972
 973
 974
 975
 976
 977
 978
 979
 980
 981
 982
 983
 984
 985
 986
 987
 988
 989
 990
 991
 992
 993
 994
 995
 996
 997
 998
 999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
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
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
1077
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
1104
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
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
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
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
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
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
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
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
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
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
;;;; This file implements the IR1 optimization phase of the compiler.
;;;; IR1 optimization is a grab-bag of optimizations that don't make
;;;; major changes to the block-level control flow and don't use flow
;;;; analysis. These optimizations can mostly be classified as
;;;; "meta-evaluation", but there is a sizable top-down component as
;;;; well.
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
(in-package "SB!C")
;;;; interface for obtaining results of constant folding
;;; Return true for an LVAR whose sole use is a reference to a
;;; constant leaf.
(defun constant-lvar-p (thing)
(declare (type (or lvar null) thing))
(and (lvar-p thing)
(let ((use (principal-lvar-use thing)))
(and (ref-p use) (constant-p (ref-leaf use))))))
;;; Return the constant value for an LVAR whose only use is a constant
;;; node.
(declaim (ftype (function (lvar) t) lvar-value))
(defun lvar-value (lvar)
(let ((use (principal-lvar-use lvar)))
(constant-value (ref-leaf use))))
;;;; interface for obtaining results of type inference
;;; Our best guess for the type of this lvar's value. Note that this
;;; may be VALUES or FUNCTION type, which cannot be passed as an
;;; argument to the normal type operations. See LVAR-TYPE.
;;;
;;; The result value is cached in the LVAR-%DERIVED-TYPE slot. If the
;;; slot is true, just return that value, otherwise recompute and
;;; stash the value there.
#!-sb-fluid (declaim (inline lvar-derived-type))
(defun lvar-derived-type (lvar)
(declare (type lvar lvar))
(or (lvar-%derived-type lvar)
(setf (lvar-%derived-type lvar)
(%lvar-derived-type lvar))))
(defun %lvar-derived-type (lvar)
(declare (type lvar lvar))
(let ((uses (lvar-uses lvar)))
(cond ((null uses) *empty-type*)
((listp uses)
(do ((res (node-derived-type (first uses))
(values-type-union (node-derived-type (first current))
res))
(current (rest uses) (rest current)))
((null current) res)))
(t
(node-derived-type (lvar-uses lvar))))))
;;; Return the derived type for LVAR's first value. This is guaranteed
;;; not to be a VALUES or FUNCTION type.
(declaim (ftype (sfunction (lvar) ctype) lvar-type))
(defun lvar-type (lvar)
(single-value-type (lvar-derived-type lvar)))
;;; If LVAR is an argument of a function, return a type which the
;;; function checks LVAR for.
#!-sb-fluid (declaim (inline lvar-externally-checkable-type))
(defun lvar-externally-checkable-type (lvar)
(or (lvar-%externally-checkable-type lvar)
(%lvar-%externally-checkable-type lvar)))
(defun %lvar-%externally-checkable-type (lvar)
(declare (type lvar lvar))
(let ((dest (lvar-dest lvar)))
(if (not (and dest (combination-p dest)))
;; TODO: MV-COMBINATION
(setf (lvar-%externally-checkable-type lvar) *wild-type*)
(let* ((fun (combination-fun dest))
(args (combination-args dest))
(fun-type (lvar-type fun)))
(setf (lvar-%externally-checkable-type fun) *wild-type*)
(if (or (not (call-full-like-p dest))
(not (fun-type-p fun-type))
;; FUN-TYPE might be (AND FUNCTION (SATISFIES ...)).
(fun-type-wild-args fun-type))
(dolist (arg args)
(when arg
(setf (lvar-%externally-checkable-type arg)
*wild-type*)))
(map-combination-args-and-types
(lambda (arg type)
(setf (lvar-%externally-checkable-type arg)
(acond ((lvar-%externally-checkable-type arg)
(values-type-intersection
it (coerce-to-values type)))
(t (coerce-to-values type)))))
dest)))))
(lvar-%externally-checkable-type lvar))
#!-sb-fluid(declaim (inline flush-lvar-externally-checkable-type))
(defun flush-lvar-externally-checkable-type (lvar)
(declare (type lvar lvar))
(setf (lvar-%externally-checkable-type lvar) nil))
;;;; interface routines used by optimizers
;;; This function is called by optimizers to indicate that something
;;; interesting has happened to the value of LVAR. Optimizers must
;;; make sure that they don't call for reoptimization when nothing has
;;; happened, since optimization will fail to terminate.
;;;
;;; We clear any cached type for the lvar and set the reoptimize flags
;;; on everything in sight.
(defun reoptimize-lvar (lvar)
(declare (type (or lvar null) lvar))
(when lvar
(setf (lvar-%derived-type lvar) nil)
(let ((dest (lvar-dest lvar)))
(when dest
(setf (lvar-reoptimize lvar) t)
(setf (node-reoptimize dest) t)
(binding* (;; Since this may be called during IR1 conversion,
;; PREV may be missing.
(prev (node-prev dest) :exit-if-null)
(block (ctran-block prev))
(component (block-component block)))
(when (typep dest 'cif)
(setf (block-test-modified block) t))
(setf (block-reoptimize block) t)
(setf (component-reoptimize component) t))))
(do-uses (node lvar)
(setf (block-type-check (node-block node)) t)))
(values))
(defun reoptimize-lvar-uses (lvar)
(declare (type lvar lvar))
(do-uses (use lvar)
(setf (node-reoptimize use) t)
(setf (block-reoptimize (node-block use)) t)
(setf (component-reoptimize (node-component use)) t)))
;;; Annotate NODE to indicate that its result has been proven to be
;;; TYPEP to RTYPE. After IR1 conversion has happened, this is the
;;; only correct way to supply information discovered about a node's
;;; type. If you screw with the NODE-DERIVED-TYPE directly, then
;;; information may be lost and reoptimization may not happen.
;;;
;;; What we do is intersect RTYPE with NODE's DERIVED-TYPE. If the
;;; intersection is different from the old type, then we do a
;;; REOPTIMIZE-LVAR on the NODE-LVAR.
(defun derive-node-type (node rtype)
(declare (type valued-node node) (type ctype rtype))
(let ((node-type (node-derived-type node)))
(unless (eq node-type rtype)
(let ((int (values-type-intersection node-type rtype))
(lvar (node-lvar node)))
(when (type/= node-type int)
(when (and *check-consistency*
(eq int *empty-type*)
(not (eq rtype *empty-type*)))
(let ((*compiler-error-context* node))
(compiler-warn
"New inferred type ~S conflicts with old type:~
~% ~S~%*** possible internal error? Please report this."
(type-specifier rtype) (type-specifier node-type))))
(setf (node-derived-type node) int)
;; If the new type consists of only one object, replace the
;; node with a constant reference.
(when (and (ref-p node)
(lambda-var-p (ref-leaf node)))
(let ((type (single-value-type int)))
(when (and (member-type-p type)
(null (rest (member-type-members type))))
(change-ref-leaf node (find-constant
(first (member-type-members type)))))))
(reoptimize-lvar lvar)))))
(values))
;;; This is similar to DERIVE-NODE-TYPE, but asserts that it is an
;;; error for LVAR's value not to be TYPEP to TYPE. We implement it
;;; splitting off DEST a new CAST node; old LVAR will deliver values
;;; to CAST. If we improve the assertion, we set TYPE-CHECK and
;;; TYPE-ASSERTED to guarantee that the new assertion will be checked.
(defun assert-lvar-type (lvar type policy)
(declare (type lvar lvar) (type ctype type))
(unless (values-subtypep (lvar-derived-type lvar) type)
(let* ((dest (lvar-dest lvar))
(ctran (node-prev dest)))
(with-ir1-environment-from-node dest
(let* ((cast (make-cast lvar type policy))
(internal-lvar (make-lvar))
(internal-ctran (make-ctran)))
(setf (ctran-next ctran) cast
(node-prev cast) ctran)
(use-continuation cast internal-ctran internal-lvar)
(link-node-to-previous-ctran dest internal-ctran)
(substitute-lvar internal-lvar lvar)
(setf (lvar-dest lvar) cast)
(reoptimize-lvar lvar)
(when (return-p dest)
(node-ends-block cast))
(setf (block-attributep (block-flags (node-block cast))
type-check type-asserted)
t))))))
;;;; IR1-OPTIMIZE
;;; Do one forward pass over COMPONENT, deleting unreachable blocks
;;; and doing IR1 optimizations. We can ignore all blocks that don't
;;; have the REOPTIMIZE flag set. If COMPONENT-REOPTIMIZE is true when
;;; we are done, then another iteration would be beneficial.
(defun ir1-optimize (component)
(declare (type component component))
(setf (component-reoptimize component) nil)
(loop with block = (block-next (component-head component))
with tail = (component-tail component)
for last-block = block
until (eq block tail)
do (cond
;; We delete blocks when there is either no predecessor or the
;; block is in a lambda that has been deleted. These blocks
;; would eventually be deleted by DFO recomputation, but doing
;; it here immediately makes the effect available to IR1
;; optimization.
((or (block-delete-p block)
(null (block-pred block)))
(delete-block-lazily block)
(setq block (clean-component component block)))
((eq (functional-kind (block-home-lambda block)) :deleted)
;; Preserve the BLOCK-SUCC invariant that almost every block has
;; one successor (and a block with DELETE-P set is an acceptable
;; exception).
(mark-for-deletion block)
(setq block (clean-component component block)))
(t
(loop
(let ((succ (block-succ block)))
(unless (singleton-p succ)
(return)))
(let ((last (block-last block)))
(typecase last
(cif
(flush-dest (if-test last))
(when (unlink-node last)
(return)))
(exit
(when (maybe-delete-exit last)
(return)))))
(unless (join-successor-if-possible block)
(return)))
(when (and (block-reoptimize block) (block-component block))
(aver (not (block-delete-p block)))
(ir1-optimize-block block))
(cond ((and (block-delete-p block) (block-component block))
(setq block (clean-component component block)))
((and (block-flush-p block) (block-component block))
(flush-dead-code block)))))
do (when (eq block last-block)
(setq block (block-next block))))
(values))
;;; Loop over the nodes in BLOCK, acting on (and clearing) REOPTIMIZE
;;; flags.
;;;
;;; Note that although they are cleared here, REOPTIMIZE flags might
;;; still be set upon return from this function, meaning that further
;;; optimization is wanted (as a consequence of optimizations we did).
(defun ir1-optimize-block (block)
(declare (type cblock block))
;; We clear the node and block REOPTIMIZE flags before doing the
;; optimization, not after. This ensures that the node or block will
;; be reoptimized if necessary.
(setf (block-reoptimize block) nil)
(do-nodes (node nil block :restart-p t)
(when (node-reoptimize node)
;; As above, we clear the node REOPTIMIZE flag before optimizing.
(setf (node-reoptimize node) nil)
(typecase node
(ref)
(combination
;; With a COMBINATION, we call PROPAGATE-FUN-CHANGE whenever
;; the function changes, and call IR1-OPTIMIZE-COMBINATION if
;; any argument changes.
(ir1-optimize-combination node))
(cif
(ir1-optimize-if node))
(creturn
;; KLUDGE: We leave the NODE-OPTIMIZE flag set going into
;; IR1-OPTIMIZE-RETURN, since IR1-OPTIMIZE-RETURN wants to
;; clear the flag itself. -- WHN 2002-02-02, quoting original
;; CMU CL comments
(setf (node-reoptimize node) t)
(ir1-optimize-return node))
(mv-combination
(ir1-optimize-mv-combination node))
(exit
;; With an EXIT, we derive the node's type from the VALUE's
;; type.
(let ((value (exit-value node)))
(when value
(derive-node-type node (lvar-derived-type value)))))
(cset
(ir1-optimize-set node))
(cast
(ir1-optimize-cast node)))))
(values))
;;; Try to join with a successor block. If we succeed, we return true,
;;; otherwise false.
(defun join-successor-if-possible (block)
(declare (type cblock block))
(let ((next (first (block-succ block))))
(when (block-start next) ; NEXT is not an END-OF-COMPONENT marker
(cond ( ;; We cannot combine with a successor block if:
(or
;; the successor has more than one predecessor;
(rest (block-pred next))
;; the successor is the current block (infinite loop);
(eq next block)
;; the next block has a different cleanup, and thus
;; we may want to insert cleanup code between the
;; two blocks at some point;
(not (eq (block-end-cleanup block)
(block-start-cleanup next)))
;; the next block has a different home lambda, and
;; thus the control transfer is a non-local exit.
(not (eq (block-home-lambda block)
(block-home-lambda next)))
;; Stack analysis phase wants ENTRY to start a block.
(entry-p (block-start-node next)))
nil)
(t
(join-blocks block next)
t)))))
;;; Join together two blocks. The code in BLOCK2 is moved into BLOCK1
;;; and BLOCK2 is deleted from the DFO. We combine the optimize flags
;;; for the two blocks so that any indicated optimization gets done.
(defun join-blocks (block1 block2)
(declare (type cblock block1 block2))
(let* ((last1 (block-last block1))
(last2 (block-last block2))
(succ (block-succ block2))
(start2 (block-start block2)))
(do ((ctran start2 (node-next (ctran-next ctran))))
((not ctran))
(setf (ctran-block ctran) block1))
(unlink-blocks block1 block2)
(dolist (block succ)
(unlink-blocks block2 block)
(link-blocks block1 block))
(setf (ctran-kind start2) :inside-block)
(setf (node-next last1) start2)
(setf (ctran-use start2) last1)
(setf (block-last block1) last2))
(setf (block-flags block1)
(attributes-union (block-flags block1)
(block-flags block2)
(block-attributes type-asserted test-modified)))
(let ((next (block-next block2))
(prev (block-prev block2)))
(setf (block-next prev) next)
(setf (block-prev next) prev))
(values))
;;; Delete any nodes in BLOCK whose value is unused and which have no
;;; side effects. We can delete sets of lexical variables when the set
;;; variable has no references.
(defun flush-dead-code (block)
(declare (type cblock block))
(setf (block-flush-p block) nil)
(do-nodes-backwards (node lvar block :restart-p t)
(unless lvar
(typecase node
(ref
(delete-ref node)
(unlink-node node))
(combination
(let ((kind (combination-kind node))
(info (combination-fun-info node)))
(when (and (eq kind :known) (fun-info-p info))
(let ((attr (fun-info-attributes info)))
(when (and (not (ir1-attributep attr call))
;; ### For now, don't delete potentially
;; flushable calls when they have the CALL
;; attribute. Someday we should look at the
;; functional args to determine if they have
;; any side effects.
(if (policy node (= safety 3))
(ir1-attributep attr flushable)
(ir1-attributep attr unsafely-flushable)))
(flush-combination 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)
(delq node (basic-var-sets var)))
(unlink-node node))))
(cast
(unless (cast-type-check node)
(flush-dest (cast-value node))
(unlink-node node))))))
(values))
;;;; local call return type propagation
;;; This function is called on RETURN nodes that have their REOPTIMIZE
;;; flag set. It iterates over the uses of the RESULT, looking for
;;; interesting stuff to update the TAIL-SET. If a use isn't a local
;;; call, then we union its type together with the types of other such
;;; uses. We assign to the RETURN-RESULT-TYPE the intersection of this
;;; type with the RESULT's asserted type. We can make this
;;; intersection now (potentially before type checking) because this
;;; assertion on the result will eventually be checked (if
;;; appropriate.)
;;;
;;; We call MAYBE-CONVERT-TAIL-LOCAL-CALL on each local non-MV
;;; combination, which may change the succesor of the call to be the
;;; called function, and if so, checks if the call can become an
;;; assignment. If we convert to an assignment, we abort, since the
;;; RETURN has been deleted.
(defun find-result-type (node)
(declare (type creturn node))
(let ((result (return-result node)))
(collect ((use-union *empty-type* values-type-union))
(do-uses (use result)
(let ((use-home (node-home-lambda use)))
(cond ((or (eq (functional-kind use-home) :deleted)
(block-delete-p (node-block use))))
((and (basic-combination-p use)
(eq (basic-combination-kind use) :local))
(aver (eq (lambda-tail-set use-home)
(lambda-tail-set (combination-lambda use))))
(when (combination-p use)
(when (nth-value 1 (maybe-convert-tail-local-call use))
(return-from find-result-type t))))
(t
(use-union (node-derived-type use))))))
(let ((int
;; (values-type-intersection
;; (continuation-asserted-type result) ; FIXME -- APD, 2002-01-26
(use-union)
;; )
))
(setf (return-result-type node) int))))
nil)
;;; Do stuff to realize that something has changed about the value
;;; delivered to a return node. Since we consider the return values of
;;; all functions in the tail set to be equivalent, this amounts to
;;; bringing the entire tail set up to date. We iterate over the
;;; returns for all the functions in the tail set, reanalyzing them
;;; all (not treating NODE specially.)
;;;
;;; When we are done, we check whether the new type is different from
;;; the old TAIL-SET-TYPE. If so, we set the type and also reoptimize
;;; all the lvars for references to functions in the tail set. This
;;; will cause IR1-OPTIMIZE-COMBINATION to derive the new type as the
;;; results of the calls.
(defun ir1-optimize-return (node)
(declare (type creturn node))
(tagbody
:restart
(let* ((tails (lambda-tail-set (return-lambda node)))
(funs (tail-set-funs tails)))
(collect ((res *empty-type* values-type-union))
(dolist (fun funs)
(let ((return (lambda-return fun)))
(when return
(when (node-reoptimize return)
(setf (node-reoptimize return) nil)
(when (find-result-type return)
(go :restart)))
(res (return-result-type return)))))
(when (type/= (res) (tail-set-type tails))
(setf (tail-set-type tails) (res))
(dolist (fun (tail-set-funs tails))
(dolist (ref (leaf-refs fun))
(reoptimize-lvar (node-lvar ref))))))))
(values))
;;;; IF optimization
;;; If the test has multiple uses, replicate the node when possible.
;;; Also check whether the predicate is known to be true or false,
;;; deleting the IF node in favor of the appropriate branch when this
;;; is the case.
(defun ir1-optimize-if (node)
(declare (type cif node))
(let ((test (if-test node))
(block (node-block node)))
(when (and (eq (block-start-node block) node)
(listp (lvar-uses test)))
(do-uses (use test)
(when (immediately-used-p test use)
(convert-if-if use node)
(when (not (listp (lvar-uses test))) (return)))))
(let* ((type (lvar-type test))
(victim
(cond ((constant-lvar-p test)
(if (lvar-value test)
(if-alternative node)
(if-consequent node)))
((not (types-equal-or-intersect type (specifier-type 'null)))
(if-alternative node))
((type= type (specifier-type 'null))
(if-consequent node)))))
(when victim
(flush-dest test)
(when (rest (block-succ block))
(unlink-blocks block victim))
(setf (component-reanalyze (node-component node)) t)
(unlink-node node))))
(values))
;;; Create a new copy of an IF node that tests the value of the node
;;; USE. The test must have >1 use, and must be immediately used by
;;; USE. NODE must be the only node in its block (implying that
;;; block-start = if-test).
;;;
;;; This optimization has an effect semantically similar to the
;;; source-to-source transformation:
;;; (IF (IF A B C) D E) ==>
;;; (IF A (IF B D E) (IF C D E))
;;;
;;; We clobber the NODE-SOURCE-PATH of both the original and the new
;;; node so that dead code deletion notes will definitely not consider
;;; either node to be part of the original source. One node might
;;; become unreachable, resulting in a spurious note.
(defun convert-if-if (use node)
(declare (type node use) (type cif node))
(with-ir1-environment-from-node node
(let* ((block (node-block node))
(test (if-test node))
(cblock (if-consequent node))
(ablock (if-alternative node))
(use-block (node-block use))
(new-ctran (make-ctran))
(new-lvar (make-lvar))
(new-node (make-if :test new-lvar
:consequent cblock
:alternative ablock))
(new-block (ctran-starts-block new-ctran)))
(link-node-to-previous-ctran new-node new-ctran)
(setf (lvar-dest new-lvar) new-node)
(setf (block-last new-block) new-node)
(unlink-blocks use-block block)
(%delete-lvar-use use)
(add-lvar-use use new-lvar)
(link-blocks use-block new-block)
(link-blocks new-block cblock)
(link-blocks new-block ablock)
(push "<IF Duplication>" (node-source-path node))
(push "<IF Duplication>" (node-source-path new-node))
(reoptimize-lvar test)
(reoptimize-lvar new-lvar)
(setf (component-reanalyze *current-component*) t)))
(values))
;;;; exit IR1 optimization
;;; This function attempts to delete an exit node, returning true if
;;; it deletes the block as a consequence:
;;; -- If the exit is degenerate (has no ENTRY), then we don't do
;;; anything, since there is nothing to be done.
;;; -- If the exit node and its ENTRY have the same home lambda then
;;; we know the exit is local, and can delete the exit. We change
;;; uses of the Exit-Value to be uses of the original lvar,
;;; then unlink the node. If the exit is to a TR context, then we
;;; must do MERGE-TAIL-SETS on any local calls which delivered
;;; their value to this exit.
;;; -- If there is no value (as in a GO), then we skip the value
;;; semantics.
;;;
;;; This function is also called by environment analysis, since it
;;; wants all exits to be optimized even if normal optimization was
;;; omitted.
(defun maybe-delete-exit (node)
(declare (type exit node))
(let ((value (exit-value node))
(entry (exit-entry node)))
(when (and entry
(eq (node-home-lambda node) (node-home-lambda entry)))
(setf (entry-exits entry) (delq node (entry-exits entry)))
(if value
(delete-filter node (node-lvar node) value)
(unlink-node node)))))
;;;; combination IR1 optimization
;;; Report as we try each transform?
#!+sb-show
(defvar *show-transforms-p* nil)
;;; Do IR1 optimizations on a COMBINATION node.
(declaim (ftype (function (combination) (values)) ir1-optimize-combination))
(defun ir1-optimize-combination (node)
(when (lvar-reoptimize (basic-combination-fun node))
(propagate-fun-change node)
(maybe-terminate-block node nil))
(let ((args (basic-combination-args node))
(kind (basic-combination-kind node))
(info (basic-combination-fun-info node)))
(ecase kind
(:local
(let ((fun (combination-lambda node)))
(if (eq (functional-kind fun) :let)
(propagate-let-args node fun)
(propagate-local-call-args node fun))))
(:error
(dolist (arg args)
(when arg
(setf (lvar-reoptimize arg) nil))))
(:full
(dolist (arg args)
(when arg
(setf (lvar-reoptimize arg) nil)))
(when info
(let ((fun (fun-info-derive-type info)))
(when fun
(let ((res (funcall fun node)))
(when res
(derive-node-type node (coerce-to-values res))
(maybe-terminate-block node nil)))))))
(:known
(aver info)
(dolist (arg args)
(when arg
(setf (lvar-reoptimize arg) nil)))
(let ((attr (fun-info-attributes info)))
(when (and (ir1-attributep attr foldable)
;; KLUDGE: The next test could be made more sensitive,
;; only suppressing constant-folding of functions with
;; CALL attributes when they're actually passed
;; function arguments. -- WHN 19990918
(not (ir1-attributep attr call))
(every #'constant-lvar-p args)
(node-lvar node)
;; Even if the function is foldable in principle,
;; it might be one of our low-level
;; implementation-specific functions. Such
;; functions don't necessarily exist at runtime on
;; a plain vanilla ANSI Common Lisp
;; cross-compilation host, in which case the
;; cross-compiler can't fold it because the
;; cross-compiler doesn't know how to evaluate it.
#+sb-xc-host
(or (fboundp (combination-fun-source-name node))
(progn (format t ";;; !!! Unbound fun: (~S~{ ~S~})~%"
(combination-fun-source-name node)
(mapcar #'lvar-value args))
nil)))
(constant-fold-call node)
(return-from ir1-optimize-combination)))
(let ((fun (fun-info-derive-type info)))
(when fun
(let ((res (funcall fun node)))
(when res
(derive-node-type node (coerce-to-values res))
(maybe-terminate-block node nil)))))
(let ((fun (fun-info-optimizer info)))
(unless (and fun (funcall fun node))
(dolist (x (fun-info-transforms info))
#!+sb-show
(when *show-transforms-p*
(let* ((lvar (basic-combination-fun node))
(fname (lvar-fun-name lvar t)))
(/show "trying transform" x (transform-function x) "for" fname)))
(unless (ir1-transform node x)
#!+sb-show
(when *show-transforms-p*
(/show "quitting because IR1-TRANSFORM result was NIL"))
(return))))))))
(values))
;;; If NODE doesn't return (i.e. return type is NIL), then terminate
;;; the block there, and link it to the component tail.
;;;
;;; Except when called during IR1 convertion, we delete the
;;; continuation if it has no other uses. (If it does have other uses,
;;; we reoptimize.)
;;;
;;; Termination on the basis of a continuation type is
;;; inhibited when:
;;; -- The continuation is deleted (hence the assertion is spurious), or
;;; -- We are in IR1 conversion (where THE assertions are subject to
;;; weakening.) FIXME: Now THE assertions are not weakened, but new
;;; uses can(?) be added later. -- APD, 2003-07-17
;;;
;;; Why do we need to consider LVAR type? -- APD, 2003-07-30
(defun maybe-terminate-block (node ir1-converting-not-optimizing-p)
(declare (type (or basic-combination cast) node))
(let* ((block (node-block node))
(lvar (node-lvar node))
(ctran (node-next node))
(tail (component-tail (block-component block)))
(succ (first (block-succ block))))
(unless (or (and (eq node (block-last block)) (eq succ tail))
(block-delete-p block))
(when (eq (node-derived-type node) *empty-type*)
(cond (ir1-converting-not-optimizing-p
(cond
((block-last block)
(aver (eq (block-last block) node)))
(t
(setf (block-last block) node)
(setf (ctran-use ctran) nil)
(setf (ctran-kind ctran) :unused)
(setf (ctran-block ctran) nil)
(setf (node-next node) nil)
(link-blocks block (ctran-starts-block ctran)))))
(t
(node-ends-block node)))
(unlink-blocks block (first (block-succ block)))
(setf (component-reanalyze (block-component block)) t)
(aver (not (block-succ block)))
(link-blocks block tail)
(if ir1-converting-not-optimizing-p
(%delete-lvar-use node)
(delete-lvar-use node))
t))))
;;; This is called both by IR1 conversion and IR1 optimization when
;;; they have verified the type signature for the call, and are
;;; wondering if something should be done to special-case the call. If
;;; CALL is a call to a global function, then see whether it defined
;;; or known:
;;; -- If a DEFINED-FUN should be inline expanded, then convert
;;; the expansion and change the call to call it. Expansion is
;;; enabled if :INLINE or if SPACE=0. If the FUNCTIONAL slot is
;;; true, we never expand, since this function has already been
;;; converted. Local call analysis will duplicate the definition
;;; if necessary. We claim that the parent form is LABELS for
;;; context declarations, since we don't want it to be considered
;;; a real global function.
;;; -- If it is a known function, mark it as such by setting the KIND.
;;;
;;; We return the leaf referenced (NIL if not a leaf) and the
;;; FUN-INFO assigned.
(defun recognize-known-call (call ir1-converting-not-optimizing-p)
(declare (type combination call))
(let* ((ref (lvar-uses (basic-combination-fun call)))
(leaf (when (ref-p ref) (ref-leaf ref)))
(inlinep (if (defined-fun-p leaf)
(defined-fun-inlinep leaf)
:no-chance)))
(cond
((eq inlinep :notinline)
(let ((info (info :function :info (leaf-source-name leaf))))
(when info
(setf (basic-combination-fun-info call) info))
(values nil nil)))
((not (and (global-var-p leaf)
(eq (global-var-kind leaf) :global-function)))
(values leaf nil))
((and (ecase inlinep
(:inline t)
(:no-chance nil)
((nil :maybe-inline) (policy call (zerop space))))
(defined-fun-p leaf)
(defined-fun-inline-expansion leaf)
(let ((fun (defined-fun-functional leaf)))
(or (not fun)
(and (eq inlinep :inline) (functional-kind fun))))
(inline-expansion-ok call))
(flet (;; FIXME: Is this what the old CMU CL internal documentation
;; called semi-inlining? A more descriptive name would
;; be nice. -- WHN 2002-01-07
(frob ()
(let ((res (ir1-convert-lambda-for-defun
(defined-fun-inline-expansion leaf)
leaf t
#'ir1-convert-inline-lambda)))
(setf (defined-fun-functional leaf) res)
(change-ref-leaf ref res))))
(if ir1-converting-not-optimizing-p
(frob)
(with-ir1-environment-from-node call
(frob)
(locall-analyze-component *current-component*))))
(values (ref-leaf (lvar-uses (basic-combination-fun call)))
nil))
(t
(let ((info (info :function :info (leaf-source-name leaf))))
(if info
(values leaf
(progn
(setf (basic-combination-kind call) :known)
(setf (basic-combination-fun-info call) info)))
(values leaf nil)))))))
;;; Check whether CALL satisfies TYPE. If so, apply the type to the
;;; call, and do MAYBE-TERMINATE-BLOCK and return the values of
;;; RECOGNIZE-KNOWN-CALL. If an error, set the combination kind and
;;; return NIL, NIL. If the type is just FUNCTION, then skip the
;;; syntax check, arg/result type processing, but still call
;;; RECOGNIZE-KNOWN-CALL, since the call might be to a known lambda,
;;; and that checking is done by local call analysis.
(defun validate-call-type (call type ir1-converting-not-optimizing-p)
(declare (type combination call) (type ctype type))
(cond ((not (fun-type-p type))
(aver (multiple-value-bind (val win)
(csubtypep type (specifier-type 'function))
(or val (not win))))
(recognize-known-call call ir1-converting-not-optimizing-p))
((valid-fun-use call type
:argument-test #'always-subtypep
:result-test nil
;; KLUDGE: Common Lisp is such a dynamic
;; language that all we can do here in
;; general is issue a STYLE-WARNING. It
;; would be nice to issue a full WARNING
;; in the special case of of type
;; mismatches within a compilation unit
;; (as in section 3.2.2.3 of the spec)
;; but at least as of sbcl-0.6.11, we
;; don't keep track of whether the
;; mismatched data came from the same
;; compilation unit, so we can't do that.
;; -- WHN 2001-02-11
;;
;; FIXME: Actually, I think we could
;; issue a full WARNING if the call
;; violates a DECLAIM FTYPE.
:lossage-fun #'compiler-style-warn
:unwinnage-fun #'compiler-notify)
(assert-call-type call type)
(maybe-terminate-block call ir1-converting-not-optimizing-p)
(recognize-known-call call ir1-converting-not-optimizing-p))
(t
(setf (combination-kind call) :error)
(values nil nil))))
;;; This is called by IR1-OPTIMIZE when the function for a call has
;;; changed. If the call is local, we try to LET-convert it, and
;;; derive the result type. If it is a :FULL call, we validate it
;;; against the type, which recognizes known calls, does inline
;;; expansion, etc. If a call to a predicate in a non-conditional
;;; position or to a function with a source transform, then we
;;; reconvert the form to give IR1 another chance.
(defun propagate-fun-change (call)
(declare (type combination call))
(let ((*compiler-error-context* call)
(fun-lvar (basic-combination-fun call)))
(setf (lvar-reoptimize fun-lvar) nil)
(case (combination-kind call)
(:local
(let ((fun (combination-lambda call)))
(maybe-let-convert fun)
(unless (member (functional-kind fun) '(:let :assignment :deleted))
(derive-node-type call (tail-set-type (lambda-tail-set fun))))))
(:full
(multiple-value-bind (leaf info)
(validate-call-type call (lvar-type fun-lvar) nil)
(cond ((functional-p leaf)
(convert-call-if-possible
(lvar-uses (basic-combination-fun call))
call))
((not leaf))
((and (leaf-has-source-name-p leaf)
(or (info :function :source-transform (leaf-source-name leaf))
(and info
(ir1-attributep (fun-info-attributes info)
predicate)
(let ((lvar (node-lvar call)))
(and lvar (not (if-p (lvar-dest lvar))))))))
(let ((name (leaf-source-name leaf))
(dummies (make-gensym-list
(length (combination-args call)))))
(transform-call call
`(lambda ,dummies
(,@(if (symbolp name)
`(,name)
`(funcall #',name))
,@dummies))
(leaf-source-name leaf)))))))))
(values))
;;;; known function optimization
;;; Add a failed optimization note to FAILED-OPTIMZATIONS for NODE,
;;; FUN and ARGS. If there is already a note for NODE and TRANSFORM,
;;; replace it, otherwise add a new one.
(defun record-optimization-failure (node transform args)
(declare (type combination node) (type transform transform)
(type (or fun-type list) args))
(let* ((table (component-failed-optimizations *component-being-compiled*))
(found (assoc transform (gethash node table))))
(if found
(setf (cdr found) args)
(push (cons transform args) (gethash node table))))
(values))
;;; Attempt to transform NODE using TRANSFORM-FUNCTION, subject to the
;;; call type constraint TRANSFORM-TYPE. If we are inhibited from
;;; doing the transform for some reason and FLAME is true, then we
;;; make a note of the message in FAILED-OPTIMIZATIONS for IR1
;;; finalize to pick up. We return true if the transform failed, and
;;; thus further transformation should be attempted. We return false
;;; if either the transform succeeded or was aborted.
(defun ir1-transform (node transform)
(declare (type combination node) (type transform transform))
(let* ((type (transform-type transform))
(fun (transform-function transform))
(constrained (fun-type-p type))
(table (component-failed-optimizations *component-being-compiled*))
(flame (if (transform-important transform)
(policy node (>= speed inhibit-warnings))
(policy node (> speed inhibit-warnings))))
(*compiler-error-context* node))
(cond ((or (not constrained)
(valid-fun-use node type))
(multiple-value-bind (severity args)
(catch 'give-up-ir1-transform
(transform-call node
(funcall fun node)
(combination-fun-source-name node))
(values :none nil))
(ecase severity
(:none
(remhash node table)
nil)
(:aborted
(setf (combination-kind node) :error)
(when args
(apply #'compiler-warn args))
(remhash node table)
nil)
(:failure
(if args
(when flame
(record-optimization-failure node transform args))
(setf (gethash node table)
(remove transform (gethash node table) :key #'car)))
t)
(:delayed
(remhash node table)
nil))))
((and flame
(valid-fun-use node
type
:argument-test #'types-equal-or-intersect
:result-test #'values-types-equal-or-intersect))
(record-optimization-failure node transform type)
t)
(t
t))))
;;; When we don't like an IR1 transform, we throw the severity/reason
;;; and args.
;;;
;;; GIVE-UP-IR1-TRANSFORM is used to throw out of an IR1 transform,
;;; aborting this attempt to transform the call, but admitting the
;;; possibility that this or some other transform will later succeed.
;;; If arguments are supplied, they are format arguments for an
;;; efficiency note.
;;;
;;; ABORT-IR1-TRANSFORM is used to throw out of an IR1 transform and
;;; force a normal call to the function at run time. No further
;;; optimizations will be attempted.
;;;
;;; DELAY-IR1-TRANSFORM is used to throw out of an IR1 transform, and
;;; delay the transform on the node until later. REASONS specifies
;;; when the transform will be later retried. The :OPTIMIZE reason
;;; causes the transform to be delayed until after the current IR1
;;; optimization pass. The :CONSTRAINT reason causes the transform to
;;; be delayed until after constraint propagation.
;;;
;;; FIXME: Now (0.6.11.44) that there are 4 variants of this (GIVE-UP,
;;; ABORT, DELAY/:OPTIMIZE, DELAY/:CONSTRAINT) and we're starting to
;;; do CASE operations on the various REASON values, it might be a
;;; good idea to go OO, representing the reasons by objects, using
;;; CLOS methods on the objects instead of CASE, and (possibly) using
;;; SIGNAL instead of THROW.
(declaim (ftype (function (&rest t) nil) give-up-ir1-transform))
(defun give-up-ir1-transform (&rest args)
(throw 'give-up-ir1-transform (values :failure args)))
(defun abort-ir1-transform (&rest args)
(throw 'give-up-ir1-transform (values :aborted args)))
(defun delay-ir1-transform (node &rest reasons)
(let ((assoc (assoc node *delayed-ir1-transforms*)))
(cond ((not assoc)
(setf *delayed-ir1-transforms*
(acons node reasons *delayed-ir1-transforms*))
(throw 'give-up-ir1-transform :delayed))
((cdr assoc)
(dolist (reason reasons)
(pushnew reason (cdr assoc)))
(throw 'give-up-ir1-transform :delayed)))))
;;; Clear any delayed transform with no reasons - these should have
;;; been tried in the last pass. Then remove the reason from the
;;; delayed transform reasons, and if any become empty then set
;;; reoptimize flags for the node. Return true if any transforms are
;;; to be retried.
(defun retry-delayed-ir1-transforms (reason)
(setf *delayed-ir1-transforms*
(remove-if-not #'cdr *delayed-ir1-transforms*))
(let ((reoptimize nil))
(dolist (assoc *delayed-ir1-transforms*)
(let ((reasons (remove reason (cdr assoc))))
(setf (cdr assoc) reasons)
(unless reasons
(let ((node (car assoc)))
(unless (node-deleted node)
(setf reoptimize t)
(setf (node-reoptimize node) t)
(let ((block (node-block node)))
(setf (block-reoptimize block) t)
(setf (component-reoptimize (block-component block)) t)))))))
reoptimize))
;;; Take the lambda-expression RES, IR1 convert it in the proper
;;; environment, and then install it as the function for the call
;;; NODE. We do local call analysis so that the new function is
;;; integrated into the control flow.
;;;
;;; We require the original function source name in order to generate
;;; a meaningful debug name for the lambda we set up. (It'd be
;;; possible to do this starting from debug names as well as source
;;; names, but as of sbcl-0.7.1.5, there was no need for this
;;; generality, since source names are always known to our callers.)
(defun transform-call (call res source-name)
(declare (type combination call) (list res))
(aver (and (legal-fun-name-p source-name)
(not (eql source-name '.anonymous.))))
(node-ends-block call)
(with-ir1-environment-from-node call
(with-component-last-block (*current-component*
(block-next (node-block call)))
(let ((new-fun (ir1-convert-inline-lambda
res
:debug-name (debug-namify "LAMBDA-inlined ~A"
(as-debug-name
source-name
"<unknown function>"))))
(ref (lvar-use (combination-fun call))))
(change-ref-leaf ref new-fun)
(setf (combination-kind call) :full)
(locall-analyze-component *current-component*))))
(values))
;;; Replace a call to a foldable function of constant arguments with
;;; the result of evaluating the form. If there is an error during the
;;; evaluation, we give a warning and leave the call alone, making the
;;; call a :ERROR call.
;;;
;;; If there is more than one value, then we transform the call into a
;;; VALUES form.
(defun constant-fold-call (call)
(let ((args (mapcar #'lvar-value (combination-args call)))
(fun-name (combination-fun-source-name call)))
(multiple-value-bind (values win)
(careful-call fun-name
args
call
;; Note: CMU CL had COMPILER-WARN here, and that
;; seems more natural, but it's probably not.
;;
;; It's especially not while bug 173 exists:
;; Expressions like
;; (COND (END
;; (UNLESS (OR UNSAFE? (<= END SIZE)))
;; ...))
;; can cause constant-folding TYPE-ERRORs (in
;; #'<=) when END can be proved to be NIL, even
;; though the code is perfectly legal and safe
;; because a NIL value of END means that the
;; #'<= will never be executed.
;;
;; Moreover, even without bug 173,
;; quite-possibly-valid code like
;; (COND ((NONINLINED-PREDICATE END)
;; (UNLESS (<= END SIZE))
;; ...))
;; (where NONINLINED-PREDICATE is something the
;; compiler can't do at compile time, but which
;; turns out to make the #'<= expression
;; unreachable when END=NIL) could cause errors
;; when the compiler tries to constant-fold (<=
;; END SIZE).
;;
;; So, with or without bug 173, it'd be
;; unnecessarily evil to do a full
;; COMPILER-WARNING (and thus return FAILURE-P=T
;; from COMPILE-FILE) for legal code, so we we
;; use a wimpier COMPILE-STYLE-WARNING instead.
#'compiler-style-warn
"constant folding")
(cond ((not win)
(setf (combination-kind call) :error))
((and (proper-list-of-length-p values 1))
(with-ir1-environment-from-node call
(let* ((lvar (node-lvar call))
(prev (node-prev call))
(intermediate-ctran (make-ctran)))
(%delete-lvar-use call)
(setf (ctran-next prev) nil)
(setf (node-prev call) nil)
(reference-constant prev intermediate-ctran lvar
(first values))
(link-node-to-previous-ctran call intermediate-ctran)
(reoptimize-lvar lvar)
(flush-combination call))))
(t (let ((dummies (make-gensym-list (length args))))
(transform-call
call
`(lambda ,dummies
(declare (ignore ,@dummies))
(values ,@(mapcar (lambda (x) `',x) values)))
fun-name))))))
(values))
;;;; local call optimization
;;; 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 (fun-type-p var-type)
(let ((int (type-approx-intersection2 var-type type)))
(when (type/= int var-type)
(setf (leaf-type leaf) int)
(dolist (ref (leaf-refs leaf))
(derive-node-type ref (make-single-value-type int))
;; KLUDGE: LET var substitution
(let* ((lvar (node-lvar ref)))
(when (and lvar (combination-p (lvar-dest lvar)))
(reoptimize-lvar lvar))))))
(values))))
;;; Iteration variable: exactly one SETQ of the form:
;;;
;;; (let ((var initial))
;;; ...
;;; (setq var (+ var step))
;;; ...)
(defun maybe-infer-iteration-var-type (var initial-type)
(binding* ((sets (lambda-var-sets var) :exit-if-null)
(set (first sets))
(() (null (rest sets)) :exit-if-null)
(set-use (principal-lvar-use (set-value set)))
(() (and (combination-p set-use)
(eq (combination-kind set-use) :known)
(fun-info-p (combination-fun-info set-use))
(not (node-to-be-deleted-p set-use))
(eq (combination-fun-source-name set-use) '+))
:exit-if-null)
(+-args (basic-combination-args set-use))
(() (and (proper-list-of-length-p +-args 2 2)
(let ((first (principal-lvar-use
(first +-args))))
(and (ref-p first)
(eq (ref-leaf first) var))))
:exit-if-null)
(step-type (lvar-type (second +-args)))
(set-type (lvar-type (set-value set))))
(when (and (numeric-type-p initial-type)
(numeric-type-p step-type)
(numeric-type-equal initial-type step-type))
(multiple-value-bind (low high)
(cond ((csubtypep step-type (specifier-type '(real 0 *)))
(values (numeric-type-low initial-type)
(when (and (numeric-type-p set-type)
(numeric-type-equal set-type initial-type))
(numeric-type-high set-type))))
((csubtypep step-type (specifier-type '(real * 0)))
(values (when (and (numeric-type-p set-type)
(numeric-type-equal set-type initial-type))
(numeric-type-low set-type))
(numeric-type-high initial-type)))
(t
(values nil nil)))
(modified-numeric-type initial-type
:low low
:high high
:enumerable nil)))))
(deftransform + ((x y) * * :result result)
"check for iteration variable reoptimization"
(let ((dest (principal-lvar-end result))
(use (principal-lvar-use x)))
(when (and (ref-p use)
(set-p dest)
(eq (ref-leaf use)
(set-var dest)))
(reoptimize-lvar (set-value dest))))
(give-up-ir1-transform))
;;; Figure out the type of a LET variable that has sets. We compute
;;; the union of the INITIAL-TYPE and the types of all the set
;;; values and to a PROPAGATE-TO-REFS with this type.
(defun propagate-from-sets (var initial-type)
(collect ((res initial-type type-union))
(dolist (set (basic-var-sets var))
(let ((type (lvar-type (set-value set))))
(res type)
(when (node-reoptimize set)
(derive-node-type set (make-single-value-type type))
(setf (node-reoptimize set) nil))))
(let ((res (res)))
(awhen (maybe-infer-iteration-var-type var initial-type)
(setq res it))
(propagate-to-refs var res)))
(values))
;;; 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* ((initial-value (let-var-initial-value var))
(initial-type (lvar-type initial-value)))
(setf (lvar-reoptimize initial-value) nil)
(propagate-from-sets var initial-type))))))
(derive-node-type node (make-single-value-type
(lvar-type (set-value node))))
(values))
;;; 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
((or constant functional) t)
(lambda-var
(null (lambda-var-sets leaf)))
(defined-fun
(not (eq (defined-fun-inlinep leaf) :notinline)))
(global-var
(case (global-var-kind leaf)
(:global-function
(let ((name (leaf-source-name leaf)))
(or #-sb-xc-host
(eq (symbol-package (fun-name-block-name name))
*cl-package*)
(info :function :info name)))))))))
;;; If we have a non-set LET var with a single use, then (if possible)
;;; replace the variable reference's LVAR with the arg lvar.
;;;
;;; 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-lvar (arg var)
(declare (type lvar arg) (type lambda-var var))
(binding* ((ref (first (leaf-refs var)))
(lvar (node-lvar ref) :exit-if-null)
(dest (lvar-dest lvar)))
(when (and
;; Think about (LET ((A ...)) (IF ... A ...)): two
;; LVAR-USEs should not be met on one path.
(eq (lvar-uses lvar) ref)
(typecase dest
;; we should not change lifetime of unknown values lvars
(cast
(and (type-single-value-p (lvar-derived-type arg))
(multiple-value-bind (pdest pprev)
(principal-lvar-end lvar)
(declare (ignore pdest))
(lvar-single-value-p pprev))))
(mv-combination
(or (eq (basic-combination-fun dest) lvar)
(and (eq (basic-combination-kind dest) :local)
(type-single-value-p (lvar-derived-type arg)))))
((or creturn exit)
;; While CRETURN and EXIT nodes may be known-values,
;; they have their own complications, such as
;; substitution into CRETURN may create new tail calls.
nil)
(t
(aver (lvar-single-value-p lvar))
t))
(eq (node-home-lambda ref)
(lambda-home (lambda-var-home var))))
(setf (node-derived-type ref) *wild-type*)
(substitute-lvar-uses lvar arg)
(delete-lvar-use ref)
(change-ref-leaf ref (find-constant nil))
(delete-ref ref)
(unlink-node ref)
(reoptimize-lvar lvar)
t)))
;;; 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 lvar.
(defun delete-let (clambda)
(declare (type clambda clambda))
(aver (functional-letlike-p clambda))
(note-unreferenced-vars clambda)
(let ((call (let-combination clambda)))
(flush-dest (basic-combination-fun call))
(unlink-node call)
(unlink-node (lambda-bind clambda))
(setf (lambda-bind clambda) nil))
(setf (functional-kind clambda) :zombie)
(let ((home (lambda-home clambda)))
(setf (lambda-lets home) (delete clambda (lambda-lets home))))
(values))
;;; 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 leaf 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 LVAR-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 (lvar-reoptimize arg))
(setf (lvar-reoptimize arg) nil)
(cond
((lambda-var-sets var)
(propagate-from-sets var (lvar-type arg)))
((let ((use (lvar-uses arg)))
(when (ref-p use)
(let ((leaf (ref-leaf use)))
(when (and (constant-reference-p use)
(csubtypep (leaf-type leaf)
;; (NODE-DERIVED-TYPE USE) would
;; be better -- APD, 2003-05-15
(leaf-type var)))
(propagate-to-refs var (lvar-type arg))
(let ((use-component (node-component use)))
(prog1 (substitute-leaf-if
(lambda (ref)
(cond ((eq (node-component ref) use-component)
t)
(t
(aver (lambda-toplevelish-p (lambda-home fun)))
nil)))
leaf var)))
t)))))
((and (null (rest (leaf-refs var)))
(substitute-single-use-lvar arg var)))
(t
(propagate-to-refs var (lvar-type arg))))))
(when (every #'not (combination-args call))
(delete-let fun))
(values))
;;; 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 LVAR-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 (or (functional-entry-fun fun)
(lambda-optional-dispatch fun))
(let* ((vars (lambda-vars fun))
(union (mapcar (lambda (arg var)
(when (and arg
(lvar-reoptimize arg)
(null (basic-var-sets var)))
(lvar-type arg)))
(basic-combination-args call)
vars))
(this-ref (lvar-use (basic-combination-fun call))))
(dolist (arg (basic-combination-args call))
(when arg
(setf (lvar-reoptimize arg) nil)))
(dolist (ref (leaf-refs fun))
(let ((dest (node-dest ref)))
(unless (or (eq ref this-ref) (not dest))
(setq union
(mapcar (lambda (this-arg old)
(when old
(setf (lvar-reoptimize this-arg) nil)
(type-union (lvar-type this-arg) old)))
(basic-combination-args dest)
union)))))
(loop for var in vars
and type in union
when type do (propagate-to-refs var type))))
(values))
;;;; multiple values optimization
;;; 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)
(ecase (basic-combination-kind node)
(:local
(let ((fun-lvar (basic-combination-fun node)))
(when (lvar-reoptimize fun-lvar)
(setf (lvar-reoptimize fun-lvar) nil)
(maybe-let-convert (combination-lambda node))))
(setf (lvar-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))))
(:full
(let* ((fun (basic-combination-fun node))
(fun-changed (lvar-reoptimize fun))
(args (basic-combination-args node)))
(when fun-changed
(setf (lvar-reoptimize fun) nil)
(let ((type (lvar-type fun)))
(when (fun-type-p type)
(derive-node-type node (fun-type-returns type))))
(maybe-terminate-block node nil)
(let ((use (lvar-uses fun)))
(when (and (ref-p use) (functional-p (ref-leaf use)))
(convert-call-if-possible use node)
(when (eq (basic-combination-kind node) :local)
(maybe-let-convert (ref-leaf use))))))
(unless (or (eq (basic-combination-kind node) :local)
(eq (lvar-fun-name fun) '%throw))
(ir1-optimize-mv-call node))
(dolist (arg args)
(setf (lvar-reoptimize arg) nil))))
(:error))
(values))
;;; Propagate derived type info from the values lvar 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)))
(n-vars (length vars))
(types (values-type-in (lvar-derived-type arg)
n-vars)))
(loop for var in vars
and type in types
do (if (basic-var-sets var)
(propagate-from-sets var type)
(propagate-to-refs var type)))
(setf (lvar-reoptimize arg) nil))
(values))
;;; 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 (lvar-uses (basic-combination-fun node)))
(args (basic-combination-args node)))
(unless (and (ref-p ref) (constant-reference-p ref)
(singleton-p args))
(return-from ir1-optimize-mv-call))
(multiple-value-bind (min max)
(fun-type-nargs (lvar-type fun))
(let ((total-nvals
(multiple-value-bind (types nvals)
(values-types (lvar-derived-type (first args)))
(declare (ignore types))
(if (eq nvals :unknown) nil nvals))))
(when total-nvals
(when (and min (< total-nvals min))
(compiler-warn
"MULTIPLE-VALUE-CALL with ~R values when the function expects ~
at least ~R."
total-nvals min)
(setf (basic-combination-kind node) :error)
(return-from ir1-optimize-mv-call))
(when (and max (> total-nvals max))
(compiler-warn
"MULTIPLE-VALUE-CALL with ~R values when the function expects ~
at most ~R."
total-nvals max)
(setf (basic-combination-kind node) :error)
(return-from ir1-optimize-mv-call)))
(let ((count (cond (total-nvals)
((and (policy node (zerop verify-arg-count))
(eql min max))
min)
(t nil))))
(when count
(with-ir1-environment-from-node node
(let* ((dums (make-gensym-list count))
(ignore (gensym))
(fun (ir1-convert-lambda
`(lambda (&optional ,@dums &rest ,ignore)
(declare (ignore ,ignore))
(funcall ,(ref-leaf ref) ,@dums)))))
(change-ref-leaf ref fun)
(aver (eq (basic-combination-kind node) :full))
(locall-analyze-component *current-component*)
(aver (eq (basic-combination-kind node) :local)))))))))
(values))
;;; 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
;;; lvars. 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 (lvar-uses arg)))
(when (and (combination-p use)
(eq (lvar-fun-name (combination-fun use))
'values))
(let* ((fun (combination-lambda call))
(vars (lambda-vars fun))
(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-from-node use
(let ((node-prev (node-prev use)))
(setf (node-prev use) nil)
(setf (ctran-next node-prev) nil)
(collect ((res vals))
(loop for count below (- nvars nvals)
for prev = node-prev then ctran
for ctran = (make-ctran)
and lvar = (make-lvar use)
do (reference-constant prev ctran lvar nil)
(res lvar)
finally (link-node-to-previous-ctran
use ctran))
(setq vals (res)))))))
(setf (combination-args use) vals)
(flush-dest (combination-fun use))
(let ((fun-lvar (basic-combination-fun call)))
(setf (lvar-dest fun-lvar) use)
(setf (combination-fun use) fun-lvar)
(flush-lvar-externally-checkable-type fun-lvar))
(setf (combination-kind use) :local)
(setf (functional-kind fun) :let)
(flush-dest (first (basic-combination-args call)))
(unlink-node call)
(when vals
(reoptimize-lvar (first vals)))
(propagate-to-args use fun)
(reoptimize-call use))
t)))
;;; 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 lvar
;;; (allowing the LIST to be flushed.)
;;;
;;; FIXME: Thus we lose possible type assertions on (LIST ...).
(defoptimizer (values-list optimizer) ((list) node)
(let ((use (lvar-uses list)))
(when (and (combination-p use)
(eq (lvar-fun-name (combination-fun use))
'list))
;; FIXME: VALUES might not satisfy an assertion on NODE-LVAR.
(change-ref-leaf (lvar-uses (combination-fun node))
(find-free-fun 'values "in a strange place"))
(setf (combination-kind node) :full)
(let ((args (combination-args use)))
(dolist (arg args)
(setf (lvar-dest arg) node)
(flush-lvar-externally-checkable-type arg))
(setf (combination-args use) nil)
(flush-dest list)
(setf (combination-args node) args))
t)))
;;; 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)
(unless (lvar-single-value-p (node-lvar node))
(give-up-ir1-transform))
(setf (node-derived-type node)
(make-short-values-type (list (single-value-type
(node-derived-type node)))))
(principal-lvar-single-valuify (node-lvar node))
(if vals
(let ((dummies (make-gensym-list (length (cdr vals)))))
`(lambda (val ,@dummies)
(declare (ignore ,@dummies))
val))
nil))
;;; TODO:
;;; - CAST chains;
(defun ir1-optimize-cast (cast &optional do-not-optimize)
(declare (type cast cast))
(let ((value (cast-value cast))
(atype (cast-asserted-type cast)))
(when (not do-not-optimize)
(let ((lvar (node-lvar cast)))
(when (values-subtypep (lvar-derived-type value)
(cast-asserted-type cast))
(delete-filter cast lvar value)
(when lvar
(reoptimize-lvar lvar)
(when (lvar-single-value-p lvar)
(note-single-valuified-lvar lvar)))
(return-from ir1-optimize-cast t))
(when (and (listp (lvar-uses value))
lvar)
;; Pathwise removing of CAST
(let ((ctran (node-next cast))
(dest (lvar-dest lvar))
next-block)
(collect ((merges))
(do-uses (use value)
(when (and (values-subtypep (node-derived-type use) atype)
(immediately-used-p value use))
(unless next-block
(when ctran (ensure-block-start ctran))
(setq next-block (first (block-succ (node-block cast))))
(ensure-block-start (node-prev cast)))
(%delete-lvar-use use)
(add-lvar-use use lvar)
(unlink-blocks (node-block use) (node-block cast))
(link-blocks (node-block use) next-block)
(when (and (return-p dest)
(basic-combination-p use)
(eq (basic-combination-kind use) :local))
(merges use))))
(dolist (use (merges))
(merge-tail-sets use)))))))
(let* ((value-type (lvar-derived-type value))
(int (values-type-intersection value-type atype)))
(derive-node-type cast int)
(when (eq int *empty-type*)
(unless (eq value-type *empty-type*)
;; FIXME: Do it in one step.
(filter-lvar
value
`(multiple-value-call #'list 'dummy))
(filter-lvar
(cast-value cast)
;; FIXME: Derived type.
`(%compile-time-type-error 'dummy
',(type-specifier atype)
',(type-specifier value-type)))
;; KLUDGE: FILTER-LVAR does not work for non-returning
;; functions, so we declare the return type of
;; %COMPILE-TIME-TYPE-ERROR to be * and derive the real type
;; here.
(setq value (cast-value cast))
(derive-node-type (lvar-uses value) *empty-type*)
(maybe-terminate-block (lvar-uses value) nil)
;; FIXME: Is it necessary?
(aver (null (block-pred (node-block cast))))
(delete-block-lazily (node-block cast))
(return-from ir1-optimize-cast)))
(when (eq (node-derived-type cast) *empty-type*)
(maybe-terminate-block cast nil))
(when (and (cast-%type-check cast)
(values-subtypep value-type
(cast-type-to-check cast)))
(setf (cast-%type-check cast) nil))))
(unless do-not-optimize
(setf (node-reoptimize cast) nil)))