Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC

Commits:

4 changed files:

Changes:

  • compiler/GHC/StgToCmm/Heap.hs
    1 
    +{-# LANGUAGE OverloadedStrings #-}
    1 2 
     -----------------------------------------------------------------------------
    2 3 
     --
    3 4 
     -- Stg to C--: heap management functions
    ... ... @@ -44,7 +45,7 @@ import GHC.Types.Id ( Id )
    44 45 
     import GHC.Unit
    45 46 
     import GHC.Platform
    46 47 
     import GHC.Platform.Profile
    47 
    -import GHC.Data.FastString( mkFastString, fsLit )
    48 
    +import GHC.Data.FastString( FastString )
    48 49 
     import GHC.Utils.Panic( sorry )
    49 50
    50 51 
     import Control.Monad (when)
    ... ... @@ -125,7 +126,7 @@ allocHeapClosure rep info_ptr use_cc payload = do
    125 126 
                 -- ie 1 *before* the info-ptr word of new object.
    126 127
    127 128 
       base <- getHpRelOffset info_offset
    128 
    -  emitComment $ mkFastString "allocHeapClosure"
    129 
    +  emitComment "allocHeapClosure"
    129 130 
       emitSetDynHdr base info_ptr use_cc
    130 131
    131 132 
       -- Fill in the fields
    ... ... @@ -460,35 +461,41 @@ genericGC checkYield code
    460 461 
            call <- mkCall generic_gc (GC, GC) [] [] updfr_sz []
    461 462 
            heapCheck False checkYield (call <*> mkBranch lretry) code
    462 463
    464 
    +-- | Predefined ("canned") GC functions
    465 
    +--
    466 
    +-- Functions have been added to cover 99% of the GC calls made in GHC and Cabal.
    467 
    +-- See #27142.
    463 468 
     cannedGCEntryPoint :: Platform -> [LocalReg] -> Maybe CmmExpr
    464 
    -cannedGCEntryPoint platform regs
    465 
    -  = case map localRegType regs of
    466 
    -      []  -> Just (mkGcLabel "stg_gc_noregs")
    467 
    -      [ty]
    468 
    -          | isGcPtrType ty -> Just (mkGcLabel "stg_gc_unpt_r1")
    469 
    -          | isFloatType ty -> case width of
    470 
    -                                  W32       -> Just (mkGcLabel "stg_gc_f1")
    471 
    -                                  W64       -> Just (mkGcLabel "stg_gc_d1")
    472 
    -                                  _         -> Nothing
    473 
    -
    474 
    -          | width == wordWidth platform -> Just (mkGcLabel "stg_gc_unbx_r1")
    475 
    -          | width == W64                -> Just (mkGcLabel "stg_gc_l1")
    476 
    -          | otherwise                   -> Nothing
    477 
    -          where
    478 
    -              width = typeWidth ty
    479 
    -      [ty1,ty2]
    480 
    -          |  isGcPtrType ty1
    481 
    -          && isGcPtrType ty2 -> Just (mkGcLabel "stg_gc_pp")
    482 
    -      [ty1,ty2,ty3]
    483 
    -          |  isGcPtrType ty1
    484 
    -          && isGcPtrType ty2
    485 
    -          && isGcPtrType ty3 -> Just (mkGcLabel "stg_gc_ppp")
    486 
    -      [ty1,ty2,ty3,ty4]
    487 
    -          |  isGcPtrType ty1
    488 
    -          && isGcPtrType ty2
    489 
    -          && isGcPtrType ty3
    490 
    -          && isGcPtrType ty4 -> Just (mkGcLabel "stg_gc_pppp")
    491 
    -      _otherwise -> Nothing
    469 
    +cannedGCEntryPoint platform regs =
    470 
    +  case map localRegType regs of
    471 
    +    []   -> ret "stg_gc_noregs"
    472 
    +    [ty]
    473 
    +        | is_gc  ty -> ret "stg_gc_unpt_r1"
    474 
    +        | is_f32 ty -> ret "stg_gc_f1"
    475 
    +        | is_f64 ty -> ret "stg_gc_d1"
    476 
    +        | is_wn ty  -> ret "stg_gc_unbx_r1"
    477 
    +        | is_w64 ty -> ret "stg_gc_l1"
    478 
    +    [ty1,ty2]
    479 
    +        | is_gc ty1 && is_gc ty2 -> ret "stg_gc_pp"
    480 
    +        | is_gc ty1 && is_wn ty2 -> ret "stg_gc_pi"
    481 
    +        | is_wn ty1 && is_gc ty2 -> ret "stg_gc_ip"
    482 
    +        | is_wn ty1 && is_wn ty2 -> ret "stg_gc_ii"
    483 
    +    [ty1,ty2,ty3]
    484 
    +        | is_gc ty1 && is_gc ty2 && is_gc ty3 -> ret "stg_gc_ppp"
    485 
    +        | is_w8 ty1 && is_gc ty2 && is_gc ty3 -> ret "stg_gc_bpp"
    486 
    +    [ty1,ty2,ty3,ty4]
    487 
    +        | is_gc ty1 && is_gc ty2 && is_gc ty3 && is_gc ty4 -> ret "stg_gc_pppp"
    488 
    +    [ty1,ty2,ty3,ty4,ty5]
    489 
    +        | is_gc ty1 && is_gc ty2 && is_gc ty3 && is_gc ty4 && is_gc ty5 -> ret "stg_gc_ppppp"
    490 
    +    _ -> Nothing
    491 
    +  where
    492 
    +    ret fs = Just (mkGcLabel fs)
    493 
    +    is_gc  ty = isGcPtrType ty
    494 
    +    is_wn  ty = isBitsType ty && typeWidth ty == wordWidth platform
    495 
    +    is_w8  ty = isBitsType ty && typeWidth ty == W8
    496 
    +    is_w64 ty = isBitsType ty && typeWidth ty == W64
    497 
    +    is_f32 ty = isFloatType ty && typeWidth ty == W32
    498 
    +    is_f64 ty = isFloatType ty && typeWidth ty == W64
    492 499
    493 500 
     -- Note [stg_gc arguments]
    494 501 
     -- ~~~~~~~~~~~~~~~~~~~~~~~
    ... ... @@ -514,8 +521,8 @@ generic_gc :: CmmExpr
    514 521 
     generic_gc = mkGcLabel "stg_gc_noregs"
    515 522
    516 523 
     -- | Create a CLabel for calling a garbage collector entry point
    517 
    -mkGcLabel :: String -> CmmExpr
    518 
    -mkGcLabel s = CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit s)))
    524 
    +mkGcLabel :: FastString -> CmmExpr
    525 
    +mkGcLabel s = CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId s))
    519 526
    520 527 
     -------------------------------
    521 528 
     heapCheck :: Bool -> Bool -> CmmAGraph -> FCode a -> FCode a

  • rts/HeapStackCheck.cmm
    ... ... @@ -373,8 +373,6 @@ stg_gc_l1 return (L_ l)
    373 373 
         jump stg_gc_noregs (stg_ret_l_info, l) ();
    374 374 
     }
    375 375
    376 
    -/*-- Unboxed tuples with multiple pointers -------------------------------- */
    377 
    -
    378 376 
     stg_gc_pp return (P_ arg1, P_ arg2)
    379 377 
     {
    380 378 
         call stg_gc_noregs();
    ... ... @@ -393,6 +391,36 @@ stg_gc_pppp return (P_ arg1, P_ arg2, P_ arg3, P_ arg4)
    393 391 
         return (arg1,arg2,arg3,arg4);
    394 392 
     }
    395 393
    394 
    +stg_gc_ppppp return (P_ arg1, P_ arg2, P_ arg3, P_ arg4, P_ arg5)
    395 
    +{
    396 
    +    call stg_gc_noregs();
    397 
    +    return (arg1,arg2,arg3,arg4,arg5);
    398 
    +}
    399 
    +
    400 
    +stg_gc_ip return (W_ arg1, P_ arg2)
    401 
    +{
    402 
    +    call stg_gc_noregs();
    403 
    +    return (arg1,arg2);
    404 
    +}
    405 
    +
    406 
    +stg_gc_pi return (P_ arg1, W_ arg2)
    407 
    +{
    408 
    +    call stg_gc_noregs();
    409 
    +    return (arg1,arg2);
    410 
    +}
    411 
    +
    412 
    +stg_gc_ii return (W_ arg1, W_ arg2)
    413 
    +{
    414 
    +    call stg_gc_noregs();
    415 
    +    return (arg1,arg2);
    416 
    +}
    417 
    +
    418 
    +stg_gc_bpp return (I8 arg1, P_ arg2, P_ arg3)
    419 
    +{
    420 
    +    call stg_gc_noregs();
    421 
    +    return (arg1,arg2,arg3);
    422 
    +}
    423 
    +
    396 424 
     /* -----------------------------------------------------------------------------
    397 425 
        Generic function entry heap check code.
    398 426

  • rts/RtsSymbols.c
    ... ... @@ -499,6 +499,11 @@ extern char **environ;
    499 499 
           SymI_HasDataProto(stg_gc_pp)                                          \
    500 500 
           SymI_HasDataProto(stg_gc_ppp)                                         \
    501 501 
           SymI_HasDataProto(stg_gc_pppp)                                        \
    502 
    +      SymI_HasDataProto(stg_gc_ppppp)                                       \
    503 
    +      SymI_HasDataProto(stg_gc_ip)                                          \
    504 
    +      SymI_HasDataProto(stg_gc_pi)                                          \
    505 
    +      SymI_HasDataProto(stg_gc_ii)                                          \
    506 
    +      SymI_HasDataProto(stg_gc_bpp)                                         \
    502 507 
           SymI_HasDataProto(__stg_gc_fun)                                       \
    503 508 
           SymI_HasDataProto(stg_gc_fun_info)                                    \
    504 509 
           SymI_HasDataProto(stg_yield_noregs)                                   \

  • rts/include/stg/MiscClosures.h
    ... ... @@ -361,6 +361,11 @@ RTS_FUN_DECL(stg_gc_l1);
    361 361 
     RTS_FUN_DECL(stg_gc_pp);
    362 362 
     RTS_FUN_DECL(stg_gc_ppp);
    363 363 
     RTS_FUN_DECL(stg_gc_pppp);
    364 
    +RTS_FUN_DECL(stg_gc_ppppp);
    365 
    +RTS_FUN_DECL(stg_gc_ip);
    366 
    +RTS_FUN_DECL(stg_gc_pi);
    367 
    +RTS_FUN_DECL(stg_gc_ii);
    368 
    +RTS_FUN_DECL(stg_gc_bpp);
    364 369
    365 370 
     RTS_RET(stg_gc_fun);
    366 371 
     RTS_FUN_DECL(__stg_gc_fun);

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