ghc 9.4.1 → 9.4.2
raw patch · 19 files changed
+196/−115 lines, 19 filesdep ~ghc-bootdep ~ghc-heapdep ~ghci
Dependency ranges changed: ghc-boot, ghc-heap, ghci
Files
- CodeGen.Platform.h +8/−0
- GHC/Cmm/Lexer.hs +2/−2
- GHC/Driver/GenerateCgIPEStub.hs +4/−6
- GHC/Driver/Main.hs +34/−26
- GHC/Driver/Make.hs +1/−1
- GHC/Driver/Pipeline.hs +33/−41
- GHC/Driver/Pipeline/Execute.hs +3/−3
- GHC/Driver/Pipeline/Monad.hs +1/−0
- GHC/Iface/Make.hs +18/−9
- GHC/Parser/HaddockLex.hs +2/−2
- GHC/Parser/Lexer.hs +2/−2
- GHC/Stg/InferTags.hs +4/−5
- GHC/Stg/InferTags/Rewrite.hs +41/−2
- GHC/Stg/InferTags/TagSig.hs +10/−0
- GHC/Stg/Pipeline.hs +11/−2
- GHC/StgToByteCode.hs +15/−4
- GHC/StgToCmm/Types.hs +2/−5
- GHC/Types/Name/Set.hs +1/−1
- ghc.cabal +4/−4
CodeGen.Platform.h view
@@ -926,6 +926,14 @@ -- ip0 -- used for spill offset computations freeReg 16 = False +#if defined(darwin_HOST_OS) || defined(ios_HOST_OS)+-- x18 is reserved by the platform on Darwin/iOS, and can not be used+-- More about ARM64 ABI that Apple platforms support:+-- https://developer.apple.com/documentation/xcode/writing-arm64-code-for-apple-platforms+-- https://github.com/Siguza/ios-resources/blob/master/bits/arm64.md+freeReg 18 = False+#endif+ # if defined(REG_Base) freeReg REG_Base = False # endif
GHC/Cmm/Lexer.hs view
@@ -1,7 +1,7 @@ {-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-missing-signatures #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-}-{-# LINE 13 "_build/source-dist/ghc-9.4.1-src/ghc-9.4.1/compiler/GHC/Cmm/Lexer.x" #-}+{-# LINE 13 "_build/source-dist/ghc-9.4.2-src/ghc-9.4.2/compiler/GHC/Cmm/Lexer.x" #-} module GHC.Cmm.Lexer ( CmmToken(..), cmmlex, ) where@@ -354,7 +354,7 @@ , (0,alex_action_19) ] -{-# LINE 129 "_build/source-dist/ghc-9.4.1-src/ghc-9.4.1/compiler/GHC/Cmm/Lexer.x" #-}+{-# LINE 129 "_build/source-dist/ghc-9.4.2-src/ghc-9.4.2/compiler/GHC/Cmm/Lexer.x" #-} data CmmToken = CmmT_SpecChar Char | CmmT_DotDot
GHC/Driver/GenerateCgIPEStub.hs view
@@ -26,11 +26,9 @@ 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 @@ 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 fstate = initFCodeState platform@@ -198,7 +196,7 @@ (_, ipeCmmGroupSRTs) <- liftIO $ cmmPipeline hsc_env (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
GHC/Driver/Main.hs view
@@ -172,15 +172,14 @@ 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.Parser ( parseCmmFile )@@ -253,6 +252,8 @@ import GHC.Types.Name.Set (NonCaffySet) import GHC.Driver.GenerateCgIPEStub (generateCgIPEStub) import Data.List.NonEmpty (NonEmpty ((:|)))+import GHC.Stg.InferTags.TagSig (seqTagSig)+import GHC.Types.Unique.FM {- **********************************************************************@@ -1613,7 +1614,7 @@ -- | 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.@@ -1658,11 +1659,16 @@ 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 =@@ -1701,11 +1707,12 @@ 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 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) hscInteractive :: HscEnv@@ -1735,7 +1742,9 @@ prepd_binds <- {-# SCC "CorePrep" #-} corePrepPgm 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 ------------------@@ -1826,7 +1835,7 @@ -> 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.@@ -1837,13 +1846,10 @@ 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)@@ -1851,8 +1857,8 @@ 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@@ -1881,7 +1887,7 @@ 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@@ -1889,7 +1895,8 @@ -> 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) -}@@ -1897,7 +1904,7 @@ (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@@ -1905,20 +1912,21 @@ 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 ictxt (initStgPipelineOpts dflags for_bytecode) this_mod stg_binds@@ -1926,7 +1934,7 @@ 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) {- ********************************************************************** %* *@@ -2072,7 +2080,7 @@ prepd_binds <- {-# SCC "CorePrep" #-} liftIO $ corePrepPgm 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)@@ -2298,7 +2306,7 @@ 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 (hsc_logger hsc_env) (hsc_dflags hsc_env) ictxt
GHC/Driver/Make.hs view
@@ -299,7 +299,7 @@ in if | ghcLink dflags == LinkBinary && isJust ofile && not do_linking -> Just (Left $ singleMessage $ mkPlainErrorMsgEnvelope noSrcSpan (DriverRedirectedNoMain $ mainModuleNameIs dflags)) -- This should be an error, not a warning (#10895).- | do_linking -> Just (Right (LinkNode unit_nodes uid))+ | ghcLink dflags /= NoLink, do_linking -> Just (Right (LinkNode unit_nodes uid)) | otherwise -> Nothing -- Note [Missing home modules]
GHC/Driver/Pipeline.hs view
@@ -171,7 +171,7 @@ -> Just (DriverPsHeaderMessage (PsHeaderMessage msg)) _ -> Nothing - pipe_env = mkPipeEnv StopPreprocess input_fn (Temporary TFL_GhcSession)+ pipe_env = mkPipeEnv StopPreprocess input_fn mb_phase (Temporary TFL_GhcSession) mkInputFn = case mb_input_buf of Just input_buf -> do@@ -238,7 +238,7 @@ [ml_obj_file $ ms_location summary] plugin_hsc_env <- initializePlugins hsc_env- let pipe_env = mkPipeEnv NoStop input_fn pipelineOutput+ let pipe_env = mkPipeEnv NoStop input_fn Nothing pipelineOutput status <- hscRecompStatus mHscMessage plugin_hsc_env upd_summary mb_old_iface mb_old_linkable (mod_index, nmods) let pipeline = hscPipeline pipe_env (setDumpPrefix pipe_env plugin_hsc_env, upd_summary, status)@@ -513,7 +513,7 @@ NoStop -> doLink hsc_env o_files compileFile :: HscEnv -> StopPhase -> (FilePath, Maybe Phase) -> IO (Maybe FilePath)-compileFile hsc_env stop_phase (src, _mb_phase) = do+compileFile hsc_env stop_phase (src, mb_phase) = do exists <- doesFileExist src when (not exists) $ throwGhcExceptionIO (CmdLineError ("does not exist: " ++ src))@@ -534,8 +534,8 @@ | isJust mb_o_file = SpecificFile -- -o foo applies to the file we are compiling now | otherwise = Persistent- pipe_env = mkPipeEnv stop_phase src output- pipeline = pipelineStart pipe_env (setDumpPrefix pipe_env hsc_env) src+ pipe_env = mkPipeEnv stop_phase src mb_phase output+ pipeline = pipelineStart pipe_env (setDumpPrefix pipe_env hsc_env) src mb_phase runPipeline (hsc_hooks hsc_env) pipeline @@ -584,7 +584,7 @@ #if __GLASGOW_HASKELL__ < 811 RawObject -> panic "compileForeign: should be unreachable" #endif- pipe_env = mkPipeEnv NoStop stub_c (Temporary TFL_GhcSession)+ pipe_env = mkPipeEnv NoStop stub_c Nothing (Temporary TFL_GhcSession) res <- runPipeline (hsc_hooks hsc_env) (pipeline pipe_env hsc_env Nothing stub_c) case res of -- This should never happen as viaCPipeline should only return `Nothing` when the stop phase is `StopC`.@@ -608,7 +608,7 @@ let home_unit = hsc_home_unit hsc_env src = text "int" <+> ppr (mkHomeModule home_unit mod_name) <+> text "= 0;" writeFile empty_stub (showSDoc dflags (pprCode CStyle src))- let pipe_env = (mkPipeEnv NoStop empty_stub Persistent) { src_basename = basename}+ let pipe_env = (mkPipeEnv NoStop empty_stub Nothing Persistent) { src_basename = basename} pipeline = viaCPipeline HCc pipe_env hsc_env (Just location) empty_stub _ <- runPipeline (hsc_hooks hsc_env) pipeline return ()@@ -618,15 +618,17 @@ mkPipeEnv :: StopPhase -- End phase -> FilePath -- input fn+ -> Maybe Phase -> PipelineOutput -- Output -> PipeEnv-mkPipeEnv stop_phase input_fn output =+mkPipeEnv stop_phase input_fn start_phase output = let (basename, suffix) = splitExtension input_fn suffix' = drop 1 suffix -- strip off the . env = PipeEnv{ stop_phase, src_filename = input_fn, src_basename = basename, src_suffix = suffix',+ start_phase = fromMaybe (startPhase suffix') start_phase, output_spec = output } in env @@ -696,8 +698,7 @@ where platform = targetPlatform (hsc_dflags hsc_env) runAfter :: P p => Phase -> a -> p a -> p a- runAfter = phaseIfAfter platform start_phase- start_phase = startPhase (src_suffix pipe_env)+ runAfter = phaseIfAfter platform (start_phase pipe_env) runAfterFlag :: P p => HscEnv -> Phase@@ -734,7 +735,7 @@ NoBackend -> case result of HscUpdate iface -> return (iface, Nothing)- HscRecomp {} -> (,) <$> liftIO (mkFullIface hsc_env (hscs_partial_iface result) Nothing) <*> pure Nothing+ HscRecomp {} -> (,) <$> liftIO (mkFullIface hsc_env (hscs_partial_iface result) Nothing Nothing) <*> pure Nothing -- TODO: Why is there not a linkable? -- Interpreter -> (,) <$> use (T_IO (mkFullIface hsc_env (hscs_partial_iface result) Nothing)) <*> pure Nothing _ -> do@@ -823,9 +824,9 @@ Interpreter -> return Nothing -- Pipeline from a given suffix-pipelineStart :: P m => PipeEnv -> HscEnv -> FilePath -> m (Maybe FilePath)-pipelineStart pipe_env hsc_env input_fn =- fromSuffix (src_suffix pipe_env)+pipelineStart :: P m => PipeEnv -> HscEnv -> FilePath -> Maybe Phase -> m (Maybe FilePath)+pipelineStart pipe_env hsc_env input_fn mb_phase =+ fromPhase (fromMaybe (startPhase $ src_suffix pipe_env) mb_phase) where stop_after = stop_phase pipe_env frontend :: P m => HscSource -> m (Maybe FilePath)@@ -857,33 +858,24 @@ objFromLinkable _ = Nothing - fromSuffix :: P m => String -> m (Maybe FilePath)- fromSuffix "lhs" = frontend HsSrcFile- fromSuffix "lhs-boot" = frontend HsBootFile- fromSuffix "lhsig" = frontend HsigFile- fromSuffix "hs" = frontend HsSrcFile- fromSuffix "hs-boot" = frontend HsBootFile- fromSuffix "hsig" = frontend HsigFile- fromSuffix "hscpp" = frontend HsSrcFile- fromSuffix "hspp" = frontend HsSrcFile- fromSuffix "hc" = c HCc- fromSuffix "c" = c Cc- fromSuffix "cpp" = c Ccxx- fromSuffix "C" = c Cc- fromSuffix "m" = c Cobjc- fromSuffix "M" = c Cobjcxx- fromSuffix "mm" = c Cobjcxx- fromSuffix "cc" = c Ccxx- fromSuffix "cxx" = c Ccxx- fromSuffix "s" = as False- fromSuffix "S" = as True- fromSuffix "ll" = llvmPipeline pipe_env hsc_env Nothing input_fn- fromSuffix "bc" = llvmLlcPipeline pipe_env hsc_env Nothing input_fn- fromSuffix "lm_s" = llvmManglePipeline pipe_env hsc_env Nothing input_fn- fromSuffix "o" = return (Just input_fn)- fromSuffix "cmm" = Just <$> cmmCppPipeline pipe_env hsc_env input_fn- fromSuffix "cmmcpp" = Just <$> cmmPipeline pipe_env hsc_env input_fn- fromSuffix _ = return (Just input_fn)+ fromPhase :: P m => Phase -> m (Maybe FilePath)+ fromPhase (Unlit p) = frontend p+ fromPhase (Cpp p) = frontend p+ fromPhase (HsPp p) = frontend p+ fromPhase (Hsc p) = frontend p+ fromPhase HCc = c HCc+ fromPhase Cc = c Cc+ fromPhase Ccxx = c Ccxx+ fromPhase Cobjc = c Cobjc+ fromPhase Cobjcxx = c Cobjcxx+ fromPhase (As p) = as p+ fromPhase LlvmOpt = llvmPipeline pipe_env hsc_env Nothing input_fn+ fromPhase LlvmLlc = llvmLlcPipeline pipe_env hsc_env Nothing input_fn+ fromPhase LlvmMangle = llvmManglePipeline pipe_env hsc_env Nothing input_fn+ fromPhase StopLn = return (Just input_fn)+ fromPhase CmmCpp = Just <$> cmmCppPipeline pipe_env hsc_env input_fn+ fromPhase Cmm = Just <$> cmmPipeline pipe_env hsc_env input_fn+ fromPhase MergeForeign = panic "fromPhase: MergeForeign" {- Note [The Pipeline Monad]
GHC/Driver/Pipeline/Execute.hs view
@@ -503,7 +503,7 @@ Interpreter -> do -- In interpreted mode the regular codeGen backend is not run so we -- generate a interface without codeGen info.- 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 (hasStub, comp_bc, spt_entries) <- hscInteractive hsc_env cgguts mod_location@@ -521,9 +521,9 @@ return ([], final_iface, Just linkable, panic "interpreter") _ -> do output_fn <- phaseOutputFilenameNew next_phase pipe_env hsc_env (Just location)- (outputFilename, mStub, foreign_files, mb_cg_infos) <-+ (outputFilename, mStub, foreign_files, mb_stg_infos, mb_cg_infos) <- hscGenHardCode hsc_env cgguts mod_location output_fn- final_iface <- mkFullIface hsc_env partial_iface mb_cg_infos+ final_iface <- mkFullIface hsc_env partial_iface mb_stg_infos mb_cg_infos -- See Note [Writing interface files] hscMaybeWriteIface logger dflags False final_iface mb_old_iface_hash mod_location
GHC/Driver/Pipeline/Monad.hs view
@@ -29,6 +29,7 @@ src_filename :: String, -- ^ basename of original input source src_basename :: String, -- ^ basename of original input source src_suffix :: String, -- ^ its extension+ start_phase :: Phase, output_spec :: PipelineOutput -- ^ says where to put the pipeline output }
GHC/Iface/Make.hs view
@@ -23,7 +23,7 @@ import GHC.Hs -import GHC.StgToCmm.Types (CgInfos (..))+import GHC.StgToCmm.Types (CmmCgInfos (..)) import GHC.Tc.Utils.TcType import GHC.Tc.Utils.Monad@@ -98,6 +98,7 @@ import Data.List ( findIndex, mapAccumL, sortBy ) import Data.Ord import Data.IORef+import GHC.Stg.Pipeline (StgCgInfos) {-@@ -133,16 +134,16 @@ -- | 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" #-}@@ -155,11 +156,16 @@ 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@@ -177,6 +183,9 @@ 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').@@ -230,7 +239,7 @@ docs mod_summary mod_details - mkFullIface hsc_env partial_iface Nothing+ mkFullIface hsc_env partial_iface Nothing Nothing mkIface_ :: HscEnv -> Module -> HscSource -> Bool -> Dependencies -> GlobalRdrEnv
GHC/Parser/HaddockLex.hs view
@@ -1,7 +1,7 @@ {-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-missing-signatures #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-}-{-# LINE 1 "_build/source-dist/ghc-9.4.1-src/ghc-9.4.1/compiler/GHC/Parser/HaddockLex.x" #-}+{-# LINE 1 "_build/source-dist/ghc-9.4.2-src/ghc-9.4.2/compiler/GHC/Parser/HaddockLex.x" #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -funbox-strict-fields #-}@@ -110,7 +110,7 @@ , (0,alex_action_1) ] -{-# LINE 87 "_build/source-dist/ghc-9.4.1-src/ghc-9.4.1/compiler/GHC/Parser/HaddockLex.x" #-}+{-# LINE 87 "_build/source-dist/ghc-9.4.2-src/ghc-9.4.2/compiler/GHC/Parser/HaddockLex.x" #-} data AlexInput = AlexInput { alexInput_position :: !RealSrcLoc , alexInput_string :: !ByteString
GHC/Parser/Lexer.hs view
@@ -1,7 +1,7 @@ {-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-missing-signatures #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-}-{-# LINE 43 "_build/source-dist/ghc-9.4.1-src/ghc-9.4.1/compiler/GHC/Parser/Lexer.x" #-}+{-# LINE 43 "_build/source-dist/ghc-9.4.2-src/ghc-9.4.2/compiler/GHC/Parser/Lexer.x" #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-}@@ -609,7 +609,7 @@ , (0,alex_action_84) ] -{-# LINE 700 "_build/source-dist/ghc-9.4.1-src/ghc-9.4.1/compiler/GHC/Parser/Lexer.x" #-}+{-# LINE 700 "_build/source-dist/ghc-9.4.2-src/ghc-9.4.2/compiler/GHC/Parser/Lexer.x" #-} -- ----------------------------------------------------------------------------- -- The token type
GHC/Stg/InferTags.hs view
@@ -27,7 +27,6 @@ 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 @@ -- -> 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
GHC/Stg/InferTags/Rewrite.hs view
@@ -25,7 +25,7 @@ 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,55 @@ 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 tag inference 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 | 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
GHC/Stg/InferTags/TagSig.hs view
@@ -16,6 +16,7 @@ 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 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
GHC/Stg/Pipeline.hs view
@@ -13,6 +13,7 @@ ( StgPipelineOpts (..) , StgToDo (..) , stg2stg+ , StgCgInfos ) where import GHC.Prelude@@ -38,6 +39,9 @@ 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]@@ -51,6 +55,10 @@ 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}@@ -65,7 +73,7 @@ -> StgPipelineOpts -> Module -- module being compiled -> [StgTopBinding] -- input program- -> IO [CgStgTopBinding] -- output program+ -> IO ([CgStgTopBinding], StgCgInfos) -- output program stg2stg logger ictxt opts this_mod binds = do { dump_when Opt_D_dump_stg_from_core "Initial STG:" binds ; showPass logger "Stg2Stg"@@ -84,7 +92,8 @@ -- 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
GHC/StgToByteCode.hs view
@@ -1669,10 +1669,21 @@ 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
GHC/StgToCmm/Types.hs view
@@ -1,7 +1,7 @@ module GHC.StgToCmm.Types- ( CgInfos (..)+ ( CmmCgInfos (..) , LambdaFormInfo (..) , ModuleLFInfos , StandardFormInfo (..)@@ -13,8 +13,6 @@ import GHC.Core.DataCon -import GHC.Stg.InferTags.TagSig- import GHC.Runtime.Heap.Layout import GHC.Types.Basic@@ -85,7 +83,7 @@ -- -- 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 @@ -- ^ LambdaFormInfos of exported closures in the current module. , cgIPEStub :: !CStub -- ^ The C stub which is used for IPE information- , cgTagSigs :: !(NameEnv TagSig) } --------------------------------------------------------------------------------
GHC/Types/Name/Set.hs view
@@ -220,5 +220,5 @@ -- | '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)
ghc.cabal view
@@ -3,7 +3,7 @@ -- ./configure. Make sure you are editing ghc.cabal.in, not ghc.cabal. Name: ghc-Version: 9.4.1+Version: 9.4.2 License: BSD-3-Clause License-File: LICENSE Author: The GHC Team@@ -91,9 +91,9 @@ transformers == 0.5.*, exceptions == 0.10.*, stm,- ghc-boot == 9.4.1,- ghc-heap == 9.4.1,- ghci == 9.4.1+ ghc-boot == 9.4.2,+ ghc-heap == 9.4.2,+ ghci == 9.4.2 if os(windows) Build-Depends: Win32 >= 2.3 && < 2.13