diff --git a/CodeGen.Platform.h b/CodeGen.Platform.h --- a/CodeGen.Platform.h +++ b/CodeGen.Platform.h @@ -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 diff --git a/GHC/Cmm/Lexer.hs b/GHC/Cmm/Lexer.hs --- a/GHC/Cmm/Lexer.hs +++ b/GHC/Cmm/Lexer.hs @@ -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 diff --git a/GHC/Driver/GenerateCgIPEStub.hs b/GHC/Driver/GenerateCgIPEStub.hs --- a/GHC/Driver/GenerateCgIPEStub.hs +++ b/GHC/Driver/GenerateCgIPEStub.hs @@ -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 diff --git a/GHC/Driver/Main.hs b/GHC/Driver/Main.hs --- a/GHC/Driver/Main.hs +++ b/GHC/Driver/Main.hs @@ -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 diff --git a/GHC/Driver/Make.hs b/GHC/Driver/Make.hs --- a/GHC/Driver/Make.hs +++ b/GHC/Driver/Make.hs @@ -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] diff --git a/GHC/Driver/Pipeline.hs b/GHC/Driver/Pipeline.hs --- a/GHC/Driver/Pipeline.hs +++ b/GHC/Driver/Pipeline.hs @@ -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] diff --git a/GHC/Driver/Pipeline/Execute.hs b/GHC/Driver/Pipeline/Execute.hs --- a/GHC/Driver/Pipeline/Execute.hs +++ b/GHC/Driver/Pipeline/Execute.hs @@ -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 diff --git a/GHC/Driver/Pipeline/Monad.hs b/GHC/Driver/Pipeline/Monad.hs --- a/GHC/Driver/Pipeline/Monad.hs +++ b/GHC/Driver/Pipeline/Monad.hs @@ -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 } diff --git a/GHC/Iface/Make.hs b/GHC/Iface/Make.hs --- a/GHC/Iface/Make.hs +++ b/GHC/Iface/Make.hs @@ -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 diff --git a/GHC/Parser/HaddockLex.hs b/GHC/Parser/HaddockLex.hs --- a/GHC/Parser/HaddockLex.hs +++ b/GHC/Parser/HaddockLex.hs @@ -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 diff --git a/GHC/Parser/Lexer.hs b/GHC/Parser/Lexer.hs --- a/GHC/Parser/Lexer.hs +++ b/GHC/Parser/Lexer.hs @@ -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 diff --git a/GHC/Stg/InferTags.hs b/GHC/Stg/InferTags.hs --- a/GHC/Stg/InferTags.hs +++ b/GHC/Stg/InferTags.hs @@ -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 diff --git a/GHC/Stg/InferTags/Rewrite.hs b/GHC/Stg/InferTags/Rewrite.hs --- a/GHC/Stg/InferTags/Rewrite.hs +++ b/GHC/Stg/InferTags/Rewrite.hs @@ -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 diff --git a/GHC/Stg/InferTags/TagSig.hs b/GHC/Stg/InferTags/TagSig.hs --- a/GHC/Stg/InferTags/TagSig.hs +++ b/GHC/Stg/InferTags/TagSig.hs @@ -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 diff --git a/GHC/Stg/Pipeline.hs b/GHC/Stg/Pipeline.hs --- a/GHC/Stg/Pipeline.hs +++ b/GHC/Stg/Pipeline.hs @@ -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 diff --git a/GHC/StgToByteCode.hs b/GHC/StgToByteCode.hs --- a/GHC/StgToByteCode.hs +++ b/GHC/StgToByteCode.hs @@ -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 diff --git a/GHC/StgToCmm/Types.hs b/GHC/StgToCmm/Types.hs --- a/GHC/StgToCmm/Types.hs +++ b/GHC/StgToCmm/Types.hs @@ -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) } -------------------------------------------------------------------------------- diff --git a/GHC/Types/Name/Set.hs b/GHC/Types/Name/Set.hs --- a/GHC/Types/Name/Set.hs +++ b/GHC/Types/Name/Set.hs @@ -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) diff --git a/ghc.cabal b/ghc.cabal --- a/ghc.cabal +++ b/ghc.cabal @@ -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