Fix GHCis interaction with tag inference.

I had assumed that wrappers were not inlined in interactive mode.
Meaning we would always execute the compiled wrapper which properly
takes care of upholding the strict field invariant.
This turned out to be wrong. So instead we now run tag inference even
when we generate bytecode. In that case only for correctness not
performance reasons although it will be still beneficial for runtime
in some cases.

I further fixed a bug where GHCi didn't tag nullary constructors
properly when used as arguments. Which caused segfaults when calling
into compiled functions which expect the strict field invariant to
be upheld.

-------------------------
Metric Increase:
    T4801

Metric Decrease:
    T13035
-------------------------

19 files changed, 175 insertions, 68 deletions

diff --git a/compiler/GHC/Driver/GenerateCgIPEStub.hs b/compiler/GHC/Driver/GenerateCgIPEStub.hs
index 96bf352e51..981ced9929 100644
--- a/compiler/GHC/Driver/GenerateCgIPEStub.hs
+++ b/compiler/GHC/Driver/GenerateCgIPEStub.hs
@@ -26,11 +26,9 @@ import GHC.Runtime.Heap.Layout (isStackRep)
 import GHC.Settings (Platform, platformUnregisterised)
 import GHC.StgToCmm.Monad (getCmm, initC, runC, initFCodeState)
 import GHC.StgToCmm.Prof (initInfoTableProv)
-import GHC.StgToCmm.Types (CgInfos (..), ModuleLFInfos)
-import GHC.Stg.InferTags.TagSig (TagSig)
+import GHC.StgToCmm.Types (CmmCgInfos (..), ModuleLFInfos)
 import GHC.Types.IPE (InfoTableProvMap (provInfoTables), IpeSourceLocation)
 import GHC.Types.Name.Set (NonCaffySet)
-import GHC.Types.Name.Env (NameEnv)
 import GHC.Types.Tickish (GenTickish (SourceNote))
 import GHC.Unit.Types (Module)
 import GHC.Utils.Misc
@@ -180,8 +178,8 @@ The find the tick:
     remembered in a `Maybe`.
 -}
 
-generateCgIPEStub :: HscEnv -> Module -> InfoTableProvMap -> NameEnv TagSig -> Stream IO CmmGroupSRTs (NonCaffySet, ModuleLFInfos) -> Stream IO CmmGroupSRTs CgInfos
-generateCgIPEStub hsc_env this_mod denv tag_sigs s = do
+generateCgIPEStub :: HscEnv -> Module -> InfoTableProvMap -> Stream IO CmmGroupSRTs (NonCaffySet, ModuleLFInfos) -> Stream IO CmmGroupSRTs CmmCgInfos
+generateCgIPEStub hsc_env this_mod denv s = do
   let dflags   = hsc_dflags hsc_env
       platform = targetPlatform dflags
       fstate   = initFCodeState platform
@@ -198,7 +196,7 @@ generateCgIPEStub hsc_env this_mod denv tag_sigs s = do
   (_, ipeCmmGroupSRTs) <- liftIO $ cmmPipeline hsc_env (emptySRT this_mod) ipeCmmGroup
   Stream.yield ipeCmmGroupSRTs
 
-  return CgInfos {cgNonCafs = nonCaffySet, cgLFInfos = moduleLFInfos, cgIPEStub = ipeStub, cgTagSigs = tag_sigs}
+  return CmmCgInfos {cgNonCafs = nonCaffySet, cgLFInfos = moduleLFInfos, cgIPEStub = ipeStub}
   where
     collect :: Platform -> [(Label, CmmInfoTable, Maybe IpeSourceLocation)] -> CmmGroupSRTs -> IO ([(Label, CmmInfoTable, Maybe IpeSourceLocation)], CmmGroupSRTs)
     collect platform acc cmmGroupSRTs = do
diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs
index 16d95d47be..8c7e2289d7 100644
--- a/compiler/GHC/Driver/Main.hs
+++ b/compiler/GHC/Driver/Main.hs
@@ -172,15 +172,14 @@ import GHC.Tc.Utils.Monad
 import GHC.Tc.Utils.Zonk    ( ZonkFlexi (DefaultFlexi) )
 
 import GHC.Stg.Syntax
-import GHC.Stg.Pipeline ( stg2stg )
-import GHC.Stg.InferTags
+import GHC.Stg.Pipeline ( stg2stg, StgCgInfos )
 
 import GHC.Builtin.Utils
 import GHC.Builtin.Names
 import GHC.Builtin.Uniques ( mkPseudoUniqueE )
 
 import qualified GHC.StgToCmm as StgToCmm ( codeGen )
-import GHC.StgToCmm.Types (CgInfos (..), ModuleLFInfos)
+import GHC.StgToCmm.Types (CmmCgInfos (..), ModuleLFInfos)
 
 import GHC.Cmm
 import GHC.Cmm.Parser       ( parseCmmFile )
@@ -253,6 +252,8 @@ import GHC.Driver.Env.KnotVars
 import GHC.Types.Name.Set (NonCaffySet)
 import GHC.Driver.GenerateCgIPEStub (generateCgIPEStub)
 import Data.List.NonEmpty (NonEmpty ((:|)))
+import GHC.Stg.InferTags.TagSig (seqTagSig)
+import GHC.Types.Unique.FM
 
 
 {- **********************************************************************
@@ -1613,7 +1614,7 @@ hscSimpleIface' tc_result summary = do
 
 -- | Compile to hard-code.
 hscGenHardCode :: HscEnv -> CgGuts -> ModLocation -> FilePath
-               -> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)], Maybe CgInfos)
+               -> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)], Maybe StgCgInfos, Maybe CmmCgInfos )
                 -- ^ @Just f@ <=> _stub.c is f
 hscGenHardCode hsc_env cgguts location output_filename = do
         let CgGuts{ -- This is the last use of the ModGuts in a compilation.
@@ -1658,11 +1659,16 @@ hscGenHardCode hsc_env cgguts location output_filename = do
                                    late_cc_binds data_tycons
 
         -----------------  Convert to STG ------------------
-        (stg_binds, denv, (caf_ccs, caf_cc_stacks))
+        (stg_binds, denv, (caf_ccs, caf_cc_stacks), stg_cg_infos)
             <- {-# SCC "CoreToStg" #-}
                withTiming logger
                    (text "CoreToStg"<+>brackets (ppr this_mod))
-                   (\(a, b, (c,d)) -> a `seqList` b `seq` c `seqList` d `seqList` ())
+                   (\(a, b, (c,d), tag_env) ->
+                        a `seqList`
+                        b `seq`
+                        c `seqList`
+                        d `seqList`
+                        (seqEltsUFM (seqTagSig) tag_env))
                    (myCoreToStg logger dflags (hsc_IC hsc_env) False this_mod location prepd_binds)
 
         let cost_centre_info =
@@ -1701,11 +1707,12 @@ hscGenHardCode hsc_env cgguts location output_filename = do
             let foreign_stubs st = foreign_stubs0 `appendStubC` prof_init
                                                   `appendStubC` cgIPEStub st
 
-            (output_filename, (_stub_h_exists, stub_c_exists), foreign_fps, cg_infos)
+            (output_filename, (_stub_h_exists, stub_c_exists), foreign_fps, cmm_cg_infos)
                 <- {-# SCC "codeOutput" #-}
                   codeOutput logger tmpfs dflags (hsc_units hsc_env) this_mod output_filename location
                   foreign_stubs foreign_files dependencies rawcmms1
-            return (output_filename, stub_c_exists, foreign_fps, Just cg_infos)
+            return  ( output_filename, stub_c_exists, foreign_fps
+                    , Just stg_cg_infos, Just cmm_cg_infos)
 
 
 hscInteractive :: HscEnv
@@ -1735,7 +1742,9 @@ hscInteractive hsc_env cgguts location = do
     prepd_binds <- {-# SCC "CorePrep" #-}
                    corePrepPgm hsc_env this_mod location core_binds data_tycons
 
-    (stg_binds, _infotable_prov, _caf_ccs__caf_cc_stacks)
+    -- The stg cg info only provides a runtime benfit, but is not requires so we just
+    -- omit it here
+    (stg_binds, _infotable_prov, _caf_ccs__caf_cc_stacks, _ignore_stg_cg_infos)
       <- {-# SCC "CoreToStg" #-}
           myCoreToStg logger dflags (hsc_IC hsc_env) True this_mod location prepd_binds
     -----------------  Generate byte code ------------------
@@ -1826,7 +1835,7 @@ doCodeGen :: HscEnv -> Module -> InfoTableProvMap -> [TyCon]
           -> CollectedCCs
           -> [CgStgTopBinding] -- ^ Bindings come already annotated with fvs
           -> HpcInfo
-          -> IO (Stream IO CmmGroupSRTs CgInfos)
+          -> IO (Stream IO CmmGroupSRTs CmmCgInfos)
          -- Note we produce a 'Stream' of CmmGroups, so that the
          -- backend can be run incrementally.  Otherwise it generates all
          -- the C-- up front, which has a significant space cost.
@@ -1837,13 +1846,10 @@ doCodeGen hsc_env this_mod denv data_tycons
         hooks      = hsc_hooks  hsc_env
         tmpfs      = hsc_tmpfs  hsc_env
         platform   = targetPlatform dflags
-
-    -- Do tag inference on optimized STG
-    (!stg_post_infer,export_tag_info) <-
-        {-# SCC "StgTagFields" #-} inferTags dflags logger this_mod stg_binds_w_fvs
+        stg_ppr_opts = (initStgPprOpts dflags)
 
     putDumpFileMaybe logger Opt_D_dump_stg_final "Final STG:" FormatSTG
-        (pprGenStgTopBindings (initStgPprOpts dflags) stg_post_infer)
+        (pprGenStgTopBindings stg_ppr_opts stg_binds_w_fvs)
 
     let stg_to_cmm dflags mod = case stgToCmmHook hooks of
                         Nothing -> StgToCmm.codeGen logger tmpfs (initStgToCmmConfig dflags mod)
@@ -1851,8 +1857,8 @@ doCodeGen hsc_env this_mod denv data_tycons
 
     let cmm_stream :: Stream IO CmmGroup ModuleLFInfos
         -- See Note [Forcing of stg_binds]
-        cmm_stream = stg_post_infer `seqList` {-# SCC "StgToCmm" #-}
-            stg_to_cmm dflags this_mod denv data_tycons cost_centre_info stg_post_infer hpc_info
+        cmm_stream = stg_binds_w_fvs `seqList` {-# SCC "StgToCmm" #-}
+            stg_to_cmm dflags this_mod denv data_tycons cost_centre_info stg_binds_w_fvs hpc_info
 
         -- codegen consumes a stream of CmmGroup, and produces a new
         -- stream of CmmGroup (not necessarily synchronised: one
@@ -1881,7 +1887,7 @@ doCodeGen hsc_env this_mod denv data_tycons
             putDumpFileMaybe logger Opt_D_dump_cmm "Output Cmm" FormatCMM (pdoc platform a)
           return a
 
-    return $ Stream.mapM dump2 $ generateCgIPEStub hsc_env this_mod denv export_tag_info pipeline_stream
+    return $ Stream.mapM dump2 $ generateCgIPEStub hsc_env this_mod denv pipeline_stream
 
 myCoreToStgExpr :: Logger -> DynFlags -> InteractiveContext
                 -> Bool
@@ -1889,7 +1895,8 @@ myCoreToStgExpr :: Logger -> DynFlags -> InteractiveContext
                 -> IO ( Id
                       , [CgStgTopBinding]
                       , InfoTableProvMap
-                      , CollectedCCs )
+                      , CollectedCCs
+                      , StgCgInfos )
 myCoreToStgExpr logger dflags ictxt for_bytecode this_mod ml prepd_expr = do
     {- Create a temporary binding (just because myCoreToStg needs a
        binding for the stg2stg step) -}
@@ -1897,7 +1904,7 @@ myCoreToStgExpr logger dflags ictxt for_bytecode this_mod ml prepd_expr = do
                                 (mkPseudoUniqueE 0)
                                 Many
                                 (exprType prepd_expr)
-    (stg_binds, prov_map, collected_ccs) <-
+    (stg_binds, prov_map, collected_ccs, stg_cg_infos) <-
        myCoreToStg logger
                    dflags
                    ictxt
@@ -1905,20 +1912,21 @@ myCoreToStgExpr logger dflags ictxt for_bytecode this_mod ml prepd_expr = do
                    this_mod
                    ml
                    [NonRec bco_tmp_id prepd_expr]
-    return (bco_tmp_id, stg_binds, prov_map, collected_ccs)
+    return (bco_tmp_id, stg_binds, prov_map, collected_ccs, stg_cg_infos)
 
 myCoreToStg :: Logger -> DynFlags -> InteractiveContext
             -> Bool
             -> Module -> ModLocation -> CoreProgram
             -> IO ( [CgStgTopBinding] -- output program
                   , InfoTableProvMap
-                  , CollectedCCs )  -- CAF cost centre info (declared and used)
+                  , CollectedCCs -- CAF cost centre info (declared and used)
+                  , StgCgInfos )
 myCoreToStg logger dflags ictxt for_bytecode this_mod ml prepd_binds = do
     let (stg_binds, denv, cost_centre_info)
          = {-# SCC "Core2Stg" #-}
            coreToStg dflags this_mod ml prepd_binds
 
-    stg_binds_with_fvs
+    (stg_binds_with_fvs,stg_cg_info)
         <- {-# SCC "Stg2Stg" #-}
            stg2stg logger ictxt (initStgPipelineOpts dflags for_bytecode)
                    this_mod stg_binds
@@ -1926,7 +1934,7 @@ myCoreToStg logger dflags ictxt for_bytecode this_mod ml prepd_binds = do
     putDumpFileMaybe logger Opt_D_dump_stg_cg "CodeGenInput STG:" FormatSTG
         (pprGenStgTopBindings (initStgPprOpts dflags) stg_binds_with_fvs)
 
-    return (stg_binds_with_fvs, denv, cost_centre_info)
+    return (stg_binds_with_fvs, denv, cost_centre_info, stg_cg_info)
 
 {- **********************************************************************
 %*                                                                      *
@@ -2072,7 +2080,7 @@ hscParsedDecls hsc_env decls = runInteractiveHsc hsc_env $ do
     prepd_binds <- {-# SCC "CorePrep" #-}
       liftIO $ corePrepPgm hsc_env this_mod iNTERACTIVELoc core_binds data_tycons
 
-    (stg_binds, _infotable_prov, _caf_ccs__caf_cc_stacks)
+    (stg_binds, _infotable_prov, _caf_ccs__caf_cc_stacks, _stg_cg_info)
         <- {-# SCC "CoreToStg" #-}
            liftIO $ myCoreToStg (hsc_logger hsc_env)
                                 (hsc_dflags hsc_env)
@@ -2298,7 +2306,7 @@ hscCompileCoreExpr' hsc_env srcspan ds_expr
                                       ml_hie_file  = panic "hscCompileCoreExpr':ml_hie_file" }
 
          ; let ictxt = hsc_IC hsc_env
-         ; (binding_id, stg_expr, _, _) <-
+         ; (binding_id, stg_expr, _, _, _stg_cg_info) <-
              myCoreToStgExpr (hsc_logger hsc_env)
                              (hsc_dflags hsc_env)
                              ictxt
diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs
index 86dc055e55..37c8538d5f 100644
--- a/compiler/GHC/Driver/Pipeline.hs
+++ b/compiler/GHC/Driver/Pipeline.hs
@@ -735,7 +735,7 @@ hscBackendPipeline pipe_env hsc_env mod_sum result =
     NoBackend ->
       case result of
         HscUpdate iface ->  return (iface, Nothing)
-        HscRecomp {} -> (,) <$> liftIO (mkFullIface hsc_env (hscs_partial_iface result) Nothing) <*> pure Nothing
+        HscRecomp {} -> (,) <$> liftIO (mkFullIface hsc_env (hscs_partial_iface result) Nothing Nothing) <*> pure Nothing
     -- TODO: Why is there not a linkable?
     -- Interpreter -> (,) <$> use (T_IO (mkFullIface hsc_env (hscs_partial_iface result) Nothing)) <*> pure Nothing
     _ -> do
diff --git a/compiler/GHC/Driver/Pipeline/Execute.hs b/compiler/GHC/Driver/Pipeline/Execute.hs
index 4f2c30c5a7..f3ecb679c4 100644
--- a/compiler/GHC/Driver/Pipeline/Execute.hs
+++ b/compiler/GHC/Driver/Pipeline/Execute.hs
@@ -503,7 +503,7 @@ runHscBackendPhase pipe_env hsc_env mod_name src_flavour location result = do
           Interpreter -> do
               -- In interpreted mode the regular codeGen backend is not run so we
               -- generate a interface without codeGen info.
-              final_iface <- mkFullIface hsc_env partial_iface Nothing
+              final_iface <- mkFullIface hsc_env partial_iface Nothing Nothing
               hscMaybeWriteIface logger dflags True final_iface mb_old_iface_hash location
 
               (hasStub, comp_bc, spt_entries) <- hscInteractive hsc_env cgguts mod_location
@@ -521,9 +521,9 @@ runHscBackendPhase pipe_env hsc_env mod_name src_flavour location result = do
               return ([], final_iface, Just linkable, panic "interpreter")
           _ -> do
               output_fn <- phaseOutputFilenameNew next_phase pipe_env hsc_env (Just location)
-              (outputFilename, mStub, foreign_files, mb_cg_infos) <-
+              (outputFilename, mStub, foreign_files, mb_stg_infos, mb_cg_infos) <-
                 hscGenHardCode hsc_env cgguts mod_location output_fn
-              final_iface <- mkFullIface hsc_env partial_iface mb_cg_infos
+              final_iface <- mkFullIface hsc_env partial_iface mb_stg_infos mb_cg_infos
 
               -- See Note [Writing interface files]
               hscMaybeWriteIface logger dflags False final_iface mb_old_iface_hash mod_location
diff --git a/compiler/GHC/Iface/Make.hs b/compiler/GHC/Iface/Make.hs
index 7cf782a18d..4a70fe3867 100644
--- a/compiler/GHC/Iface/Make.hs
+++ b/compiler/GHC/Iface/Make.hs
@@ -23,7 +23,7 @@ import GHC.Prelude
 
 import GHC.Hs
 
-import GHC.StgToCmm.Types (CgInfos (..))
+import GHC.StgToCmm.Types (CmmCgInfos (..))
 
 import GHC.Tc.Utils.TcType
 import GHC.Tc.Utils.Monad
@@ -98,6 +98,7 @@ import Data.Function
 import Data.List ( findIndex, mapAccumL, sortBy )
 import Data.Ord
 import Data.IORef
+import GHC.Stg.Pipeline (StgCgInfos)
 
 
 {-
@@ -133,16 +134,16 @@ mkPartialIface hsc_env mod_details mod_summary
 -- | Fully instantiate an interface. Adds fingerprints and potentially code
 -- generator produced information.
 --
--- CgInfos is not available when not generating code (-fno-code), or when not
+-- CmmCgInfos is not available when not generating code (-fno-code), or when not
 -- generating interface pragmas (-fomit-interface-pragmas). See also
 -- Note [Conveying CAF-info and LFInfo between modules] in GHC.StgToCmm.Types.
-mkFullIface :: HscEnv -> PartialModIface -> Maybe CgInfos -> IO ModIface
-mkFullIface hsc_env partial_iface mb_cg_infos = do
+mkFullIface :: HscEnv -> PartialModIface -> Maybe StgCgInfos -> Maybe CmmCgInfos -> IO ModIface
+mkFullIface hsc_env partial_iface mb_stg_infos mb_cmm_infos = do
     let decls
           | gopt Opt_OmitInterfacePragmas (hsc_dflags hsc_env)
           = mi_decls partial_iface
           | otherwise
-          = updateDecl (mi_decls partial_iface) mb_cg_infos
+          = updateDecl (mi_decls partial_iface) mb_stg_infos mb_cmm_infos
 
     full_iface <-
       {-# SCC "addFingerprints" #-}
@@ -155,11 +156,16 @@ mkFullIface hsc_env partial_iface mb_cg_infos = do
 
     return full_iface
 
-updateDecl :: [IfaceDecl] -> Maybe CgInfos -> [IfaceDecl]
-updateDecl decls Nothing = decls
-updateDecl decls (Just CgInfos{ cgNonCafs = NonCaffySet non_cafs, cgLFInfos = lf_infos, cgTagSigs = tag_sigs })
+updateDecl :: [IfaceDecl] -> Maybe StgCgInfos -> Maybe CmmCgInfos -> [IfaceDecl]
+updateDecl decls Nothing Nothing = decls
+updateDecl decls m_stg_infos m_cmm_infos
   = map update_decl decls
   where
+    (non_cafs,lf_infos) = maybe (mempty, mempty)
+                                (\cmm_info -> (ncs_nameSet (cgNonCafs cmm_info), cgLFInfos cmm_info))
+                                m_cmm_infos
+    tag_sigs = fromMaybe mempty m_stg_infos
+
     update_decl (IfaceId nm ty details infos)
       | let not_caffy = elemNameSet nm non_cafs
       , let mb_lf_info = lookupNameEnv lf_infos nm
@@ -177,6 +183,9 @@ updateDecl decls (Just CgInfos{ cgNonCafs = NonCaffySet non_cafs, cgLFInfos = lf
     update_decl decl
       = decl
 
+
+
+
 -- | Make an interface from the results of typechecking only.  Useful
 -- for non-optimising compilation, or where we aren't generating any
 -- object code at all ('NoBackend').
@@ -230,7 +239,7 @@ mkIfaceTc hsc_env safe_mode mod_details mod_summary
                    docs mod_summary
                    mod_details
 
-          mkFullIface hsc_env partial_iface Nothing
+          mkFullIface hsc_env partial_iface Nothing Nothing
 
 mkIface_ :: HscEnv -> Module -> HscSource
          -> Bool -> Dependencies -> GlobalRdrEnv
diff --git a/compiler/GHC/Stg/InferTags.hs b/compiler/GHC/Stg/InferTags.hs
index 9081f21006..6b629f7229 100644
--- a/compiler/GHC/Stg/InferTags.hs
+++ b/compiler/GHC/Stg/InferTags.hs
@@ -27,7 +27,6 @@ import GHC.Stg.InferTags.Types
 import GHC.Stg.InferTags.Rewrite (rewriteTopBinds)
 import Data.Maybe
 import GHC.Types.Name.Env (mkNameEnv, NameEnv)
-import GHC.Driver.Config.Stg.Ppr
 import GHC.Driver.Session
 import GHC.Utils.Logger
 import qualified GHC.Unit.Types
@@ -217,17 +216,17 @@ the output of itself.
 --           -> CollectedCCs
 --           -> [CgStgTopBinding] -- ^ Bindings come already annotated with fvs
 --           -> HpcInfo
---           -> IO (Stream IO CmmGroupSRTs CgInfos)
+--           -> IO (Stream IO CmmGroupSRTs CmmCgInfos)
 --          -- Note we produce a 'Stream' of CmmGroups, so that the
 --          -- backend can be run incrementally.  Otherwise it generates all
 --          -- the C-- up front, which has a significant space cost.
-inferTags :: DynFlags -> Logger -> (GHC.Unit.Types.Module) -> [CgStgTopBinding] -> IO ([TgStgTopBinding], NameEnv TagSig)
-inferTags dflags logger this_mod stg_binds = do
+inferTags :: StgPprOpts -> Logger -> (GHC.Unit.Types.Module) -> [CgStgTopBinding] -> IO ([TgStgTopBinding], NameEnv TagSig)
+inferTags ppr_opts logger this_mod stg_binds = do
 
     -- Annotate binders with tag information.
     let (!stg_binds_w_tags) = {-# SCC "StgTagFields" #-}
                                         inferTagsAnal stg_binds
-    putDumpFileMaybe logger Opt_D_dump_stg_tags "CodeGenAnal STG:" FormatSTG (pprGenStgTopBindings (initStgPprOpts dflags) stg_binds_w_tags)
+    putDumpFileMaybe logger Opt_D_dump_stg_tags "CodeGenAnal STG:" FormatSTG (pprGenStgTopBindings ppr_opts stg_binds_w_tags)
 
     let export_tag_info = collectExportInfo stg_binds_w_tags
 
diff --git a/compiler/GHC/Stg/InferTags/Rewrite.hs b/compiler/GHC/Stg/InferTags/Rewrite.hs
index 68fa311515..ada3d38f10 100644
--- a/compiler/GHC/Stg/InferTags/Rewrite.hs
+++ b/compiler/GHC/Stg/InferTags/Rewrite.hs
@@ -25,7 +25,7 @@ import GHC.Types.Name
 import GHC.Types.Unique.Supply
 import GHC.Types.Unique.FM
 import GHC.Types.RepType
-import GHC.Unit.Types (Module)
+import GHC.Unit.Types (Module, isInteractiveModule)
 
 import GHC.Core.DataCon
 import GHC.Core (AltCon(..) )
@@ -212,16 +212,55 @@ withLcl fv act = do
     setFVs old_fvs
     return r
 
+{- Note [Tag inference for interactive contexts]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When compiling bytecode we call myCoreToStg to get STG code first.
+myCoreToStg in turn calls out to stg2stg which runs the STG to STG
+passes followed by free variables analysis and tag inference at the end.
+Running tag inference is important as it upholds Note [Strict Field Invariant].
+While code executed by GHCi doesn't take advantage of the SFI it can call into
+compiled code which does. So it must still make sure that the SFI is upheld.
+See also #21083 and #22042.
+
+However there one important difference in code generation for GHCi and regular
+compilation. When compiling an entire module (not a GHCi expression), we call
+`stg2stg` on the entire module which allows us to build up a map which is guaranteed
+to have an entry for every binder in the current module.
+For non-interactive compilation the tag inference rewrite pass takes advantage
+of this by building up a map from binders to their tag signatures.
+
+When compiling a GHCi expression on the other hand we invoke stg2stg separately
+for each expression on the prompt. This means in GHCi for a sequence of:
+    > let x = True
+    > let y = StrictJust x
+We first run stg2stg for `[x = True]`. And then again for [y = StrictJust x]`.
+
+While computing the tag signature for `y` during tag inference inferConTag will check
+if `x` is already tagged by looking up the tagsig of `x` in the binder->signature mapping.
+However since this mapping isn't persistent between stg2stg
+invocations the lookup will fail. This isn't a correctness issue since it's always
+safe to assume a binding isn't tagged and that's what we do in such cases.
+
+However for non-interactive mode we *don't* want to do this. Since in non-interactive mode
+we have all binders of the module available for each invocation we can expect the binder->signature
+mapping to be complete and all lookups to succeed. This means in non-interactive contexts a failed lookup
+indicates a bug in the tag inference implementation.
+For this reason we assert that we are running in interactive mode if a lookup fails.
+-}
 isTagged :: Id -> RM Bool
 isTagged v = do
     this_mod <- getMod
+    -- See Note [Tag inference for interactive contexts]
+    let lookupDefault v = assertPpr (isInteractiveModule this_mod)
+                                    (text "unknown Id:" <> ppr this_mod <+> ppr v)
+                                    (TagSig TagDunno)
     case nameIsLocalOrFrom this_mod (idName v) of
         True
             | isUnliftedType (idType v)
             -> return True
             | otherwise -> do -- Local binding
                 !s <- getMap
-                let !sig = lookupWithDefaultUFM s (pprPanic "unknown Id:" (ppr v)) v
+                let !sig = lookupWithDefaultUFM s (lookupDefault v) v
                 return $ case sig of
                     TagSig info ->
                         case info of
diff --git a/compiler/GHC/Stg/InferTags/TagSig.hs b/compiler/GHC/Stg/InferTags/TagSig.hs
index a1381881f1..391c9e35a3 100644
--- a/compiler/GHC/Stg/InferTags/TagSig.hs
+++ b/compiler/GHC/Stg/InferTags/TagSig.hs
@@ -16,6 +16,7 @@ import GHC.Types.Var
 import GHC.Utils.Outputable
 import GHC.Utils.Binary
 import GHC.Utils.Panic.Plain
+import Data.Coerce
 
 data TagInfo
   = TagDunno            -- We don't know anything about the tag.
@@ -64,3 +65,12 @@ isTaggedSig :: TagSig -> Bool
 isTaggedSig (TagSig TagProper) = True
 isTaggedSig (TagSig TagTagged) = True
 isTaggedSig _ = False
+
+seqTagSig :: TagSig -> ()
+seqTagSig = coerce seqTagInfo
+
+seqTagInfo :: TagInfo -> ()
+seqTagInfo TagTagged      = ()
+seqTagInfo TagDunno       = ()
+seqTagInfo TagProper      = ()
+seqTagInfo (TagTuple tis) = foldl' (\_unit sig -> seqTagSig (coerce sig)) () tis
\ No newline at end of file
diff --git a/compiler/GHC/Stg/Pipeline.hs b/compiler/GHC/Stg/Pipeline.hs
index e037e9517e..834ea55336 100644
--- a/compiler/GHC/Stg/Pipeline.hs
+++ b/compiler/GHC/Stg/Pipeline.hs
@@ -13,6 +13,7 @@ module GHC.Stg.Pipeline
   ( StgPipelineOpts (..)
   , StgToDo (..)
   , stg2stg
+  , StgCgInfos
   ) where
 
 import GHC.Prelude
@@ -38,6 +39,9 @@ import Control.Monad
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Reader
 import GHC.Settings (Platform)
+import GHC.Stg.InferTags (inferTags)
+import GHC.Types.Name.Env (NameEnv)
+import GHC.Stg.InferTags.TagSig (TagSig)
 
 data StgPipelineOpts = StgPipelineOpts
   { stgPipeline_phases      :: ![StgToDo]
@@ -51,6 +55,10 @@ data StgPipelineOpts = StgPipelineOpts
 newtype StgM a = StgM { _unStgM :: ReaderT Char IO a }
   deriving (Functor, Applicative, Monad, MonadIO)
 
+-- | Information to be exposed in interface files which is produced
+-- by the stg2stg passes.
+type StgCgInfos = NameEnv TagSig
+
 instance MonadUnique StgM where
   getUniqueSupplyM = StgM $ do { mask <- ask
                                ; liftIO $! mkSplitUniqSupply mask}
@@ -65,7 +73,7 @@ stg2stg :: Logger
         -> StgPipelineOpts
         -> Module                    -- module being compiled
         -> [StgTopBinding]           -- input program
-        -> IO [CgStgTopBinding]        -- output program
+        -> IO ([CgStgTopBinding], StgCgInfos) -- output program
 stg2stg logger ictxt opts this_mod binds
   = do  { dump_when Opt_D_dump_stg_from_core "Initial STG:" binds
         ; showPass logger "Stg2Stg"
@@ -84,7 +92,8 @@ stg2stg logger ictxt opts this_mod binds
           -- This pass will also augment each closure with non-global free variables
           -- annotations (which is used by code generator to compute offsets into closures)
         ; let binds_sorted_with_fvs = depSortWithAnnotStgPgm this_mod binds'
-        ; return binds_sorted_with_fvs
+        -- See Note [Tag inference for interactive contexts]
+        ; inferTags (stgPipeline_pprOpts opts) logger this_mod binds_sorted_with_fvs
    }
 
   where
diff --git a/compiler/GHC/StgToByteCode.hs b/compiler/GHC/StgToByteCode.hs
index bc4a3b71ad..870f1be8d8 100644
--- a/compiler/GHC/StgToByteCode.hs
+++ b/compiler/GHC/StgToByteCode.hs
@@ -1669,10 +1669,21 @@ pushAtom d p (StgVarArg var)
         case lookupVarEnv topStrings var of
             Just ptr -> pushAtom d p $ StgLitArg $ mkLitWord platform $
               fromIntegral $ ptrToWordPtr $ fromRemotePtr ptr
-            Nothing -> do
-                let sz = idSizeCon platform var
-                massert (sz == wordSize platform)
-                return (unitOL (PUSH_G (getName var)), sz)
+            Nothing
+              -- PUSH_G doesn't tag constructors. So we use PACK here
+              -- if we are dealing with nullary constructor.
+              | Just con <- isDataConWorkId_maybe var
+              -> do
+                  massert (sz == wordSize platform)
+                  massert (isNullaryRepDataCon con)
+                  return (unitOL (PACK con 0), sz)
+              | otherwise
+              -> do
+                  let
+                  massert (sz == wordSize platform)
+                  return (unitOL (PUSH_G (getName var)), sz)
+              where
+                !sz = idSizeCon platform var
 
 
 pushAtom _ _ (StgLitArg lit) = pushLiteral True lit
diff --git a/compiler/GHC/StgToCmm/Types.hs b/compiler/GHC/StgToCmm/Types.hs
index dd6b3355ba..c2b17c3e5f 100644
--- a/compiler/GHC/StgToCmm/Types.hs
+++ b/compiler/GHC/StgToCmm/Types.hs
@@ -1,7 +1,7 @@
 
 
 module GHC.StgToCmm.Types
-  ( CgInfos (..)
+  ( CmmCgInfos (..)
   , LambdaFormInfo (..)
   , ModuleLFInfos
   , StandardFormInfo (..)
@@ -13,8 +13,6 @@ import GHC.Prelude
 
 import GHC.Core.DataCon
 
-import GHC.Stg.InferTags.TagSig
-
 import GHC.Runtime.Heap.Layout
 
 import GHC.Types.Basic
@@ -85,7 +83,7 @@ moving parts are:
 --
 -- See also Note [Conveying CAF-info and LFInfo between modules] above.
 --
-data CgInfos = CgInfos
+data CmmCgInfos = CmmCgInfos
   { cgNonCafs :: !NonCaffySet
       -- ^ Exported Non-CAFFY closures in the current module. Everything else is
       -- either not exported of CAFFY.
@@ -93,7 +91,6 @@ data CgInfos = CgInfos
       -- ^ LambdaFormInfos of exported closures in the current module.
   , cgIPEStub :: !CStub
       -- ^ The C stub which is used for IPE information
-  , cgTagSigs :: !(NameEnv TagSig)
   }
 
 --------------------------------------------------------------------------------
diff --git a/compiler/GHC/Types/Name/Set.hs b/compiler/GHC/Types/Name/Set.hs
index d2ffadf429..dda678c95d 100644
--- a/compiler/GHC/Types/Name/Set.hs
+++ b/compiler/GHC/Types/Name/Set.hs
@@ -220,5 +220,5 @@ findUses dus uses
 
 -- | 'Id's which have no CAF references. This is a result of analysis of C--.
 -- It is always safe to use an empty 'NonCaffySet'. TODO Refer to Note.
-newtype NonCaffySet = NonCaffySet NameSet
+newtype NonCaffySet = NonCaffySet { ncs_nameSet :: NameSet }
   deriving (Semigroup, Monoid)
diff --git a/testsuite/tests/ghci.debugger/scripts/T12458.stdout b/testsuite/tests/ghci.debugger/scripts/T12458.stdout
index 64c8134355..f5d42883f9 100644
--- a/testsuite/tests/ghci.debugger/scripts/T12458.stdout
+++ b/testsuite/tests/ghci.debugger/scripts/T12458.stdout
@@ -1,2 +1,2 @@
-d = (_t1::forall {k} {a :: k}. D a)
+d = <D>
 ()
diff --git a/testsuite/tests/ghci.debugger/scripts/print018.stdout b/testsuite/tests/ghci.debugger/scripts/print018.stdout
index e0ab829716..977d61cb7b 100644
--- a/testsuite/tests/ghci.debugger/scripts/print018.stdout
+++ b/testsuite/tests/ghci.debugger/scripts/print018.stdout
@@ -1,9 +1,9 @@
 Breakpoint 0 activated at Test.hs:40:10-17
 Stopped in Test.Test2.poly, Test.hs:40:10-17
 _result :: () = _
-x :: a = _
-x = (_t1::a)
-x :: a
+x :: Unary = Unary
+x = Unary
+x :: Unary
 ()
 x = Unary
 x :: Unary
diff --git a/testsuite/tests/simplStg/should_run/Makefile b/testsuite/tests/simplStg/should_run/Makefile
index 9101fbd40a..03a3b5199e 100644
--- a/testsuite/tests/simplStg/should_run/Makefile
+++ b/testsuite/tests/simplStg/should_run/Makefile
@@ -1,3 +1,12 @@
 TOP=../../..
 include $(TOP)/mk/boilerplate.mk
 include $(TOP)/mk/test.mk
+
+T22042: T22042_clean
+	"$(TEST_HC)" $(TEST_HC_OPTS) -O T22042a.hs -dynamic -c
+	"$(TEST_HC)" $(TEST_HC_OPTS) -e ":main" T22042.hs T22042a.o
+
+T22042_clean:
+	rm -f T22042a.o T22042a.hi
+
+.PHONY: T22042 T22042_clean
diff --git a/testsuite/tests/simplStg/should_run/T22042.hs b/testsuite/tests/simplStg/should_run/T22042.hs
new file mode 100644
index 0000000000..45f1ec1936
--- /dev/null
+++ b/testsuite/tests/simplStg/should_run/T22042.hs
@@ -0,0 +1,6 @@
+module Main where
+
+import T22042a
+
+main = do
+  putStrLn (foo $ SC A B C)
diff --git a/testsuite/tests/simplStg/should_run/T22042.stdout b/testsuite/tests/simplStg/should_run/T22042.stdout
new file mode 100644
index 0000000000..5da849b5c6
--- /dev/null
+++ b/testsuite/tests/simplStg/should_run/T22042.stdout
@@ -0,0 +1 @@
+ABC
diff --git a/testsuite/tests/simplStg/should_run/T22042a.hs b/testsuite/tests/simplStg/should_run/T22042a.hs
new file mode 100644
index 0000000000..41d412f120
--- /dev/null
+++ b/testsuite/tests/simplStg/should_run/T22042a.hs
@@ -0,0 +1,10 @@
+module T22042a where
+
+data A = A | AA deriving Show
+data B = B | AB deriving Show
+data C = C | AC deriving Show
+
+data SC = SC !A !B !C
+
+foo :: SC -> String
+foo (SC a b c) = show a ++ show b ++ show c
diff --git a/testsuite/tests/simplStg/should_run/all.T b/testsuite/tests/simplStg/should_run/all.T
index 1d017043d6..d5d40cc237 100644
--- a/testsuite/tests/simplStg/should_run/all.T
+++ b/testsuite/tests/simplStg/should_run/all.T
@@ -19,3 +19,4 @@ test('T13536a',
     [''])
 
 test('inferTags001', normal, multimod_compile_and_run, ['inferTags001', 'inferTags001_a'])
+test('T22042', [extra_files(['T22042a.hs']),only_ways('normal'),unless(have_dynamic(), skip)], makefile_test, ['T22042'])