summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/GHC/Driver/GenerateCgIPEStub.hs10
-rw-r--r--compiler/GHC/Driver/Main.hs60
-rw-r--r--compiler/GHC/Driver/Pipeline.hs2
-rw-r--r--compiler/GHC/Driver/Pipeline/Execute.hs6
-rw-r--r--compiler/GHC/Iface/Make.hs27
-rw-r--r--compiler/GHC/Stg/InferTags.hs9
-rw-r--r--compiler/GHC/Stg/InferTags/Rewrite.hs46
-rw-r--r--compiler/GHC/Stg/InferTags/TagSig.hs10
-rw-r--r--compiler/GHC/Stg/Pipeline.hs13
-rw-r--r--compiler/GHC/StgToByteCode.hs19
-rw-r--r--compiler/GHC/StgToCmm/Types.hs7
-rw-r--r--compiler/GHC/Types/Name/Set.hs2
-rw-r--r--testsuite/tests/ghci.debugger/scripts/T12458.stdout2
-rw-r--r--testsuite/tests/ghci.debugger/scripts/print018.stdout6
-rw-r--r--testsuite/tests/simplStg/should_run/Makefile9
-rw-r--r--testsuite/tests/simplStg/should_run/T22042.hs6
-rw-r--r--testsuite/tests/simplStg/should_run/T22042.stdout1
-rw-r--r--testsuite/tests/simplStg/should_run/T22042a.hs10
-rw-r--r--testsuite/tests/simplStg/should_run/all.T1
19 files changed, 177 insertions, 69 deletions
diff --git a/compiler/GHC/Driver/GenerateCgIPEStub.hs b/compiler/GHC/Driver/GenerateCgIPEStub.hs
index 647457d44c..be478f1bdb 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
logger = hsc_logger hsc_env
@@ -200,7 +198,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 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 5f22840395..a16156143a 100644
--- a/compiler/GHC/Driver/Main.hs
+++ b/compiler/GHC/Driver/Main.hs
@@ -192,15 +192,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.Info.Build
@@ -281,6 +280,8 @@ import Data.Time
import System.IO.Unsafe ( unsafeInterleaveIO )
import GHC.Iface.Env ( trace_if )
+import GHC.Stg.InferTags.TagSig (seqTagSig)
+import GHC.Types.Unique.FM
{- **********************************************************************
@@ -1770,7 +1771,7 @@ hscSimpleIface' mb_core_program 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.
@@ -1820,11 +1821,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 =
@@ -1863,11 +1869,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 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 stg_cg_infos, Just cmm_cg_infos)
-- The part of CgGuts that we need for HscInteractive
@@ -1915,7 +1922,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 ------------------
@@ -2036,7 +2045,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.
@@ -2047,13 +2056,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)
@@ -2061,8 +2067,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
@@ -2093,7 +2099,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
@@ -2101,7 +2107,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) -}
@@ -2109,7 +2116,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
@@ -2117,20 +2124,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
@@ -2138,7 +2146,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)
{- **********************************************************************
%* *
@@ -2289,7 +2297,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)
@@ -2527,7 +2535,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
diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs
index 04cd266f51..8588dfdda8 100644
--- a/compiler/GHC/Driver/Pipeline.hs
+++ b/compiler/GHC/Driver/Pipeline.hs
@@ -742,7 +742,7 @@ hscBackendPipeline pipe_env hsc_env mod_sum result =
else
case result of
HscUpdate iface -> return (iface, emptyHomeModInfoLinkable)
- HscRecomp {} -> (,) <$> liftIO (mkFullIface hsc_env (hscs_partial_iface result) Nothing) <*> pure emptyHomeModInfoLinkable
+ HscRecomp {} -> (,) <$> liftIO (mkFullIface hsc_env (hscs_partial_iface result) Nothing Nothing) <*> pure emptyHomeModInfoLinkable
-- TODO: Why is there not a linkable?
-- Interpreter -> (,) <$> use (T_IO (mkFullIface hsc_env (hscs_partial_iface result) Nothing)) <*> pure Nothing
diff --git a/compiler/GHC/Driver/Pipeline/Execute.hs b/compiler/GHC/Driver/Pipeline/Execute.hs
index bddb1dfbde..915265f8f3 100644
--- a/compiler/GHC/Driver/Pipeline/Execute.hs
+++ b/compiler/GHC/Driver/Pipeline/Execute.hs
@@ -536,10 +536,10 @@ runHscBackendPhase pipe_env hsc_env mod_name src_flavour location result = do
else if backendWritesFiles (backend dflags) then
do
output_fn <- phaseOutputFilenameNew next_phase pipe_env hsc_env (Just location)
- (outputFilename, mStub, foreign_files, cg_infos) <-
+ (outputFilename, mStub, foreign_files, stg_infos, cg_infos) <-
hscGenHardCode hsc_env cgguts mod_location output_fn
- final_iface <- mkFullIface hsc_env partial_iface cg_infos
+ final_iface <- mkFullIface hsc_env partial_iface stg_infos cg_infos
-- See Note [Writing interface files]
hscMaybeWriteIface logger dflags False final_iface mb_old_iface_hash mod_location
@@ -567,7 +567,7 @@ runHscBackendPhase pipe_env hsc_env mod_name src_flavour location result = do
-- In interpreted mode the regular codeGen backend is not run so we
-- generate a interface without codeGen info.
do
- 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
bc <- generateFreshByteCode hsc_env mod_name (mkCgInteractiveGuts cgguts) mod_location
return ([], final_iface, emptyHomeModInfoLinkable { homeMod_bytecode = Just bc } , panic "interpreter")
diff --git a/compiler/GHC/Iface/Make.hs b/compiler/GHC/Iface/Make.hs
index 8fa1fcb7e5..d4336ca0c8 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
@@ -99,6 +99,7 @@ import Data.Function
import Data.List ( findIndex, mapAccumL, sortBy )
import Data.Ord
import Data.IORef
+import GHC.Stg.Pipeline (StgCgInfos)
{-
@@ -135,16 +136,16 @@ mkPartialIface hsc_env core_prog 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" #-}
@@ -157,11 +158,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
@@ -179,6 +185,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').
@@ -237,7 +246,7 @@ mkIfaceTc hsc_env safe_mode mod_details mod_summary mb_program
docs mod_summary
mod_details
- mkFullIface hsc_env partial_iface Nothing
+ mkFullIface hsc_env partial_iface Nothing Nothing
mkIface_ :: HscEnv -> Module -> CoreProgram -> HscSource
-> Bool -> Dependencies -> GlobalRdrEnv
diff --git a/compiler/GHC/Stg/InferTags.hs b/compiler/GHC/Stg/InferTags.hs
index 9236bc44a6..c9835d5787 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 99caa79ddb..060ebcac22 100644
--- a/compiler/GHC/Stg/InferTags/Rewrite.hs
+++ b/compiler/GHC/Stg/InferTags/Rewrite.hs
@@ -30,7 +30,7 @@ import GHC.Types.Unique.Supply
import GHC.Types.Unique.FM
import GHC.Types.RepType
import GHC.Types.Var.Set
-import GHC.Unit.Types ( Module )
+import GHC.Unit.Types
import GHC.Core.DataCon
import GHC.Core ( AltCon(..) )
@@ -215,9 +215,49 @@ 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 the tag inference pass including
+it's rewriting phase 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
| Just Unlifted <- typeLevity_maybe (idType v)
@@ -226,8 +266,8 @@ isTagged v = do
-> return True
| otherwise -> do -- Local binding
!s <- getMap
- let !sig = lookupWithDefaultUFM s (pprPanic "unknown Id:" (ppr v)) v
- return $! case sig of
+ let !sig = lookupWithDefaultUFM s (lookupDefault v) v
+ return $ case sig of
TagSig info ->
case info of
TagDunno -> False
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 eb37d73c8c..2a72f7a28e 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
@@ -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 passes.
+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,8 @@ 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
+ -- 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 6af15363bd..be2d6a82fa 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'])
View Lorry Controller Status