[Git][ghc/ghc][wip/andreask/ghci-tag-nullary] Fix GHCis interaction with tag inference.

Andreas Klebinger (@AndreasK) gitlab at gitlab.haskell.org
Wed Aug 17 12:12:32 UTC 2022



Andreas Klebinger pushed to branch wip/andreask/ghci-tag-nullary at Glasgow Haskell Compiler / GHC


Commits:
4926ef75 by Andreas Klebinger at 2022-08-17T14:11:27+02:00
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
-------------------------

- - - - -


15 changed files:

- compiler/GHC/Driver/GenerateCgIPEStub.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Stg/InferTags.hs
- compiler/GHC/Stg/InferTags/Rewrite.hs
- compiler/GHC/Stg/InferTags/TagSig.hs
- compiler/GHC/Stg/Pipeline.hs
- compiler/GHC/StgToByteCode.hs
- compiler/GHC/StgToCmm/Types.hs
- testsuite/tests/ghci.debugger/scripts/T12458.stdout
- testsuite/tests/ghci.debugger/scripts/print018.stdout
- testsuite/tests/simplStg/should_run/Makefile
- + testsuite/tests/simplStg/should_run/T22042.hs
- + testsuite/tests/simplStg/should_run/T22042.stdout
- + testsuite/tests/simplStg/should_run/T22042a.hs
- testsuite/tests/simplStg/should_run/all.T


Changes:

=====================================
compiler/GHC/Driver/GenerateCgIPEStub.hs
=====================================
@@ -24,13 +24,12 @@ import GHC.Driver.Config.Cmm
 import GHC.Prelude
 import GHC.Runtime.Heap.Layout (isStackRep)
 import GHC.Settings (Platform, platformUnregisterised)
+import GHC.Stg.Pipeline (StgCgInfos)
 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.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 +179,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 -> StgCgInfos -> Stream IO CmmGroupSRTs (NonCaffySet, ModuleLFInfos) -> Stream IO CmmGroupSRTs CgInfos
+generateCgIPEStub hsc_env this_mod denv stg_cg_infos s = do
   let dflags   = hsc_dflags hsc_env
       platform = targetPlatform dflags
       logger   = hsc_logger hsc_env
@@ -200,7 +199,7 @@ generateCgIPEStub hsc_env this_mod denv tag_sigs s = do
   (_, ipeCmmGroupSRTs) <- liftIO $ cmmPipeline logger cmm_cfg (emptySRT this_mod) ipeCmmGroup
   Stream.yield ipeCmmGroupSRTs
 
-  return CgInfos {cgNonCafs = nonCaffySet, cgLFInfos = moduleLFInfos, cgIPEStub = ipeStub, cgTagSigs = tag_sigs}
+  return CgInfos {cgNonCafs = nonCaffySet, cgLFInfos = moduleLFInfos, cgIPEStub = ipeStub, cgTagSigs = stg_cg_infos}
   where
     collect :: Platform -> [(Label, CmmInfoTable, Maybe IpeSourceLocation)] -> CmmGroupSRTs -> IO ([(Label, CmmInfoTable, Maybe IpeSourceLocation)], CmmGroupSRTs)
     collect platform acc cmmGroupSRTs = do


=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -186,8 +186,7 @@ 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
@@ -268,6 +267,8 @@ import Data.Functor
 import Control.DeepSeq (force)
 import Data.Bifunctor (first)
 import Data.List.NonEmpty (NonEmpty ((:|)))
+import GHC.Stg.InferTags.TagSig (seqTagSig)
+import GHC.Types.Unique.FM
 
 
 {- **********************************************************************
@@ -1719,11 +1720,16 @@ hscGenHardCode hsc_env cgguts location output_filename = do
             this_mod location 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 =
@@ -1745,7 +1751,7 @@ hscGenHardCode hsc_env cgguts location output_filename = do
             cmms <- {-# SCC "StgToCmm" #-}
                             doCodeGen hsc_env this_mod denv data_tycons
                                 cost_centre_info
-                                stg_binds hpc_info
+                                stg_binds stg_cg_infos hpc_info
 
             ------------------  Code output -----------------------
             rawcmms0 <- {-# SCC "cmmToRawCmm" #-}
@@ -1766,7 +1772,8 @@ hscGenHardCode hsc_env cgguts location output_filename = do
                 <- {-# SCC "codeOutput" #-}
                   codeOutput logger tmpfs llvm_config 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 cg_infos{ cgTagSigs = stg_cg_infos})
 
 
 hscInteractive :: HscEnv
@@ -1801,7 +1808,9 @@ hscInteractive hsc_env cgguts location = do
         (initCorePrepPgmConfig (hsc_dflags hsc_env) (interactiveInScope $ hsc_IC 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 ------------------
@@ -1894,25 +1903,23 @@ This reduces residency towards the end of the CodeGen phase significantly
 doCodeGen :: HscEnv -> Module -> InfoTableProvMap -> [TyCon]
           -> CollectedCCs
           -> [CgStgTopBinding] -- ^ Bindings come already annotated with fvs
+          -> StgCgInfos
           -> HpcInfo
           -> IO (Stream IO CmmGroupSRTs CgInfos)
          -- 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.
 doCodeGen hsc_env this_mod denv data_tycons
-              cost_centre_info stg_binds_w_fvs hpc_info = do
+              cost_centre_info stg_binds_w_fvs stg_cg_info hpc_info = do
     let dflags     = hsc_dflags hsc_env
         logger     = hsc_logger hsc_env
         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)
@@ -1920,8 +1927,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
@@ -1952,7 +1959,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 stg_cg_info pipeline_stream
 
 myCoreToStgExpr :: Logger -> DynFlags -> InteractiveContext
                 -> Bool
@@ -1960,7 +1967,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) -}
@@ -1968,7 +1976,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
@@ -1976,20 +1984,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 (interactiveInScope ictxt) (initStgPipelineOpts dflags for_bytecode)
                    this_mod stg_binds
@@ -1997,7 +2006,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)
 
 {- **********************************************************************
 %*                                                                      *
@@ -2148,7 +2157,7 @@ hscParsedDecls hsc_env decls = runInteractiveHsc hsc_env $ do
         (initCorePrepPgmConfig (hsc_dflags hsc_env) (interactiveInScope $ hsc_IC 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)
@@ -2385,7 +2394,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 logger
                              dflags
                              ictxt


=====================================
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
@@ -221,13 +220,13 @@ the output of itself.
 --          -- 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
 


=====================================
compiler/GHC/Stg/InferTags/Rewrite.hs
=====================================
@@ -26,7 +26,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,49 @@ withLcl fv act = do
     setFVs old_fvs
     return r
 
+{- Note [Tag inference for interactive contexts]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When running code in GHCi we perform tag inference/rewrites
+for individual expressions as part of stg2stg in order to uphold
+Note [Strict Field Invariant]. See also #21083 and #22042.
+
+This means in GHCi for a sequence of:
+    > let x = True
+    > ...
+    > let y = StrictJust x
+We first run tagInference for `x = True`. We compute a tag signature for `x`
+but that information is currently not persistent inside GHCi.
+When later on we run tag inference for `let y = StrictJust x` we check for
+the tag sig of `x` inside inferConTag but we don't have any information about
+the tagSig for `x` anymore.
+The options to work around this  are either have GHCi persist this information.
+Or we just default to TagDunno in interactive contexts if the lookup fails.
+For simplicity we do the later.
+
+The difference arises because we call stg2stg once with *all* binders for the
+current module in non-interactive mode. E.g we would call stg2stg [x = True, y = StrictJust].
+This allows us to cache information about all in scope binders from the current Module.
+This doesn't work in interactive mode where we first call `stg2stg [x = True]`
+and later `stg2stg [y = StrictJust x]`.
+
+As a consequence if a lookup fails for an id from the current module we check if we are
+in an interactive context. If so we just default to TagDunno. If we aren't in an interactive
+context we consider this an error and we have an assert to check for that.
+-}
 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


=====================================
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


=====================================
compiler/GHC/Stg/Pipeline.hs
=====================================
@@ -13,6 +13,7 @@ module GHC.Stg.Pipeline
   ( StgPipelineOpts (..)
   , StgToDo (..)
   , stg2stg
+  , StgCgInfos
   ) where
 
 import GHC.Prelude
@@ -39,6 +40,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]
@@ -52,6 +56,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 pass.
+type StgCgInfos = NameEnv TagSig
+
 instance MonadUnique StgM where
   getUniqueSupplyM = StgM $ do { mask <- ask
                                ; liftIO $! mkSplitUniqSupply mask}
@@ -66,7 +74,7 @@ stg2stg :: Logger
         -> StgPipelineOpts
         -> Module                    -- ^ module being compiled
         -> [StgTopBinding]           -- ^ input program
-        -> IO [CgStgTopBinding]        -- output program
+        -> IO ([CgStgTopBinding], StgCgInfos) -- output program
 stg2stg logger extra_vars opts this_mod binds
   = do  { dump_when Opt_D_dump_stg_from_core "Initial STG:" binds
         ; showPass logger "Stg2Stg"
@@ -85,7 +93,7 @@ stg2stg logger extra_vars 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
+        ; inferTags (stgPipeline_pprOpts opts) logger this_mod binds_sorted_with_fvs
    }
 
   where


=====================================
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


=====================================
compiler/GHC/StgToCmm/Types.hs
=====================================
@@ -94,6 +94,7 @@ data CgInfos = CgInfos
   , cgIPEStub :: !CStub
       -- ^ The C stub which is used for IPE information
   , cgTagSigs :: !(NameEnv TagSig)
+      -- ^ Tag sigs. These are produced by stg2stg hence why they end up in CgInfos.
   }
 
 --------------------------------------------------------------------------------


=====================================
testsuite/tests/ghci.debugger/scripts/T12458.stdout
=====================================
@@ -1,2 +1,2 @@
-d = (_t1::forall {k} {a :: k}. D a)
+d = <D>
 ()


=====================================
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


=====================================
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


=====================================
testsuite/tests/simplStg/should_run/T22042.hs
=====================================
@@ -0,0 +1,6 @@
+module Main where
+
+import T22042a
+
+main = do
+  putStrLn (foo $ SC A B C)


=====================================
testsuite/tests/simplStg/should_run/T22042.stdout
=====================================
@@ -0,0 +1 @@
+ABC


=====================================
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


=====================================
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')], makefile_test, ['T22042'])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4926ef75f2a387865174ff4a93bd603b9c39b57a

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4926ef75f2a387865174ff4a93bd603b9c39b57a
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20220817/c885fbd7/attachment-0001.html>


More information about the ghc-commits mailing list