[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 09:02:55 UTC 2022



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


Commits:
5a3a0813 by Andreas Klebinger at 2022-08-17T11:02:29+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 only generate bytecode. In that case only for correctness reasons.
Which is alright as it's fairly cheap to run.

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
=====================================
@@ -27,13 +27,12 @@ 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.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
+import GHC.Stg.Pipeline (StgCgInfos)
 
 {-
 Note [Stacktraces from Info Table Provenance Entries (IPE based stack unwinding)]
@@ -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,42 @@ 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 each individual STG expression entered on the prompt.
+
+This means in GHCi for a sequence of:
+    > let x = True
+    > let y = x
+We first run tagInference for `x = True`. While that computes a tag signature for `x` that information
+is currently not persistet.
+Then we process `y = x`, and to do so we check for the tag sig of `x` (which we don't have).
+This isn't a problem as we can always just default to TagDunno and nothing bad will happen.
+
+But in a non-interactive context this would indicate an error as every binding
+should be processed in dependency order for the whole module at once.
+Therefore taggedness information should be available for every id mentioned in any RHS.
+
+So if a lookup fails we check if we are in an interactive context. If so we just default
+to TagDunno. If we aren't in an interactive context this is an error and we have an assert
+to check 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
=====================================
@@ -1,4 +1,5 @@
 {-# LANGUAGE TypeFamilies, DataKinds, GADTs, FlexibleInstances #-}
+{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE ConstraintKinds #-}
 
@@ -16,6 +17,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 +66,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/5a3a081308be683500e6b22ca0f10df22b6f9fc7

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5a3a081308be683500e6b22ca0f10df22b6f9fc7
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/80c38121/attachment-0001.html>


More information about the ghc-commits mailing list