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, 39 insertions, 1 deletions

diff --git a/compiler/GHC/StgToCmm/Bind.hs b/compiler/GHC/StgToCmm/Bind.hs
index 177c3f2912..3e9f5a52d5 100644
--- a/compiler/GHC/StgToCmm/Bind.hs
+++ b/compiler/GHC/StgToCmm/Bind.hs
@@ -25,6 +25,8 @@ import GHC.Stg.Syntax
 import GHC.Platform
 import GHC.Platform.Profile
 
+import GHC.Builtin.Names (unpackCStringName, unpackCStringUtf8Name)
+
 import GHC.StgToCmm.Config
 import GHC.StgToCmm.Expr
 import GHC.StgToCmm.Monad
@@ -87,6 +89,9 @@ cgTopRhsClosure platform rec id ccs upd_flag args body =
       lf_info       = mkClosureLFInfo platform id TopLevel [] upd_flag args
   in (cg_id_info, gen_code lf_info closure_label)
   where
+
+  gen_code :: LambdaFormInfo -> CLabel -> FCode ()
+
   -- special case for a indirection (f = g).  We create an IND_STATIC
   -- closure pointing directly to the indirectee.  This is exactly
   -- what the CAF will eventually evaluate to anyway, we're just
@@ -101,11 +106,44 @@ cgTopRhsClosure platform rec id ccs upd_flag args body =
   -- concurrent/should_run/4030 fails, for instance.
   --
   gen_code _ closure_label
-    | StgApp f [] <- body, null args, isNonRec rec
+    | StgApp f [] <- body
+    , null args
+    , isNonRec rec
     = do
          cg_info <- getCgIdInfo f
          emitDataCon closure_label indStaticInfoTable ccs [unLit (idInfoToAmode cg_info)]
 
+  -- Emit standard stg_unpack_cstring closures for top-level unpackCString# thunks.
+  --
+  -- Note that we do not do this for thunks enclosured in code ticks (e.g. hpc
+  -- ticks) since we want to ensure that these ticks are not lost (e.g.
+  -- resulting in Strings being reported by hpc as uncovered). However, we
+  -- don't worry about standard profiling ticks since unpackCString tends not
+  -- be terribly interesting in profiles. See Note [unpack_cstring closures] in
+  -- StgStdThunks.cmm.
+  gen_code _ closure_label
+    | null args
+    , StgApp f [arg] <- stripStgTicksTopE (not . tickishIsCode) body
+    , Just unpack <- is_string_unpack_op f
+    = do arg' <- getArgAmode (NonVoid arg)
+         case arg' of
+           CmmLit lit -> do
+             let info = CmmInfoTable
+                   { cit_lbl = unpack
+                   , cit_rep = HeapRep True 0 1 Thunk
+                   , cit_prof = NoProfilingInfo
+                   , cit_srt = Nothing
+                   , cit_clo = Nothing
+                   }
+             emitDecl $ CmmData (Section Data closure_label) $
+                 CmmStatics closure_label info ccs [] [lit]
+           _ -> panic "cgTopRhsClosure.gen_code"
+    where
+      is_string_unpack_op f
+        | idName f == unpackCStringName     = Just mkRtsUnpackCStringLabel
+        | idName f == unpackCStringUtf8Name = Just mkRtsUnpackCStringUtf8Label
+        | otherwise                         = Nothing
+
   gen_code lf_info _closure_label
    = do { profile <- getProfile
         ; let name = idName id