[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:18:59 UTC 2022
Andreas Klebinger pushed to branch wip/andreask/ghci-tag-nullary at Glasgow Haskell Compiler / GHC
Commits:
a44dab5a by Andreas Klebinger at 2022-08-17T14:18:38+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',unless(have_dynamic(), skip))], makefile_test, ['T22042'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a44dab5a3f141b0e88a62d3ffd28fe15b0e8a9e7
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a44dab5a3f141b0e88a62d3ffd28fe15b0e8a9e7
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/70c7c6a3/attachment-0001.html>
More information about the ghc-commits
mailing list