[Git][ghc/ghc][master] Fix GHCis interaction with tag inference.
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Tue Oct 18 07:35:13 UTC 2022
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
0ac60423 by Andreas Klebinger at 2022-10-18T03:34:47-04: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.
Fixes #22042 and #21083
-------------------------
Metric Increase:
T4801
Metric Decrease:
T13035
-------------------------
- - - - -
19 changed files:
- compiler/GHC/Driver/GenerateCgIPEStub.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Driver/Pipeline.hs
- compiler/GHC/Driver/Pipeline/Execute.hs
- compiler/GHC/Iface/Make.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
- compiler/GHC/Types/Name/Set.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
=====================================
@@ -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
=====================================
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
=====================================
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
=====================================
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")
=====================================
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
=====================================
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
=====================================
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
=====================================
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 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
=====================================
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
=====================================
@@ -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)
}
--------------------------------------------------------------------------------
=====================================
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)
=====================================
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/0ac6042302219b162a23b85f637bcc8fa27fafaa
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0ac6042302219b162a23b85f637bcc8fa27fafaa
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/20221018/ad310174/attachment-0001.html>
More information about the ghc-commits
mailing list