Introduce a standard thunk for allocating stringswip/osa1/std_string_thunks

Currently for a top-level closure in the form

    hey = unpackCString# x

we generate code like this:

    Main.hey_entry() //  [R1]
             { info_tbls: [(c2T4,
                            label: Main.hey_info
                            rep: HeapRep static { Thunk }
                            srt: Nothing)]
               stack_info: arg_space: 8 updfr_space: Just 8
             }
         {offset
           c2T4: // global
               _rqm::P64 = R1;
               if ((Sp + 8) - 24 < SpLim) (likely: False) goto c2T5; else goto c2T6;
           c2T5: // global
               R1 = _rqm::P64;
               call (stg_gc_enter_1)(R1) args: 8, res: 0, upd: 8;
           c2T6: // global
               (_c2T1::I64) = call "ccall" arg hints:  [PtrHint,
                                                        PtrHint]  result hints:  [PtrHint] newCAF(BaseReg, _rqm::P64);
               if (_c2T1::I64 == 0) goto c2T3; else goto c2T2;
           c2T3: // global
               call (I64[_rqm::P64])() args: 8, res: 0, upd: 8;
           c2T2: // global
               I64[Sp - 16] = stg_bh_upd_frame_info;
               I64[Sp - 8] = _c2T1::I64;
               R2 = hey1_r2Gg_bytes;
               Sp = Sp - 16;
               call GHC.CString.unpackCString#_info(R2) args: 24, res: 0, upd: 24;
         }
     }

This code is generated for every string literal. Only difference between
top-level closures like this is the argument for the bytes of the string
(hey1_r2Gg_bytes in the code above).

With this patch we introduce a standard thunk in the RTS, called
stg_MK_STRING_info, that does what `unpackCString# x` does, except it
gets the bytes address from the payload. Using this, for the closure
above, we generate this:

    Main.hey_closure" {
        Main.hey_closure:
            const stg_MK_STRING_info;
            const 0; // padding for indirectee
            const 0; // static link
            const 0; // saved info
            const hey1_r1Gg_bytes; // the payload
    }

This is much smaller in code.

Metric Decrease:
    T10421
    T11195
    T12150
    T12425
    T16577
    T18282
    T18698a
    T18698b

Co-Authored By: Ben Gamari <ben@well-typed.com>

1 files changed, 44 insertions, 21 deletions

diff --git a/compiler/GHC/Cmm/Info/Build.hs b/compiler/GHC/Cmm/Info/Build.hs
index 4b9294020d..e363eb879d 100644
--- a/compiler/GHC/Cmm/Info/Build.hs
+++ b/compiler/GHC/Cmm/Info/Build.hs
@@ -576,7 +576,7 @@ cafAnalData
   -> CAFSet
 cafAnalData platform st = case st of
    CmmStaticsRaw _lbl _data           -> Set.empty
-   CmmStatics _lbl _itbl _ccs payload ->
+   CmmStatics _lbl _itbl _ccs payload _extras ->
        foldl' analyzeStatic Set.empty payload
      where
        analyzeStatic s lit =
@@ -741,7 +741,9 @@ getBlockLabels = mapMaybe getBlockLabel
 getLabelledBlocks :: Platform -> CmmDecl -> [(SomeLabel, CAFfyLabel)]
 getLabelledBlocks platform decl = case decl of
    CmmData _ (CmmStaticsRaw _ _)    -> []
-   CmmData _ (CmmStatics lbl _ _ _) -> [ (DeclLabel lbl, mkCAFfyLabel platform lbl) ]
+   CmmData _ (CmmStatics lbl info _ _ _) -> [ (DeclLabel lbl, mkCAFfyLabel platform lbl)
+                                            | not (isThunkRep (cit_rep info))
+                                            ]
    CmmProc top_info _ _ _           -> [ (BlockLabel blockId, caf_lbl)
                                        | (blockId, info) <- mapToList (info_tbls top_info)
                                        , let rep = cit_rep info
@@ -786,28 +788,48 @@ depAnalSRTs platform cafEnv cafEnv_static decls =
   graph :: [SCC (SomeLabel, CAFfyLabel, Set CAFfyLabel)]
   graph = stronglyConnCompFromEdgedVerticesOrd nodes
 
--- | Get @(Label, CAFfyLabel, Set CAFfyLabel)@ for each CAF block.
--- The @Set CafLabel@ represents the set of CAFfy things which this CAF's code
+-- | Get @(Maybe Label, CAFfyLabel, Set CAFfyLabel)@ for each CAF block.
+-- The @Set CAFfyLabel@ represents the set of CAFfy things which this CAF's code
 -- depends upon.
 --
--- CAFs are treated differently from other labelled blocks:
+--  - The 'Label' represents the entry code of the closure. This may be
+--    'Nothing' if it is a standard closure type (e.g. @stg_unpack_cstring@; see
+--    Note [unpack_cstring closures] in StgStdThunks.cmm).
+--  - The 'CAFLabel' is the label of the CAF closure.
+--  - The @Set CAFLabel@ is the set of CAFfy closures which should be included
+--    in the closure's SRT.
+--
+-- Note that CAFs are treated differently from other labelled blocks:
 --
 --  - we never shortcut a reference to a CAF to the contents of its
 --    SRT, since the point of SRTs is to keep CAFs alive.
 --
 --  - CAFs therefore don't take part in the dependency analysis in depAnalSRTs.
 --    instead we generate their SRTs after everything else.
---
-getCAFs :: Platform -> CAFEnv -> [CmmDecl] -> [(Label, CAFfyLabel, Set CAFfyLabel)]
-getCAFs platform cafEnv decls =
-  [ (g_entry g, mkCAFfyLabel platform topLbl, cafs)
-  | CmmProc top_info topLbl _ g <- decls
-  , Just info <- [mapLookup (g_entry g) (info_tbls top_info)]
-  , let rep = cit_rep info
-  , isStaticRep rep && isThunkRep rep
-  , Just cafs <- [mapLookup (g_entry g) cafEnv]
-  ]
+getCAFs :: Platform -> CAFEnv -> [CmmDecl] -> [(Maybe Label, CAFfyLabel, Set CAFfyLabel)]
+getCAFs platform cafEnv = mapMaybe getCAFLabel
+  where
+    getCAFLabel :: CmmDecl -> Maybe (Maybe Label, CAFfyLabel, Set CAFfyLabel)
+
+    getCAFLabel (CmmProc top_info top_lbl _ g)
+      | Just info <- mapLookup (g_entry g) (info_tbls top_info)
+      , let rep = cit_rep info
+      , isStaticRep rep && isThunkRep rep
+      , Just cafs <- mapLookup (g_entry g) cafEnv
+      = Just (Just (g_entry g), mkCAFfyLabel platform top_lbl, cafs)
+
+      | otherwise
+      = Nothing
+
+    getCAFLabel (CmmData _ (CmmStatics top_lbl info _ccs _payload _extras))
+      | isThunkRep (cit_rep info)
+      = Just (Nothing, mkCAFfyLabel platform top_lbl, Set.empty)
+
+      | otherwise
+      = Nothing
 
+    getCAFLabel (CmmData _ (CmmStaticsRaw _lbl _payload))
+      = Nothing
 
 -- | Get the list of blocks that correspond to the entry points for
 -- @FUN_STATIC@ closures.  These are the blocks for which if we have an
@@ -882,7 +904,7 @@ doSRTs cfg moduleSRTInfo procs data_ = do
               pprPanic "doSRTs" (text "Proc in static data list:" <+> pdoc platform decl)
             CmmData _ static ->
               case static of
-                CmmStatics lbl _ _ _ -> (lbl, set)
+                CmmStatics lbl _ _ _ _ -> (lbl, set)
                 CmmStaticsRaw lbl _ -> (lbl, set)
 
       (proc_envs, procss) = unzip procs
@@ -902,7 +924,7 @@ doSRTs cfg moduleSRTInfo procs data_ = do
     sccs :: [SCC (SomeLabel, CAFfyLabel, Set CAFfyLabel)]
     sccs = {-# SCC depAnalSRTs #-} depAnalSRTs platform cafEnv static_data_env decls
 
-    cafsWithSRTs :: [(Label, CAFfyLabel, Set CAFfyLabel)]
+    cafsWithSRTs :: [(Maybe Label, CAFfyLabel, Set CAFfyLabel)]
     cafsWithSRTs = getCAFs platform cafEnv decls
 
   srtTraceM "doSRTs" (text "data:"            <+> pdoc platform data_ $$
@@ -925,7 +947,7 @@ doSRTs cfg moduleSRTInfo procs data_ = do
         flip runStateT moduleSRTInfo $ do
           nonCAFs <- mapM (doSCC cfg staticFuns static_data_env) sccs
           cAFs <- forM cafsWithSRTs $ \(l, cafLbl, cafs) ->
-            oneSRT cfg staticFuns [BlockLabel l] [cafLbl]
+            oneSRT cfg staticFuns (map BlockLabel (maybeToList l)) [cafLbl]
                    True{-is a CAF-} cafs static_data_env
           return (nonCAFs ++ cAFs)
 
@@ -1248,6 +1270,7 @@ buildSRT profile refs = do
         [] -- no padding
         [mkIntCLit platform 0] -- link field
         [] -- no saved info
+        [] -- no extras
   return (mkDataLits (Section Data lbl) lbl fields, SRTEntry lbl)
 
 -- | Update info tables with references to their SRTs. Also generate
@@ -1263,10 +1286,10 @@ updInfoSRTs
 updInfoSRTs _ _ _ _ (CmmData s (CmmStaticsRaw lbl statics))
   = [CmmData s (CmmStaticsRaw lbl statics)]
 
-updInfoSRTs profile _ _ caffy (CmmData s (CmmStatics lbl itbl ccs payload))
+updInfoSRTs profile _ _ caffy (CmmData s (CmmStatics lbl itbl ccs payload extras))
   = [CmmData s (CmmStaticsRaw lbl (map CmmStaticLit field_lits))]
   where
-    field_lits = mkStaticClosureFields profile itbl ccs caffy payload
+    field_lits = mkStaticClosureFields profile itbl ccs caffy payload extras
 
 updInfoSRTs profile srt_env funSRTEnv caffy (CmmProc top_info top_l live g)
   | Just (_,closure) <- maybeStaticClosure = [ proc, closure ]
@@ -1296,7 +1319,7 @@ updInfoSRTs profile srt_env funSRTEnv caffy (CmmProc top_info top_l live g)
             Just srtEntries -> srtTrace "maybeStaticFun" (pdoc (profilePlatform profile) res)
               (info_tbl { cit_rep = new_rep }, res)
               where res = [ CmmLabel lbl | SRTEntry lbl <- srtEntries ]
-          fields = mkStaticClosureFields profile info_tbl ccs caffy srtEntries
+          fields = mkStaticClosureFields profile info_tbl ccs caffy srtEntries []
           new_rep = case cit_rep of
              HeapRep sta ptrs nptrs ty ->
                HeapRep sta (ptrs + length srtEntries) nptrs ty