Cheng Shao pushed to branch wip/split-sections-scc at Glasgow Haskell Compiler / GHC

Commits:

18 changed files:

Changes:

  • .gitlab/ci.sh
    ... ... @@ -265,6 +265,15 @@ function setup() {
    265 265 
       # testsuite driver!
    266 266 
       git config gc.auto 0
    267 267
    268 
    +  # Some runners still choke at the perf note fetch step, which has to
    269 
    +  # do with slow internet connection, see
    270 
    +  # https://docs.gitlab.com/topics/git/troubleshooting_git/#error-stream-0-was-not-closed-cleanly
    271 
    +  # for the http.postBuffer mitigation. It might seem
    272 
    +  # counter-intuitive that "post buffer" helps with fetching, but git
    273 
    +  # indeed issues post requests when fetching over https, it's a
    274 
    +  # bidirectional negotiation with the remote.
    275 
    +  git config http.postBuffer 52428800
    276 
    +
    268 277 
       info "====================================================="
    269 278 
       info "Toolchain versions"
    270 279 
       info "====================================================="

  • compiler/GHC/Builtin/Names.hs
    ... ... @@ -222,12 +222,11 @@ basicKnownKeyNames
    222 222
    223 223 
             -- Type representation types
    224 224 
             trModuleTyConName, trModuleDataConName,
    225 
    -        trNameTyConName, trNameSDataConName, trNameDDataConName,
    225 
    +        trNameSDataConName,
    226 226 
             trTyConTyConName, trTyConDataConName,
    227 227
    228 228 
             -- Typeable
    229 229 
             typeableClassName,
    230 
    -        typeRepTyConName,
    231 230 
             someTypeRepTyConName,
    232 231 
             someTypeRepDataConName,
    233 232 
             kindRepTyConName,
    ... ... @@ -237,13 +236,10 @@ basicKnownKeyNames
    237 236 
             kindRepFunDataConName,
    238 237 
             kindRepTYPEDataConName,
    239 238 
             kindRepTypeLitSDataConName,
    240 
    -        kindRepTypeLitDDataConName,
    241 
    -        typeLitSortTyConName,
    242 239 
             typeLitSymbolDataConName,
    243 240 
             typeLitNatDataConName,
    244 241 
             typeLitCharDataConName,
    245 242 
             typeRepIdName,
    246 
    -        mkTrTypeName,
    247 243 
             mkTrConName,
    248 244 
             mkTrAppCheckedName,
    249 245 
             mkTrFunName,
    ... ... @@ -296,7 +292,7 @@ basicKnownKeyNames
    296 292 
             fmapName,
    297 293
    298 294 
             -- Monad stuff
    299 
    -        thenIOName, bindIOName, returnIOName, failIOName, bindMName, thenMName,
    295 
    +        thenIOName, bindIOName, returnIOName, bindMName, thenMName,
    300 296 
             returnMName, joinMName,
    301 297
    302 298 
             -- MonadFail
    ... ... @@ -409,26 +405,18 @@ basicKnownKeyNames
    409 405 
             naturalQuotName,
    410 406 
             naturalRemName,
    411 407 
             naturalAndName,
    412 
    -        naturalAndNotName,
    413 408 
             naturalOrName,
    414 409 
             naturalXorName,
    415 410 
             naturalTestBitName,
    416 411 
             naturalBitName,
    417 412 
             naturalGcdName,
    418 413 
             naturalLcmName,
    419 
    -        naturalLog2Name,
    420 
    -        naturalLogBaseWordName,
    421 
    -        naturalLogBaseName,
    422 
    -        naturalPowModName,
    423 
    -        naturalSizeInBaseName,
    424 414
    425 415 
             bignatEqName,
    426 416
    427 417 
             -- Float/Double
    428 418 
             integerToFloatName,
    429 419 
             integerToDoubleName,
    430 
    -        naturalToFloatName,
    431 
    -        naturalToDoubleName,
    432 420 
             rationalToFloatName,
    433 421 
             rationalToDoubleName,
    434 422
    ... ... @@ -476,11 +464,9 @@ basicKnownKeyNames
    476 464
    477 465 
             -- Generics
    478 466 
             , genClassName, gen1ClassName
    479 
    -        , datatypeClassName, constructorClassName, selectorClassName
    480 467
    481 468 
             -- Monad comprehensions
    482 469 
             , guardMName
    483 
    -        , liftMName
    484 470 
             , mzipName
    485 471
    486 472 
             -- GHCi Sandbox
    ... ... @@ -492,9 +478,6 @@ basicKnownKeyNames
    492 478 
             , staticPtrDataConName, staticPtrInfoDataConName
    493 479 
             , fromStaticPtrName
    494 480
    495 
    -        -- Fingerprint
    496 
    -        , fingerprintDataConName
    497 
    -
    498 481 
             -- Custom type errors
    499 482 
             , errorMessageTypeErrorFamName
    500 483 
             , typeErrorTextDataConName
    ... ... @@ -517,12 +500,9 @@ basicKnownKeyNames
    517 500
    518 501 
     genericTyConNames :: [Name]
    519 502 
     genericTyConNames = [
    520 
    -    v1TyConName, u1TyConName, par1TyConName, rec1TyConName,
    521 
    -    k1TyConName, m1TyConName, sumTyConName, prodTyConName,
    522 
    -    compTyConName, rTyConName, dTyConName,
    523 
    -    cTyConName, sTyConName, rec0TyConName,
    524 
    -    d1TyConName, c1TyConName, s1TyConName,
    525 
    -    repTyConName, rep1TyConName, uRecTyConName,
    503 
    +    v1TyConName, u1TyConName, par1TyConName, rec1TyConName, sumTyConName,
    504 
    +    prodTyConName, compTyConName, rec0TyConName, d1TyConName, c1TyConName,
    505 
    +    s1TyConName, repTyConName, rep1TyConName,
    526 506 
         uAddrTyConName, uCharTyConName, uDoubleTyConName,
    527 507 
         uFloatTyConName, uIntTyConName, uWordTyConName,
    528 508 
         prefixIDataConName, infixIDataConName, leftAssociativeDataConName,
    ... ... @@ -939,11 +919,8 @@ voidTyConName = tcQual gHC_INTERNAL_BASE (fsLit "Void") voidTyConKey
    939 919
    940 920 
     -- Generics (types)
    941 921 
     v1TyConName, u1TyConName, par1TyConName, rec1TyConName,
    942 
    -  k1TyConName, m1TyConName, sumTyConName, prodTyConName,
    943 
    -  compTyConName, rTyConName, dTyConName,
    944 
    -  cTyConName, sTyConName, rec0TyConName,
    945 
    -  d1TyConName, c1TyConName, s1TyConName,
    946 
    -  repTyConName, rep1TyConName, uRecTyConName,
    922 
    +  sumTyConName, prodTyConName, compTyConName, rec0TyConName, d1TyConName,
    923 
    +  c1TyConName, s1TyConName, repTyConName, rep1TyConName,
    947 924 
       uAddrTyConName, uCharTyConName, uDoubleTyConName,
    948 925 
       uFloatTyConName, uIntTyConName, uWordTyConName,
    949 926 
       prefixIDataConName, infixIDataConName, leftAssociativeDataConName,
    ... ... @@ -958,18 +935,11 @@ v1TyConName = tcQual gHC_INTERNAL_GENERICS (fsLit "V1") v1TyConKey
    958 935 
     u1TyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "U1") u1TyConKey
    959 936 
     par1TyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "Par1") par1TyConKey
    960 937 
     rec1TyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "Rec1") rec1TyConKey
    961 
    -k1TyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "K1") k1TyConKey
    962 
    -m1TyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "M1") m1TyConKey
    963 938
    964 939 
     sumTyConName    = tcQual gHC_INTERNAL_GENERICS (fsLit ":+:") sumTyConKey
    965 940 
     prodTyConName   = tcQual gHC_INTERNAL_GENERICS (fsLit ":*:") prodTyConKey
    966 941 
     compTyConName   = tcQual gHC_INTERNAL_GENERICS (fsLit ":.:") compTyConKey
    967 942
    968 
    -rTyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "R") rTyConKey
    969 
    -dTyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "D") dTyConKey
    970 
    -cTyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "C") cTyConKey
    971 
    -sTyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "S") sTyConKey
    972 
    -
    973 943 
     rec0TyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "Rec0") rec0TyConKey
    974 944 
     d1TyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "D1") d1TyConKey
    975 945 
     c1TyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "C1") c1TyConKey
    ... ... @@ -978,7 +948,6 @@ s1TyConName = tcQual gHC_INTERNAL_GENERICS (fsLit "S1") s1TyConKey
    978 948 
     repTyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "Rep")  repTyConKey
    979 949 
     rep1TyConName = tcQual gHC_INTERNAL_GENERICS (fsLit "Rep1") rep1TyConKey
    980 950
    981 
    -uRecTyConName      = tcQual gHC_INTERNAL_GENERICS (fsLit "URec") uRecTyConKey
    982 951 
     uAddrTyConName     = tcQual gHC_INTERNAL_GENERICS (fsLit "UAddr") uAddrTyConKey
    983 952 
     uCharTyConName     = tcQual gHC_INTERNAL_GENERICS (fsLit "UChar") uCharTyConKey
    984 953 
     uDoubleTyConName   = tcQual gHC_INTERNAL_GENERICS (fsLit "UDouble") uDoubleTyConKey
    ... ... @@ -1169,18 +1138,12 @@ integerFromNaturalName
    1169 1138 
        , naturalQuotName
    1170 1139 
        , naturalRemName
    1171 1140 
        , naturalAndName
    1172 
    -   , naturalAndNotName
    1173 1141 
        , naturalOrName
    1174 1142 
        , naturalXorName
    1175 1143 
        , naturalTestBitName
    1176 1144 
        , naturalBitName
    1177 1145 
        , naturalGcdName
    1178 1146 
        , naturalLcmName
    1179 
    -   , naturalLog2Name
    1180 
    -   , naturalLogBaseWordName
    1181 
    -   , naturalLogBaseName
    1182 
    -   , naturalPowModName
    1183 
    -   , naturalSizeInBaseName
    1184 1147 
        , bignatEqName
    1185 1148 
        , bignatCompareName
    1186 1149 
        , bignatCompareWordName
    ... ... @@ -1209,18 +1172,12 @@ naturalQuotRemName = bnnVarQual "naturalQuotRem#" naturalQuotRe
    1209 1172 
     naturalQuotName           = bnnVarQual "naturalQuot"               naturalQuotIdKey
    1210 1173 
     naturalRemName            = bnnVarQual "naturalRem"                naturalRemIdKey
    1211 1174 
     naturalAndName            = bnnVarQual "naturalAnd"                naturalAndIdKey
    1212 
    -naturalAndNotName         = bnnVarQual "naturalAndNot"             naturalAndNotIdKey
    1213 1175 
     naturalOrName             = bnnVarQual "naturalOr"                 naturalOrIdKey
    1214 1176 
     naturalXorName            = bnnVarQual "naturalXor"                naturalXorIdKey
    1215 1177 
     naturalTestBitName        = bnnVarQual "naturalTestBit#"           naturalTestBitIdKey
    1216 1178 
     naturalBitName            = bnnVarQual "naturalBit#"               naturalBitIdKey
    1217 1179 
     naturalGcdName            = bnnVarQual "naturalGcd"                naturalGcdIdKey
    1218 1180 
     naturalLcmName            = bnnVarQual "naturalLcm"                naturalLcmIdKey
    1219 
    -naturalLog2Name           = bnnVarQual "naturalLog2#"              naturalLog2IdKey
    1220 
    -naturalLogBaseWordName    = bnnVarQual "naturalLogBaseWord#"       naturalLogBaseWordIdKey
    1221 
    -naturalLogBaseName        = bnnVarQual "naturalLogBase#"           naturalLogBaseIdKey
    1222 
    -naturalPowModName         = bnnVarQual "naturalPowMod"             naturalPowModIdKey
    1223 
    -naturalSizeInBaseName     = bnnVarQual "naturalSizeInBase#"        naturalSizeInBaseIdKey
    1224 1181
    1225 1182 
     integerFromNaturalName    = bniVarQual "integerFromNatural"        integerFromNaturalIdKey
    1226 1183 
     integerToNaturalClampName = bniVarQual "integerToNaturalClamp"     integerToNaturalClampIdKey
    ... ... @@ -1291,12 +1248,9 @@ realFloatClassName = clsQual gHC_INTERNAL_FLOAT (fsLit "RealFloat") realFloatCla
    1291 1248
    1292 1249 
     -- other GHC.Internal.Float functions
    1293 1250 
     integerToFloatName, integerToDoubleName,
    1294 
    -  naturalToFloatName, naturalToDoubleName,
    1295 1251 
       rationalToFloatName, rationalToDoubleName :: Name
    1296 1252 
     integerToFloatName   = varQual gHC_INTERNAL_FLOAT (fsLit "integerToFloat#") integerToFloatIdKey
    1297 1253 
     integerToDoubleName  = varQual gHC_INTERNAL_FLOAT (fsLit "integerToDouble#") integerToDoubleIdKey
    1298 
    -naturalToFloatName   = varQual gHC_INTERNAL_FLOAT (fsLit "naturalToFloat#") naturalToFloatIdKey
    1299 
    -naturalToDoubleName  = varQual gHC_INTERNAL_FLOAT (fsLit "naturalToDouble#") naturalToDoubleIdKey
    1300 1254 
     rationalToFloatName  = varQual gHC_INTERNAL_FLOAT (fsLit "rationalToFloat") rationalToFloatIdKey
    1301 1255 
     rationalToDoubleName = varQual gHC_INTERNAL_FLOAT (fsLit "rationalToDouble") rationalToDoubleIdKey
    1302 1256
    ... ... @@ -1307,17 +1261,13 @@ ixClassName = clsQual gHC_INTERNAL_IX (fsLit "Ix") ixClassKey
    1307 1261 
     -- Typeable representation types
    1308 1262 
     trModuleTyConName
    1309 1263 
       , trModuleDataConName
    1310 
    -  , trNameTyConName
    1311 1264 
       , trNameSDataConName
    1312 
    -  , trNameDDataConName
    1313 1265 
       , trTyConTyConName
    1314 1266 
       , trTyConDataConName
    1315 1267 
       :: Name
    1316 1268 
     trModuleTyConName     = tcQual gHC_TYPES          (fsLit "Module")         trModuleTyConKey
    1317 1269 
     trModuleDataConName   = dcQual gHC_TYPES          (fsLit "Module")         trModuleDataConKey
    1318 
    -trNameTyConName       = tcQual gHC_TYPES          (fsLit "TrName")         trNameTyConKey
    1319 1270 
     trNameSDataConName    = dcQual gHC_TYPES          (fsLit "TrNameS")        trNameSDataConKey
    1320 
    -trNameDDataConName    = dcQual gHC_TYPES          (fsLit "TrNameD")        trNameDDataConKey
    1321 1271 
     trTyConTyConName      = tcQual gHC_TYPES          (fsLit "TyCon")          trTyConTyConKey
    1322 1272 
     trTyConDataConName    = dcQual gHC_TYPES          (fsLit "TyCon")          trTyConDataConKey
    1323 1273
    ... ... @@ -1328,7 +1278,6 @@ kindRepTyConName
    1328 1278 
       , kindRepFunDataConName
    1329 1279 
       , kindRepTYPEDataConName
    1330 1280 
       , kindRepTypeLitSDataConName
    1331 
    -  , kindRepTypeLitDDataConName
    1332 1281 
       :: Name
    1333 1282 
     kindRepTyConName      = tcQual gHC_TYPES          (fsLit "KindRep")        kindRepTyConKey
    1334 1283 
     kindRepTyConAppDataConName = dcQual gHC_TYPES     (fsLit "KindRepTyConApp") kindRepTyConAppDataConKey
    ... ... @@ -1337,24 +1286,19 @@ kindRepAppDataConName = dcQual gHC_TYPES (fsLit "KindRepApp") kindR
    1337 1286 
     kindRepFunDataConName = dcQual gHC_TYPES          (fsLit "KindRepFun")     kindRepFunDataConKey
    1338 1287 
     kindRepTYPEDataConName = dcQual gHC_TYPES         (fsLit "KindRepTYPE")    kindRepTYPEDataConKey
    1339 1288 
     kindRepTypeLitSDataConName = dcQual gHC_TYPES     (fsLit "KindRepTypeLitS") kindRepTypeLitSDataConKey
    1340 
    -kindRepTypeLitDDataConName = dcQual gHC_TYPES     (fsLit "KindRepTypeLitD") kindRepTypeLitDDataConKey
    1341 1289
    1342 
    -typeLitSortTyConName
    1343 
    -  , typeLitSymbolDataConName
    1290 
    +typeLitSymbolDataConName
    1344 1291 
       , typeLitNatDataConName
    1345 1292 
       , typeLitCharDataConName
    1346 1293 
       :: Name
    1347 
    -typeLitSortTyConName     = tcQual gHC_TYPES       (fsLit "TypeLitSort")    typeLitSortTyConKey
    1348 1294 
     typeLitSymbolDataConName = dcQual gHC_TYPES       (fsLit "TypeLitSymbol")  typeLitSymbolDataConKey
    1349 1295 
     typeLitNatDataConName    = dcQual gHC_TYPES       (fsLit "TypeLitNat")     typeLitNatDataConKey
    1350 1296 
     typeLitCharDataConName   = dcQual gHC_TYPES       (fsLit "TypeLitChar")    typeLitCharDataConKey
    1351 1297
    1352 1298 
     -- Class Typeable, and functions for constructing `Typeable` dictionaries
    1353 1299 
     typeableClassName
    1354 
    -  , typeRepTyConName
    1355 1300 
       , someTypeRepTyConName
    1356 1301 
       , someTypeRepDataConName
    1357 
    -  , mkTrTypeName
    1358 1302 
       , mkTrConName
    1359 1303 
       , mkTrAppCheckedName
    1360 1304 
       , mkTrFunName
    ... ... @@ -1365,11 +1309,9 @@ typeableClassName
    1365 1309 
       , trGhcPrimModuleName
    1366 1310 
       :: Name
    1367 1311 
     typeableClassName     = clsQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "Typeable")       typeableClassKey
    1368 
    -typeRepTyConName      = tcQual  gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "TypeRep")        typeRepTyConKey
    1369 1312 
     someTypeRepTyConName   = tcQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "SomeTypeRep")    someTypeRepTyConKey
    1370 1313 
     someTypeRepDataConName = dcQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "SomeTypeRep")    someTypeRepDataConKey
    1371 1314 
     typeRepIdName         = varQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "typeRep#")       typeRepIdKey
    1372 
    -mkTrTypeName          = varQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "mkTrType")       mkTrTypeKey
    1373 1315 
     mkTrConName           = varQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "mkTrCon")        mkTrConKey
    1374 1316 
     mkTrAppCheckedName    = varQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "mkTrAppChecked") mkTrAppCheckedKey
    1375 1317 
     mkTrFunName           = varQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "mkTrFun")        mkTrFunKey
    ... ... @@ -1494,15 +1436,10 @@ readClassName :: Name
    1494 1436 
     readClassName   = clsQual gHC_INTERNAL_READ (fsLit "Read")      readClassKey
    1495 1437
    1496 1438 
     -- Classes Generic and Generic1, Datatype, Constructor and Selector
    1497 
    -genClassName, gen1ClassName, datatypeClassName, constructorClassName,
    1498 
    -  selectorClassName :: Name
    1439 
    +genClassName, gen1ClassName :: Name
    1499 1440 
     genClassName  = clsQual gHC_INTERNAL_GENERICS (fsLit "Generic")  genClassKey
    1500 1441 
     gen1ClassName = clsQual gHC_INTERNAL_GENERICS (fsLit "Generic1") gen1ClassKey
    1501 1442
    1502 
    -datatypeClassName    = clsQual gHC_INTERNAL_GENERICS (fsLit "Datatype")    datatypeClassKey
    1503 
    -constructorClassName = clsQual gHC_INTERNAL_GENERICS (fsLit "Constructor") constructorClassKey
    1504 
    -selectorClassName    = clsQual gHC_INTERNAL_GENERICS (fsLit "Selector")    selectorClassKey
    1505 
    -
    1506 1443 
     genericClassNames :: [Name]
    1507 1444 
     genericClassNames = [genClassName, gen1ClassName]
    1508 1445
    ... ... @@ -1513,13 +1450,12 @@ ghciStepIoMName = varQual gHC_INTERNAL_GHCI (fsLit "ghciStepIO") ghciStepIoMClas
    1513 1450
    1514 1451 
     -- IO things
    1515 1452 
     ioTyConName, ioDataConName,
    1516 
    -  thenIOName, bindIOName, returnIOName, failIOName :: Name
    1453 
    +  thenIOName, bindIOName, returnIOName :: Name
    1517 1454 
     ioTyConName       = tcQual  gHC_TYPES (fsLit "IO")       ioTyConKey
    1518 1455 
     ioDataConName     = dcQual  gHC_TYPES (fsLit "IO")       ioDataConKey
    1519 1456 
     thenIOName        = varQual gHC_INTERNAL_BASE  (fsLit "thenIO")   thenIOIdKey
    1520 1457 
     bindIOName        = varQual gHC_INTERNAL_BASE  (fsLit "bindIO")   bindIOIdKey
    1521 1458 
     returnIOName      = varQual gHC_INTERNAL_BASE  (fsLit "returnIO") returnIOIdKey
    1522 
    -failIOName        = varQual gHC_INTERNAL_IO    (fsLit "failIO")   failIOIdKey
    1523 1459
    1524 1460 
     -- IO things
    1525 1461 
     printName :: Name
    ... ... @@ -1564,9 +1500,8 @@ choiceAName = varQual gHC_INTERNAL_ARROW (fsLit "|||") choiceAIdKey
    1564 1500 
     loopAName          = varQual gHC_INTERNAL_ARROW (fsLit "loop")      loopAIdKey
    1565 1501
    1566 1502 
     -- Monad comprehensions
    1567 
    -guardMName, liftMName, mzipName :: Name
    1503 
    +guardMName, mzipName :: Name
    1568 1504 
     guardMName         = varQual gHC_INTERNAL_MONAD (fsLit "guard")    guardMIdKey
    1569 
    -liftMName          = varQual gHC_INTERNAL_MONAD (fsLit "liftM")    liftMIdKey
    1570 1505 
     mzipName           = varQual gHC_INTERNAL_CONTROL_MONAD_ZIP (fsLit "mzip") mzipIdKey
    1571 1506
    1572 1507
    ... ... @@ -1654,10 +1589,6 @@ fromStaticPtrName :: Name
    1654 1589 
     fromStaticPtrName =
    1655 1590 
         varQual gHC_INTERNAL_STATICPTR (fsLit "fromStaticPtr") fromStaticPtrClassOpKey
    1656 1591
    1657 
    -fingerprintDataConName :: Name
    1658 
    -fingerprintDataConName =
    1659 
    -    dcQual gHC_INTERNAL_FINGERPRINT_TYPE (fsLit "Fingerprint") fingerprintDataConKey
    1660 
    -
    1661 1592 
     constPtrConName :: Name
    1662 1593 
     constPtrConName =
    1663 1594 
         tcQual gHC_INTERNAL_FOREIGN_C_CONSTPTR (fsLit "ConstPtr") constPtrTyConKey
    ... ... @@ -1753,15 +1684,10 @@ applicativeClassKey = mkPreludeClassUnique 34
    1753 1684 
     foldableClassKey        = mkPreludeClassUnique 35
    1754 1685 
     traversableClassKey     = mkPreludeClassUnique 36
    1755 1686
    1756 
    -genClassKey, gen1ClassKey, datatypeClassKey, constructorClassKey,
    1757 
    -  selectorClassKey :: Unique
    1687 
    +genClassKey, gen1ClassKey :: Unique
    1758 1688 
     genClassKey   = mkPreludeClassUnique 37
    1759 1689 
     gen1ClassKey  = mkPreludeClassUnique 38
    1760 1690
    1761 
    -datatypeClassKey    = mkPreludeClassUnique 39
    1762 
    -constructorClassKey = mkPreludeClassUnique 40
    1763 
    -selectorClassKey    = mkPreludeClassUnique 41
    1764 
    -
    1765 1691 
     -- KnownNat: see Note [KnownNat & KnownSymbol and EvLit] in GHC.Tc.Instance.Class
    1766 1692 
     knownNatClassNameKey :: Unique
    1767 1693 
     knownNatClassNameKey = mkPreludeClassUnique 42
    ... ... @@ -1940,21 +1866,16 @@ pluginTyConKey, frontendPluginTyConKey :: Unique
    1940 1866 
     pluginTyConKey                          = mkPreludeTyConUnique 102
    1941 1867 
     frontendPluginTyConKey                  = mkPreludeTyConUnique 103
    1942 1868
    1943 
    -trTyConTyConKey, trModuleTyConKey, trNameTyConKey,
    1944 
    -  kindRepTyConKey, typeLitSortTyConKey :: Unique
    1869 
    +trTyConTyConKey, trModuleTyConKey,
    1870 
    +  kindRepTyConKey :: Unique
    1945 1871 
     trTyConTyConKey                         = mkPreludeTyConUnique 104
    1946 1872 
     trModuleTyConKey                        = mkPreludeTyConUnique 105
    1947 
    -trNameTyConKey                          = mkPreludeTyConUnique 106
    1948 1873 
     kindRepTyConKey                         = mkPreludeTyConUnique 107
    1949 
    -typeLitSortTyConKey                     = mkPreludeTyConUnique 108
    1950 1874
    1951 1875 
     -- Generics (Unique keys)
    1952 1876 
     v1TyConKey, u1TyConKey, par1TyConKey, rec1TyConKey,
    1953 
    -  k1TyConKey, m1TyConKey, sumTyConKey, prodTyConKey,
    1954 
    -  compTyConKey, rTyConKey, dTyConKey,
    1955 
    -  cTyConKey, sTyConKey, rec0TyConKey,
    1956 
    -  d1TyConKey, c1TyConKey, s1TyConKey,
    1957 
    -  repTyConKey, rep1TyConKey, uRecTyConKey,
    1877 
    +  sumTyConKey, prodTyConKey, compTyConKey, rec0TyConKey,
    1878 
    +  d1TyConKey, c1TyConKey, s1TyConKey, repTyConKey, rep1TyConKey,
    1958 1879 
       uAddrTyConKey, uCharTyConKey, uDoubleTyConKey,
    1959 1880 
       uFloatTyConKey, uIntTyConKey, uWordTyConKey :: Unique
    1960 1881
    ... ... @@ -1962,18 +1883,11 @@ v1TyConKey = mkPreludeTyConUnique 135
    1962 1883 
     u1TyConKey    = mkPreludeTyConUnique 136
    1963 1884 
     par1TyConKey  = mkPreludeTyConUnique 137
    1964 1885 
     rec1TyConKey  = mkPreludeTyConUnique 138
    1965 
    -k1TyConKey    = mkPreludeTyConUnique 139
    1966 
    -m1TyConKey    = mkPreludeTyConUnique 140
    1967 1886
    1968 1887 
     sumTyConKey   = mkPreludeTyConUnique 141
    1969 1888 
     prodTyConKey  = mkPreludeTyConUnique 142
    1970 1889 
     compTyConKey  = mkPreludeTyConUnique 143
    1971 1890
    1972 
    -rTyConKey = mkPreludeTyConUnique 144
    1973 
    -dTyConKey = mkPreludeTyConUnique 146
    1974 
    -cTyConKey = mkPreludeTyConUnique 147
    1975 
    -sTyConKey = mkPreludeTyConUnique 148
    1976 
    -
    1977 1891 
     rec0TyConKey  = mkPreludeTyConUnique 149
    1978 1892 
     d1TyConKey    = mkPreludeTyConUnique 151
    1979 1893 
     c1TyConKey    = mkPreludeTyConUnique 152
    ... ... @@ -1982,7 +1896,6 @@ s1TyConKey = mkPreludeTyConUnique 153
    1982 1896 
     repTyConKey  = mkPreludeTyConUnique 155
    1983 1897 
     rep1TyConKey = mkPreludeTyConUnique 156
    1984 1898
    1985 
    -uRecTyConKey    = mkPreludeTyConUnique 157
    1986 1899 
     uAddrTyConKey   = mkPreludeTyConUnique 158
    1987 1900 
     uCharTyConKey   = mkPreludeTyConUnique 159
    1988 1901 
     uDoubleTyConKey = mkPreludeTyConUnique 160
    ... ... @@ -2026,8 +1939,7 @@ callStackTyConKey :: Unique
    2026 1939 
     callStackTyConKey = mkPreludeTyConUnique 191
    2027 1940
    2028 1941 
     -- Typeables
    2029 
    -typeRepTyConKey, someTypeRepTyConKey, someTypeRepDataConKey :: Unique
    2030 
    -typeRepTyConKey       = mkPreludeTyConUnique 192
    1942 
    +someTypeRepTyConKey, someTypeRepDataConKey :: Unique
    2031 1943 
     someTypeRepTyConKey   = mkPreludeTyConUnique 193
    2032 1944 
     someTypeRepDataConKey = mkPreludeTyConUnique 194
    2033 1945
    ... ... @@ -2159,19 +2071,15 @@ staticPtrDataConKey = mkPreludeDataConUnique 33
    2159 2071 
     staticPtrInfoDataConKey :: Unique
    2160 2072 
     staticPtrInfoDataConKey                 = mkPreludeDataConUnique 34
    2161 2073
    2162 
    -fingerprintDataConKey :: Unique
    2163 
    -fingerprintDataConKey                   = mkPreludeDataConUnique 35
    2164 
    -
    2165 2074 
     srcLocDataConKey :: Unique
    2166 2075 
     srcLocDataConKey                        = mkPreludeDataConUnique 37
    2167 2076
    2168 2077 
     trTyConDataConKey, trModuleDataConKey,
    2169 
    -  trNameSDataConKey, trNameDDataConKey,
    2078 
    +  trNameSDataConKey,
    2170 2079 
       trGhcPrimModuleKey :: Unique
    2171 2080 
     trTyConDataConKey                       = mkPreludeDataConUnique 41
    2172 2081 
     trModuleDataConKey                      = mkPreludeDataConUnique 43
    2173 2082 
     trNameSDataConKey                       = mkPreludeDataConUnique 45
    2174 
    -trNameDDataConKey                       = mkPreludeDataConUnique 46
    2175 2083 
     trGhcPrimModuleKey                      = mkPreludeDataConUnique 47
    2176 2084
    2177 2085 
     typeErrorTextDataConKey,
    ... ... @@ -2246,7 +2154,7 @@ vecElemDataConKeys = map mkPreludeDataConUnique [96..105]
    2246 2154 
     -- Typeable things
    2247 2155 
     kindRepTyConAppDataConKey, kindRepVarDataConKey, kindRepAppDataConKey,
    2248 2156 
         kindRepFunDataConKey, kindRepTYPEDataConKey,
    2249 
    -    kindRepTypeLitSDataConKey, kindRepTypeLitDDataConKey
    2157 
    +    kindRepTypeLitSDataConKey
    2250 2158 
         :: Unique
    2251 2159 
     kindRepTyConAppDataConKey = mkPreludeDataConUnique 106
    2252 2160 
     kindRepVarDataConKey      = mkPreludeDataConUnique 107
    ... ... @@ -2254,7 +2162,6 @@ kindRepAppDataConKey = mkPreludeDataConUnique 108
    2254 2162 
     kindRepFunDataConKey      = mkPreludeDataConUnique 109
    2255 2163 
     kindRepTYPEDataConKey     = mkPreludeDataConUnique 110
    2256 2164 
     kindRepTypeLitSDataConKey = mkPreludeDataConUnique 111
    2257 
    -kindRepTypeLitDDataConKey = mkPreludeDataConUnique 112
    2258 2165
    2259 2166 
     typeLitSymbolDataConKey, typeLitNatDataConKey, typeLitCharDataConKey :: Unique
    2260 2167 
     typeLitSymbolDataConKey   = mkPreludeDataConUnique 113
    ... ... @@ -2342,7 +2249,7 @@ cstringLengthIdKey = mkPreludeMiscIdUnique 28
    2342 2249
    2343 2250 
     concatIdKey, filterIdKey, zipIdKey,
    2344 2251 
         bindIOIdKey, returnIOIdKey, newStablePtrIdKey,
    2345 
    -    printIdKey, failIOIdKey, nullAddrIdKey, voidArgIdKey,
    2252 
    +    printIdKey, nullAddrIdKey, voidArgIdKey,
    2346 2253 
         otherwiseIdKey, assertIdKey :: Unique
    2347 2254 
     concatIdKey                   = mkPreludeMiscIdUnique 31
    2348 2255 
     filterIdKey                   = mkPreludeMiscIdUnique 32
    ... ... @@ -2351,7 +2258,6 @@ bindIOIdKey = mkPreludeMiscIdUnique 34
    2351 2258 
     returnIOIdKey                 = mkPreludeMiscIdUnique 35
    2352 2259 
     newStablePtrIdKey             = mkPreludeMiscIdUnique 36
    2353 2260 
     printIdKey                    = mkPreludeMiscIdUnique 37
    2354 
    -failIOIdKey                   = mkPreludeMiscIdUnique 38
    2355 2261 
     nullAddrIdKey                 = mkPreludeMiscIdUnique 39
    2356 2262 
     voidArgIdKey                  = mkPreludeMiscIdUnique 40
    2357 2263 
     otherwiseIdKey                = mkPreludeMiscIdUnique 43
    ... ... @@ -2390,11 +2296,9 @@ considerAccessibleIdKey = mkPreludeMiscIdUnique 125
    2390 2296 
     noinlineIdKey           = mkPreludeMiscIdUnique 126
    2391 2297 
     noinlineConstraintIdKey = mkPreludeMiscIdUnique 127
    2392 2298
    2393 
    -integerToFloatIdKey, integerToDoubleIdKey, naturalToFloatIdKey, naturalToDoubleIdKey :: Unique
    2299 
    +integerToFloatIdKey, integerToDoubleIdKey :: Unique
    2394 2300 
     integerToFloatIdKey    = mkPreludeMiscIdUnique 128
    2395 2301 
     integerToDoubleIdKey   = mkPreludeMiscIdUnique 129
    2396 
    -naturalToFloatIdKey    = mkPreludeMiscIdUnique 130
    2397 
    -naturalToDoubleIdKey   = mkPreludeMiscIdUnique 131
    2398 2302
    2399 2303 
     rationalToFloatIdKey, rationalToDoubleIdKey :: Unique
    2400 2304 
     rationalToFloatIdKey   = mkPreludeMiscIdUnique 132
    ... ... @@ -2472,9 +2376,8 @@ toIntegerClassOpKey = mkPreludeMiscIdUnique 192
    2472 2376 
     toRationalClassOpKey = mkPreludeMiscIdUnique 193
    2473 2377
    2474 2378 
     -- Monad comprehensions
    2475 
    -guardMIdKey, liftMIdKey, mzipIdKey :: Unique
    2379 
    +guardMIdKey, mzipIdKey :: Unique
    2476 2380 
     guardMIdKey     = mkPreludeMiscIdUnique 194
    2477 
    -liftMIdKey      = mkPreludeMiscIdUnique 195
    2478 2381 
     mzipIdKey       = mkPreludeMiscIdUnique 196
    2479 2382
    2480 2383 
     -- GHCi
    ... ... @@ -2497,7 +2400,6 @@ proxyHashKey = mkPreludeMiscIdUnique 502
    2497 2400
    2498 2401 
     -- Used to make `Typeable` dictionaries
    2499 2402 
     mkTyConKey
    2500 
    -  , mkTrTypeKey
    2501 2403 
       , mkTrConKey
    2502 2404 
       , mkTrAppCheckedKey
    2503 2405 
       , mkTrFunKey
    ... ... @@ -2507,7 +2409,6 @@ mkTyConKey
    2507 2409 
       , typeRepIdKey
    2508 2410 
       :: Unique
    2509 2411 
     mkTyConKey            = mkPreludeMiscIdUnique 503
    2510 
    -mkTrTypeKey           = mkPreludeMiscIdUnique 504
    2511 2412 
     mkTrConKey            = mkPreludeMiscIdUnique 505
    2512 2413 
     mkTrAppCheckedKey     = mkPreludeMiscIdUnique 506
    2513 2414 
     typeNatTypeRepKey     = mkPreludeMiscIdUnique 507
    ... ... @@ -2620,18 +2521,12 @@ integerFromNaturalIdKey
    2620 2521 
        , naturalQuotIdKey
    2621 2522 
        , naturalRemIdKey
    2622 2523 
        , naturalAndIdKey
    2623 
    -   , naturalAndNotIdKey
    2624 2524 
        , naturalOrIdKey
    2625 2525 
        , naturalXorIdKey
    2626 2526 
        , naturalTestBitIdKey
    2627 2527 
        , naturalBitIdKey
    2628 2528 
        , naturalGcdIdKey
    2629 2529 
        , naturalLcmIdKey
    2630 
    -   , naturalLog2IdKey
    2631 
    -   , naturalLogBaseWordIdKey
    2632 
    -   , naturalLogBaseIdKey
    2633 
    -   , naturalPowModIdKey
    2634 
    -   , naturalSizeInBaseIdKey
    2635 2530 
        , bignatEqIdKey
    2636 2531 
        , bignatCompareIdKey
    2637 2532 
        , bignatCompareWordIdKey
    ... ... @@ -2686,18 +2581,12 @@ naturalQuotRemIdKey = mkPreludeMiscIdUnique 669
    2686 2581 
     naturalQuotIdKey           = mkPreludeMiscIdUnique 670
    2687 2582 
     naturalRemIdKey            = mkPreludeMiscIdUnique 671
    2688 2583 
     naturalAndIdKey            = mkPreludeMiscIdUnique 672
    2689 
    -naturalAndNotIdKey         = mkPreludeMiscIdUnique 673
    2690 2584 
     naturalOrIdKey             = mkPreludeMiscIdUnique 674
    2691 2585 
     naturalXorIdKey            = mkPreludeMiscIdUnique 675
    2692 2586 
     naturalTestBitIdKey        = mkPreludeMiscIdUnique 676
    2693 2587 
     naturalBitIdKey            = mkPreludeMiscIdUnique 677
    2694 2588 
     naturalGcdIdKey            = mkPreludeMiscIdUnique 678
    2695 2589 
     naturalLcmIdKey            = mkPreludeMiscIdUnique 679
    2696 
    -naturalLog2IdKey           = mkPreludeMiscIdUnique 680
    2697 
    -naturalLogBaseWordIdKey    = mkPreludeMiscIdUnique 681
    2698 
    -naturalLogBaseIdKey        = mkPreludeMiscIdUnique 682
    2699 
    -naturalPowModIdKey         = mkPreludeMiscIdUnique 683
    2700 
    -naturalSizeInBaseIdKey     = mkPreludeMiscIdUnique 684
    2701 2590
    2702 2591 
     bignatEqIdKey              = mkPreludeMiscIdUnique 691
    2703 2592 
     bignatCompareIdKey         = mkPreludeMiscIdUnique 692

  • compiler/GHC/CmmToAsm.hs
    ... ... @@ -85,6 +85,7 @@ import GHC.CmmToAsm.BlockLayout as BlockLayout
    85 85 
     import GHC.Settings.Config
    86 86 
     import GHC.CmmToAsm.Instr
    87 87 
     import GHC.CmmToAsm.PIC
    88 
    +import GHC.CmmToAsm.Ppr (pprSectionHeader)
    88 89 
     import GHC.Platform.Reg
    89 90 
     import GHC.Platform.Reg.Class (RegClass)
    90 91 
     import GHC.CmmToAsm.Monad
    ... ... @@ -97,7 +98,9 @@ import GHC.Cmm.DebugBlock
    97 98 
     import GHC.Cmm.BlockId
    98 99 
     import GHC.StgToCmm.CgUtils ( fixStgRegisters )
    99 100 
     import GHC.Cmm
    101 
    +import GHC.Cmm.Dataflow.Graph (entryLabel)
    100 102 
     import GHC.Cmm.Dataflow.Label
    103 
    +import GHC.Cmm.Dataflow.Block (foldBlockNodesF)
    101 104 
     import GHC.Cmm.GenericOpt
    102 105 
     import GHC.Cmm.CLabel
    103 106
    ... ... @@ -123,13 +126,18 @@ import GHC.Data.Stream (liftIO)
    123 126 
     import qualified GHC.Data.Stream as Stream
    124 127 
     import GHC.Settings
    125 128
    126 
    -import Data.List (sortBy)
    129 
    +import Data.List (sortBy, find)
    127 130 
     import Data.List.NonEmpty (groupAllWith, head)
    128 131 
     import Data.Maybe
    129 132 
     import Data.Ord         ( comparing )
    133 
    +import Data.Char (isSpace)
    130 134 
     import Control.Monad
    131 135 
     import System.IO
    132 
    -import System.Directory ( getCurrentDirectory )
    136 
    +import System.Directory ( getCurrentDirectory, getTemporaryDirectory, removeFile )
    137 
    +import qualified Data.Graph as Graph
    138 
    +import qualified Data.Map.Strict as Map
    139 
    +import qualified Data.Set as Set
    140 
    +import qualified Data.ByteString.Char8 as BS8
    133 141
    134 142 
     --------------------
    135 143 
     nativeCodeGen :: forall a . Logger -> ToolSettings -> NCGConfig -> ModLocation -> Handle
    ... ... @@ -139,7 +147,13 @@ nativeCodeGen logger ts config modLoc h cmms
    139 147 
      = let platform = ncgPlatform config
    140 148 
            nCG' :: ( OutputableP Platform statics, Outputable jumpDest, Instruction instr)
    141 149 
                 => NcgImpl statics instr jumpDest -> UniqDSMT IO a
    142 
    -       nCG' ncgImpl = nativeCodeGen' logger config modLoc ncgImpl h cmms
    150 
    +       nCG' ncgImpl
    151 
    +         | shouldGroupSplitSections config
    152 
    +         = nativeCodeGenGrouped logger config modLoc ncgImpl h cmms
    153 
    +         | otherwise
    154 
    +         = do
    155 
    +             (a, _) <- nativeCodeGen' logger config modLoc ncgImpl False h cmms
    156 
    +             return a
    143 157 
        in case platformArch platform of
    144 158 
           ArchX86       -> nCG' (X86.ncgX86     config)
    145 159 
           ArchX86_64    -> nCG' (X86.ncgX86_64  config)
    ... ... @@ -174,8 +188,257 @@ data NativeGenAcc statics instr
    174 188 
             , ngs_unwinds     :: !(LabelMap [UnwindPoint])
    175 189 
                  -- ^ see Note [Unwinding information in the NCG]
    176 190 
                  -- and Note [What is this unwinding business?] in "GHC.Cmm.DebugBlock".
    191 
    +        , ngs_splitSecAcc :: !(Maybe SplitSecAcc)
    177 192 
             }
    178 193
    194 
    +-- -----------------------------------------------------------------------------
    195 
    +-- Split sections grouping
    196 
    +
    197 
    +data SplitNodeKey
    198 
    +  = SplitNodeKey !SectionType !CLabel
    199 
    +
    200 
    +data SplitSecAcc = SplitSecAcc
    201 
    +  { ssOwner      :: !(Map.Map CLabel SplitNodeKey)
    202 
    +  , ssNodeOrder  :: !(Map.Map SplitNodeKey Int)
    203 
    +  , ssNodes      :: ![SplitNodeKey] -- ^ first-seen order
    204 
    +  , ssNextId     :: !Int
    205 
    +  , ssPendingRefs :: !(Map.Map SplitNodeKey (Set.Set CLabel))
    206 
    +  }
    207 
    +
    208 
    +emptySplitSecAcc :: SplitSecAcc
    209 
    +emptySplitSecAcc = SplitSecAcc
    210 
    +  { ssOwner = Map.empty
    211 
    +  , ssNodeOrder = Map.empty
    212 
    +  , ssNodes = []
    213 
    +  , ssNextId = 0
    214 
    +  , ssPendingRefs = Map.empty
    215 
    +  }
    216 
    +
    217 
    +ensureSplitNode :: SplitNodeKey -> SplitSecAcc -> SplitSecAcc
    218 
    +ensureSplitNode node acc =
    219 
    +  case Map.lookup node (ssNodeOrder acc) of
    220 
    +    Just _  -> acc
    221 
    +    Nothing ->
    222 
    +      let newId = ssNextId acc
    223 
    +      in acc { ssNodeOrder = Map.insert node newId (ssNodeOrder acc)
    224 
    +             , ssNodes = ssNodes acc ++ [node]
    225 
    +             , ssNextId = newId + 1
    226 
    +             }
    227 
    +
    228 
    +addSplitOwner :: CLabel -> SplitNodeKey -> SplitSecAcc -> SplitSecAcc
    229 
    +addSplitOwner lbl node acc =
    230 
    +  let acc' = ensureSplitNode node acc
    231 
    +  in acc' { ssOwner = Map.insert lbl node (ssOwner acc') }
    232 
    +
    233 
    +addSplitRefs :: SplitNodeKey -> Set.Set CLabel -> SplitSecAcc -> SplitSecAcc
    234 
    +addSplitRefs node refs acc =
    235 
    +  let acc' = ensureSplitNode node acc
    236 
    +      refs' = Map.findWithDefault Set.empty node (ssPendingRefs acc')
    237 
    +      refs'' = refs `Set.union` refs'
    238 
    +  in acc' { ssPendingRefs = Map.insert node refs'' (ssPendingRefs acc') }
    239 
    +
    240 
    +sectionTypeKey :: SectionType -> Int
    241 
    +sectionTypeKey t = case t of
    242 
    +  Text                    -> 0
    243 
    +  Data                    -> 1
    244 
    +  ReadOnlyData            -> 2
    245 
    +  RelocatableReadOnlyData -> 3
    246 
    +  UninitialisedData       -> 4
    247 
    +  InitArray               -> 5
    248 
    +  FiniArray               -> 6
    249 
    +  CString                 -> 7
    250 
    +  IPE                     -> 8
    251 
    +
    252 
    +instance Eq SplitNodeKey where
    253 
    +  SplitNodeKey t1 l1 == SplitNodeKey t2 l2 =
    254 
    +    sectionTypeKey t1 == sectionTypeKey t2 && l1 == l2
    255 
    +
    256 
    +instance Ord SplitNodeKey where
    257 
    +  compare (SplitNodeKey t1 l1) (SplitNodeKey t2 l2) =
    258 
    +    compare (sectionTypeKey t1, l1) (sectionTypeKey t2, l2)
    259 
    +
    260 
    +shouldGroupSplitSections :: NCGConfig -> Bool
    261 
    +shouldGroupSplitSections config =
    262 
    +  ncgSplitSections config && case platformOS (ncgPlatform config) of
    263 
    +    OSDarwin -> False
    264 
    +    OSAIX    -> False
    265 
    +    _        -> True
    266 
    +
    267 
    +labelsOfCmmLit :: CmmLit -> Set.Set CLabel
    268 
    +labelsOfCmmLit lit = case lit of
    269 
    +  CmmLabel lbl             -> Set.singleton lbl
    270 
    +  CmmLabelOff lbl _         -> Set.singleton lbl
    271 
    +  CmmLabelDiffOff lbl1 lbl2 _ _ -> Set.fromList [lbl1, lbl2]
    272 
    +  _                        -> Set.empty
    273 
    +
    274 
    +labelsOfCmmExpr :: CmmExpr -> Set.Set CLabel -> Set.Set CLabel
    275 
    +labelsOfCmmExpr expr acc = case expr of
    276 
    +  CmmLit lit -> labelsOfCmmLit lit `Set.union` acc
    277 
    +  _          -> acc
    278 
    +
    279 
    +collectStaticsLabels :: [CmmStatic] -> Set.Set CLabel
    280 
    +collectStaticsLabels = foldl' collect Set.empty
    281 
    +  where
    282 
    +    collect acc (CmmStaticLit lit) = labelsOfCmmLit lit `Set.union` acc
    283 
    +    collect acc _                  = acc
    284 
    +
    285 
    +collectGraphLabels :: CmmGraph -> Set.Set CLabel
    286 
    +collectGraphLabels graph =
    287 
    +  foldl' collectBlock Set.empty (toBlockList graph)
    288 
    +  where
    289 
    +    collectBlock acc block =
    290 
    +      foldBlockNodesF (\node a -> foldExpDeep labelsOfCmmExpr node a) block acc
    291 
    +
    292 
    +procSectionLabelRaw :: RawCmmDecl -> CLabel
    293 
    +procSectionLabelRaw (CmmProc infos entry _ graph) =
    294 
    +  case mapLookup (g_entry graph) infos of
    295 
    +    Just (CmmStaticsRaw info_lbl _) -> info_lbl
    296 
    +    Nothing                         -> entry
    297 
    +procSectionLabelRaw _ = panic "procSectionLabelRaw: not a CmmProc"
    298 
    +
    299 
    +procSectionLabelNat :: NatCmmDecl statics instr -> CLabel
    300 
    +procSectionLabelNat (CmmProc infos entry _ (ListGraph blocks)) =
    301 
    +  case find (\b -> blockLbl (blockId b) == entry) blocks of
    302 
    +    Just b ->
    303 
    +      case mapLookup (blockId b) infos of
    304 
    +        Just (CmmStaticsRaw info_lbl _) -> info_lbl
    305 
    +        Nothing                         -> entry
    306 
    +    Nothing -> entry
    307 
    +procSectionLabelNat _ = panic "procSectionLabelNat: not a CmmProc"
    308 
    +
    309 
    +collectSplitSecRawDecl :: RawCmmDecl -> SplitSecAcc -> SplitSecAcc
    310 
    +collectSplitSecRawDecl decl acc = case decl of
    311 
    +  CmmData (Section secTy suffix) (CmmStaticsRaw _ statics) ->
    312 
    +    let node = SplitNodeKey secTy suffix
    313 
    +        acc' = addSplitOwner suffix node acc
    314 
    +        refs = collectStaticsLabels statics
    315 
    +    in addSplitRefs node refs acc'
    316 
    +  CmmProc infos entry _ graph ->
    317 
    +    let procLbl = procSectionLabelRaw decl
    318 
    +        procNode = SplitNodeKey Text procLbl
    319 
    +        acc1 = addSplitOwner entry procNode acc
    320 
    +        acc2 = addSplitOwner procLbl procNode acc1
    321 
    +        acc3 = foldl' (\a b -> addSplitOwner (blockLbl (entryLabel b)) procNode a)
    322 
    +                      acc2 (toBlockList graph)
    323 
    +        infoStatics = mapElems infos
    324 
    +        acc4 = foldl' (\a (CmmStaticsRaw info_lbl _) -> addSplitOwner info_lbl procNode a)
    325 
    +                      acc3 infoStatics
    326 
    +        infoRefs = foldl' (\s (CmmStaticsRaw _ st) -> collectStaticsLabels st `Set.union` s)
    327 
    +                          Set.empty infoStatics
    328 
    +        graphRefs = collectGraphLabels graph
    329 
    +        refs = graphRefs `Set.union` infoRefs
    330 
    +    in addSplitRefs procNode refs acc4
    331 
    +
    332 
    +collectSplitSecJumpTables :: [NatCmmDecl statics instr] -> SplitSecAcc -> SplitSecAcc
    333 
    +collectSplitSecJumpTables decls acc = go Nothing acc decls
    334 
    +  where
    335 
    +    go _ acc' [] = acc'
    336 
    +    go mProc acc' (d:ds) = case d of
    337 
    +      CmmProc _ _ _ _ ->
    338 
    +        let procLbl = procSectionLabelNat d
    339 
    +            procNode = SplitNodeKey Text procLbl
    340 
    +            acc'' = addSplitOwner procLbl procNode acc'
    341 
    +        in go (Just procLbl) acc'' ds
    342 
    +      CmmData (Section secTy suffix) _ ->
    343 
    +        case mProc of
    344 
    +          Nothing      -> go mProc acc' ds
    345 
    +          Just procLbl ->
    346 
    +            let procNode = SplitNodeKey Text procLbl
    347 
    +                tableNode = SplitNodeKey secTy suffix
    348 
    +                acc1 = addSplitOwner suffix tableNode acc'
    349 
    +                acc2 = addSplitRefs procNode (Set.singleton suffix) acc1
    350 
    +                acc3 = addSplitRefs tableNode (Set.singleton procLbl) acc2
    351 
    +            in go mProc acc3 ds
    352 
    +
    353 
    +splitSectionGroups :: SplitSecAcc -> Map.Map SplitNodeKey CLabel
    354 
    +splitSectionGroups acc =
    355 
    +  let nodes = ssNodes acc
    356 
    +      owner = ssOwner acc
    357 
    +      refsMap = ssPendingRefs acc
    358 
    +      nodeOrder node = Map.findWithDefault maxBound node (ssNodeOrder acc)
    359 
    +      edgesFor node =
    360 
    +        let refs = Map.findWithDefault Set.empty node refsMap
    361 
    +            addRef s lbl =
    362 
    +              case Map.lookup lbl owner of
    363 
    +                Just node' -> Set.insert node' s
    364 
    +                Nothing    -> s
    365 
    +        in Set.toList (Set.foldl' addRef Set.empty refs)
    366 
    +      sccs = Graph.stronglyConnComp [ (node, node, edgesFor node) | node <- nodes ]
    367 
    +  in foldl' (assignScc nodeOrder) Map.empty sccs
    368 
    +  where
    369 
    +    assignScc nodeOrder acc' scc =
    370 
    +      let sccNodes = case scc of
    371 
    +            Graph.AcyclicSCC n  -> [n]
    372 
    +            Graph.CyclicSCC ns -> ns
    373 
    +          reps = foldl' (pickRep nodeOrder) Map.empty sccNodes
    374 
    +          pickRep order repsAcc node@(SplitNodeKey secTy lbl) =
    375 
    +            let secKey = sectionTypeKey secTy in
    376 
    +            case Map.lookup secKey repsAcc of
    377 
    +              Nothing -> Map.insert secKey lbl repsAcc
    378 
    +              Just curLbl ->
    379 
    +                if order node < order (SplitNodeKey secTy curLbl)
    380 
    +                  then Map.insert secKey lbl repsAcc
    381 
    +                  else repsAcc
    382 
    +          addNode m node@(SplitNodeKey secTy _) =
    383 
    +            case Map.lookup (sectionTypeKey secTy) reps of
    384 
    +              Just repLbl -> Map.insert node repLbl m
    385 
    +              Nothing     -> m
    386 
    +      in foldl' addNode acc' sccNodes
    387 
    +
    388 
    +splitSectionRewriteMap :: NCGConfig -> SplitSecAcc -> Map.Map BS8.ByteString BS8.ByteString
    389 
    +splitSectionRewriteMap config acc =
    390 
    +  let ctx = ncgAsmContext config
    391 
    +      groups = splitSectionGroups acc
    392 
    +      lineFor secTy lbl =
    393 
    +        BS8.pack $ showSDocOneLine ctx (pprSectionHeader config (Section secTy lbl))
    394 
    +      addEntry m (SplitNodeKey secTy oldLbl) newLbl =
    395 
    +        let oldLine = lineFor secTy oldLbl
    396 
    +            newLine = lineFor secTy newLbl
    397 
    +        in if oldLine == newLine
    398 
    +             then m
    399 
    +             else case Map.lookup oldLine m of
    400 
    +                    Nothing -> Map.insert oldLine newLine m
    401 
    +                    Just _  -> m
    402 
    +  in Map.foldlWithKey' addEntry Map.empty groups
    403 
    +
    404 
    +rewriteSplitSections :: Map.Map BS8.ByteString BS8.ByteString -> Handle -> Handle -> IO ()
    405 
    +rewriteSplitSections mapping hIn hOut = loop
    406 
    +  where
    407 
    +    sectionPrefix = BS8.pack ".section "
    408 
    +    loop = do
    409 
    +      eof <- hIsEOF hIn
    410 
    +      unless eof $ do
    411 
    +        line <- BS8.hGetLine hIn
    412 
    +        let (prefix, body) = BS8.span isSpace line
    413 
    +            line' =
    414 
    +              if BS8.isPrefixOf sectionPrefix body
    415 
    +                then case Map.lookup body mapping of
    416 
    +                       Just newBody -> BS8.append prefix newBody
    417 
    +                       Nothing      -> line
    418 
    +                else line
    419 
    +        BS8.hPut hOut line'
    420 
    +        BS8.hPut hOut (BS8.singleton '\n')
    421 
    +        loop
    422 
    +
    423 
    +nativeCodeGenGrouped :: (OutputableP Platform statics, Outputable jumpDest, Instruction instr)
    424 
    +               => Logger
    425 
    +               -> NCGConfig
    426 
    +               -> ModLocation
    427 
    +               -> NcgImpl statics instr jumpDest
    428 
    +               -> Handle
    429 
    +               -> CgStream RawCmmGroup a
    430 
    +               -> UniqDSMT IO a
    431 
    +nativeCodeGenGrouped logger config modLoc ncgImpl h cmms = do
    432 
    +  tmpDir <- liftIO getTemporaryDirectory
    433 
    +  (tmpPath, tmpHandle) <- liftIO $ openBinaryTempFile tmpDir "ghc-split-sections"
    434 
    +  (a, acc) <- nativeCodeGen' logger config modLoc ncgImpl True tmpHandle cmms
    435 
    +  liftIO $ hClose tmpHandle
    436 
    +  let mapping = splitSectionRewriteMap config acc
    437 
    +  liftIO $ withBinaryFile tmpPath ReadMode $ \hIn ->
    438 
    +    rewriteSplitSections mapping hIn h
    439 
    +  liftIO $ removeFile tmpPath
    440 
    +  return a
    441 
    +
    179 442 
     {-
    180 443 
     Note [Unwinding information in the NCG]
    181 444 
     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    ... ... @@ -205,19 +468,22 @@ nativeCodeGen' :: (OutputableP Platform statics, Outputable jumpDest, Instructio
    205 468 
                    -> NCGConfig
    206 469 
                    -> ModLocation
    207 470 
                    -> NcgImpl statics instr jumpDest
    471 
    +               -> Bool
    208 472 
                    -> Handle
    209 473 
                    -> CgStream RawCmmGroup a
    210 
    -               -> UniqDSMT IO a
    211 
    -nativeCodeGen' logger config modLoc ncgImpl h cmms
    474 
    +               -> UniqDSMT IO (a, SplitSecAcc)
    475 
    +nativeCodeGen' logger config modLoc ncgImpl collectSplit h cmms
    212 476 
      = do
    213 477 
             -- BufHandle is a performance hack.  We could hide it inside
    214 478 
             -- Pretty if it weren't for the fact that we do lots of little
    215 479 
             -- printDocs here (in order to do codegen in constant space).
    216 480 
             bufh <- liftIO $ newBufHandle h
    217 
    -        let ngs0 = NGS [] [] [] [] [] [] emptyUFM mapEmpty
    481 
    +        let splitAcc = if collectSplit then Just emptySplitSecAcc else Nothing
    482 
    +        let ngs0 = NGS [] [] [] [] [] [] emptyUFM mapEmpty splitAcc
    218 483 
             (ngs, a) <- cmmNativeGenStream logger config modLoc ncgImpl bufh cmms ngs0
    219 484 
             _ <- finishNativeGen logger config modLoc bufh ngs
    220 
    -        return a
    485 
    +        let finalAcc = fromMaybe emptySplitSecAcc (ngs_splitSecAcc ngs)
    486 
    +        return (a, finalAcc)
    221 487
    222 488 
     finishNativeGen :: Instruction instr
    223 489 
                     => Logger
    ... ... @@ -359,7 +625,11 @@ cmmNativeGens logger config ncgImpl h dbgMap = go
    359 625 
             return (ngs, us)
    360 626
    361 627 
         go (cmm : cmms) ngs count us = do
    362 
    -        let fileIds = ngs_dwarfFiles ngs
    628 
    +        let ngs1 = case ngs_splitSecAcc ngs of
    629 
    +              Nothing  -> ngs
    630 
    +              Just acc -> ngs { ngs_splitSecAcc = Just (collectSplitSecRawDecl cmm acc) }
    631 
    +
    632 
    +        let fileIds = ngs_dwarfFiles ngs1
    363 633 
             (us', fileIds', native, imports, colorStats, linearStats, unwinds, mcfg)
    364 634 
               <- {-# SCC "cmmNativeGen" #-}
    365 635 
                  cmmNativeGen logger ncgImpl us fileIds dbgMap
    ... ... @@ -399,15 +669,17 @@ cmmNativeGens logger config ncgImpl h dbgMap = go
    399 669 
                             then native : ngs_natives ngs else []
    400 670
    401 671 
                 mCon = maybe id (:)
    402 
    -            ngs' = ngs{ ngs_imports     = imports : ngs_imports ngs
    403 
    -                      , ngs_natives     = natives'
    404 
    -                      , ngs_colorStats  = colorStats `mCon` ngs_colorStats ngs
    405 
    -                      , ngs_linearStats = linearStats `mCon` ngs_linearStats ngs
    406 
    -                      , ngs_labels      = ngs_labels ngs ++ labels'
    407 
    -                      , ngs_dwarfFiles  = fileIds'
    408 
    -                      , ngs_unwinds     = ngs_unwinds ngs `mapUnion` unwinds
    409 
    -                      }
    410 
    -        go cmms ngs' (count + 1) us'
    672 
    +            ngs' = ngs1{ ngs_imports     = imports : ngs_imports ngs1
    673 
    +                       , ngs_natives     = natives'
    674 
    +                       , ngs_colorStats  = colorStats `mCon` ngs_colorStats ngs1
    675 
    +                       , ngs_linearStats = linearStats `mCon` ngs_linearStats ngs1
    676 
    +                       , ngs_labels      = ngs_labels ngs1 ++ labels'
    677 
    +                       , ngs_dwarfFiles  = fileIds'
    678 
    +                       , ngs_unwinds     = ngs_unwinds ngs1 `mapUnion` unwinds
    679 
    +                       }
    680 
    +            ngs'' = ngs' { ngs_splitSecAcc =
    681 
    +                             fmap (collectSplitSecJumpTables native) (ngs_splitSecAcc ngs') }
    682 
    +        go cmms ngs'' (count + 1) us'
    411 683
    412 684
    413 685 
     -- see Note [pprNatCmmDeclS and pprNatCmmDeclH] in GHC.CmmToAsm.Monad

  • compiler/GHC/HsToCore/Foreign/Wasm.hs
    ... ... @@ -224,6 +224,25 @@ especially since leaving all the boxing/unboxing business to C unifies
    224 224 
     the implementation of JSFFI imports and exports
    225 225 
     (rts_mkJSVal/rts_getJSVal).
    226 226
    227 
    +We don't support unboxed FFI types like Int# etc. But we do support
    228 
    +one kind of unlifted FFI type for JSFFI import arguments:
    229 
    +ByteArray#/MutableByteArray#. The semantics is the same in C: the
    230 
    +pointer to the ByteArray# payload is passed instead of the ByteArray#
    231 
    +closure itself. This allows efficient zero-copy data exchange between
    232 
    +Haskell and JavaScript using unpinned ByteArray#, and the following
    233 
    +conditions must be met:
    234 
    +
    235 
    +- The JSFFI import itself must be a sync import marked as unsafe
    236 
    +- The JavaScript code must not re-enter Haskell when a ByteArray# is
    237 
    +  passed as argument
    238 
    +
    239 
    +There's no magic in the handling of ByteArray#/MutableByteArray#
    240 
    +arguments. When generating C stub, we treat them like Ptr that points
    241 
    +to the payload, just without the rts_getPtr() unboxing call. After
    242 
    +lowering to C import, the backend takes care of adding the offset, see
    243 
    +add_shim in GHC.StgToCmm.Foreign and
    244 
    +Note [Unlifted boxed arguments to foreign calls].
    245 
    +
    227 246 
     Now, each sync import calls a generated C function with a unique
    228 247 
     symbol. The C function uses rts_get* to unbox the arguments, call into
    229 248 
     JavaScript, then boxes the result with rts_mk* and returns it to
    ... ... @@ -517,8 +536,9 @@ importCStub sync cfun_name arg_tys res_ty js_src = CStub c_doc [] []
    517 536 
         cfun_ret
    518 537 
           | res_ty `eqType` unitTy = cfun_call_import <> semi
    519 538 
           | otherwise = text "return" <+> cfun_call_import <> semi
    520 
    -    cfun_make_arg arg_ty arg_val =
    521 
    -      text ("rts_get" ++ ffiType arg_ty) <> parens arg_val
    539 
    +    cfun_make_arg arg_ty arg_val
    540 
    +      | isByteArrayPrimTy arg_ty = arg_val
    541 
    +      | otherwise = text ("rts_get" ++ ffiType arg_ty) <> parens arg_val
    522 542 
         cfun_make_ret ret_val
    523 543 
           | res_ty `eqType` unitTy = ret_val
    524 544 
           | otherwise =
    ... ... @@ -543,7 +563,11 @@ importCStub sync cfun_name arg_tys res_ty js_src = CStub c_doc [] []
    543 563 
           | res_ty `eqType` unitTy = text "void"
    544 564 
           | otherwise = text "HaskellObj"
    545 565 
         cfun_arg_list =
    546 
    -      [text "HaskellObj" <+> char 'a' <> int n | n <- [1 .. length arg_tys]]
    566 
    +      [ text (if isByteArrayPrimTy arg_ty then "HsPtr" else "HaskellObj")
    567 
    +          <+> char 'a'
    568 
    +          <> int n
    569 
    +      | (arg_ty, n) <- zip arg_tys [1 ..]
    570 
    +      ]
    547 571 
         cfun_args = case cfun_arg_list of
    548 572 
           [] -> text "void"
    549 573 
           _ -> hsep $ punctuate comma cfun_arg_list
    ... ... @@ -746,8 +770,18 @@ lookupGhcInternalTyCon m t = do
    746 770 
       n <- lookupOrig (mkGhcInternalModule m) (mkTcOcc t)
    747 771 
       dsLookupTyCon n
    748 772
    773 
    +isByteArrayPrimTy :: Type -> Bool
    774 
    +isByteArrayPrimTy ty
    775 
    +  | Just tc <- tyConAppTyCon_maybe ty,
    776 
    +    tc == byteArrayPrimTyCon || tc == mutableByteArrayPrimTyCon =
    777 
    +      True
    778 
    +  | otherwise =
    779 
    +      False
    780 
    +
    749 781 
     ffiType :: Type -> String
    750 
    -ffiType = occNameString . getOccName . fst . splitTyConApp
    782 
    +ffiType ty
    783 
    +  | isByteArrayPrimTy ty = "Ptr"
    784 
    +  | otherwise = occNameString $ getOccName $ tyConAppTyCon ty
    751 785
    752 786 
     commonCDecls :: SDoc
    753 787 
     commonCDecls =

  • compiler/GHC/Parser/String.hs
    ... ... @@ -19,6 +19,7 @@ import Data.Char (chr, ord)
    19 19 
     import qualified Data.Foldable1 as Foldable1
    20 20 
     import qualified Data.List.NonEmpty as NonEmpty
    21 21 
     import Data.Maybe (listToMaybe, mapMaybe)
    22 
    +import GHC.Data.OrdList (fromOL, nilOL, snocOL)
    22 23 
     import GHC.Data.StringBuffer (StringBuffer)
    23 24 
     import qualified GHC.Data.StringBuffer as StringBuffer
    24 25 
     import GHC.Parser.CharClass (
    ... ... @@ -167,16 +168,16 @@ collapseGaps = go
    167 168 
           [] -> panic "gap unexpectedly ended"
    168 169
    169 170 
     resolveEscapes :: HasChar c => [c] -> Either (c, LexErr) [c]
    170 
    -resolveEscapes = go dlistEmpty
    171 
    +resolveEscapes = go nilOL
    171 172 
       where
    172 173 
         go !acc = \case
    173 
    -      [] -> pure $ dlistToList acc
    174 
    +      [] -> pure $ fromOL acc
    174 175 
           Char '\\' : Char '&' : cs -> go acc cs
    175 176 
           backslash@(Char '\\') : cs ->
    176 177 
             case resolveEscapeChar cs of
    177 
    -          Right (esc, cs') -> go (acc `dlistSnoc` setChar esc backslash) cs'
    178 
    +          Right (esc, cs') -> go (acc `snocOL` setChar esc backslash) cs'
    178 179 
               Left (c, e) -> Left (c, e)
    179 
    -      c : cs -> go (acc `dlistSnoc` c) cs
    180 
    +      c : cs -> go (acc `snocOL` c) cs
    180 181
    181 182 
     -- -----------------------------------------------------------------------------
    182 183 
     -- Escape characters
    ... ... @@ -420,17 +421,3 @@ It's more precisely defined with the following algorithm:
    420 421 
         * Lines with only whitespace characters
    421 422 
     3. Calculate the longest prefix of whitespace shared by all lines in the remaining list
    422 423 
     -}
    423 
    -
    424 
    --- -----------------------------------------------------------------------------
    425 
    --- DList
    426 
    -
    427 
    -newtype DList a = DList ([a] -> [a])
    428 
    -
    429 
    -dlistEmpty :: DList a
    430 
    -dlistEmpty = DList id
    431 
    -
    432 
    -dlistToList :: DList a -> [a]
    433 
    -dlistToList (DList f) = f []
    434 
    -
    435 
    -dlistSnoc :: DList a -> a -> DList a
    436 
    -dlistSnoc (DList f) x = DList (f . (x :))

  • compiler/GHC/StgToCmm/InfoTableProv.hs
    ... ... @@ -11,6 +11,7 @@ import GHC.IO (unsafePerformIO)
    11 11 
     #endif
    12 12
    13 13 
     import Data.Char
    14 
    +import Data.Foldable
    14 15 
     import GHC.Prelude
    15 16 
     import GHC.Platform
    16 17 
     import GHC.Types.SrcLoc (pprUserRealSpan, srcSpanFile)
    ... ... @@ -18,6 +19,7 @@ import GHC.Types.Unique.DSM
    18 19 
     import GHC.Unit.Module
    19 20 
     import GHC.Utils.Outputable
    20 21 
     import GHC.Data.FastString (fastStringToShortText, unpackFS, LexicalFastString(..))
    22 
    +import GHC.Data.OrdList (OrdList, nilOL, snocOL)
    21 23
    22 24 
     import GHC.Cmm
    23 25 
     import GHC.Cmm.CLabel
    ... ... @@ -286,7 +288,7 @@ data CgInfoProvEnt = CgInfoProvEnt
    286 288 
                                    , ipeSrcSpan :: !StrTabOffset
    287 289 
                                    }
    288 290
    289 
    -data StringTable = StringTable { stStrings :: DList ShortText
    291 
    +data StringTable = StringTable { stStrings :: !(OrdList ShortText)
    290 292 
                                    , stLength :: !Int
    291 293 
                                    , stLookup :: !(M.Map ShortText StrTabOffset)
    292 294 
                                    }
    ... ... @@ -295,7 +297,7 @@ type StrTabOffset = Word32
    295 297
    296 298 
     emptyStringTable :: StringTable
    297 299 
     emptyStringTable =
    298 
    -    StringTable { stStrings = emptyDList
    300 
    +    StringTable { stStrings = nilOL
    299 301 
                     , stLength = 0
    300 302 
                     , stLookup = M.empty
    301 303 
                     }
    ... ... @@ -303,7 +305,7 @@ emptyStringTable =
    303 305 
     getStringTableStrings :: StringTable -> BS.ByteString
    304 306 
     getStringTableStrings st =
    305 307 
         BSL.toStrict $ BSB.toLazyByteString
    306 
    -    $ foldMap f $ dlistToList (stStrings st)
    308 
    +    $ foldMap' f $ stStrings st
    307 309 
       where
    308 310 
         f x = BSB.shortByteString (ST.contents x) `mappend` BSB.word8 0
    309 311
    ... ... @@ -312,7 +314,7 @@ lookupStringTable str = state $ \st ->
    312 314 
         case M.lookup str (stLookup st) of
    313 315 
           Just off -> (off, st)
    314 316 
           Nothing ->
    315 
    -          let !st' = st { stStrings = stStrings st `snoc` str
    317 
    +          let !st' = st { stStrings = stStrings st `snocOL` str
    316 318 
                             , stLength  = stLength st + ST.byteLength str + 1
    317 319 
                             , stLookup  = M.insert str res (stLookup st)
    318 320 
                             }
    ... ... @@ -359,14 +361,3 @@ foreign import ccall unsafe "ZSTD_compressBound"
    359 361
    360 362 
     defaultCompressionLevel :: Int
    361 363 
     defaultCompressionLevel = 3
    362 
    -
    363 
    -newtype DList a = DList ([a] -> [a])
    364 
    -
    365 
    -emptyDList :: DList a
    366 
    -emptyDList = DList id
    367 
    -
    368 
    -snoc :: DList a -> a -> DList a
    369 
    -snoc (DList f) x = DList (f . (x:))
    370 
    -
    371 
    -dlistToList :: DList a -> [a]
    372 
    -dlistToList (DList f) = f []

  • docs/users_guide/wasm.rst
    ... ... @@ -265,7 +265,7 @@ backend’s JavaScript FFI, which we’ll now abbreviate as JSFFI.
    265 265 
     Marshalable types and ``JSVal``
    266 266 
     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    267 267
    268 
    -JSFFI supports all boxed marshalable foreign types in C FFI:
    268 
    +JSFFI supports all lifted marshalable foreign types in C FFI:
    269 269
    270 270 
     -  ``Bool``
    271 271 
     -  ``Char``
    ... ... @@ -298,8 +298,14 @@ types in JSFFI. Some caveats to keep in mind:
    298 298 
        results in type errors, so keep this in mind. As for ``Int`` /
    299 299 
        ``Word``, they are 32-bit since the GHC wasm backend is based on
    300 300 
        ``wasm32`` .
    301 
    --  JSFFI doesn’t support unboxed foreign types like ``Int#``,
    302 
    -   ``ByteArray#``, etc, even when ``UnliftedFFITypes`` is enabled.
    301 
    +-  JSFFI doesn’t support unboxed foreign types like ``Int#``, even
    302 
    +   when ``UnliftedFFITypes`` is enabled. The only supported unlifted
    303 
    +   types are ``ByteArray#`` and ``MutableByteArray#``, they may only
    304 
    +   be used as JSFFI import argument types, with the same semantics in
    305 
    +   C FFI: the pointer to the payload is passed to JavaScript. Be
    306 
    +   careful and avoid calling back into Haskell in such cases,
    307 
    +   otherwise GC may occur and the pointer may be invalidated if it's
    308 
    +   unpinned!
    303 309
    304 310 
     In addition to the above types, JSFFI supports the ``JSVal`` type and
    305 311 
     its ``newtype``\ s as argument/result types. ``JSVal`` is defined in

  • hadrian/doc/flavours.md
    ... ... @@ -249,10 +249,6 @@ The supported transformers are listed below:
    249 249 
         <tr>
    250 250 
             <td><code>profiled_ghc</code></td>
    251 251 
             <td>Build the GHC executable with cost-centre profiling support.
    252 
    -            It is recommended that you use this in conjunction with `no_dynamic_ghc` since
    253 
    -            GHC does not support loading of profiled libraries with the
    254 
    -            dynamic linker. You should use a flavour that builds profiling libs and rts,
    255 
    -            i.e. not <code>quick</code>. <br>
    256 252 
                 This flag adds cost centres with the -fprof-late flag.</td>
    257 253 
         </tr>
    258 254 
         <tr>
    ... ... @@ -274,6 +270,10 @@ The supported transformers are listed below:
    274 270 
             <td><code>text_simdutf</code></td>
    275 271 
             <td>Enable building the <code>text</code> package with <code>simdutf</code> support.</td>
    276 272 
         </tr>
    273 
    +    <tr>
    274 
    +        <td><code>with_profiled_libs</code></td>
    275 
    +        <td>Enables building of stage1+ libraries and the RTS in profiled build ways (the opposite of <code>no_profiled_libs</code>).</td>
    276 
    +    </tr>
    277 277 
         <tr>
    278 278 
             <td><code>no_profiled_libs</code></td>
    279 279 
             <td>Disables building of libraries in profiled build ways.</td>

  • hadrian/src/Flavour.hs
    ... ... @@ -15,6 +15,7 @@ module Flavour
    15 15 
       , enableProfiledGhc
    16 16 
       , disableDynamicGhcPrograms
    17 17 
       , disableDynamicLibs
    18 
    +  , enableProfiledLibs
    18 19 
       , disableProfiledLibs
    19 20 
       , enableLinting
    20 21 
       , enableHaddock
    ... ... @@ -62,6 +63,7 @@ flavourTransformers = M.fromList
    62 63 
         , "no_dynamic_libs"  =: disableDynamicLibs
    63 64 
         , "native_bignum"    =: useNativeBignum
    64 65 
         , "text_simdutf"     =: enableTextWithSIMDUTF
    66 
    +    , "with_profiled_libs" =: enableProfiledLibs
    65 67 
         , "no_profiled_libs" =: disableProfiledLibs
    66 68 
         , "omit_pragmas"     =: omitPragmas
    67 69 
         , "ipe"              =: enableIPE
    ... ... @@ -169,6 +171,7 @@ enableDebugInfo :: Flavour -> Flavour
    169 171 
     enableDebugInfo = addArgs $ notStage0 ? mconcat
    170 172 
         [ builder (Ghc CompileHs) ? pure ["-g3"]
    171 173 
         , builder (Ghc CompileCWithGhc) ? pure ["-optc-g3"]
    174 
    +    , builder (Ghc CompileCppWithGhc) ? pure ["-optcxx-g3"]
    172 175 
         , builder (Cc CompileC) ? arg "-g3"
    173 176 
         , builder (Cabal Setup) ? arg "--disable-library-stripping"
    174 177 
         , builder (Cabal Setup) ? arg "--disable-executable-stripping"
    ... ... @@ -307,29 +310,11 @@ enableUBSan =
    307 310 
     viaLlvmBackend :: Flavour -> Flavour
    308 311 
     viaLlvmBackend = addArgs $ notStage0 ? builder Ghc ? arg "-fllvm"
    309 312
    310 
    --- | Build the GHC executable with profiling enabled in stages 2 and later. It
    311 
    --- is also recommended that you use this with @'dynamicGhcPrograms' = False@
    312 
    --- since GHC does not support loading of profiled libraries with the
    313 
    --- dynamically-linker.
    313 
    +-- | Build the GHC executable with profiling enabled in stages 2 and
    314 
    +-- later.
    314 315 
     enableProfiledGhc :: Flavour -> Flavour
    315 316 
     enableProfiledGhc flavour =
    316 
    -  enableLateCCS flavour
    317 
    -    { rtsWays = do
    318 
    -        ws <- rtsWays flavour
    319 
    -        mconcat
    320 
    -          [ pure ws
    321 
    -          , buildingCompilerStage' (>= Stage2) ? pure (foldMap profiled_ways ws)
    322 
    -          ]
    323 
    -    , libraryWays = mconcat
    324 
    -        [ libraryWays flavour
    325 
    -        , buildingCompilerStage' (>= Stage2) ? pure (Set.singleton profiling)
    326 
    -        ]
    327 
    -    , ghcProfiled = (>= Stage2)
    328 
    -    }
    329 
    -    where
    330 
    -      profiled_ways w
    331 
    -        | wayUnit Dynamic w = Set.empty
    332 
    -        | otherwise         = Set.singleton (w <> profiling)
    317 
    +  enableLateCCS $ enableProfiledLibs flavour { ghcProfiled = (>= Stage2) }
    333 318
    334 319 
     -- | Disable 'dynamicGhcPrograms'.
    335 320 
     disableDynamicGhcPrograms :: Flavour -> Flavour
    ... ... @@ -346,6 +331,20 @@ disableDynamicLibs flavour =
    346 331 
         prune :: Ways -> Ways
    347 332 
         prune = fmap $ Set.filter (not . wayUnit Dynamic)
    348 333
    334 
    +-- | Build libraries and the RTS in profiled ways (opposite of
    335 
    +-- 'disableProfiledLibs').
    336 
    +enableProfiledLibs :: Flavour -> Flavour
    337 
    +enableProfiledLibs flavour =
    338 
    +  flavour
    339 
    +    { libraryWays = addProfilingWays $ libraryWays flavour,
    340 
    +      rtsWays = addProfilingWays $ rtsWays flavour
    341 
    +    }
    342 
    +  where
    343 
    +    addProfilingWays :: Ways -> Ways
    344 
    +    addProfilingWays ways = do
    345 
    +      ws <- ways
    346 
    +      buildProfiled <- notStage0
    347 
    +      pure $ if buildProfiled then ws <> Set.map (<> profiling) ws else ws
    349 348
    350 349 
     -- | Don't build libraries in profiled 'Way's.
    351 350 
     disableProfiledLibs :: Flavour -> Flavour

  • hadrian/src/Settings/Packages.hs
    ... ... @@ -351,7 +351,7 @@ rtsPackageArgs = package rts ? do
    351 351 
               , Debug     `wayUnit` way          ? pure [ "-DDEBUG"
    352 352 
                                                         , "-fno-omit-frame-pointer"
    353 353 
                                                         , "-g3"
    354 
    -                                                    , "-O0" ]
    354 
    +                                                    , "-Og" ]
    355 355 
               -- Set the namespace for the rts fs functions
    356 356 
               , arg $ "-DFS_NAMESPACE=rts"
    357 357

  • libraries/ghc-internal/src/GHC/Internal/IO/Handle.hs
    ... ... @@ -480,7 +480,7 @@ hIsOpen handle =
    480 480 
           SemiClosedHandle     -> return False
    481 481 
           _                    -> return True
    482 482
    483 
    --- | @'hIsOpen' hdl@ returns whether the handle is closed.
    483 
    +-- | @'hIsClosed' hdl@ returns whether the handle is closed.
    484 484 
     -- If the 'haType' of @hdl@ is 'ClosedHandle' this returns 'True'
    485 485 
     -- and 'False' otherwise.
    486 486 
     hIsClosed :: Handle -> IO Bool

  • rts/linker/InitFini.c
    ... ... @@ -75,7 +75,7 @@ static void sortInitFiniList(struct InitFiniList **slist, enum SortOrder order)
    75 75 
             while (*last != NULL && (*last)->next != NULL) {
    76 76 
                 struct InitFiniList *s0 = *last;
    77 77 
                 struct InitFiniList *s1 = s0->next;
    78 
    -            bool flip;
    78 
    +            bool flip = false;
    79 79 
                 switch (order) {
    80 80 
                     case INCREASING: flip = s0->priority > s1->priority; break;
    81 81 
                     case DECREASING: flip = s0->priority < s1->priority; break;

  • rts/sm/Sanity.c
    ... ... @@ -692,7 +692,7 @@ checkCompactObjects(bdescr *bd)
    692 692 
             ASSERT((W_)str == (W_)block + sizeof(StgCompactNFDataBlock));
    693 693
    694 694 
             StgWord totalW = 0;
    695 
    -        StgCompactNFDataBlock *last;
    695 
    +        StgCompactNFDataBlock *last = block;
    696 696 
             for ( ; block ; block = block->next) {
    697 697 
                 last = block;
    698 698 
                 ASSERT(block->owner == str);

  • testsuite/tests/jsffi/all.T
    ... ... @@ -25,4 +25,6 @@ test('jsffion', [], compile_and_run, ['-optl-Wl,--export=main'])
    25 25
    26 26 
     test('jsffisleep', [], compile_and_run, ['-optl-Wl,--export=testWouldBlock,--export=testLazySleep,--export=testThreadDelay,--export=testInterruptingSleep'])
    27 27
    28 
    +test('bytearrayarg', [], compile_and_run, ['-optl-Wl,--export=main'])
    29 
    +
    28 30 
     test('textconv', [], compile_and_run, ['-optl-Wl,--export=main'])

  • testsuite/tests/jsffi/bytearrayarg.hs
    1 
    +{-# LANGUAGE MagicHash #-}
    2 
    +{-# LANGUAGE UnboxedTuples #-}
    3 
    +{-# LANGUAGE UnliftedFFITypes #-}
    4 
    +
    5 
    +module Test where
    6 
    +
    7 
    +import GHC.Exts
    8 
    +import GHC.IO
    9 
    +import GHC.Word (Word8(W8#))
    10 
    +
    11 
    +foreign import javascript unsafe "(() => { const u8 = new Uint8Array(__exports.memory.buffer, $1, 4); return (u8[0] === 0x12 && u8[1] === 0x34 && u8[2] === 0x56 && u8[3] === 0x78) ? 1 : 0; })()"
    12 
    +  js_check_mba :: MutableByteArray# RealWorld -> IO Int
    13 
    +
    14 
    +foreign import javascript unsafe "(() => { const u8 = new Uint8Array(__exports.memory.buffer, $1, 4); return (u8[0] === 0x12 && u8[1] === 0x34 && u8[2] === 0x56 && u8[3] === 0x78) ? 1 : 0; })()"
    15 
    +  js_check_ba :: ByteArray# -> IO Int
    16 
    +
    17 
    +foreign export javascript "main"
    18 
    +  main :: IO ()
    19 
    +
    20 
    +main :: IO ()
    21 
    +main =
    22 
    +  IO $ \s0 ->
    23 
    +    case newPinnedByteArray# 4# s0 of
    24 
    +      (# s1, mba# #) ->
    25 
    +        case (0x12 :: Word8) of { W8# b0# ->
    26 
    +        case (0x34 :: Word8) of { W8# b1# ->
    27 
    +        case (0x56 :: Word8) of { W8# b2# ->
    28 
    +        case (0x78 :: Word8) of { W8# b3# ->
    29 
    +          let s2 = writeWord8Array# mba# 0# b0# s1
    30 
    +              s3 = writeWord8Array# mba# 1# b1# s2
    31 
    +              s4 = writeWord8Array# mba# 2# b2# s3
    32 
    +              s5 = writeWord8Array# mba# 3# b3# s4
    33 
    +           in case unIO (js_check_mba mba#) s5 of
    34 
    +                (# s6, ok_mba #) -> case unsafeFreezeByteArray# mba# s6 of
    35 
    +                  (# s7, ba# #) -> case unIO (js_check_ba ba#) s7 of
    36 
    +                    (# s8, ok_ba #) -> case unIO (print ok_mba) s8 of
    37 
    +                      (# s9, _ #) -> case unIO (print ok_ba) s9 of
    38 
    +                        (# s10, _ #) -> (# s10, () #)
    39 
    +        }}}}

  • testsuite/tests/jsffi/bytearrayarg.mjs
    1 
    +export default async (__exports) => {
    2 
    +  await __exports.main();
    3 
    +  process.exit();
    4 
    +}

  • testsuite/tests/jsffi/bytearrayarg.stdout
    1 
    +1
    2 
    +1

  • testsuite/tests/perf/should_run/all.T
    ... ... @@ -420,6 +420,7 @@ test('T17949', [collect_stats('bytes allocated', 1), only_ways(['normal'])], com
    420 420 
     test('ByteCodeAsm',
    421 421 
                    [ extra_run_opts('"' + config.libdir + '"')
    422 422 
                    , js_broken(22261)
    423 
    +               , when(arch('wasm32'), run_timeout_multiplier(10))
    423 424 
                    , collect_stats('bytes allocated', 10),
    424 425 
                    ],
    425 426 
                    compile_and_run,

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help