diff options
| author | doyougnu <jeffrey.young@iohk.io> | 2022-01-04 13:22:50 -0800 |
|---|---|---|
| committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2022-01-31 18:46:11 -0500 |
| commit | 60a54a8f3681869142b0967749a6999b22bad76a (patch) | |
| tree | 920aa3a8343ef6f1a6f51bab385e9c2e20f2e57c | |
| parent | ee5c4f9d05fab41f53364dc18d30932034e6ada6 (diff) | |
| download | haskell-60a54a8f3681869142b0967749a6999b22bad76a.tar.gz | |
StgToCmm: decouple DynFlags, add StgToCmmConfig
StgToCmm: add Config, remove CgInfoDownwards
StgToCmm: runC api change to take StgToCmmConfig
StgToCmm: CgInfoDownad -> StgToCmmConfig
StgToCmm.Monad: update getters/setters/withers
StgToCmm: remove CallOpts in StgToCmm.Closure
StgToCmm: remove dynflag references
StgToCmm: PtrOpts removed
StgToCmm: add TMap to config, Prof - dynflags
StgToCmm: add omit yields to config
StgToCmm.ExtCode: remove redundant import
StgToCmm.Heap: remove references to dynflags
StgToCmm: codeGen api change, DynFlags -> Config
StgToCmm: remove dynflags in Env and StgToCmm
StgToCmm.DataCon: remove dynflags references
StgToCmm: remove dynflag references in DataCon
StgToCmm: add backend avx flags to config
StgToCmm.Prim: remove dynflag references
StgToCmm.Expr: remove dynflag references
StgToCmm.Bind: remove references to dynflags
StgToCmm: move DoAlignSanitisation to Cmm.Type
StgToCmm: remove PtrOpts in Cmm.Parser.y
DynFlags: update ipInitCode api
StgToCmm: Config Module is single source of truth
StgToCmm: Lazy config breaks IORef deadlock
testsuite: bump countdeps threshold
StgToCmm.Config: strictify fields except UpdFrame
Strictifying UpdFrameOffset causes the RTS build with stage1 to
deadlock. Additionally, before the deadlock performance of the RTS
is noticeably slower.
StgToCmm.Config: add field descriptions
StgToCmm: revert strictify on Module in config
testsuite: update CountDeps tests
StgToCmm: update comment, fix exports
Specifically update comment about loopification passed into dynflags
then stored into stgToCmmConfig. And remove getDynFlags from
Monad.hs exports
Types.Name: add pprFullName function
StgToCmm.Ticky: use pprFullname, fixup ExtCode imports
Cmm.Info: revert cmmGetClosureType removal
StgToCmm.Bind: use pprFullName, Config update comments
StgToCmm: update closureDescription api
StgToCmm: SAT altHeapCheck
StgToCmm: default render for Info table, ticky
Use default rendering contexts for info table and ticky ticky, which should be independent of command line input.
testsuite: bump count deps
pprFullName: flag for ticky vs normal style output
convertInfoProvMap: remove unused parameter
StgToCmm.Config: add backend flags to config
StgToCmm.Config: remove Backend from Config
StgToCmm.Prim: refactor Backend call sites
StgToCmm.Prim: remove redundant imports
StgToCmm.Config: refactor vec compatibility check
StgToCmm.Config: add allowQuotRem2 flag
StgToCmm.Ticky: print internal names with parens
StgToCmm.Bind: dispatch ppr based on externality
StgToCmm: Add pprTickyname, Fix ticky naming
Accidently removed the ctx for ticky SDoc output. The only relevant flag
is sdocPprDebug which was accidental set to False due to using
defaultSDocContext without altering the flag.
StgToCmm: remove stateful fields in config
fixup: config: remove redundant imports
StgToCmm: move Sequel type to its own module
StgToCmm: proliferate getCallMethod updated api
StgToCmm.Monad: add FCodeState to Monad Api
StgToCmm: add second reader monad to FCode
fixup: Prim.hs: missed a merge conflict
fixup: Match countDeps tests to HEAD
StgToCmm.Monad: withState -> withCgState
To disambiguate it from mtl withState. This withState shouldn't be
returning the new state as a value. However, fixing this means tackling
the knot tying in CgState and so is very difficult since it changes when
the thunk of the knot is forced which either leads to deadlock or to
compiler panic.
35 files changed, 805 insertions, 650 deletions
diff --git a/compiler/GHC/Cmm/Info.hs b/compiler/GHC/Cmm/Info.hs index 06100aa176..53e1b67fcc 100644 --- a/compiler/GHC/Cmm/Info.hs +++ b/compiler/GHC/Cmm/Info.hs @@ -5,7 +5,6 @@ module GHC.Cmm.Info ( srtEscape, -- info table accessors - PtrOpts (..), closureInfoPtr, entryCode, getConstrTag, @@ -439,25 +438,19 @@ srtEscape platform = toStgHalfWord platform (-1) -- ------------------------------------------------------------------------- -data PtrOpts = PtrOpts - { po_profile :: !Profile -- ^ Platform profile - , po_align_check :: !Bool -- ^ Insert alignment check (cf @-falignment-sanitisation@) - } - -- | Wrap a 'CmmExpr' in an alignment check when @-falignment-sanitisation@ is -- enabled. -wordAligned :: PtrOpts -> CmmExpr -> CmmExpr -wordAligned opts e - | po_align_check opts +wordAligned :: Platform -> DoAlignSanitisation -> CmmExpr -> CmmExpr +wordAligned platform align_check e + | align_check = CmmMachOp (MO_AlignmentCheck (platformWordSizeInBytes platform) (wordWidth platform)) [e] | otherwise = e - where platform = profilePlatform (po_profile opts) -- | Takes a closure pointer and returns the info table pointer -closureInfoPtr :: PtrOpts -> CmmExpr -> CmmExpr -closureInfoPtr opts e = - CmmLoad (wordAligned opts e) (bWord (profilePlatform (po_profile opts))) +closureInfoPtr :: Platform -> DoAlignSanitisation -> CmmExpr -> CmmExpr +closureInfoPtr platform align_check e = + CmmLoad (wordAligned platform align_check e) (bWord platform) -- | Takes an info pointer (the first word of a closure) and returns its entry -- code @@ -471,23 +464,21 @@ entryCode platform e = -- constructor tag obtained from the info table -- This lives in the SRT field of the info table -- (constructors don't need SRTs). -getConstrTag :: PtrOpts -> CmmExpr -> CmmExpr -getConstrTag opts closure_ptr +getConstrTag :: Profile -> DoAlignSanitisation -> CmmExpr -> CmmExpr +getConstrTag profile align_check closure_ptr = CmmMachOp (MO_UU_Conv (halfWordWidth platform) (wordWidth platform)) [infoTableConstrTag profile info_table] where - info_table = infoTable profile (closureInfoPtr opts closure_ptr) + info_table = infoTable profile (closureInfoPtr platform align_check closure_ptr) platform = profilePlatform profile - profile = po_profile opts -- | Takes a closure pointer, and return the closure type -- obtained from the info table -cmmGetClosureType :: PtrOpts -> CmmExpr -> CmmExpr -cmmGetClosureType opts closure_ptr +cmmGetClosureType :: Profile -> DoAlignSanitisation -> CmmExpr -> CmmExpr +cmmGetClosureType profile align_check closure_ptr = CmmMachOp (MO_UU_Conv (halfWordWidth platform) (wordWidth platform)) [infoTableClosureType profile info_table] where - info_table = infoTable profile (closureInfoPtr opts closure_ptr) + info_table = infoTable profile (closureInfoPtr platform align_check closure_ptr) platform = profilePlatform profile - profile = po_profile opts -- | Takes an info pointer (the first word of a closure) -- and returns a pointer to the first word of the standard-form diff --git a/compiler/GHC/Cmm/Parser.y b/compiler/GHC/Cmm/Parser.y index 712a7a5e8a..ed9492aa32 100644 --- a/compiler/GHC/Cmm/Parser.y +++ b/compiler/GHC/Cmm/Parser.y @@ -208,6 +208,7 @@ import qualified Prelude -- for happy-generated code import GHC.Driver.Session import GHC.Driver.Ppr import GHC.Driver.Config.Parser (initParserOpts) +import GHC.Driver.Config.StgToCmm import GHC.Platform import GHC.Platform.Profile @@ -217,13 +218,14 @@ import GHC.StgToCmm.Prof import GHC.StgToCmm.Heap import GHC.StgToCmm.Monad hiding ( getCode, getCodeR, getCodeScoped, emitLabel, emit , emitStore, emitAssign, emitOutOfLine, withUpdFrameOff - , getUpdFrameOff, getProfile, getPlatform, getPtrOpts ) + , getUpdFrameOff, getProfile, getPlatform, getContext) import qualified GHC.StgToCmm.Monad as F import GHC.StgToCmm.Utils import GHC.StgToCmm.Foreign import GHC.StgToCmm.Expr import GHC.StgToCmm.Lit import GHC.StgToCmm.Closure +import GHC.StgToCmm.Config import GHC.StgToCmm.Layout hiding (ArgRep(..)) import GHC.StgToCmm.Ticky import GHC.StgToCmm.Prof @@ -238,7 +240,7 @@ import GHC.Cmm.Info import GHC.Cmm.BlockId import GHC.Cmm.Lexer import GHC.Cmm.CLabel -import GHC.Cmm.Parser.Monad hiding (getPlatform, getProfile, getPtrOpts) +import GHC.Cmm.Parser.Monad hiding (getPlatform, getProfile) import qualified GHC.Cmm.Parser.Monad as PD import GHC.Cmm.CallConv import GHC.Runtime.Heap.Layout @@ -449,10 +451,10 @@ cmmproc :: { CmmParse () } { do ((entry_ret_label, info, stk_formals, formals), agraph) <- getCodeScoped $ loopDecls $ do { (entry_ret_label, info, stk_formals) <- $1; - dflags <- getDynFlags; platform <- getPlatform; + ctx <- getContext; formals <- sequence (fromMaybe [] $3); - withName (showSDoc dflags (pdoc platform entry_ret_label)) + withName (renderWithContext ctx (pdoc platform entry_ret_label)) $4; return (entry_ret_label, info, stk_formals, formals) } let do_layout = isJust $3 @@ -925,8 +927,9 @@ nameToMachOp name = exprOp :: FastString -> [CmmParse CmmExpr] -> PD (CmmParse CmmExpr) exprOp name args_code = do - ptr_opts <- PD.getPtrOpts - case lookupUFM (exprMacros ptr_opts) name of + profile <- PD.getProfile + align_check <- gopt Opt_AlignmentSanitisation <$> getDynFlags + case lookupUFM (exprMacros profile align_check) name of Just f -> return $ do args <- sequence args_code return (f args) @@ -934,21 +937,20 @@ exprOp name args_code = do mo <- nameToMachOp name return $ mkMachOp mo args_code -exprMacros :: PtrOpts -> UniqFM FastString ([CmmExpr] -> CmmExpr) -exprMacros ptr_opts = listToUFM [ +exprMacros :: Profile -> DoAlignSanitisation -> UniqFM FastString ([CmmExpr] -> CmmExpr) +exprMacros profile align_check = listToUFM [ ( fsLit "ENTRY_CODE", \ [x] -> entryCode platform x ), - ( fsLit "INFO_PTR", \ [x] -> closureInfoPtr ptr_opts x ), - ( fsLit "STD_INFO", \ [x] -> infoTable profile x ), + ( fsLit "INFO_PTR", \ [x] -> closureInfoPtr platform align_check x ), + ( fsLit "STD_INFO", \ [x] -> infoTable profile x ), ( fsLit "FUN_INFO", \ [x] -> funInfoTable profile x ), - ( fsLit "GET_ENTRY", \ [x] -> entryCode platform (closureInfoPtr ptr_opts x) ), - ( fsLit "GET_STD_INFO", \ [x] -> infoTable profile (closureInfoPtr ptr_opts x) ), - ( fsLit "GET_FUN_INFO", \ [x] -> funInfoTable profile (closureInfoPtr ptr_opts x) ), + ( fsLit "GET_ENTRY", \ [x] -> entryCode platform (closureInfoPtr platform align_check x) ), + ( fsLit "GET_STD_INFO", \ [x] -> infoTable profile (closureInfoPtr platform align_check x) ), + ( fsLit "GET_FUN_INFO", \ [x] -> funInfoTable profile (closureInfoPtr platform align_check x) ), ( fsLit "INFO_TYPE", \ [x] -> infoTableClosureType profile x ), ( fsLit "INFO_PTRS", \ [x] -> infoTablePtrs profile x ), ( fsLit "INFO_NPTRS", \ [x] -> infoTableNonPtrs profile x ) ] where - profile = po_profile ptr_opts platform = profilePlatform profile -- we understand a subset of C-- primitives: @@ -1513,13 +1515,14 @@ parseCmmFile dflags this_mod home_unit filename = do return (warnings, errors, Nothing) POk pst code -> do st <- initC + let fstate = F.initFCodeState (profilePlatform $ targetProfile dflags) let fcode = do ((), cmm) <- getCmm $ unEC code "global" (initEnv (targetProfile dflags)) [] >> return () let used_info = map (cmmInfoTableToInfoProvEnt this_mod) (mapMaybe topInfoTable cmm) ((), cmm2) <- getCmm $ mapM_ emitInfoTableProv used_info return (cmm ++ cmm2, used_info) - (cmm, _) = runC dflags no_module st fcode + (cmm, _) = runC (initStgToCmmConfig dflags no_module) fstate st fcode (warnings,errors) = getPsMessages pst if not (isEmptyMessages errors) then return (warnings, errors, Nothing) diff --git a/compiler/GHC/Cmm/Parser/Monad.hs b/compiler/GHC/Cmm/Parser/Monad.hs index 4a72780c2f..e7d763497a 100644 --- a/compiler/GHC/Cmm/Parser/Monad.hs +++ b/compiler/GHC/Cmm/Parser/Monad.hs @@ -13,7 +13,6 @@ module GHC.Cmm.Parser.Monad ( , failMsgPD , getProfile , getPlatform - , getPtrOpts , getHomeUnitId ) where @@ -21,7 +20,6 @@ import GHC.Prelude import GHC.Platform import GHC.Platform.Profile -import GHC.Cmm.Info import Control.Monad @@ -69,15 +67,6 @@ getProfile = targetProfile <$> getDynFlags getPlatform :: PD Platform getPlatform = profilePlatform <$> getProfile -getPtrOpts :: PD PtrOpts -getPtrOpts = do - dflags <- getDynFlags - profile <- getProfile - pure $ PtrOpts - { po_profile = profile - , po_align_check = gopt Opt_AlignmentSanitisation dflags - } - -- | Return the UnitId of the home-unit. This is used to create labels. getHomeUnitId :: PD UnitId getHomeUnitId = PD $ \_ hu s -> POk s (homeUnitId hu) diff --git a/compiler/GHC/Cmm/Type.hs b/compiler/GHC/Cmm/Type.hs index b62aa01a90..ee059caa12 100644 --- a/compiler/GHC/Cmm/Type.hs +++ b/compiler/GHC/Cmm/Type.hs @@ -26,6 +26,8 @@ module GHC.Cmm.Type , cmmVec , vecLength, vecElemType , isVecType + + , DoAlignSanitisation ) where @@ -471,3 +473,6 @@ C calling convention rather early on in the compiler). However, given this, the cons outweigh the pros. -} + +-- | is @-falignment-sanitisation@ enabled? +type DoAlignSanitisation = Bool diff --git a/compiler/GHC/CoreToStg.hs b/compiler/GHC/CoreToStg.hs index 8540421639..0f6ac1121d 100644 --- a/compiler/GHC/CoreToStg.hs +++ b/compiler/GHC/CoreToStg.hs @@ -725,7 +725,7 @@ mkTopStgRhs dflags this_mod ccs bndr (PreStgRhs bndrs rhs) -- so this is not a function binding | StgConApp con mn args _ <- unticked_rhs , -- Dynamic StgConApps are updatable - not (isDllConApp dflags this_mod con args) + not (isDllConApp (targetPlatform dflags) (gopt Opt_ExternalDynamicRefs dflags) this_mod con args) = -- CorePrep does this right, but just to make sure assertPpr (not (isUnboxedTupleDataCon con || isUnboxedSumDataCon con)) (ppr bndr $$ ppr con $$ ppr args) diff --git a/compiler/GHC/Driver/CodeOutput.hs b/compiler/GHC/Driver/CodeOutput.hs index f9cb1adce3..feb9efb5f7 100644 --- a/compiler/GHC/Driver/CodeOutput.hs +++ b/compiler/GHC/Driver/CodeOutput.hs @@ -336,9 +336,14 @@ profilingInitCode platform this_mod (local_CCs, singleton_CCSs) -- | Generate code to initialise info pointer origin -- See note [Mapping Info Tables to Source Positions] -ipInitCode :: DynFlags -> Module -> [InfoProvEnt] -> CStub -ipInitCode dflags this_mod ents - = if not (gopt Opt_InfoTableMap dflags) +ipInitCode + :: Bool -- is Opt_InfoTableMap enabled or not + -> Platform + -> Module + -> [InfoProvEnt] + -> CStub +ipInitCode do_info_table platform this_mod ents + = if not do_info_table then mempty else CStub $ vcat $ map emit_ipe_decl ents @@ -351,7 +356,6 @@ ipInitCode dflags this_mod ents ]) ] where - platform = targetPlatform dflags emit_ipe_decl ipe = text "extern InfoProvEnt" <+> ipe_lbl <> text "[];" where ipe_lbl = pprCLabel platform CStyle (mkIPELabel ipe) diff --git a/compiler/GHC/Driver/Config/StgToCmm.hs b/compiler/GHC/Driver/Config/StgToCmm.hs new file mode 100644 index 0000000000..ae59e41fdf --- /dev/null +++ b/compiler/GHC/Driver/Config/StgToCmm.hs @@ -0,0 +1,74 @@ +module GHC.Driver.Config.StgToCmm + ( initStgToCmmConfig + ) where + +import GHC.StgToCmm.Config + +import GHC.Driver.Backend +import GHC.Driver.Session +import GHC.Platform +import GHC.Platform.Profile +import GHC.Unit.Module +import GHC.Utils.Outputable + +import Data.Maybe +import Prelude + +initStgToCmmConfig :: DynFlags -> Module -> StgToCmmConfig +initStgToCmmConfig dflags mod = StgToCmmConfig + -- settings + { stgToCmmProfile = profile + , stgToCmmThisModule = mod + , stgToCmmTmpDir = tmpDir dflags + , stgToCmmContext = initSDocContext dflags defaultDumpStyle + , stgToCmmDebugLevel = debugLevel dflags + , stgToCmmBinBlobThresh = binBlobThreshold dflags + , stgToCmmMaxInlAllocSize = maxInlineAllocSize dflags + -- ticky options + , stgToCmmDoTicky = gopt Opt_Ticky dflags + , stgToCmmTickyAllocd = gopt Opt_Ticky_Allocd dflags + , stgToCmmTickyLNE = gopt Opt_Ticky_LNE dflags + , stgToCmmTickyDynThunk = gopt Opt_Ticky_Dyn_Thunk dflags + -- flags + , stgToCmmLoopification = gopt Opt_Loopification dflags + , stgToCmmAlignCheck = gopt Opt_AlignmentSanitisation dflags + , stgToCmmOptHpc = gopt Opt_Hpc dflags + , stgToCmmFastPAPCalls = gopt Opt_FastPAPCalls dflags + , stgToCmmSCCProfiling = sccProfilingEnabled dflags + , stgToCmmEagerBlackHole = gopt Opt_EagerBlackHoling dflags + , stgToCmmInfoTableMap = gopt Opt_InfoTableMap dflags + , stgToCmmOmitYields = gopt Opt_OmitYields dflags + , stgToCmmOmitIfPragmas = gopt Opt_OmitInterfacePragmas dflags + , stgToCmmPIC = gopt Opt_PIC dflags + , stgToCmmPIE = gopt Opt_PIE dflags + , stgToCmmExtDynRefs = gopt Opt_ExternalDynamicRefs dflags + , stgToCmmDoBoundsCheck = gopt Opt_DoBoundsChecking dflags + -- backend flags + , stgToCmmAllowBigArith = not ncg + , stgToCmmAllowQuotRemInstr = ncg && (x86ish || ppc) + , stgToCmmAllowQuotRem2 = (ncg && (x86ish || ppc)) || llvm + , stgToCmmAllowExtendedAddSubInstrs = (ncg && (x86ish || ppc)) || llvm + , stgToCmmAllowIntMul2Instr = (ncg && x86ish) || llvm + , stgToCmmAllowFabsInstrs = (ncg && (x86ish || ppc || aarch64)) || llvm + -- SIMD flags + , stgToCmmVecInstrsErr = vec_err + , stgToCmmAvx = isAvxEnabled dflags + , stgToCmmAvx2 = isAvx2Enabled dflags + , stgToCmmAvx512f = isAvx512fEnabled dflags + } where profile = targetProfile dflags + platform = profilePlatform profile + bk_end = backend dflags + ncg = bk_end == NCG + llvm = bk_end == LLVM + x86ish = case platformArch platform of + ArchX86 -> True + ArchX86_64 -> True + _ -> False + ppc = case platformArch platform of + ArchPPC -> True + ArchPPC_64 _ -> True + _ -> False + aarch64 = platformArch platform == ArchAArch64 + vec_err = case backend dflags of + LLVM -> Nothing + _ -> Just (unlines ["SIMD vector instructions require the LLVM back-end.", "Please use -fllvm."]) diff --git a/compiler/GHC/Driver/GenerateCgIPEStub.hs b/compiler/GHC/Driver/GenerateCgIPEStub.hs index e0b0deaa83..c650df6023 100644 --- a/compiler/GHC/Driver/GenerateCgIPEStub.hs +++ b/compiler/GHC/Driver/GenerateCgIPEStub.hs @@ -19,11 +19,12 @@ import qualified GHC.Data.Stream as Stream import GHC.Driver.Env (hsc_dflags) import GHC.Driver.Flags (GeneralFlag (Opt_InfoTableMap)) import GHC.Driver.Session (gopt, targetPlatform) +import GHC.Driver.Config.StgToCmm import GHC.Plugins (HscEnv, NonCaffySet) import GHC.Prelude import GHC.Runtime.Heap.Layout (isStackRep) import GHC.Settings (Platform, platformUnregisterised) -import GHC.StgToCmm.Monad (getCmm, initC, runC) +import GHC.StgToCmm.Monad (getCmm, initC, runC, initFCodeState) import GHC.StgToCmm.Prof (initInfoTableProv) import GHC.StgToCmm.Types (CgInfos (..), ModuleLFInfos) import GHC.Types.IPE (InfoTableProvMap (provInfoTables), IpeSourceLocation) @@ -177,8 +178,9 @@ The find the tick: generateCgIPEStub :: HscEnv -> Module -> InfoTableProvMap -> Stream IO CmmGroupSRTs (NonCaffySet, ModuleLFInfos) -> Stream IO CmmGroupSRTs CgInfos generateCgIPEStub hsc_env this_mod denv s = do - let dflags = hsc_dflags hsc_env + let dflags = hsc_dflags hsc_env platform = targetPlatform dflags + fstate = initFCodeState platform cgState <- liftIO initC -- Collect info tables, but only if -finfo-table-map is enabled, otherwise labeledInfoTablesWithTickishes is empty. @@ -187,7 +189,7 @@ generateCgIPEStub hsc_env this_mod denv s = do -- Yield Cmm for Info Table Provenance Entries (IPEs) let denv' = denv {provInfoTables = Map.fromList (map (\(_, i, t) -> (cit_lbl i, t)) labeledInfoTablesWithTickishes)} - ((ipeStub, ipeCmmGroup), _) = runC dflags this_mod cgState $ getCmm (initInfoTableProv (map sndOfTriple labeledInfoTablesWithTickishes) denv' this_mod) + ((ipeStub, ipeCmmGroup), _) = runC (initStgToCmmConfig dflags this_mod) fstate cgState $ getCmm (initInfoTableProv (map sndOfTriple labeledInfoTablesWithTickishes) denv') (_, ipeCmmGroupSRTs) <- liftIO $ cmmPipeline hsc_env (emptySRT this_mod) ipeCmmGroup Stream.yield ipeCmmGroupSRTs diff --git a/compiler/GHC/Driver/Hooks.hs b/compiler/GHC/Driver/Hooks.hs index b455baef9d..ae00340d54 100644 --- a/compiler/GHC/Driver/Hooks.hs +++ b/compiler/GHC/Driver/Hooks.hs @@ -62,6 +62,7 @@ import GHC.Core.Type import GHC.Tc.Types import GHC.Stg.Syntax import GHC.StgToCmm.Types (ModuleLFInfos) +import GHC.StgToCmm.Config import GHC.Cmm import GHCi.RemoteTypes @@ -144,7 +145,7 @@ data Hooks = Hooks , getValueSafelyHook :: !(Maybe (HscEnv -> Maybe ModuleNameWithIsBoot -> Name -> Type -> IO (Either Type HValue))) , createIservProcessHook :: !(Maybe (CreateProcess -> IO ProcessHandle)) - , stgToCmmHook :: !(Maybe (DynFlags -> Module -> InfoTableProvMap -> [TyCon] -> CollectedCCs + , stgToCmmHook :: !(Maybe (StgToCmmConfig -> InfoTableProvMap -> [TyCon] -> CollectedCCs -> [CgStgTopBinding] -> HpcInfo -> Stream IO CmmGroup ModuleLFInfos)) , cmmToRawCmmHook :: !(forall a . Maybe (DynFlags -> Maybe Module -> Stream IO CmmGroupSRTs a -> IO (Stream IO RawCmmGroup a))) diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs index 38406fe172..5c088cc959 100644 --- a/compiler/GHC/Driver/Main.hs +++ b/compiler/GHC/Driver/Main.hs @@ -104,8 +104,9 @@ import GHC.Driver.Env import GHC.Driver.Errors import GHC.Driver.Errors.Types import GHC.Driver.CodeOutput -import GHC.Driver.Config.Logger (initLogFlags) -import GHC.Driver.Config.Parser (initParserOpts) +import GHC.Driver.Config.Logger (initLogFlags) +import GHC.Driver.Config.Parser (initParserOpts) +import GHC.Driver.Config.StgToCmm (initStgToCmmConfig) import GHC.Driver.Config.Diagnostic import GHC.Driver.Hooks @@ -1703,12 +1704,13 @@ hscInteractive hsc_env cgguts location = do hscCompileCmmFile :: HscEnv -> FilePath -> FilePath -> IO (Maybe FilePath) hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do let dflags = hsc_dflags hsc_env - let logger = hsc_logger hsc_env - let profile = targetProfile dflags - let hooks = hsc_hooks hsc_env - let tmpfs = hsc_tmpfs hsc_env + logger = hsc_logger hsc_env + hooks = hsc_hooks hsc_env + tmpfs = hsc_tmpfs hsc_env + profile = targetProfile dflags home_unit = hsc_home_unit hsc_env platform = targetPlatform dflags + do_info_table = gopt Opt_InfoTableMap dflags -- Make up a module name to give the NCG. We can't pass bottom here -- lest we reproduce #11784. mod_name = mkModuleName $ "Cmm$" ++ FilePath.takeFileName filename @@ -1736,11 +1738,11 @@ hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do FormatCMM (pdoc platform cmmgroup) rawCmms <- case cmmToRawCmmHook hooks of - Nothing -> cmmToRawCmm logger profile (Stream.yield cmmgroup) - Just h -> h dflags Nothing (Stream.yield cmmgroup) + Nothing -> cmmToRawCmm logger profile (Stream.yield cmmgroup) + Just h -> h dflags Nothing (Stream.yield cmmgroup) let foreign_stubs _ = - let ip_init = ipInitCode dflags cmm_mod ents + let ip_init = ipInitCode do_info_table platform cmm_mod ents in NoStubs `appendStubC` ip_init (_output_filename, (_stub_h_exists, stub_c_exists), _foreign_fps, _caf_infos) @@ -1785,17 +1787,17 @@ doCodeGen :: HscEnv -> Module -> InfoTableProvMap -> [TyCon] -- the C-- up front, which has a significant space cost. doCodeGen hsc_env this_mod denv data_tycons cost_centre_info stg_binds_w_fvs hpc_info = do - let dflags = hsc_dflags hsc_env - let logger = hsc_logger hsc_env - let hooks = hsc_hooks hsc_env - let tmpfs = hsc_tmpfs hsc_env - let platform = targetPlatform dflags + let dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env + hooks = hsc_hooks hsc_env + tmpfs = hsc_tmpfs hsc_env + platform = targetPlatform dflags putDumpFileMaybe logger Opt_D_dump_stg_final "Final STG:" FormatSTG (pprGenStgTopBindings (initStgPprOpts dflags) stg_binds_w_fvs) - let stg_to_cmm = case stgToCmmHook hooks of - Nothing -> StgToCmm.codeGen logger tmpfs - Just h -> h + let stg_to_cmm dflags mod = case stgToCmmHook hooks of + Nothing -> StgToCmm.codeGen logger tmpfs (initStgToCmmConfig dflags mod) + Just h -> h (initStgToCmmConfig dflags mod) let cmm_stream :: Stream IO CmmGroup ModuleLFInfos -- See Note [Forcing of stg_binds] diff --git a/compiler/GHC/Stg/Syntax.hs b/compiler/GHC/Stg/Syntax.hs index cc93157126..5d2b0facc1 100644 --- a/compiler/GHC/Stg/Syntax.hs +++ b/compiler/GHC/Stg/Syntax.hs @@ -127,14 +127,19 @@ data StgArg -- | Does this constructor application refer to anything in a different -- *Windows* DLL? -- If so, we can't allocate it statically -isDllConApp :: DynFlags -> Module -> DataCon -> [StgArg] -> Bool -isDllConApp dflags this_mod con args - | not (gopt Opt_ExternalDynamicRefs dflags) = False +isDllConApp + :: Platform + -> Bool -- is Opt_ExternalDynamicRefs enabled? + -> Module + -> DataCon + -> [StgArg] + -> Bool +isDllConApp platform ext_dyn_refs this_mod con args + | not ext_dyn_refs = False | platformOS platform == OSMinGW32 = isDynLinkName platform this_mod (dataConName con) || any is_dll_arg args | otherwise = False where - platform = targetPlatform dflags -- NB: typePrimRep1 is legit because any free variables won't have -- unlifted type (there are no unlifted things at top level) is_dll_arg :: StgArg -> Bool diff --git a/compiler/GHC/StgToCmm.hs b/compiler/GHC/StgToCmm.hs index f9ece04b8a..9931b81e6e 100644 --- a/compiler/GHC/StgToCmm.hs +++ b/compiler/GHC/StgToCmm.hs @@ -16,7 +16,6 @@ module GHC.StgToCmm ( codeGen ) where import GHC.Prelude as Prelude import GHC.Driver.Backend -import GHC.Driver.Session import GHC.StgToCmm.Prof (initCostCentres, ldvEnter) import GHC.StgToCmm.Monad @@ -26,6 +25,7 @@ import GHC.StgToCmm.DataCon import GHC.StgToCmm.Layout import GHC.StgToCmm.Utils import GHC.StgToCmm.Closure +import GHC.StgToCmm.Config import GHC.StgToCmm.Hpc import GHC.StgToCmm.Ticky import GHC.StgToCmm.Types (ModuleLFInfos) @@ -73,8 +73,7 @@ import Data.IORef codeGen :: Logger -> TmpFs - -> DynFlags - -> Module + -> StgToCmmConfig -> InfoTableProvMap -> [TyCon] -> CollectedCCs -- (Local/global) cost-centres needing declaring/registering. @@ -83,7 +82,7 @@ codeGen :: Logger -> Stream IO CmmGroup ModuleLFInfos -- Output as a stream, so codegen can -- be interleaved with output -codeGen logger tmpfs dflags this_mod (InfoTableProvMap (UniqMap denv) _ _) data_tycons +codeGen logger tmpfs cfg (InfoTableProvMap (UniqMap denv) _ _) data_tycons cost_centre_info stg_binds hpc_info = do { -- cg: run the code generator, and yield the resulting CmmGroup -- Using an IORef to store the state is a bit crude, but otherwise @@ -94,7 +93,8 @@ codeGen logger tmpfs dflags this_mod (InfoTableProvMap (UniqMap denv) _ _) data_ cg fcode = do (a, cmm) <- liftIO . withTimingSilent logger (text "STG -> Cmm") (`seq` ()) $ do st <- readIORef cgref - let (a,st') = runC dflags this_mod st (getCmm fcode) + let fstate = initFCodeState $ stgToCmmPlatform cfg + let (a,st') = runC cfg fstate st (getCmm fcode) -- NB. stub-out cgs_tops and cgs_stmts. This fixes -- a big space leak. DO NOT REMOVE! @@ -108,9 +108,9 @@ codeGen logger tmpfs dflags this_mod (InfoTableProvMap (UniqMap denv) _ _) data_ -- FIRST. This is because when -split-objs is on we need to -- combine this block with its initialisation routines; see -- Note [pipeline-split-init]. - ; cg (mkModuleInit cost_centre_info this_mod hpc_info) + ; cg (mkModuleInit cost_centre_info (stgToCmmThisModule cfg) hpc_info) - ; mapM_ (cg . cgTopBinding logger tmpfs dflags) stg_binds + ; mapM_ (cg . cgTopBinding logger tmpfs cfg) stg_binds -- Put datatype_stuff after code_stuff, because the -- datatype closure table (for enumeration types) to -- (say) PrelBase_True_closure, which is defined in @@ -127,7 +127,7 @@ codeGen logger tmpfs dflags this_mod (InfoTableProvMap (UniqMap denv) _ _) data_ -- Emit special info tables for everything used in this module -- This will only do something if `-fdistinct-info-tables` is turned on. - ; mapM_ (\(dc, ns) -> forM_ ns $ \(k, _ss) -> cg (cgDataCon (UsageSite this_mod k) dc)) (nonDetEltsUFM denv) + ; mapM_ (\(dc, ns) -> forM_ ns $ \(k, _ss) -> cg (cgDataCon (UsageSite (stgToCmmThisModule cfg) k) dc)) (nonDetEltsUFM denv) ; final_state <- liftIO (readIORef cgref) ; let cg_id_infos = cgs_binds final_state @@ -140,7 +140,7 @@ codeGen logger tmpfs dflags this_mod (InfoTableProvMap (UniqMap denv) _ _) data_ !lf = cg_lf info !generatedInfo - | gopt Opt_OmitInterfacePragmas dflags + | stgToCmmOmitIfPragmas cfg = emptyNameEnv | otherwise = mkNameEnv (Prelude.map extractInfo (nonDetEltsUFM cg_id_infos)) @@ -162,17 +162,17 @@ This is so that we can write the top level processing in a compositional style, with the increasing static environment being plumbed as a state variable. -} -cgTopBinding :: Logger -> TmpFs -> DynFlags -> CgStgTopBinding -> FCode () -cgTopBinding logger tmpfs dflags = \case +cgTopBinding :: Logger -> TmpFs -> StgToCmmConfig -> CgStgTopBinding -> FCode () +cgTopBinding logger tmpfs cfg = \case StgTopLifted (StgNonRec id rhs) -> do - let (info, fcode) = cgTopRhs dflags NonRecursive id rhs + let (info, fcode) = cgTopRhs cfg NonRecursive id rhs fcode addBindC info StgTopLifted (StgRec pairs) -> do let (bndrs, rhss) = unzip pairs let pairs' = zip bndrs rhss - r = unzipWith (cgTopRhs dflags Recursive) pairs' + r = unzipWith (cgTopRhs cfg Recursive) pairs' (infos, fcodes) = unzip r addBindsC infos sequence_ fcodes @@ -182,31 +182,32 @@ cgTopBinding logger tmpfs dflags = \case -- emit either a CmmString literal or dump the string in a file and emit a -- CmmFileEmbed literal. -- See Note [Embedding large binary blobs] in GHC.CmmToAsm.Ppr - let isNCG = backend dflags == NCG - isSmall = fromIntegral (BS.length str) <= binBlobThreshold dflags - asString = binBlobThreshold dflags == 0 || isSmall + let bin_blob_threshold = stgToCmmBinBlobThresh cfg + isNCG = platformDefaultBackend (stgToCmmPlatform cfg) == NCG + isSmall = fromIntegral (BS.length str) <= bin_blob_threshold + asString = bin_blob_threshold == 0 || isSmall (lit,decl) = if not isNCG || asString then mkByteStringCLit label str else mkFileEmbedLit label $ unsafePerformIO $ do - bFile <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule ".dat" + bFile <- newTempName logger tmpfs (stgToCmmTmpDir cfg) TFL_CurrentModule ".dat" BS.writeFile bFile str return bFile emitDecl decl - addBindC (litIdInfo (targetPlatform dflags) id mkLFStringLit lit) + addBindC (litIdInfo (stgToCmmPlatform cfg) id mkLFStringLit lit) -cgTopRhs :: DynFlags -> RecFlag -> Id -> CgStgRhs -> (CgIdInfo, FCode ()) +cgTopRhs :: StgToCmmConfig -> RecFlag -> Id -> CgStgRhs -> (CgIdInfo, FCode ()) -- The Id is passed along for setting up a binding... -cgTopRhs dflags _rec bndr (StgRhsCon _cc con mn _ts args) - = cgTopRhsCon dflags bndr con mn (assertNonVoidStgArgs args) +cgTopRhs cfg _rec bndr (StgRhsCon _cc con mn _ts args) + = cgTopRhsCon cfg bndr con mn (assertNonVoidStgArgs args) -- con args are always non-void, -- see Note [Post-unarisation invariants] in GHC.Stg.Unarise -cgTopRhs dflags rec bndr (StgRhsClosure fvs cc upd_flag args body) +cgTopRhs cfg rec bndr (StgRhsClosure fvs cc upd_flag args body) = assert (isEmptyDVarSet fvs) -- There should be no free variables - cgTopRhsClosure (targetPlatform dflags) rec bndr cc upd_flag args body + cgTopRhsClosure (stgToCmmPlatform cfg) rec bndr cc upd_flag args body --------------------------------------------------------------- diff --git a/compiler/GHC/StgToCmm/Bind.hs b/compiler/GHC/StgToCmm/Bind.hs index 7d89b71309..7107370698 100644 --- a/compiler/GHC/StgToCmm/Bind.hs +++ b/compiler/GHC/StgToCmm/Bind.hs @@ -26,6 +26,7 @@ import GHC.Stg.Syntax import GHC.Platform import GHC.Platform.Profile +import GHC.StgToCmm.Config import GHC.StgToCmm.Expr import GHC.StgToCmm.Monad import GHC.StgToCmm.Env @@ -106,10 +107,9 @@ cgTopRhsClosure platform rec id ccs upd_flag args body = gen_code lf_info _closure_label = do { profile <- getProfile - ; dflags <- getDynFlags ; let name = idName id ; mod_name <- getModuleName - ; let descr = closureDescription dflags mod_name name + ; let descr = closureDescription mod_name name closure_info = mkClosureInfo profile True id lf_info 0 0 descr -- We don't generate the static closure here, because we might @@ -356,9 +356,8 @@ mkRhsClosure profile bndr cc fvs upd_flag args body -- MAKE CLOSURE INFO FOR THIS CLOSURE ; mod_name <- getModuleName - ; dflags <- getDynFlags ; let name = idName bndr - descr = closureDescription dflags mod_name name + descr = closureDescription mod_name name fv_details :: [(NonVoid Id, ByteOff)] header = if isLFThunk lf_info then ThunkHeader else StdHeader (tot_wds, ptr_wds, fv_details) @@ -404,15 +403,15 @@ cgRhsStdThunk bndr lf_info payload do { -- LAY OUT THE OBJECT mod_name <- getModuleName - ; dflags <- getDynFlags - ; profile <- getProfile - ; let platform = profilePlatform profile + ; cfg <- getStgToCmmConfig + ; let profile = stgToCmmProfile cfg + ; let platform = stgToCmmPlatform cfg header = if isLFThunk lf_info then ThunkHeader else StdHeader (tot_wds, ptr_wds, payload_w_offsets) = mkVirtHeapOffsets profile header (addArgReps (nonVoidStgArgs payload)) - descr = closureDescription dflags mod_name (idName bndr) + descr = closureDescription mod_name (idName bndr) closure_info = mkClosureInfo profile False -- Not static bndr lf_info tot_wds ptr_wds descr @@ -563,16 +562,18 @@ mkSlowEntryCode :: Id -> ClosureInfo -> [LocalReg] -> FCode () -- Here, we emit the slow-entry code. mkSlowEntryCode bndr cl_info arg_regs -- function closure is already in `Node' | Just (_, ArgGen _) <- closureFunInfo cl_info - = do profile <- getProfile - platform <- getPlatform + = do cfg <- getStgToCmmConfig + upd_frame <- getUpdFrameOff let node = idToReg platform (NonVoid bndr) + profile = stgToCmmProfile cfg + platform = stgToCmmPlatform cfg slow_lbl = closureSlowEntryLabel platform cl_info fast_lbl = closureLocalEntryLabel platform cl_info -- mkDirectJump does not clobber `Node' containing function closure jump = mkJump profile NativeNodeCall (mkLblExpr fast_lbl) (map (CmmReg . CmmLocal) (node : arg_regs)) - (initUpdFrameOff platform) + upd_frame tscope <- getTickScope emitProcWithConvention Slow Nothing slow_lbl (node : arg_regs) (jump, tscope) @@ -620,9 +621,10 @@ blackHoleIt node_reg emitBlackHoleCode :: CmmExpr -> FCode () emitBlackHoleCode node = do - dflags <- getDynFlags - profile <- getProfile - let platform = profilePlatform profile + cfg <- getStgToCmmConfig + let profile = stgToCmmProfile cfg + platform = stgToCmmPlatform cfg + is_eager_bh = stgToCmmEagerBlackHole cfg -- Eager blackholing is normally disabled, but can be turned on with -- -feager-blackholing. When it is on, we replace the info pointer @@ -642,8 +644,7 @@ emitBlackHoleCode node = do -- Note the eager-blackholing check is here rather than in blackHoleOnEntry, -- because emitBlackHoleCode is called from GHC.Cmm.Parser. - let eager_blackholing = not (profileIsProfiling profile) - && gopt Opt_EagerBlackHoling dflags + let eager_blackholing = not (profileIsProfiling profile) && is_eager_bh -- Profiling needs slop filling (to support LDV -- profiling), so currently eager blackholing doesn't -- work with profiling. @@ -668,11 +669,11 @@ setupUpdate closure_info node body then do tickyUpdateFrameOmitted; body else do tickyPushUpdateFrame - dflags <- getDynFlags + cfg <- getStgToCmmConfig let - bh = blackHoleOnEntry closure_info && - not (sccProfilingEnabled dflags) && - gopt Opt_EagerBlackHoling dflags + bh = blackHoleOnEntry closure_info + && not (stgToCmmSCCProfiling cfg) + && stgToCmmEagerBlackHole cfg lbl | bh = mkBHUpdInfoLabel | otherwise = mkUpdInfoLabel @@ -730,11 +731,12 @@ link_caf :: LocalReg -- pointer to the closure -- This function returns the address of the black hole, so it can be -- updated with the new value when available. link_caf node = do - { profile <- getProfile + { cfg <- getStgToCmmConfig -- Call the RTS function newCAF, returning the newly-allocated -- blackhole indirection closure ; let newCAF_lbl = mkForeignLabel (fsLit "newCAF") Nothing ForeignLabelInExternalPackage IsFunction + ; let profile = stgToCmmProfile cfg ; let platform = profilePlatform profile ; bh <- newTemp (bWord platform) ; emitRtsCallGen [(bh,AddrHint)] newCAF_lbl @@ -744,8 +746,9 @@ link_caf node = do -- see Note [atomic CAF entry] in rts/sm/Storage.c ; updfr <- getUpdFrameOff - ; ptr_opts <- getPtrOpts - ; let target = entryCode platform (closureInfoPtr ptr_opts (CmmReg (CmmLocal node))) + ; let align_check = stgToCmmAlignCheck cfg + ; let target = entryCode platform + (closureInfoPtr platform align_check (CmmReg (CmmLocal node))) ; emit =<< mkCmmIfThen (cmmEqWord platform (CmmReg (CmmLocal bh)) (zeroExpr platform)) -- re-enter the CAF @@ -762,17 +765,11 @@ link_caf node = do -- @closureDescription@ from the let binding information. closureDescription - :: DynFlags - -> Module -- Module + :: Module -- Module -> Name -- Id of closure binding -> String -- Not called for StgRhsCon which have global info tables built in -- CgConTbls.hs with a description generated from the data constructor -closureDescription dflags mod_name name - = let ctx = initSDocContext dflags defaultDumpStyle - -- defaultDumpStyle, because we want to see the unique on the Name. - in renderWithContext ctx (char '<' <> - (if isExternalName name - then ppr name -- ppr will include the module name prefix - else pprModule mod_name <> char '.' <> ppr name) <> - char '>') +closureDescription mod_name name + = renderWithContext defaultSDocContext + (char '<' <> pprFullName mod_name name <> char '>') diff --git a/compiler/GHC/StgToCmm/Closure.hs b/compiler/GHC/StgToCmm/Closure.hs index 8b9e4f044b..b2f51c60fd 100644 --- a/compiler/GHC/StgToCmm/Closure.hs +++ b/compiler/GHC/StgToCmm/Closure.hs @@ -35,9 +35,9 @@ module GHC.StgToCmm.Closure ( isLFThunk, isLFReEntrant, lfUpdatable, -- * Used by other modules - CgLoc(..), SelfLoopInfo, CallMethod(..), + CgLoc(..), CallMethod(..), nodeMustPointToIt, isKnownFun, funTag, tagForArity, - CallOpts(..), getCallMethod, + getCallMethod, -- * ClosureInfo ClosureInfo, @@ -78,6 +78,7 @@ import GHC.Cmm import GHC.Cmm.Utils import GHC.Cmm.Ppr.Expr() -- For Outputable instances import GHC.StgToCmm.Types +import GHC.StgToCmm.Sequel import GHC.Types.CostCentre import GHC.Cmm.BlockId @@ -99,6 +100,7 @@ import GHC.Utils.Misc import Data.Coerce (coerce) import qualified Data.ByteString.Char8 as BS8 +import GHC.StgToCmm.Config ----------------------------------------------------------------------------- -- Data types and synonyms @@ -126,8 +128,6 @@ pprCgLoc platform = \case CmmLoc e -> text "cmm" <+> pdoc platform e LneLoc b rs -> text "lne" <+> ppr b <+> ppr rs -type SelfLoopInfo = (Id, BlockId, [LocalReg]) - -- used by ticky profiling isKnownFun :: LambdaFormInfo -> Bool isKnownFun LFReEntrant{} = True @@ -492,13 +492,7 @@ data CallMethod CLabel -- The code label RepArity -- Its arity -data CallOpts = CallOpts - { co_profile :: !Profile -- ^ Platform profile - , co_loopification :: !Bool -- ^ Loopification enabled (cf @-floopification@) - , co_ticky :: !Bool -- ^ Ticky profiling enabled (cf @-ticky@) - } - -getCallMethod :: CallOpts +getCallMethod :: StgToCmmConfig -> Name -- Function being applied -> Id -- Function Id used to chech if it can refer to -- CAF's and whether the function is tail-calling @@ -511,12 +505,11 @@ getCallMethod :: CallOpts -- tail calls using the same data constructor, -- JumpToIt. This saves us one case branch in -- cgIdApp - -> Maybe SelfLoopInfo -- can we perform a self-recursive tail call? + -> Maybe SelfLoopInfo -- can we perform a self-recursive tail-call -> CallMethod -getCallMethod opts _ id _ n_args v_args _cg_loc - (Just (self_loop_id, block_id, args)) - | co_loopification opts +getCallMethod cfg _ id _ n_args v_args _cg_loc (Just (self_loop_id, block_id, args)) + | stgToCmmLoopification cfg , id == self_loop_id , args `lengthIs` (n_args - v_args) -- If these patterns match then we know that: @@ -527,14 +520,13 @@ getCallMethod opts _ id _ n_args v_args _cg_loc -- self-recursive tail calls] in GHC.StgToCmm.Expr for more details = JumpToIt block_id args -getCallMethod opts name id (LFReEntrant _ arity _ _) n_args _v_args _cg_loc - _self_loop_info +getCallMethod cfg name id (LFReEntrant _ arity _ _) n_args _v_args _cg_loc _self_loop_info | n_args == 0 -- No args at all - && not (profileIsProfiling (co_profile opts)) + && not (profileIsProfiling (stgToCmmProfile cfg)) -- See Note [Evaluating functions with profiling] in rts/Apply.cmm = assert (arity /= 0) ReturnIt | n_args < arity = SlowCall -- Not enough args - | otherwise = DirectEntry (enterIdLabel (profilePlatform (co_profile opts)) name (idCafInfo id)) arity + | otherwise = DirectEntry (enterIdLabel (stgToCmmPlatform cfg) name (idCafInfo id)) arity getCallMethod _ _name _ LFUnlifted n_args _v_args _cg_loc _self_loop_info = assert (n_args == 0) ReturnIt @@ -544,14 +536,14 @@ getCallMethod _ _name _ (LFCon _) n_args _v_args _cg_loc _self_loop_info -- n_args=0 because it'd be ill-typed to apply a saturated -- constructor application to anything -getCallMethod opts name id (LFThunk _ _ updatable std_form_info is_fun) +getCallMethod cfg name id (LFThunk _ _ updatable std_form_info is_fun) n_args _v_args _cg_loc _self_loop_info | is_fun -- it *might* be a function, so we must "call" it (which is always safe) = SlowCall -- We cannot just enter it [in eval/apply, the entry code -- is the fast-entry code] -- Since is_fun is False, we are *definitely* looking at a data value - | updatable || co_ticky opts -- to catch double entry + | updatable || stgToCmmDoTicky cfg -- to catch double entry {- OLD: || opt_SMP I decided to remove this, because in SMP mode it doesn't matter if we enter the same thunk multiple times, so the optimisation @@ -573,7 +565,7 @@ getCallMethod opts name id (LFThunk _ _ updatable std_form_info is_fun) | otherwise -- Jump direct to code for single-entry thunks = assert (n_args == 0) $ - DirectEntry (thunkEntryLabel (profilePlatform (co_profile opts)) name (idCafInfo id) std_form_info + DirectEntry (thunkEntryLabel (stgToCmmPlatform cfg) name (idCafInfo id) std_form_info updatable) 0 getCallMethod _ _name _ (LFUnknown True) _n_arg _v_args _cg_locs _self_loop_info @@ -583,8 +575,7 @@ getCallMethod _ name _ (LFUnknown False) n_args _v_args _cg_loc _self_loop_info = assertPpr (n_args == 0) (ppr name <+> ppr n_args) EnterIt -- Not a function -getCallMethod _ _name _ LFLetNoEscape _n_args _v_args (LneLoc blk_id lne_regs) - _self_loop_info +getCallMethod _ _name _ LFLetNoEscape _n_args _v_args (LneLoc blk_id lne_regs) _self_loop_info = JumpToIt blk_id lne_regs getCallMethod _ _ _ _ _ _ _ _ = panic "Unknown call method" diff --git a/compiler/GHC/StgToCmm/Config.hs b/compiler/GHC/StgToCmm/Config.hs new file mode 100644 index 0000000000..8751f5ffe5 --- /dev/null +++ b/compiler/GHC/StgToCmm/Config.hs @@ -0,0 +1,76 @@ +-- | The stg to cmm code generator configuration + +module GHC.StgToCmm.Config + ( StgToCmmConfig(..) + , stgToCmmPlatform + ) where + +import GHC.Platform.Profile +import GHC.Platform +import GHC.Unit.Module +import GHC.Utils.Outputable +import GHC.Utils.TmpFs + +import GHC.Prelude + + +-- This config is static and contains information only passed *downwards* by StgToCmm.Monad +data StgToCmmConfig = StgToCmmConfig + ----------------------------- General Settings -------------------------------- + { stgToCmmProfile :: !Profile -- ^ Current profile + , stgToCmmThisModule :: Module -- ^ The module being compiled. This field kept lazy for + -- Cmm/Parser.y which preloads it with a panic + , stgToCmmTmpDir :: !TempDir -- ^ Temp Dir for files used in compilation + , stgToCmmContext :: !SDocContext -- ^ Context for StgToCmm phase + , stgToCmmDebugLevel :: !Int -- ^ The verbosity of debug messages + , stgToCmmBinBlobThresh :: !Word -- ^ Binary literals (e.g. strings) whose size is above this + -- threshold will be dumped in a binary file by the assembler + -- code generator (0 to disable) + , stgToCmmMaxInlAllocSize :: !Int -- ^ Max size, in bytes, of inline array allocations. + ------------------------------ Ticky Options ---------------------------------- + , stgToCmmDoTicky :: !Bool -- ^ Ticky profiling enabled (cf @-ticky@) + , stgToCmmTickyAllocd :: !Bool -- ^ True indicates ticky prof traces allocs of each named + -- thing in addition to allocs _by_ that thing + , stgToCmmTickyLNE :: !Bool -- ^ True indicates ticky uses name-specific counters for + -- join-points (let-no-escape) + , stgToCmmTickyDynThunk :: !Bool -- ^ True indicates ticky uses name-specific counters for + -- dynamic thunks + ---------------------------------- Flags -------------------------------------- + , stgToCmmLoopification :: !Bool -- ^ Loopification enabled (cf @-floopification@) + , stgToCmmAlignCheck :: !Bool -- ^ Insert alignment check (cf @-falignment-sanitisation@) + , stgToCmmOptHpc :: !Bool -- ^ perform code generation for code coverage + , stgToCmmFastPAPCalls :: !Bool -- ^ + , stgToCmmSCCProfiling :: !Bool -- ^ Check if cost-centre profiling is enabled + , stgToCmmEagerBlackHole :: !Bool -- ^ + , stgToCmmInfoTableMap :: !Bool -- ^ true means generate C Stub for IPE map, See note [Mapping + -- Info Tables to Source Positions] + , stgToCmmOmitYields :: !Bool -- ^ true means omit heap checks when no allocation is performed + , stgToCmmOmitIfPragmas :: !Bool -- ^ true means don't generate interface programs (implied by -O0) + , stgToCmmPIC :: !Bool -- ^ true if @-fPIC@ + , stgToCmmPIE :: !Bool -- ^ true if @-fPIE@ + , stgToCmmExtDynRefs :: !Bool -- ^ true if @-fexternal-dynamic-refs@, meaning generate + -- code for linking against dynamic libraries + , stgToCmmDoBoundsCheck :: !Bool -- ^ decides whether to check array bounds in StgToCmm.Prim + -- or not + ------------------------------ Backend Flags ---------------------------------- + , stgToCmmAllowBigArith :: !Bool -- ^ Allowed to emit larger than native size arithmetic (only LLVM and C backends) + , stgToCmmAllowQuotRemInstr :: !Bool -- ^ Allowed to generate QuotRem instructions + , stgToCmmAllowQuotRem2 :: !Bool -- ^ Allowed to generate QuotRem + , stgToCmmAllowExtendedAddSubInstrs :: !Bool -- ^ Allowed to generate AddWordC, SubWordC, Add2, etc. + , stgToCmmAllowIntMul2Instr :: !Bool -- ^ Allowed to generate IntMul2 instruction + , stgToCmmAllowFabsInstrs :: !Bool -- ^ Allowed to generate Fabs instructions + ------------------------------ SIMD flags ------------------------------------ + -- Each of these flags checks vector compatibility with the backend requested + -- during compilation. In essence, this means checking for @-fllvm@ which is + -- the only backend that currently allows SIMD instructions, see + -- Ghc.StgToCmm.Prim.checkVecCompatibility for these flags only call site. + , stgToCmmVecInstrsErr :: Maybe String -- ^ Error (if any) to raise when vector instructions are + -- used, see @StgToCmm.Prim.checkVecCompatibility@ + , stgToCmmAvx :: !Bool -- ^ check for Advanced Vector Extensions + , stgToCmmAvx2 :: !Bool -- ^ check for Advanced Vector Extensions 2 + , stgToCmmAvx512f :: !Bool -- ^ check for Advanced Vector 512-bit Extensions + } + + +stgToCmmPlatform :: StgToCmmConfig -> Platform +stgToCmmPlatform = profilePlatform . stgToCmmProfile diff --git a/compiler/GHC/StgToCmm/DataCon.hs b/compiler/GHC/StgToCmm/DataCon.hs index 2805aceb91..6a25562f6a 100644 --- a/compiler/GHC/StgToCmm/DataCon.hs +++ b/compiler/GHC/StgToCmm/DataCon.hs @@ -18,7 +18,6 @@ module GHC.StgToCmm.DataCon ( import GHC.Prelude import GHC.Platform -import GHC.Platform.Profile import GHC.Stg.Syntax import GHC.Core ( AltCon(..) ) @@ -38,7 +37,6 @@ import GHC.Runtime.Heap.Layout import GHC.Types.CostCentre import GHC.Unit import GHC.Core.DataCon -import GHC.Driver.Session import GHC.Data.FastString import GHC.Types.Id import GHC.Types.Id.Info( CafInfo( NoCafRefs ) ) @@ -53,19 +51,20 @@ import GHC.Utils.Monad (mapMaybeM) import Control.Monad import Data.Char +import GHC.StgToCmm.Config (stgToCmmPlatform) --------------------------------------------------------------- -- Top-level constructors --------------------------------------------------------------- -cgTopRhsCon :: DynFlags +cgTopRhsCon :: StgToCmmConfig -> Id -- Name of thing bound to this RHS -> DataCon -- Id -> ConstructorNumber -> [NonVoid StgArg] -- Args -> (CgIdInfo, FCode ()) -cgTopRhsCon dflags id con mn args - | Just static_info <- precomputedStaticConInfo_maybe dflags id con args +cgTopRhsCon cfg id con mn args + | Just static_info <- precomputedStaticConInfo_maybe cfg id con args , let static_code | isInternalName name = pure () | otherwise = gen_code = -- There is a pre-allocated static closure available; use it @@ -81,7 +80,7 @@ cgTopRhsCon dflags id con mn args = (id_Info, gen_code) where - platform = targetPlatform dflags + platform = stgToCmmPlatform cfg id_Info = litIdInfo platform id (mkConLFInfo con) (CmmLabel closure_label) name = idName id caffy = idCafInfo id -- any stgArgHasCafRefs args @@ -92,7 +91,7 @@ cgTopRhsCon dflags id con mn args ; this_mod <- getModuleName ; when (platformOS platform == OSMinGW32) $ -- Windows DLLs have a problem with static cross-DLL refs. - massert (not (isDllConApp dflags this_mod con (map fromNonVoid args))) + massert (not (isDllConApp platform (stgToCmmExtDynRefs cfg) this_mod con (map fromNonVoid args))) ; assert (args `lengthIs` countConRepArgs con ) return () -- LAY IT OUT @@ -166,18 +165,20 @@ buildDynCon :: Id -- Name of the thing to which this constr will -> FCode (CgIdInfo, FCode CmmAGraph) -- Return details about how to find it and initialization code buildDynCon binder mn actually_bound cc con args - = do dflags <- getDynFlags - buildDynCon' dflags binder mn actually_bound cc con args + = do cfg <- getStgToCmmConfig + -- pprTrace "noCodeLocal:" (ppr (binder,con,args,cgInfo)) True + case precomputedStaticConInfo_maybe cfg binder con args of + Just cgInfo -> return (cgInfo, return mkNop) + Nothing -> buildDynCon' binder mn actually_bound cc con args -buildDynCon' :: DynFlags - -> Id -> ConstructorNumber +buildDynCon' :: Id + -> ConstructorNumber -> Bool -> CostCentreStack -> DataCon -> [NonVoid StgArg] -> FCode (CgIdInfo, FCode CmmAGraph) - {- We used to pass a boolean indicating whether all the args were of size zero, so we could use a static constructor; but I concluded that it just isn't worth it. @@ -188,14 +189,8 @@ The reason for having a separate argument, rather than looking at the addr modes of the args is that we may be in a "knot", and premature looking at the args will cause the compiler to black-hole! -} - -buildDynCon' dflags binder _ _ _cc con args - | Just cgInfo <- precomputedStaticConInfo_maybe dflags binder con args - -- , pprTrace "noCodeLocal:" (ppr (binder,con,args,cgInfo)) True - = return (cgInfo, return mkNop) - -------- buildDynCon': the general case ----------- -buildDynCon' _ binder mn actually_bound ccs con args +buildDynCon' binder mn actually_bound ccs con args = do { (id_info, reg) <- rhsIdInfo binder lf_info ; return (id_info, gen_code reg) } @@ -204,8 +199,9 @@ buildDynCon' _ binder mn actually_bound ccs con args gen_code reg = do { modu <- getModuleName - ; profile <- getProfile - ; let platform = profilePlatform profile + ; cfg <- getStgToCmmConfig + ; let platform = stgToCmmPlatform cfg + profile = stgToCmmProfile cfg (tot_wds, ptr_wds, args_w_offsets) = mkVirtConstrOffsets profile (addArgReps args) nonptr_wds = tot_wds - ptr_wds @@ -224,6 +220,7 @@ buildDynCon' _ binder mn actually_bound ccs con args blame_cc = use_cc -- cost-centre on which to blame the alloc (same) + {- Note [Precomputed static closures] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -317,36 +314,36 @@ We don't support this optimization when compiling into Windows DLLs yet because they don't support cross package data references well. -} --- (precomputedStaticConInfo_maybe dflags id con args) +-- (precomputedStaticConInfo_maybe cfg id con args) -- returns (Just cg_id_info) -- if there is a precomputed static closure for (con args). -- In that case, cg_id_info addresses it. -- See Note [Precomputed static closures] -precomputedStaticConInfo_maybe :: DynFlags -> Id -> DataCon -> [NonVoid StgArg] -> Maybe CgIdInfo -precomputedStaticConInfo_maybe dflags binder con [] +precomputedStaticConInfo_maybe :: StgToCmmConfig -> Id -> DataCon -> [NonVoid StgArg] -> Maybe CgIdInfo +precomputedStaticConInfo_maybe cfg binder con [] -- Nullary constructors | isNullaryRepDataCon con - = Just $ litIdInfo (targetPlatform dflags) binder (mkConLFInfo con) + = Just $ litIdInfo (stgToCmmPlatform cfg) binder (mkConLFInfo con) (CmmLabel (mkClosureLabel (dataConName con) NoCafRefs)) -precomputedStaticConInfo_maybe dflags binder con [arg] +precomputedStaticConInfo_maybe cfg binder con [arg] -- Int/Char values with existing closures in the RTS | intClosure || charClosure - , platformOS platform /= OSMinGW32 || not (positionIndependent dflags) + , platformOS platform /= OSMinGW32 || not (stgToCmmPIE cfg || stgToCmmPIC cfg) , Just val <- getClosurePayload arg , inRange val = let intlike_lbl = mkCmmClosureLabel rtsUnitId (fsLit label) val_int = fromIntegral val :: Int - offsetW = (val_int - (fromIntegral min_static_range)) * (fixedHdrSizeW profile + 1) + offsetW = (val_int - fromIntegral min_static_range) * (fixedHdrSizeW profile + 1) -- INTLIKE/CHARLIKE closures consist of a header and one word payload static_amode = cmmLabelOffW platform intlike_lbl offsetW in Just $ litIdInfo platform binder (mkConLFInfo con) static_amode where - profile = targetProfile dflags - platform = profilePlatform profile - intClosure = maybeIntLikeCon con + profile = stgToCmmProfile cfg + platform = stgToCmmPlatform cfg + intClosure = maybeIntLikeCon con charClosure = maybeCharLikeCon con getClosurePayload (NonVoid (StgLitArg (LitNumber LitNumInt val))) = Just val - getClosurePayload (NonVoid (StgLitArg (LitChar val))) = Just $ (fromIntegral . ord $ val) + getClosurePayload (NonVoid (StgLitArg (LitChar val))) = Just (fromIntegral . ord $ val) getClosurePayload _ = Nothing -- Avoid over/underflow by comparisons at type Integer! inRange :: Integer -> Bool diff --git a/compiler/GHC/StgToCmm/Env.hs b/compiler/GHC/StgToCmm/Env.hs index f28f0d0ec2..8f82c02e8e 100644 --- a/compiler/GHC/StgToCmm/Env.hs +++ b/compiler/GHC/StgToCmm/Env.hs @@ -44,8 +44,6 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Panic.Plain -import GHC.Driver.Session - ------------------------------------- -- Manipulating CgIdInfo @@ -84,16 +82,16 @@ mkRhsInit platform reg lf_info expr idInfoToAmode :: CgIdInfo -> CmmExpr -- Returns a CmmExpr for the *tagged* pointer -idInfoToAmode (CgIdInfo { cg_loc = CmmLoc e }) = e +idInfoToAmode CgIdInfo { cg_loc = CmmLoc e } = e idInfoToAmode cg_info = pprPanic "idInfoToAmode" (ppr (cg_id cg_info)) -- LneLoc -- | A tag adds a byte offset to the pointer addDynTag :: Platform -> CmmExpr -> DynTag -> CmmExpr -addDynTag platform expr tag = cmmOffsetB platform expr tag +addDynTag = cmmOffsetB maybeLetNoEscape :: CgIdInfo -> Maybe (BlockId, [LocalReg]) -maybeLetNoEscape (CgIdInfo { cg_loc = LneLoc blk_id args}) = Just (blk_id, args) +maybeLetNoEscape CgIdInfo { cg_loc = LneLoc blk_id args} = Just (blk_id, args) maybeLetNoEscape _other = Nothing @@ -120,7 +118,7 @@ addBindsC new_bindings = do getCgIdInfo :: Id -> FCode CgIdInfo getCgIdInfo id - = do { platform <- targetPlatform <$> getDynFlags + = do { platform <- getPlatform ; local_binds <- getBinds -- Try local bindings first ; case lookupVarEnv local_binds id of { Just info -> return info ; @@ -179,7 +177,7 @@ bindArgToReg :: NonVoid Id -> FCode LocalReg bindArgToReg nvid@(NonVoid id) = bindToReg nvid (mkLFArgument id) bindArgsToRegs :: [NonVoid Id] -> FCode [LocalReg] -bindArgsToRegs args = mapM bindArgToReg args +bindArgsToRegs = mapM bindArgToReg idToReg :: Platform -> NonVoid Id -> LocalReg -- Make a register from an Id, typically a function argument, diff --git a/compiler/GHC/StgToCmm/Expr.hs b/compiler/GHC/StgToCmm/Expr.hs index 77476a4b7d..ff80c9eda2 100644 --- a/compiler/GHC/StgToCmm/Expr.hs +++ b/compiler/GHC/StgToCmm/Expr.hs @@ -91,9 +91,10 @@ cgExpr (StgOpApp (StgPrimOp DataToTagOp) [StgVarArg a] _res_ty) = do slow_path <- getCode $ do tmp <- newTemp (bWord platform) _ <- withSequel (AssignTo [tmp] False) (cgIdApp a []) - ptr_opts <- getPtrOpts + profile <- getProfile + align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig emitAssign (CmmLocal result_reg) - $ getConstrTag ptr_opts (cmmUntag platform (CmmReg (CmmLocal tmp))) + $ getConstrTag profile align_check (cmmUntag platform (CmmReg (CmmLocal tmp))) fast_path <- getCode $ do -- Return the constructor index from the pointer tag @@ -102,9 +103,10 @@ cgExpr (StgOpApp (StgPrimOp DataToTagOp) [StgVarArg a] _res_ty) = do $ cmmSubWord platform tag (CmmLit $ mkWordCLit platform 1) -- Return the constructor index recorded in the info table return_info_tag <- getCode $ do - ptr_opts <- getPtrOpts + profile <- getProfile + align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig emitAssign (CmmLocal result_reg) - $ getConstrTag ptr_opts (cmmUntag platform amode) + $ getConstrTag profile align_check (cmmUntag platform amode) emit =<< mkCmmIfThenElse' is_too_big_tag return_info_tag return_ptr_tag (Just False) @@ -540,9 +542,9 @@ isSimpleOp (StgFCallOp (CCall (CCallSpec _ _ safe)) _) _ = return $! not (playSa isSimpleOp (StgPrimOp DataToTagOp) _ = return False isSimpleOp (StgPrimOp op) stg_args = do arg_exprs <- getNonVoidArgAmodes stg_args - dflags <- getDynFlags + cfg <- getStgToCmmConfig -- See Note [Inlining out-of-line primops and heap checks] - return $! shouldInlinePrimOp dflags op arg_exprs + return $! shouldInlinePrimOp cfg op arg_exprs isSimpleOp (StgPrimCallOp _) _ = return False ----------------- @@ -615,9 +617,10 @@ cgAlts gc_plan bndr (AlgAlt tycon) alts else -- No, the get exact tag from info table when mAX_PTR_TAG -- See Note [Double switching for big families] do - ptr_opts <- getPtrOpts + profile <- getProfile + align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig let !untagged_ptr = cmmUntag platform (CmmReg bndr_reg) - !itag_expr = getConstrTag ptr_opts untagged_ptr + !itag_expr = getConstrTag profile align_check untagged_ptr !info0 = first pred <$> via_info if null via_ptr then emitSwitch itag_expr info0 mb_deflt 0 (fam_sz - 1) @@ -888,16 +891,16 @@ cgConApp con mn stg_args cgIdApp :: Id -> [StgArg] -> FCode ReturnKind cgIdApp fun_id args = do fun_info <- getCgIdInfo fun_id - self_loop_info <- getSelfLoop - call_opts <- getCallOpts - profile <- getProfile - let fun_arg = StgVarArg fun_id - fun_name = idName fun_id - fun = idInfoToAmode fun_info - lf_info = cg_lf fun_info - n_args = length args - v_args = length $ filter (isZeroBitTy . stgArgType) args - case getCallMethod call_opts fun_name fun_id lf_info n_args v_args (cg_loc fun_info) self_loop_info of + cfg <- getStgToCmmConfig + self_loop <- getSelfLoop + let profile = stgToCmmProfile cfg + fun_arg = StgVarArg fun_id + fun_name = idName fun_id + fun = idInfoToAmode fun_info + lf_info = cg_lf fun_info + n_args = length args + v_args = length $ filter (isZeroBitTy . stgArgType) args + case getCallMethod cfg fun_name fun_id lf_info n_args v_args (cg_loc fun_info) self_loop of -- A value in WHNF, so we can just return it. ReturnIt | isZeroBitTy (idType fun_id) -> emitReturn [] @@ -975,7 +978,7 @@ cgIdApp fun_id args = do -- Implementation is spread across a couple of places in the code: -- -- * FCode monad stores additional information in its reader environment --- (cgd_self_loop field). This information tells us which function can +-- (stgToCmmSelfLoop field). This information tells us which function can -- tail call itself in an optimized way (it is the function currently -- being compiled), what is the label of a loop header (L1 in example above) -- and information about local registers in which we should arguments @@ -1008,7 +1011,7 @@ cgIdApp fun_id args = do -- command-line option. -- -- * Command line option to turn loopification on and off is implemented in --- DynFlags. +-- DynFlags, then passed to StgToCmmConfig for this phase. -- -- -- Note [Void arguments in self-recursive tail calls] @@ -1036,12 +1039,12 @@ cgIdApp fun_id args = do emitEnter :: CmmExpr -> FCode ReturnKind emitEnter fun = do - { ptr_opts <- getPtrOpts - ; platform <- getPlatform - ; profile <- getProfile + { platform <- getPlatform + ; profile <- getProfile ; adjustHpBackwards - ; sequel <- getSequel - ; updfr_off <- getUpdFrameOff + ; sequel <- getSequel + ; updfr_off <- getUpdFrameOff + ; align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig ; case sequel of -- For a return, we have the option of generating a tag-test or -- not. If the value is tagged, we can return directly, which @@ -1052,7 +1055,9 @@ emitEnter fun = do -- Right now, we do what the old codegen did, and omit the tag -- test, just generating an enter. Return -> do - { let entry = entryCode platform $ closureInfoPtr ptr_opts $ CmmReg nodeReg + { let entry = entryCode platform + $ closureInfoPtr platform align_check + $ CmmReg nodeReg ; emit $ mkJump profile NativeNodeCall entry [cmmUntag platform fun] updfr_off ; return AssignedDirectly @@ -1084,17 +1089,18 @@ emitEnter fun = do -- code in the enclosing case expression. -- AssignTo res_regs _ -> do - { lret <- newBlockId - ; let (off, _, copyin) = copyInOflow profile NativeReturn (Young lret) res_regs [] + { lret <- newBlockId ; lcall <- newBlockId - ; updfr_off <- getUpdFrameOff + ; updfr_off <- getUpdFrameOff + ; align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig + ; let (off, _, copyin) = copyInOflow profile NativeReturn (Young lret) res_regs [] ; let area = Young lret ; let (outArgs, regs, copyout) = copyOutOflow profile NativeNodeCall Call area [fun] updfr_off [] -- refer to fun via nodeReg after the copyout, to avoid having -- both live simultaneously; this sometimes enables fun to be -- inlined in the RHS of the R1 assignment. - ; let entry = entryCode platform (closureInfoPtr ptr_opts (CmmReg nodeReg)) + ; let entry = entryCode platform (closureInfoPtr platform align_check (CmmReg nodeReg)) the_call = toCall entry (Just lret) updfr_off off outArgs regs ; tscope <- getTickScope ; emit $ diff --git a/compiler/GHC/StgToCmm/ExtCode.hs b/compiler/GHC/StgToCmm/ExtCode.hs index 380e4458e2..e80cf8b8b9 100644 --- a/compiler/GHC/StgToCmm/ExtCode.hs +++ b/compiler/GHC/StgToCmm/ExtCode.hs @@ -34,7 +34,7 @@ module GHC.StgToCmm.ExtCode ( getCode, getCodeR, getCodeScoped, emitOutOfLine, withUpdFrameOff, getUpdFrameOff, - getProfile, getPlatform, getPtrOpts + getProfile, getPlatform, getContext ) where @@ -50,10 +50,8 @@ import GHC.StgToCmm.Monad (FCode, newUnique) import GHC.Cmm import GHC.Cmm.CLabel import GHC.Cmm.Graph -import GHC.Cmm.Info import GHC.Cmm.BlockId -import GHC.Driver.Session import GHC.Data.FastString import GHC.Unit.Module import GHC.Types.Unique.FM @@ -61,6 +59,7 @@ import GHC.Types.Unique import GHC.Types.Unique.Supply import Control.Monad (ap) +import GHC.Utils.Outputable (SDocContext) -- | The environment contains variable definitions or blockids. data Named @@ -103,17 +102,14 @@ instance MonadUnique CmmParse where u <- getUniqueM return (decls, u) -instance HasDynFlags CmmParse where - getDynFlags = EC (\_ _ d -> (d,) <$> getDynFlags) - getProfile :: CmmParse Profile getProfile = EC (\_ _ d -> (d,) <$> F.getProfile) getPlatform :: CmmParse Platform getPlatform = EC (\_ _ d -> (d,) <$> F.getPlatform) -getPtrOpts :: CmmParse PtrOpts -getPtrOpts = EC (\_ _ d -> (d,) <$> F.getPtrOpts) +getContext :: CmmParse SDocContext +getContext = EC (\_ _ d -> (d,) <$> F.getContext) -- | Takes the variable declarations and imports from the monad -- and makes an environment, which is looped back into the computation. @@ -128,7 +124,6 @@ loopDecls (EC fcode) = fcode c (addListToUFM e decls) globalDecls return (globalDecls, a) - -- | Get the current environment from the monad. getEnv :: CmmParse Env getEnv = EC $ \_ e s -> return (s, e) diff --git a/compiler/GHC/StgToCmm/Heap.hs b/compiler/GHC/StgToCmm/Heap.hs index 16161cb028..39a7812b70 100644 --- a/compiler/GHC/StgToCmm/Heap.hs +++ b/compiler/GHC/StgToCmm/Heap.hs @@ -429,7 +429,7 @@ altHeapCheckReturnsTo regs lret off code -- is more efficient), but cannot be optimized away in the non-allocating -- case because it may occur in a loop noEscapeHeapCheck :: [LocalReg] -> FCode a -> FCode a -noEscapeHeapCheck regs code = altOrNoEscapeHeapCheck True regs code +noEscapeHeapCheck = altOrNoEscapeHeapCheck True cannedGCReturnsTo :: Bool -> Bool -> CmmExpr -> [LocalReg] -> Label -> ByteOff -> FCode a @@ -605,9 +605,9 @@ do_checks :: Maybe CmmExpr -- Should we check the stack? -> CmmAGraph -- What to do on failure -> FCode () do_checks mb_stk_hwm checkYield mb_alloc_lit do_gc = do - dflags <- getDynFlags - platform <- getPlatform - gc_id <- newBlockId + omit_yields <- stgToCmmOmitYields <$> getStgToCmmConfig + platform <- getPlatform + gc_id <- newBlockId let Just alloc_lit = mb_alloc_lit @@ -644,13 +644,13 @@ do_checks mb_stk_hwm checkYield mb_alloc_lit do_gc = do | checkYield && isJust mb_stk_hwm -> emitLabel loop_header_id _otherwise -> return () - if (isJust mb_alloc_lit) + if isJust mb_alloc_lit then do tickyHeapCheck emitAssign hpReg bump_hp emit =<< mkCmmIfThen' hp_oflo (alloc_n <*> mkBranch gc_id) (Just False) else - when (checkYield && not (gopt Opt_OmitYields dflags)) $ do + when (checkYield && not omit_yields) $ do -- Yielding if HpLim == 0 let yielding = CmmMachOp (mo_wordEq platform) [CmmReg hpLimReg, diff --git a/compiler/GHC/StgToCmm/Hpc.hs b/compiler/GHC/StgToCmm/Hpc.hs index 707fe9725a..23e7519d80 100644 --- a/compiler/GHC/StgToCmm/Hpc.hs +++ b/compiler/GHC/StgToCmm/Hpc.hs @@ -11,8 +11,6 @@ module GHC.StgToCmm.Hpc ( initHpc, mkTickBox ) where import GHC.Prelude import GHC.Platform -import GHC.Driver.Session - import GHC.StgToCmm.Monad import GHC.StgToCmm.Utils @@ -39,13 +37,13 @@ mkTickBox platform mod n -- | Emit top-level tables for HPC and return code to initialise initHpc :: Module -> HpcInfo -> FCode () -initHpc _ (NoHpcInfo {}) +initHpc _ NoHpcInfo{} = return () initHpc this_mod (HpcInfo tickCount _hashNo) - = do dflags <- getDynFlags - when (gopt Opt_Hpc dflags) $ + = do do_hpc <- stgToCmmOptHpc <$> getStgToCmmConfig + when do_hpc $ emitDataLits (mkHpcTicksLabel this_mod) - [ (CmmInt 0 W64) + [ CmmInt 0 W64 | _ <- take tickCount [0 :: Int ..] ] diff --git a/compiler/GHC/StgToCmm/Layout.hs b/compiler/GHC/StgToCmm/Layout.hs index 6924e30483..9e14d1e766 100644 --- a/compiler/GHC/StgToCmm/Layout.hs +++ b/compiler/GHC/StgToCmm/Layout.hs @@ -33,9 +33,6 @@ module GHC.StgToCmm.Layout ( import GHC.Prelude hiding ((<*>)) -import GHC.Driver.Session -import GHC.Driver.Ppr - import GHC.StgToCmm.Closure import GHC.StgToCmm.Env import GHC.StgToCmm.ArgRep -- notably: ( slowCallPattern ) @@ -67,6 +64,8 @@ import GHC.Utils.Panic.Plain import GHC.Utils.Constants (debugIsOn) import GHC.Data.FastString import Control.Monad +import GHC.StgToCmm.Config (stgToCmmPlatform) +import GHC.StgToCmm.Types ------------------------------------------------------------------------ -- Call and return sequences @@ -196,9 +195,12 @@ directCall conv lbl arity stg_args slowCall :: CmmExpr -> [StgArg] -> FCode ReturnKind -- (slowCall fun args) applies fun to args, returning the results to Sequel slowCall fun stg_args - = do dflags <- getDynFlags - profile <- getProfile - let platform = profilePlatform profile + = do cfg <- getStgToCmmConfig + let profile = stgToCmmProfile cfg + platform = stgToCmmPlatform cfg + ctx = stgToCmmContext cfg + fast_pap = stgToCmmFastPAPCalls cfg + align_sat = stgToCmmAlignCheck cfg argsreps <- getArgRepsAmodes stg_args let (rts_fun, arity) = slowCallPattern (map fst argsreps) @@ -206,18 +208,17 @@ slowCall fun stg_args r <- direct_call "slow_call" NativeNodeCall (mkRtsApFastLabel rts_fun) arity ((P,Just fun):argsreps) emitComment $ mkFastString ("slow_call for " ++ - showSDoc dflags (pdoc platform fun) ++ + renderWithContext ctx (pdoc platform fun) ++ " with pat " ++ unpackFS rts_fun) return r -- Note [avoid intermediate PAPs] let n_args = length stg_args - if n_args > arity && gopt Opt_FastPAPCalls dflags + if n_args > arity && fast_pap then do - ptr_opts <- getPtrOpts funv <- (CmmReg . CmmLocal) `fmap` assignTemp fun fun_iptr <- (CmmReg . CmmLocal) `fmap` - assignTemp (closureInfoPtr ptr_opts (cmmUntag platform funv)) + assignTemp (closureInfoPtr platform align_sat (cmmUntag platform funv)) -- ToDo: we could do slightly better here by reusing the -- continuation from the slow call, which we have in r. @@ -303,15 +304,14 @@ direct_call caller call_conv lbl arity args = emitCall (call_conv, NativeReturn) target (nonVArgs args) | otherwise -- Note [over-saturated calls] - = do dflags <- getDynFlags + = do do_scc_prof <- stgToCmmSCCProfiling <$> getStgToCmmConfig emitCallWithExtraStack (call_conv, NativeReturn) target (nonVArgs fast_args) - (nonVArgs (stack_args dflags)) + (nonVArgs (slowArgs rest_args do_scc_prof)) where target = CmmLit (CmmLabel lbl) (fast_args, rest_args) = splitAt real_arity args - stack_args dflags = slowArgs dflags rest_args real_arity = case call_conv of NativeNodeCall -> arity+1 _ -> arity @@ -375,12 +375,11 @@ just more arguments that we are passing on the stack (cml_args). -- | 'slowArgs' takes a list of function arguments and prepares them for -- pushing on the stack for "extra" arguments to a function which requires -- fewer arguments than we currently have. -slowArgs :: DynFlags -> [(ArgRep, Maybe CmmExpr)] -> [(ArgRep, Maybe CmmExpr)] -slowArgs _ [] = [] -slowArgs dflags args -- careful: reps contains voids (V), but args does not - | sccProfilingEnabled dflags - = save_cccs ++ this_pat ++ slowArgs dflags rest_args - | otherwise = this_pat ++ slowArgs dflags rest_args +slowArgs :: [(ArgRep, Maybe CmmExpr)] -> DoSCCProfiling -> [(ArgRep, Maybe CmmExpr)] +slowArgs [] _ = mempty +slowArgs args sccProfilingEnabled -- careful: reps contains voids (V), but args does not + | sccProfilingEnabled = save_cccs ++ this_pat ++ slowArgs rest_args sccProfilingEnabled + | otherwise = this_pat ++ slowArgs rest_args sccProfilingEnabled where (arg_pat, n) = slowCallPattern (map fst args) (call_args, rest_args) = splitAt n args diff --git a/compiler/GHC/StgToCmm/Monad.hs b/compiler/GHC/StgToCmm/Monad.hs index 0eb9dc756d..d8d6600268 100644 --- a/compiler/GHC/StgToCmm/Monad.hs +++ b/compiler/GHC/StgToCmm/Monad.hs @@ -14,7 +14,7 @@ module GHC.StgToCmm.Monad ( FCode, -- type - initC, runC, fixC, + initC, initFCodeState, runC, fixC, newUnique, emitLabel, @@ -28,7 +28,7 @@ module GHC.StgToCmm.Monad ( getCmm, aGraphToGraph, getPlatform, getProfile, getCodeR, getCode, getCodeScoped, getHeapUsage, - getCallOpts, getPtrOpts, + getContext, mkCmmIfThenElse, mkCmmIfThen, mkCmmIfGoto, mkCmmIfThenElse', mkCmmIfThen', mkCmmIfGoto', @@ -45,7 +45,7 @@ module GHC.StgToCmm.Monad ( setTickyCtrLabel, getTickyCtrLabel, tickScope, getTickScope, - withUpdFrameOff, getUpdFrameOff, initUpdFrameOff, + withUpdFrameOff, getUpdFrameOff, HeapUsage(..), VirtualHpOffset, initHpUsage, getHpUsage, setHpUsage, heapHWM, @@ -54,13 +54,13 @@ module GHC.StgToCmm.Monad ( getModuleName, -- ideally we wouldn't export these, but some other modules access internal state - getState, setState, getSelfLoop, withSelfLoop, getInfoDown, getDynFlags, + getState, setState, getSelfLoop, withSelfLoop, getStgToCmmConfig, -- more localised access to monad state CgIdInfo(..), getBinds, setBinds, -- out of general friendliness, we also export ... - CgInfoDownwards(..), CgState(..) -- non-abstract + StgToCmmConfig(..), CgState(..) -- non-abstract ) where import GHC.Prelude hiding( sequence, succ ) @@ -68,13 +68,13 @@ import GHC.Prelude hiding( sequence, succ ) import GHC.Platform import GHC.Platform.Profile import GHC.Cmm +import GHC.StgToCmm.Config import GHC.StgToCmm.Closure -import GHC.Driver.Session +import GHC.StgToCmm.Sequel import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Graph as CmmGraph import GHC.Cmm.BlockId import GHC.Cmm.CLabel -import GHC.Cmm.Info import GHC.Runtime.Heap.Layout import GHC.Unit import GHC.Types.Id @@ -109,24 +109,30 @@ import Data.List (mapAccumL) -- - the current heap usage -- - a UniqSupply -- --- - A reader monad, for CgInfoDownwards, containing --- - DynFlags, +-- - A reader monad, for StgToCmmConfig, containing +-- - the profile, -- - the current Module +-- - the debug level +-- - a bunch of flags see StgToCmm.Config for full details + +-- - A second reader monad with: -- - the update-frame offset -- - the ticky counter label -- - the Sequel (the continuation to return to) -- - the self-recursive tail call information +-- - The tick scope for new blocks and ticks +-- -------------------------------------------------------- -newtype FCode a = FCode' { doFCode :: CgInfoDownwards -> CgState -> (a, CgState) } +newtype FCode a = FCode' { doFCode :: StgToCmmConfig -> FCodeState -> CgState -> (a, CgState) } -- Not derived because of #18202. -- See Note [The one-shot state monad trick] in GHC.Utils.Monad instance Functor FCode where fmap f (FCode m) = - FCode $ \info_down state -> - case m info_down state of + FCode $ \cfg fst state -> + case m cfg fst state of (x, state') -> (f x, state') -- This pattern synonym makes the simplifier monad eta-expand, @@ -134,29 +140,31 @@ instance Functor FCode where -- See #18202. -- See Note [The one-shot state monad trick] in GHC.Utils.Monad {-# COMPLETE FCode #-} -pattern FCode :: (CgInfoDownwards -> CgState -> (a, CgState)) +pattern FCode :: (StgToCmmConfig -> FCodeState -> CgState -> (a, CgState)) -> FCode a pattern FCode m <- FCode' m where - FCode m = FCode' $ oneShot (\cgInfoDown -> oneShot (\state ->m cgInfoDown state)) + FCode m = FCode' $ oneShot (\cfg -> oneShot + (\fstate -> oneShot + (\state -> m cfg fstate state))) instance Applicative FCode where - pure val = FCode (\_info_down state -> (val, state)) + pure val = FCode (\_cfg _fstate state -> (val, state)) {-# INLINE pure #-} (<*>) = ap instance Monad FCode where FCode m >>= k = FCode $ - \info_down state -> - case m info_down state of + \cfg fstate state -> + case m cfg fstate state of (m_result, new_state) -> case k m_result of - FCode kcode -> kcode info_down new_state + FCode kcode -> kcode cfg fstate new_state {-# INLINE (>>=) #-} instance MonadUnique FCode where getUniqueSupplyM = cgs_uniqs <$> getState - getUniqueM = FCode $ \_ st -> + getUniqueM = FCode $ \_ _ st -> let (u, us') = takeUniqFromSupply (cgs_uniqs st) in (u, st { cgs_uniqs = us' }) @@ -164,36 +172,18 @@ initC :: IO CgState initC = do { uniqs <- mkSplitUniqSupply 'c' ; return (initCgState uniqs) } -runC :: DynFlags -> Module -> CgState -> FCode a -> (a,CgState) -runC dflags mod st fcode = doFCode fcode (initCgInfoDown dflags mod) st +runC :: StgToCmmConfig -> FCodeState -> CgState -> FCode a -> (a, CgState) +runC cfg fst st fcode = doFCode fcode cfg fst st fixC :: (a -> FCode a) -> FCode a fixC fcode = FCode $ - \info_down state -> let (v, s) = doFCode (fcode v) info_down state - in (v, s) + \cfg fstate state -> + let (v, s) = doFCode (fcode v) cfg fstate state + in (v, s) -------------------------------------------------------- -- The code generator environment -------------------------------------------------------- - --- This monadery has some information that it only passes --- *downwards*, as well as some ``state'' which is modified --- as we go along. - -data CgInfoDownwards -- information only passed *downwards* by the monad - = MkCgInfoDown { - cgd_dflags :: DynFlags, - cgd_mod :: Module, -- Module being compiled - cgd_updfr_off :: UpdFrameOffset, -- Size of current update frame - cgd_ticky :: CLabel, -- Current destination for ticky counts - cgd_sequel :: Sequel, -- What to do at end of basic block - cgd_self_loop :: Maybe SelfLoopInfo,-- Which tail calls can be compiled - -- as local jumps? See Note - -- [Self-recursive tail calls] in - -- GHC.StgToCmm.Expr - cgd_tick_scope:: CmmTickScope -- Tick scope for new blocks & ticks - } - type CgBindings = IdEnv CgIdInfo data CgIdInfo @@ -207,24 +197,6 @@ instance OutputableP Platform CgIdInfo where pdoc env (CgIdInfo { cg_id = id, cg_loc = loc }) = ppr id <+> text "-->" <+> pdoc env loc --- Sequel tells what to do with the result of this expression -data Sequel - = Return -- Return result(s) to continuation found on the stack. - - | AssignTo - [LocalReg] -- Put result(s) in these regs and fall through - -- NB: no void arguments here - -- - Bool -- Should we adjust the heap pointer back to - -- recover space that's unused on this path? - -- We need to do this only if the expression - -- may allocate (e.g. it's a foreign call or - -- allocating primOp) - -instance Outputable Sequel where - ppr Return = text "Return" - ppr (AssignTo regs b) = text "AssignTo" <+> ppr regs <+> ppr b - -- See Note [sharing continuations] below data ReturnKind = AssignedDirectly @@ -297,24 +269,6 @@ data ReturnKind -- fall back to AssignedDirectly. -- - -initCgInfoDown :: DynFlags -> Module -> CgInfoDownwards -initCgInfoDown dflags mod - = MkCgInfoDown { cgd_dflags = dflags - , cgd_mod = mod - , cgd_updfr_off = initUpdFrameOff (targetPlatform dflags) - , cgd_ticky = mkTopTickyCtrLabel - , cgd_sequel = initSequel - , cgd_self_loop = Nothing - , cgd_tick_scope= GlobalScope } - -initSequel :: Sequel -initSequel = Return - -initUpdFrameOff :: Platform -> UpdFrameOffset -initUpdFrameOff platform = platformWordSizeInBytes platform -- space for the RA - - -------------------------------------------------------- -- The code generator state -------------------------------------------------------- @@ -337,6 +291,17 @@ data CgState -- the reason is the knot-tying in 'getHeapUsage'. This problem is tracked -- in #19245 +data FCodeState = + MkFCodeState { fcs_upframeoffset :: UpdFrameOffset -- ^ Size of current update frame UpdFrameOffset must be kept lazy or + -- else the RTS will deadlock _and_ also experience a severe + -- performance degredation + , fcs_sequel :: !Sequel -- ^ What to do at end of basic block + , fcs_selfloop :: Maybe SelfLoopInfo -- ^ Which tail calls can be compiled as local jumps? + -- See Note [Self-recursive tail calls] in GHC.StgToCmm.Expr + , fcs_ticky :: !CLabel -- ^ Destination for ticky counts + , fcs_tickscope :: !CmmTickScope -- ^ Tick scope for new blocks & ticks + } + data HeapUsage -- See Note [Virtual and real heap pointers] = HeapUsage { virtHp :: VirtualHpOffset, -- Virtual offset of highest-allocated word @@ -418,14 +383,14 @@ maxHpHw :: HeapUsage -> VirtualHpOffset -> HeapUsage hp_usg `maxHpHw` hw = hp_usg { virtHp = virtHp hp_usg `max` hw } -------------------------------------------------------- --- Operators for getting and setting the state and "info_down". +-- Operators for getting and setting the state and "stgToCmmConfig". -------------------------------------------------------- getState :: FCode CgState -getState = FCode $ \_info_down state -> (state, state) +getState = FCode $ \_cfg _fstate state -> (state, state) setState :: CgState -> FCode () -setState state = FCode $ \_info_down _ -> ((), state) +setState state = FCode $ \_cfg _fstate _ -> ((), state) getHpUsage :: FCode HeapUsage getHpUsage = do @@ -462,9 +427,9 @@ setBinds new_binds = do state <- getState setState $ state {cgs_binds = new_binds} -withState :: FCode a -> CgState -> FCode (a,CgState) -withState (FCode fcode) newstate = FCode $ \info_down state -> - case fcode info_down newstate of +withCgState :: FCode a -> CgState -> FCode (a,CgState) +withCgState (FCode fcode) newstate = FCode $ \cfg fstate state -> + case fcode cfg fstate newstate of (retval, state2) -> ((retval,state2), state) newUniqSupply :: FCode UniqSupply @@ -486,68 +451,41 @@ newTemp rep = do { uniq <- getUniqueM ; return (LocalReg uniq rep) } ------------------ -getInfoDown :: FCode CgInfoDownwards -getInfoDown = FCode $ \info_down state -> (info_down,state) +initFCodeState :: Platform -> FCodeState +initFCodeState p = + MkFCodeState { fcs_upframeoffset = platformWordSizeInBytes p + , fcs_sequel = Return + , fcs_selfloop = Nothing + , fcs_ticky = mkTopTickyCtrLabel + , fcs_tickscope = GlobalScope + } + +getFCodeState :: FCode FCodeState +getFCodeState = FCode $ \_ fstate state -> (fstate,state) + +-- basically local for the reader monad +withFCodeState :: FCode a -> FCodeState -> FCode a +withFCodeState (FCode fcode) fst = FCode $ \cfg _ state -> fcode cfg fst state getSelfLoop :: FCode (Maybe SelfLoopInfo) -getSelfLoop = do - info_down <- getInfoDown - return $ cgd_self_loop info_down +getSelfLoop = fcs_selfloop <$> getFCodeState withSelfLoop :: SelfLoopInfo -> FCode a -> FCode a withSelfLoop self_loop code = do - info_down <- getInfoDown - withInfoDown code (info_down {cgd_self_loop = Just self_loop}) - -instance HasDynFlags FCode where - getDynFlags = liftM cgd_dflags getInfoDown - -getProfile :: FCode Profile -getProfile = targetProfile <$> getDynFlags - -getPlatform :: FCode Platform -getPlatform = profilePlatform <$> getProfile - -getCallOpts :: FCode CallOpts -getCallOpts = do - dflags <- getDynFlags - profile <- getProfile - pure $ CallOpts - { co_profile = profile - , co_loopification = gopt Opt_Loopification dflags - , co_ticky = gopt Opt_Ticky dflags - } - -getPtrOpts :: FCode PtrOpts -getPtrOpts = do - dflags <- getDynFlags - profile <- getProfile - pure $ PtrOpts - { po_profile = profile - , po_align_check = gopt Opt_AlignmentSanitisation dflags - } - - -withInfoDown :: FCode a -> CgInfoDownwards -> FCode a -withInfoDown (FCode fcode) info_down = FCode $ \_ state -> fcode info_down state - --- ---------------------------------------------------------------------------- --- Get the current module name - -getModuleName :: FCode Module -getModuleName = do { info <- getInfoDown; return (cgd_mod info) } + fstate <- getFCodeState + withFCodeState code (fstate {fcs_selfloop = Just self_loop}) -- ---------------------------------------------------------------------------- -- Get/set the end-of-block info withSequel :: Sequel -> FCode a -> FCode a withSequel sequel code - = do { info <- getInfoDown - ; withInfoDown code (info {cgd_sequel = sequel, cgd_self_loop = Nothing }) } + = do { fstate <- getFCodeState + ; withFCodeState code (fstate { fcs_sequel = sequel + , fcs_selfloop = Nothing }) } getSequel :: FCode Sequel -getSequel = do { info <- getInfoDown - ; return (cgd_sequel info) } +getSequel = fcs_sequel <$> getFCodeState -- ---------------------------------------------------------------------------- -- Get/set the size of the update frame @@ -561,35 +499,29 @@ getSequel = do { info <- getInfoDown withUpdFrameOff :: UpdFrameOffset -> FCode a -> FCode a withUpdFrameOff size code - = do { info <- getInfoDown - ; withInfoDown code (info {cgd_updfr_off = size }) } + = do { fstate <- getFCodeState + ; withFCodeState code (fstate {fcs_upframeoffset = size }) } getUpdFrameOff :: FCode UpdFrameOffset -getUpdFrameOff - = do { info <- getInfoDown - ; return $ cgd_updfr_off info } +getUpdFrameOff = fcs_upframeoffset <$> getFCodeState -- ---------------------------------------------------------------------------- -- Get/set the current ticky counter label getTickyCtrLabel :: FCode CLabel -getTickyCtrLabel = do - info <- getInfoDown - return (cgd_ticky info) +getTickyCtrLabel = fcs_ticky <$> getFCodeState setTickyCtrLabel :: CLabel -> FCode a -> FCode a setTickyCtrLabel ticky code = do - info <- getInfoDown - withInfoDown code (info {cgd_ticky = ticky}) + fstate <- getFCodeState + withFCodeState code (fstate {fcs_ticky = ticky}) -- ---------------------------------------------------------------------------- -- Manage tick scopes -- | The current tick scope. We will assign this to generated blocks. getTickScope :: FCode CmmTickScope -getTickScope = do - info <- getInfoDown - return (cgd_tick_scope info) +getTickScope = fcs_tickscope <$> getFCodeState -- | Places blocks generated by the given code into a fresh -- (sub-)scope. This will make sure that Cmm annotations in our scope @@ -597,11 +529,33 @@ getTickScope = do -- way around. tickScope :: FCode a -> FCode a tickScope code = do - info <- getInfoDown - if debugLevel (cgd_dflags info) == 0 then code else do + cfg <- getStgToCmmConfig + fstate <- getFCodeState + if stgToCmmDebugLevel cfg == 0 then code else do u <- newUnique - let scope' = SubScope u (cgd_tick_scope info) - withInfoDown code info{ cgd_tick_scope = scope' } + let scope' = SubScope u (fcs_tickscope fstate) + withFCodeState code fstate{ fcs_tickscope = scope' } + +-- ---------------------------------------------------------------------------- +-- Config related helpers + +getStgToCmmConfig :: FCode StgToCmmConfig +getStgToCmmConfig = FCode $ \cfg _ state -> (cfg,state) + +getProfile :: FCode Profile +getProfile = stgToCmmProfile <$> getStgToCmmConfig + +getPlatform :: FCode Platform +getPlatform = profilePlatform <$> getProfile + +getContext :: FCode SDocContext +getContext = stgToCmmContext <$> getStgToCmmConfig + +-- ---------------------------------------------------------------------------- +-- Get the current module name + +getModuleName :: FCode Module +getModuleName = stgToCmmThisModule <$> getStgToCmmConfig -------------------------------------------------------- @@ -618,14 +572,16 @@ forkClosureBody :: FCode () -> FCode () forkClosureBody body_code = do { platform <- getPlatform - ; info <- getInfoDown - ; us <- newUniqSupply - ; state <- getState - ; let body_info_down = info { cgd_sequel = initSequel - , cgd_updfr_off = initUpdFrameOff platform - , cgd_self_loop = Nothing } + ; cfg <- getStgToCmmConfig + ; fstate <- getFCodeState + ; us <- newUniqSupply + ; state <- getState + ; let fcs = fstate { fcs_sequel = Return + , fcs_upframeoffset = platformWordSizeInBytes platform + , fcs_selfloop = Nothing + } fork_state_in = (initCgState us) { cgs_binds = cgs_binds state } - ((),fork_state_out) = doFCode body_code body_info_down fork_state_in + ((),fork_state_out) = doFCode body_code cfg fcs fork_state_in ; setState $ state `addCodeBlocksFrom` fork_state_out } forkLneBody :: FCode a -> FCode a @@ -636,11 +592,12 @@ forkLneBody :: FCode a -> FCode a -- the successor. In particular, any heap usage from the enclosed -- code is discarded; it should deal with its own heap consumption. forkLneBody body_code - = do { info_down <- getInfoDown - ; us <- newUniqSupply - ; state <- getState + = do { cfg <- getStgToCmmConfig + ; us <- newUniqSupply + ; state <- getState + ; fstate <- getFCodeState ; let fork_state_in = (initCgState us) { cgs_binds = cgs_binds state } - (result, fork_state_out) = doFCode body_code info_down fork_state_in + (result, fork_state_out) = doFCode body_code cfg fstate fork_state_in ; setState $ state `addCodeBlocksFrom` fork_state_out ; return result } @@ -649,12 +606,13 @@ codeOnly :: FCode () -> FCode () -- Do not affect anything else in the outer state -- Used in almost-circular code to prevent false loop dependencies codeOnly body_code - = do { info_down <- getInfoDown - ; us <- newUniqSupply - ; state <- getState + = do { cfg <- getStgToCmmConfig + ; us <- newUniqSupply + ; state <- getState + ; fstate <- getFCodeState ; let fork_state_in = (initCgState us) { cgs_binds = cgs_binds state , cgs_hp_usg = cgs_hp_usg state } - ((), fork_state_out) = doFCode body_code info_down fork_state_in + ((), fork_state_out) = doFCode body_code cfg fstate fork_state_in ; setState $ state `addCodeBlocksFrom` fork_state_out } forkAlts :: [FCode a] -> FCode [a] @@ -664,11 +622,12 @@ forkAlts :: [FCode a] -> FCode [a] -- that the virtual Hp is moved on to the worst virtual Hp for the branches forkAlts branch_fcodes - = do { info_down <- getInfoDown - ; us <- newUniqSupply + = do { cfg <- getStgToCmmConfig + ; us <- newUniqSupply ; state <- getState + ; fstate <- getFCodeState ; let compile us branch - = (us2, doFCode branch info_down branch_state) + = (us2, doFCode branch cfg fstate branch_state) where (us1,us2) = splitUniqSupply us branch_state = (initCgState us1) { @@ -693,7 +652,7 @@ forkAltPair x y = do getCodeR :: FCode a -> FCode (a, CmmAGraph) getCodeR fcode = do { state1 <- getState - ; (a, state2) <- withState fcode (state1 { cgs_stmts = mkNop }) + ; (a, state2) <- withCgState fcode (state1 { cgs_stmts = mkNop }) ; setState $ state2 { cgs_stmts = cgs_stmts state1 } ; return (a, cgs_stmts state2) } @@ -706,7 +665,7 @@ getCodeScoped fcode = do { state1 <- getState ; ((a, tscope), state2) <- tickScope $ - flip withState state1 { cgs_stmts = mkNop } $ + flip withCgState state1 { cgs_stmts = mkNop } $ do { a <- fcode ; scp <- getTickScope ; return (a, scp) } @@ -725,10 +684,11 @@ getCodeScoped fcode getHeapUsage :: (VirtualHpOffset -> FCode a) -> FCode a getHeapUsage fcode - = do { info_down <- getInfoDown + = do { cfg <- getStgToCmmConfig ; state <- getState + ; fcstate <- getFCodeState ; let fstate_in = state { cgs_hp_usg = initHpUsage } - (r, fstate_out) = doFCode (fcode hp_hw) info_down fstate_in + (r, fstate_out) = doFCode (fcode hp_hw) cfg fcstate fstate_in hp_hw = heapHWM (cgs_hp_usg fstate_out) -- Loop here! ; setState $ fstate_out { cgs_hp_usg = cgs_hp_usg state } @@ -757,8 +717,8 @@ emitTick = emitCgStmt . CgStmt . CmmTick emitUnwind :: [(GlobalReg, Maybe CmmExpr)] -> FCode () emitUnwind regs = do - dflags <- getDynFlags - when (debugLevel dflags > 0) $ + debug_level <- stgToCmmDebugLevel <$> getStgToCmmConfig + when (debug_level > 0) $ emitCgStmt $ CgStmt $ CmmUnwind regs emitAssign :: CmmReg -> CmmExpr -> FCode () @@ -838,7 +798,7 @@ getCmm :: FCode a -> FCode (a, CmmGroup) -- object splitting (at a later stage) getCmm code = do { state1 <- getState - ; (a, state2) <- withState code (state1 { cgs_tops = nilOL }) + ; (a, state2) <- withCgState code (state1 { cgs_tops = nilOL }) ; setState $ state2 { cgs_tops = cgs_tops state1 } ; return (a, fromOL (cgs_tops state2)) } diff --git a/compiler/GHC/StgToCmm/Prim.hs b/compiler/GHC/StgToCmm/Prim.hs index 5c538c45c8..8d119a4e6c 100644 --- a/compiler/GHC/StgToCmm/Prim.hs +++ b/compiler/GHC/StgToCmm/Prim.hs @@ -20,6 +20,7 @@ import GHC.Prelude hiding ((<*>)) import GHC.Platform import GHC.Platform.Profile +import GHC.StgToCmm.Config import GHC.StgToCmm.Layout import GHC.StgToCmm.Foreign import GHC.StgToCmm.Monad @@ -29,7 +30,6 @@ import GHC.StgToCmm.Heap import GHC.StgToCmm.Prof ( costCentreFrom ) import GHC.Driver.Session -import GHC.Driver.Backend import GHC.Types.Basic import GHC.Cmm.BlockId import GHC.Cmm.Graph @@ -77,18 +77,18 @@ cgOpApp (StgFCallOp fcall ty) stg_args res_ty -- Note [Foreign call results] cgOpApp (StgPrimOp primop) args res_ty = do - dflags <- getDynFlags + cfg <- getStgToCmmConfig cmm_args <- getNonVoidArgAmodes args - cmmPrimOpApp dflags primop cmm_args (Just res_ty) + cmmPrimOpApp cfg primop cmm_args (Just res_ty) cgOpApp (StgPrimCallOp primcall) args _res_ty = do { cmm_args <- getNonVoidArgAmodes args ; let fun = CmmLit (CmmLabel (mkPrimCallLabel primcall)) ; emitCall (NativeNodeCall, NativeReturn) fun cmm_args } -cmmPrimOpApp :: DynFlags -> PrimOp -> [CmmExpr] -> Maybe Type -> FCode ReturnKind -cmmPrimOpApp dflags primop cmm_args mres_ty = - case emitPrimOp dflags primop cmm_args of +cmmPrimOpApp :: StgToCmmConfig -> PrimOp -> [CmmExpr] -> Maybe Type -> FCode ReturnKind +cmmPrimOpApp cfg primop cmm_args mres_ty = + case emitPrimOp cfg primop cmm_args of PrimopCmmEmit_Internal f -> let -- if the result type isn't explicitly given, we directly use the @@ -119,8 +119,8 @@ asUnsigned w n = n .&. (bit (widthInBits w) - 1) -- Emitting code for a primop ------------------------------------------------------------------------ -shouldInlinePrimOp :: DynFlags -> PrimOp -> [CmmExpr] -> Bool -shouldInlinePrimOp dflags op args = case emitPrimOp dflags op args of +shouldInlinePrimOp :: StgToCmmConfig -> PrimOp -> [CmmExpr] -> Bool +shouldInlinePrimOp cfg op args = case emitPrimOp cfg op args of PrimopCmmEmit_External -> False PrimopCmmEmit_Internal _ -> True @@ -143,20 +143,22 @@ shouldInlinePrimOp dflags op args = case emitPrimOp dflags op args of -- might happen e.g. if there's enough static information, such as statically -- know arguments. emitPrimOp - :: DynFlags + :: StgToCmmConfig -> PrimOp -- ^ The primop -> [CmmExpr] -- ^ The primop arguments -> PrimopCmmEmit -emitPrimOp dflags primop = case primop of +emitPrimOp cfg primop = + let max_inl_alloc_size = fromIntegral (stgToCmmMaxInlAllocSize cfg) + in case primop of NewByteArrayOp_Char -> \case [(CmmLit (CmmInt n w))] - | asUnsigned w n <= fromIntegral (maxInlineAllocSize dflags) + | asUnsigned w n <= max_inl_alloc_size -> opIntoRegs $ \ [res] -> doNewByteArrayOp res (fromInteger n) _ -> PrimopCmmEmit_External NewArrayOp -> \case [(CmmLit (CmmInt n w)), init] - | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) + | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size -> opIntoRegs $ \[res] -> doNewArrayOp res (arrPtrsRep platform (fromInteger n)) mkMAP_DIRTY_infoLabel [ (mkIntExpr platform (fromInteger n), fixedHdrSize profile + pc_OFFSET_StgMutArrPtrs_ptrs (platformConstants platform)) @@ -178,31 +180,31 @@ emitPrimOp dflags primop = case primop of CloneArrayOp -> \case [src, src_off, (CmmLit (CmmInt n w))] - | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) + | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size -> opIntoRegs $ \ [res] -> emitCloneArray mkMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n) _ -> PrimopCmmEmit_External CloneMutableArrayOp -> \case [src, src_off, (CmmLit (CmmInt n w))] - | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) + | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size -> opIntoRegs $ \ [res] -> emitCloneArray mkMAP_DIRTY_infoLabel res src src_off (fromInteger n) _ -> PrimopCmmEmit_External FreezeArrayOp -> \case [src, src_off, (CmmLit (CmmInt n w))] - | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) + | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size -> opIntoRegs $ \ [res] -> emitCloneArray mkMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n) _ -> PrimopCmmEmit_External ThawArrayOp -> \case [src, src_off, (CmmLit (CmmInt n w))] - | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) + | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size -> opIntoRegs $ \ [res] -> emitCloneArray mkMAP_DIRTY_infoLabel res src src_off (fromInteger n) _ -> PrimopCmmEmit_External NewSmallArrayOp -> \case [(CmmLit (CmmInt n w)), init] - | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) + | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size -> opIntoRegs $ \ [res] -> doNewArrayOp res (smallArrPtrsRep (fromInteger n)) mkSMAP_DIRTY_infoLabel [ (mkIntExpr platform (fromInteger n), @@ -223,25 +225,25 @@ emitPrimOp dflags primop = case primop of CloneSmallArrayOp -> \case [src, src_off, (CmmLit (CmmInt n w))] - | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) + | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size -> opIntoRegs $ \ [res] -> emitCloneSmallArray mkSMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n) _ -> PrimopCmmEmit_External CloneSmallMutableArrayOp -> \case [src, src_off, (CmmLit (CmmInt n w))] - | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) + | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size -> opIntoRegs $ \ [res] -> emitCloneSmallArray mkSMAP_DIRTY_infoLabel res src src_off (fromInteger n) _ -> PrimopCmmEmit_External FreezeSmallArrayOp -> \case [src, src_off, (CmmLit (CmmInt n w))] - | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) + | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size -> opIntoRegs $ \ [res] -> emitCloneSmallArray mkSMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n) _ -> PrimopCmmEmit_External ThawSmallArrayOp -> \case [src, src_off, (CmmLit (CmmInt n w))] - | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) + | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size -> opIntoRegs $ \ [res] -> emitCloneSmallArray mkSMAP_DIRTY_infoLabel res src src_off (fromInteger n) _ -> PrimopCmmEmit_External @@ -295,14 +297,14 @@ emitPrimOp dflags primop = case primop of emitPrimCall res MO_WriteBarrier [] emitStore (cmmOffsetW platform mutv (fixedHdrSizeW profile)) var - ptrOpts <- getPtrOpts platform <- getPlatform mkdirtyMutVarCCall <- getCode $! emitCCall [{-no results-}] (CmmLit (CmmLabel mkDirty_MUT_VAR_Label)) [(baseExpr, AddrHint), (mutv, AddrHint), (CmmReg old_val, AddrHint)] emit =<< mkCmmIfThen - (cmmEqWord platform (mkLblExpr mkMUT_VAR_CLEAN_infoLabel) (closureInfoPtr ptrOpts mutv)) + (cmmEqWord platform (mkLblExpr mkMUT_VAR_CLEAN_infoLabel) + (closureInfoPtr platform (stgToCmmAlignCheck cfg) mutv)) mkdirtyMutVarCCall -- #define sizzeofByteArrayzh(r,a) \ @@ -312,7 +314,7 @@ emitPrimOp dflags primop = case primop of -- #define sizzeofMutableByteArrayzh(r,a) \ -- r = ((StgArrBytes *)(a))->bytes - SizeofMutableByteArrayOp -> emitPrimOp dflags SizeofByteArrayOp + SizeofMutableByteArrayOp -> emitPrimOp cfg SizeofByteArrayOp -- #define getSizzeofMutableByteArrayzh(r,a) \ -- r = ((StgArrBytes *)(a))->bytes @@ -394,15 +396,15 @@ emitPrimOp dflags primop = case primop of emit $ mkAssign (CmmLocal res) (cmmLoadIndexW platform arg (fixedHdrSizeW profile + bytesToWordsRoundUp platform (pc_OFFSET_StgMutArrPtrs_ptrs (platformConstants platform))) (bWord platform)) - SizeofMutableArrayOp -> emitPrimOp dflags SizeofArrayOp + SizeofMutableArrayOp -> emitPrimOp cfg SizeofArrayOp SizeofSmallArrayOp -> \[arg] -> opIntoRegs $ \[res] -> emit $ mkAssign (CmmLocal res) (cmmLoadIndexW platform arg (fixedHdrSizeW profile + bytesToWordsRoundUp platform (pc_OFFSET_StgSmallMutArrPtrs_ptrs (platformConstants platform))) (bWord platform)) - SizeofSmallMutableArrayOp -> emitPrimOp dflags SizeofSmallArrayOp - GetSizeofSmallMutableArrayOp -> emitPrimOp dflags SizeofSmallArrayOp + SizeofSmallMutableArrayOp -> emitPrimOp cfg SizeofSmallArrayOp + GetSizeofSmallMutableArrayOp -> emitPrimOp cfg SizeofSmallArrayOp -- IndexXXXoffAddr @@ -850,7 +852,7 @@ emitPrimOp dflags primop = case primop of -- SIMD primops (VecBroadcastOp vcat n w) -> \[e] -> opIntoRegs $ \[res] -> do - checkVecCompatibility dflags vcat n w + checkVecCompatibility cfg vcat n w doVecPackOp (vecElemInjectCast platform vcat w) ty zeros (replicate n e) res where zeros :: CmmExpr @@ -866,7 +868,7 @@ emitPrimOp dflags primop = case primop of ty = vecVmmType vcat n w (VecPackOp vcat n w) -> \es -> opIntoRegs $ \[res] -> do - checkVecCompatibility dflags vcat n w + checkVecCompatibility cfg vcat n w when (es `lengthIsNot` n) $ panic "emitPrimOp: VecPackOp has wrong number of arguments" doVecPackOp (vecElemInjectCast platform vcat w) ty zeros es res @@ -884,7 +886,7 @@ emitPrimOp dflags primop = case primop of ty = vecVmmType vcat n w (VecUnpackOp vcat n w) -> \[arg] -> opIntoRegs $ \res -> do - checkVecCompatibility dflags vcat n w + checkVecCompatibility cfg vcat n w when (res `lengthIsNot` n) $ panic "emitPrimOp: VecUnpackOp has wrong number of results" doVecUnpackOp (vecElemProjectCast platform vcat w) ty arg res @@ -893,56 +895,56 @@ emitPrimOp dflags primop = case primop of ty = vecVmmType vcat n w (VecInsertOp vcat n w) -> \[v,e,i] -> opIntoRegs $ \[res] -> do - checkVecCompatibility dflags vcat n w + checkVecCompatibility cfg vcat n w doVecInsertOp (vecElemInjectCast platform vcat w) ty v e i res where ty :: CmmType ty = vecVmmType vcat n w (VecIndexByteArrayOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do - checkVecCompatibility dflags vcat n w + checkVecCompatibility cfg vcat n w doIndexByteArrayOp Nothing ty res0 args where ty :: CmmType ty = vecVmmType vcat n w (VecReadByteArrayOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do - checkVecCompatibility dflags vcat n w + checkVecCompatibility cfg vcat n w doIndexByteArrayOp Nothing ty res0 args where ty :: CmmType ty = vecVmmType vcat n w (VecWriteByteArrayOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do - checkVecCompatibility dflags vcat n w + checkVecCompatibility cfg vcat n w doWriteByteArrayOp Nothing ty res0 args where ty :: CmmType ty = vecVmmType vcat n w (VecIndexOffAddrOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do - checkVecCompatibility dflags vcat n w + checkVecCompatibility cfg vcat n w doIndexOffAddrOp Nothing ty res0 args where ty :: CmmType ty = vecVmmType vcat n w (VecReadOffAddrOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do - checkVecCompatibility dflags vcat n w + checkVecCompatibility cfg vcat n w doIndexOffAddrOp Nothing ty res0 args where ty :: CmmType ty = vecVmmType vcat n w (VecWriteOffAddrOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do - checkVecCompatibility dflags vcat n w + checkVecCompatibility cfg vcat n w doWriteOffAddrOp Nothing ty res0 args where ty :: CmmType ty = vecVmmType vcat n w (VecIndexScalarByteArrayOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do - checkVecCompatibility dflags vcat n w + checkVecCompatibility cfg vcat n w doIndexByteArrayOpAs Nothing vecty ty res0 args where vecty :: CmmType @@ -952,7 +954,7 @@ emitPrimOp dflags primop = case primop of ty = vecCmmCat vcat w (VecReadScalarByteArrayOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do - checkVecCompatibility dflags vcat n w + checkVecCompatibility cfg vcat n w doIndexByteArrayOpAs Nothing vecty ty res0 args where vecty :: CmmType @@ -962,14 +964,14 @@ emitPrimOp dflags primop = case primop of ty = vecCmmCat vcat w (VecWriteScalarByteArrayOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do - checkVecCompatibility dflags vcat n w + checkVecCompatibility cfg vcat n w doWriteByteArrayOp Nothing ty res0 args where ty :: CmmType ty = vecCmmCat vcat w (VecIndexScalarOffAddrOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do - checkVecCompatibility dflags vcat n w + checkVecCompatibility cfg vcat n w doIndexOffAddrOpAs Nothing vecty ty res0 args where vecty :: CmmType @@ -979,7 +981,7 @@ emitPrimOp dflags primop = case primop of ty = vecCmmCat vcat w (VecReadScalarOffAddrOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do - checkVecCompatibility dflags vcat n w + checkVecCompatibility cfg vcat n w doIndexOffAddrOpAs Nothing vecty ty res0 args where vecty :: CmmType @@ -989,7 +991,7 @@ emitPrimOp dflags primop = case primop of ty = vecCmmCat vcat w (VecWriteScalarOffAddrOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do - checkVecCompatibility dflags vcat n w + checkVecCompatibility cfg vcat n w doWriteOffAddrOp Nothing ty res0 args where ty :: CmmType @@ -1444,92 +1446,92 @@ emitPrimOp dflags primop = case primop of DoubleToFloatOp -> \args -> opTranslate args (MO_FF_Conv W64 W32) IntQuotRemOp -> \args -> opCallishHandledLater args $ - if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args) + if allowQuotRem && not (quotRemCanBeOptimized args) then Left (MO_S_QuotRem (wordWidth platform)) else Right (genericIntQuotRemOp (wordWidth platform)) Int8QuotRemOp -> \args -> opCallishHandledLater args $ - if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args) + if allowQuotRem && not (quotRemCanBeOptimized args) then Left (MO_S_QuotRem W8) else Right (genericIntQuotRemOp W8) Int16QuotRemOp -> \args -> opCallishHandledLater args $ - if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args) + if allowQuotRem && not (quotRemCanBeOptimized args) then Left (MO_S_QuotRem W16) else Right (genericIntQuotRemOp W16) Int32QuotRemOp -> \args -> opCallishHandledLater args $ - if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args) + if allowQuotRem && not (quotRemCanBeOptimized args) then Left (MO_S_QuotRem W32) else Right (genericIntQuotRemOp W32) WordQuotRemOp -> \args -> opCallishHandledLater args $ - if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args) + if allowQuotRem && not (quotRemCanBeOptimized args) then Left (MO_U_QuotRem (wordWidth platform)) else Right (genericWordQuotRemOp (wordWidth platform)) WordQuotRem2Op -> \args -> opCallishHandledLater args $ - if (ncg && (x86ish || ppc)) || llvm + if allowQuotRem2 then Left (MO_U_QuotRem2 (wordWidth platform)) else Right (genericWordQuotRem2Op platform) Word8QuotRemOp -> \args -> opCallishHandledLater args $ - if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args) + if allowQuotRem && not (quotRemCanBeOptimized args) then Left (MO_U_QuotRem W8) else Right (genericWordQuotRemOp W8) Word16QuotRemOp -> \args -> opCallishHandledLater args $ - if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args) + if allowQuotRem && not (quotRemCanBeOptimized args) then Left (MO_U_QuotRem W16) else Right (genericWordQuotRemOp W16) Word32QuotRemOp -> \args -> opCallishHandledLater args $ - if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args) + if allowQuotRem && not (quotRemCanBeOptimized args) then Left (MO_U_QuotRem W32) else Right (genericWordQuotRemOp W32) WordAdd2Op -> \args -> opCallishHandledLater args $ - if (ncg && (x86ish || ppc)) || llvm + if allowExtAdd then Left (MO_Add2 (wordWidth platform)) else Right genericWordAdd2Op WordAddCOp -> \args -> opCallishHandledLater args $ - if (ncg && (x86ish || ppc)) || llvm + if allowExtAdd then Left (MO_AddWordC (wordWidth platform)) else Right genericWordAddCOp WordSubCOp -> \args -> opCallishHandledLater args $ - if (ncg && (x86ish || ppc)) || llvm + if allowExtAdd then Left (MO_SubWordC (wordWidth platform)) else Right genericWordSubCOp IntAddCOp -> \args -> opCallishHandledLater args $ - if (ncg && (x86ish || ppc)) || llvm + if allowExtAdd then Left (MO_AddIntC (wordWidth platform)) else Right genericIntAddCOp IntSubCOp -> \args -> opCallishHandledLater args $ - if (ncg && (x86ish || ppc)) || llvm + if allowExtAdd then Left (MO_SubIntC (wordWidth platform)) else Right genericIntSubCOp WordMul2Op -> \args -> opCallishHandledLater args $ - if ncg && (x86ish || ppc) || llvm + if allowExtAdd then Left (MO_U_Mul2 (wordWidth platform)) else Right genericWordMul2Op IntMul2Op -> \args -> opCallishHandledLater args $ - if ncg && x86ish || llvm + if allowInt2Mul then Left (MO_S_Mul2 (wordWidth platform)) else Right genericIntMul2Op FloatFabsOp -> \args -> opCallishHandledLater args $ - if (ncg && (x86ish || ppc || aarch64)) || llvm + if allowFab then Left MO_F32_Fabs else Right $ genericFabsOp W32 DoubleFabsOp -> \args -> opCallishHandledLater args $ - if (ncg && (x86ish || ppc || aarch64)) || llvm + if allowFab then Left MO_F64_Fabs else Right $ genericFabsOp W64 @@ -1643,8 +1645,8 @@ emitPrimOp dflags primop = case primop of KeepAliveOp -> panic "keepAlive# should have been eliminated in CorePrep" where - profile = targetProfile dflags - platform = profilePlatform profile + profile = stgToCmmProfile cfg + platform = stgToCmmPlatform cfg result_info = getPrimOpResultInfo primop opNop :: [CmmExpr] -> PrimopCmmEmit @@ -1677,7 +1679,7 @@ emitPrimOp dflags primop = case primop of opTranslate64 args mkMop callish = case platformWordSize platform of -- LLVM and C `can handle larger than native size arithmetic natively. - _ | not ncg -> opTranslate args $ mkMop W64 + _ | stgToCmmAllowBigArith cfg -> opTranslate args $ mkMop W64 PW4 -> opCallish args callish PW8 -> opTranslate args $ mkMop W64 @@ -1731,17 +1733,11 @@ emitPrimOp dflags primop = case primop of [_, CmmLit (CmmInt n _) ] -> isJust (exactLog2 n) _ -> False - ncg = backend dflags == NCG - llvm = backend dflags == LLVM - x86ish = case platformArch platform of - ArchX86 -> True - ArchX86_64 -> True - _ -> False - ppc = case platformArch platform of - ArchPPC -> True - ArchPPC_64 _ -> True - _ -> False - aarch64 = platformArch platform == ArchAArch64 + allowQuotRem = stgToCmmAllowQuotRemInstr cfg + allowQuotRem2 = stgToCmmAllowQuotRem2 cfg + allowExtAdd = stgToCmmAllowExtendedAddSubInstrs cfg + allowInt2Mul = stgToCmmAllowIntMul2Instr cfg + allowFab = stgToCmmAllowFabsInstrs cfg data PrimopCmmEmit -- | Out of line fake primop that's actually just a foreign call to other @@ -2008,14 +2004,14 @@ genericWordMul2Op _ _ = panic "genericWordMul2Op" genericIntMul2Op :: GenericOp genericIntMul2Op [res_c, res_h, res_l] both_args@[arg_x, arg_y] - = do dflags <- getDynFlags - platform <- getPlatform + = do cfg <- getStgToCmmConfig -- Implement algorithm from Hacker's Delight, 2nd edition, p.174 - let t = cmmExprType platform arg_x + let t = cmmExprType platform arg_x + platform = stgToCmmPlatform cfg p <- newTemp t -- 1) compute the multiplication as if numbers were unsigned _ <- withSequel (AssignTo [p, res_l] False) $ - cmmPrimOpApp dflags WordMul2Op both_args Nothing + cmmPrimOpApp cfg WordMul2Op both_args Nothing -- 2) correct the high bits of the unsigned result let carryFill x = CmmMachOp (MO_S_Shr ww) [x, wwm1] sub x y = CmmMachOp (MO_Sub ww) [x, y] @@ -2299,14 +2295,13 @@ vecElemProjectCast _ _ _ = Nothing -- it may very well be a design perspective that helps guide improving the NCG. -checkVecCompatibility :: DynFlags -> PrimOpVecCat -> Length -> Width -> FCode () -checkVecCompatibility dflags vcat l w = do - when (backend dflags /= LLVM) $ - sorry $ unlines ["SIMD vector instructions require the LLVM back-end." - ,"Please use -fllvm."] - check vecWidth vcat l w +checkVecCompatibility :: StgToCmmConfig -> PrimOpVecCat -> Length -> Width -> FCode () +checkVecCompatibility cfg vcat l w = + case stgToCmmVecInstrsErr cfg of + Nothing -> check vecWidth vcat l w -- We are in a compatible backend + Just err -> sorry err -- incompatible backend, do panic where - platform = targetPlatform dflags + platform = stgToCmmPlatform cfg check :: Width -> PrimOpVecCat -> Length -> Width -> FCode () check W128 FloatVec 4 W32 | not (isSseEnabled platform) = sorry $ "128-bit wide single-precision floating point " ++ @@ -2314,13 +2309,13 @@ checkVecCompatibility dflags vcat l w = do check W128 _ _ _ | not (isSse2Enabled platform) = sorry $ "128-bit wide integer and double precision " ++ "SIMD vector instructions require at least -msse2." - check W256 FloatVec _ _ | not (isAvxEnabled dflags) = + check W256 FloatVec _ _ | not (stgToCmmAvx cfg) = sorry $ "256-bit wide floating point " ++ "SIMD vector instructions require at least -mavx." - check W256 _ _ _ | not (isAvx2Enabled dflags) = + check W256 _ _ _ | not (stgToCmmAvx2 cfg) = sorry $ "256-bit wide integer " ++ "SIMD vector instructions require at least -mavx2." - check W512 _ _ _ | not (isAvx512fEnabled dflags) = + check W512 _ _ _ | not (stgToCmmAvx512f cfg) = sorry $ "512-bit wide " ++ "SIMD vector instructions require -mavx512f." check _ _ _ _ = return () @@ -3238,9 +3233,9 @@ doBoundsCheck :: CmmExpr -- ^ accessed index -> CmmExpr -- ^ array size (in elements) -> FCode () doBoundsCheck idx sz = do - dflags <- getDynFlags - platform <- getPlatform - when (gopt Opt_DoBoundsChecking dflags) (doCheck platform) + do_bounds_check <- stgToCmmDoBoundsCheck <$> getStgToCmmConfig + platform <- getPlatform + when do_bounds_check (doCheck platform) where doCheck platform = do boundsCheckFailed <- getCode $ emitCCall [] (mkLblExpr mkOutOfBoundsAccessLabel) [] diff --git a/compiler/GHC/StgToCmm/Prof.hs b/compiler/GHC/StgToCmm/Prof.hs index 852b77ef2b..8af9189e9a 100644 --- a/compiler/GHC/StgToCmm/Prof.hs +++ b/compiler/GHC/StgToCmm/Prof.hs @@ -29,11 +29,11 @@ module GHC.StgToCmm.Prof ( import GHC.Prelude import GHC.Driver.Session -import GHC.Driver.Ppr import GHC.Platform import GHC.Platform.Profile import GHC.StgToCmm.Closure +import GHC.StgToCmm.Config import GHC.StgToCmm.Utils import GHC.StgToCmm.Monad import GHC.StgToCmm.Lit @@ -56,7 +56,9 @@ import GHC.Driver.CodeOutput ( ipInitCode ) import GHC.Utils.Encoding import Control.Monad -import Data.Char (ord) +import Data.Char (ord) +import Data.Bifunctor (first) +import GHC.Utils.Monad (whenM) ----------------------------------------------------------------------------- -- @@ -72,7 +74,7 @@ ccType :: Platform -> CmmType -- Type of a cost centre ccType = bWord storeCurCCS :: CmmExpr -> CmmAGraph -storeCurCCS e = mkAssign cccsReg e +storeCurCCS = mkAssign cccsReg mkCCostCentre :: CostCentre -> CmmLit mkCCostCentre cc = CmmLabel (mkCCLabel cc) @@ -139,9 +141,9 @@ We want this kind of code: saveCurrentCostCentre :: FCode (Maybe LocalReg) -- Returns Nothing if profiling is off saveCurrentCostCentre - = do dflags <- getDynFlags - platform <- getPlatform - if not (sccProfilingEnabled dflags) + = do sccProfilingEnabled <- stgToCmmSCCProfiling <$> getStgToCmmConfig + platform <- getPlatform + if not sccProfilingEnabled then return Nothing else do local_cc <- newTemp (ccType platform) emitAssign (CmmLocal local_cc) cccsExpr @@ -163,7 +165,7 @@ restoreCurrentCostCentre (Just local_cc) profDynAlloc :: SMRep -> CmmExpr -> FCode () profDynAlloc rep ccs = ifProfiling $ - do profile <- targetProfile <$> getDynFlags + do profile <- getProfile let platform = profilePlatform profile profAlloc (mkIntExpr platform (heapClosureSizeW profile rep)) ccs @@ -173,12 +175,12 @@ profDynAlloc rep ccs profAlloc :: CmmExpr -> CmmExpr -> FCode () profAlloc words ccs = ifProfiling $ - do profile <- targetProfile <$> getDynFlags + do profile <- getProfile let platform = profilePlatform profile let alloc_rep = rEP_CostCentreStack_mem_alloc platform emit $ addToMemE alloc_rep (cmmOffsetB platform ccs (pc_OFFSET_CostCentreStack_mem_alloc (platformConstants platform))) - (CmmMachOp (MO_UU_Conv (wordWidth platform) (typeWidth alloc_rep)) $ + (CmmMachOp (MO_UU_Conv (wordWidth platform) (typeWidth alloc_rep)) -- subtract the "profiling overhead", which is the -- profiling header in a closure. [CmmMachOp (mo_wordSub platform) [ words, mkIntExpr platform (profHdrSize profile)]] @@ -194,21 +196,18 @@ enterCostCentreThunk closure = emit $ storeCurCCS (costCentreFrom platform closure) enterCostCentreFun :: CostCentreStack -> CmmExpr -> FCode () -enterCostCentreFun ccs closure = - ifProfiling $ - if isCurrentCCS ccs - then do platform <- getPlatform - emitRtsCall rtsUnitId (fsLit "enterFunCCS") - [(baseExpr, AddrHint), - (costCentreFrom platform closure, AddrHint)] False - else return () -- top-level function, nothing to do +enterCostCentreFun ccs closure = ifProfiling $ + when (isCurrentCCS ccs) $ + do platform <- getPlatform + emitRtsCall + rtsUnitId + (fsLit "enterFunCCS") + [(baseExpr, AddrHint), (costCentreFrom platform closure, AddrHint)] + False + -- otherwise we have a top-level function, nothing to do ifProfiling :: FCode () -> FCode () -ifProfiling code - = do profile <- targetProfile <$> getDynFlags - if profileIsProfiling profile - then code - else return () +ifProfiling = whenM (stgToCmmSCCProfiling <$> getStgToCmmConfig) --------------------------------------------------------------- -- Initialising Cost Centres & CCSs @@ -224,7 +223,7 @@ initCostCentres (local_CCs, singleton_CCSs) emitCostCentreDecl :: CostCentre -> FCode () emitCostCentreDecl cc = do - { dflags <- getDynFlags + { ctx <- stgToCmmContext <$> getStgToCmmConfig ; platform <- getPlatform ; let is_caf | isCafCC cc = mkIntCLit platform (ord 'c') -- 'c' == is a CAF | otherwise = zero platform @@ -234,7 +233,7 @@ emitCostCentreDecl cc = do $ moduleName $ cc_mod cc) ; loc <- newByteStringCLit $ utf8EncodeString $ - showPpr dflags (costCentreSrcSpan cc) + renderWithContext ctx (ppr $! costCentreSrcSpan cc) ; let lits = [ zero platform, -- StgInt ccID, label, -- char *label, @@ -278,35 +277,39 @@ sizeof_ccs_words platform (ws,ms) = pc_SIZEOF_CostCentreStack (platformConstants platform) `divMod` platformWordSizeInBytes platform -initInfoTableProv :: [CmmInfoTable] -> InfoTableProvMap -> Module -> FCode CStub +initInfoTableProv :: [CmmInfoTable] -> InfoTableProvMap -> FCode CStub -- Emit the declarations -initInfoTableProv infos itmap this_mod +initInfoTableProv infos itmap = do - dflags <- getDynFlags - let ents = convertInfoProvMap dflags infos this_mod itmap + cfg <- getStgToCmmConfig + let ents = convertInfoProvMap infos this_mod itmap + info_table = stgToCmmInfoTableMap cfg + platform = stgToCmmPlatform cfg + this_mod = stgToCmmThisModule cfg -- Output the actual IPE data mapM_ emitInfoTableProv ents -- Create the C stub which initialises the IPE map - return (ipInitCode dflags this_mod ents) + return (ipInitCode info_table platform this_mod ents) --- Info Table Prov stuff emitInfoTableProv :: InfoProvEnt -> FCode () emitInfoTableProv ip = do - { dflags <- getDynFlags - ; let mod = infoProvModule ip - ; let (src, label) = maybe ("", "") (\(s, l) -> (showPpr dflags s, l)) (infoTableProv ip) - ; platform <- getPlatform - ; let mk_string = newByteStringCLit . utf8EncodeString + { cfg <- getStgToCmmConfig + ; let mod = infoProvModule ip + ctx = stgToCmmContext cfg + platform = stgToCmmPlatform cfg + ; let (src, label) = maybe ("", "") (first (renderWithContext ctx . ppr)) (infoTableProv ip) + mk_string = newByteStringCLit . utf8EncodeString ; label <- mk_string label ; modl <- newByteStringCLit (bytesFS $ moduleNameFS - $ moduleName - $ mod) + $ moduleName mod) ; ty_string <- mk_string (infoTableType ip) - ; loc <- mk_string src - ; table_name <- mk_string (showPpr dflags (pprCLabel platform CStyle (infoTablePtr ip))) - ; closure_type <- mk_string - (showPpr dflags (text $ show $ infoProvEntClosureType ip)) + ; loc <- mk_string src + ; table_name <- mk_string (renderWithContext ctx + (pprCLabel platform CStyle (infoTablePtr ip))) + ; closure_type <- mk_string (renderWithContext ctx + (text $ show $ infoProvEntClosureType ip)) ; let lits = [ CmmLabel (infoTablePtr ip), -- Info table pointer table_name, -- char *table_name @@ -323,15 +326,12 @@ emitInfoTableProv ip = do -- Set the current cost centre stack emitSetCCC :: CostCentre -> Bool -> Bool -> FCode () -emitSetCCC cc tick push - = do profile <- targetProfile <$> getDynFlags - let platform = profilePlatform profile - if not (profileIsProfiling profile) - then return () - else do tmp <- newTemp (ccsType platform) - pushCostCentre tmp cccsExpr cc - when tick $ emit (bumpSccCount platform (CmmReg (CmmLocal tmp))) - when push $ emit (storeCurCCS (CmmReg (CmmLocal tmp))) +emitSetCCC cc tick push = ifProfiling $ + do platform <- getPlatform + tmp <- newTemp (ccsType platform) + pushCostCentre tmp cccsExpr cc + when tick $ emit (bumpSccCount platform (CmmReg (CmmLocal tmp))) + when push $ emit (storeCurCCS (CmmReg (CmmLocal tmp))) pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> FCode () pushCostCentre result ccs cc diff --git a/compiler/GHC/StgToCmm/Sequel.hs b/compiler/GHC/StgToCmm/Sequel.hs new file mode 100644 index 0000000000..ac55c3620f --- /dev/null +++ b/compiler/GHC/StgToCmm/Sequel.hs @@ -0,0 +1,46 @@ +----------------------------------------------------------------------------- +-- +-- Sequel type for Stg to C-- code generation +-- +-- (c) The University of Glasgow 2004-2006 +-- +-- This module is just a bucket of types used in StgToCmm.Monad and +-- StgToCmm.Closure. Its sole purpose is to break a cyclic dependency between +-- StgToCmm.Monad and StgToCmm.Closure which derives from coupling around +-- the BlockId and LocalReg types +----------------------------------------------------------------------------- + +module GHC.StgToCmm.Sequel + ( Sequel(..) + , SelfLoopInfo + ) where + +import GHC.Cmm.BlockId +import GHC.Cmm +import GHC.Cmm.Ppr() + +import GHC.Types.Id +import GHC.Utils.Outputable + +import GHC.Prelude + +-------------------------------------------------------------------------------- +-- | A Sequel tells what to do with the result of this expression +data Sequel + = Return -- ^ Return result(s) to continuation found on the stack. + + | AssignTo + [LocalReg] -- ^ Put result(s) in these regs and fall through + -- NB: no void arguments here + -- + Bool -- ^ Should we adjust the heap pointer back to recover + -- space that's unused on this path? We need to do this + -- only if the expression may allocate (e.g. it's a + -- foreign call or allocating primOp) + +instance Outputable Sequel where + ppr Return = text "Return" + ppr (AssignTo regs b) = text "AssignTo" <+> ppr regs <+> ppr b + +type SelfLoopInfo = (Id, BlockId, [LocalReg]) +-------------------------------------------------------------------------------- diff --git a/compiler/GHC/StgToCmm/Ticky.hs b/compiler/GHC/StgToCmm/Ticky.hs index 3aff61ac80..2a543b6553 100644 --- a/compiler/GHC/StgToCmm/Ticky.hs +++ b/compiler/GHC/StgToCmm/Ticky.hs @@ -109,6 +109,7 @@ import GHC.Platform.Profile import GHC.StgToCmm.ArgRep ( slowCallPattern , toArgRep , argRepString ) import GHC.StgToCmm.Closure +import GHC.StgToCmm.Config import {-# SOURCE #-} GHC.StgToCmm.Foreign ( emitPrimCall ) import GHC.StgToCmm.Lit ( newStringCLit ) import GHC.StgToCmm.Monad @@ -128,6 +129,7 @@ import GHC.Data.FastString import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc +import GHC.Utils.Monad (whenM) -- Turgid imports for showTypeCategory import GHC.Builtin.Names @@ -138,7 +140,7 @@ import GHC.Core.Predicate import Data.Maybe import qualified Data.Char -import Control.Monad ( when ) +import Control.Monad ( when, unless ) ----------------------------------------------------------------------------- -- @@ -161,13 +163,11 @@ withNewTickyCounterFun single_entry = withNewTickyCounter (TickyFun single_entry withNewTickyCounterLNE :: Name -> [NonVoid Id] -> FCode a -> FCode a withNewTickyCounterLNE nm args code = do - b <- tickyLNEIsOn + b <- isEnabled stgToCmmTickyLNE if not b then code else withNewTickyCounter TickyLNE nm args code thunkHasCounter :: Bool -> FCode Bool -thunkHasCounter isStatic = do - b <- tickyDynThunkIsOn - pure (not isStatic && b) +thunkHasCounter isStatic = (not isStatic &&) <$> isEnabled stgToCmmTickyDynThunk withNewTickyCounterThunk :: Bool -- ^ static @@ -214,19 +214,18 @@ emitTickyCounter cloType name args = let ctr_lbl = mkRednCountsLabel name in (>> return ctr_lbl) $ ifTicky $ do - { dflags <- getDynFlags - ; platform <- getPlatform + { cfg <- getStgToCmmConfig ; parent <- getTickyCtrLabel ; mod_name <- getModuleName -- When printing the name of a thing in a ticky file, we -- want to give the module name even for *local* things. We -- print just "x (M)" rather that "M.x" to distinguish them - -- from the global kind. - ; let ppr_for_ticky_name :: SDoc + -- from the global kind by calling to @pprTickyName@ + ; let platform = stgToCmmPlatform cfg + ppr_for_ticky_name :: SDoc ppr_for_ticky_name = - let n = ppr name - ext = case cloType of + let ext = case cloType of TickyFun single_entry -> parens $ hcat $ punctuate comma $ [text "fun"] ++ [text "se"|single_entry] TickyCon datacon -> parens (text "con:" <+> ppr (dataConName datacon)) @@ -239,12 +238,9 @@ emitTickyCounter cloType name args -- have a Haskell name Just pname -> text "in" <+> ppr (nameUnique pname) _ -> empty - in if isInternalName name - then n <+> parens (ppr mod_name) <+> ext <+> p - else n <+> ext <+> p + in pprTickyName mod_name name <+> ext <+> p - ; let ctx = (initSDocContext dflags defaultDumpStyle) - { sdocPprDebug = True } + ; let ctx = defaultSDocContext {sdocPprDebug = True} ; fun_descr_lit <- newStringCLit $ renderWithContext ctx ppr_for_ticky_name ; arg_descr_lit <- newStringCLit $ map (showTypeCategory . idType . fromNonVoid) args ; emitDataLits ctr_lbl @@ -337,8 +333,8 @@ tickyEnterLNE = ifTicky $ do -- since the counter was registered already upon being alloc'd registerTickyCtrAtEntryDyn :: CLabel -> FCode () registerTickyCtrAtEntryDyn ctr_lbl = do - already_registered <- tickyAllocdIsOn - when (not already_registered) $ registerTickyCtr ctr_lbl + already_registered <- isEnabled stgToCmmTickyAllocd + unless already_registered $ registerTickyCtr ctr_lbl -- | Register a ticky counter. -- @@ -566,33 +562,29 @@ tickyStackCheck = ifTicky $ bumpTickyCounter (fsLit "STK_CHK_ctr") -- ----------------------------------------------------------------------------- -- Ticky utils -ifTicky :: FCode () -> FCode () -ifTicky code = - getDynFlags >>= \dflags -> when (gopt Opt_Ticky dflags) code - -tickyAllocdIsOn :: FCode Bool -tickyAllocdIsOn = gopt Opt_Ticky_Allocd `fmap` getDynFlags +isEnabled :: (StgToCmmConfig -> Bool) -> FCode Bool +isEnabled = flip fmap getStgToCmmConfig -tickyLNEIsOn :: FCode Bool -tickyLNEIsOn = gopt Opt_Ticky_LNE `fmap` getDynFlags +runIfFlag :: (StgToCmmConfig -> Bool) -> FCode () -> FCode () +runIfFlag f = whenM (f <$> getStgToCmmConfig) -tickyDynThunkIsOn :: FCode Bool -tickyDynThunkIsOn = gopt Opt_Ticky_Dyn_Thunk `fmap` getDynFlags +ifTicky :: FCode () -> FCode () +ifTicky = runIfFlag stgToCmmDoTicky ifTickyAllocd :: FCode () -> FCode () -ifTickyAllocd code = tickyAllocdIsOn >>= \b -> when b code +ifTickyAllocd = runIfFlag stgToCmmTickyAllocd ifTickyLNE :: FCode () -> FCode () -ifTickyLNE code = tickyLNEIsOn >>= \b -> when b code +ifTickyLNE = runIfFlag stgToCmmTickyLNE ifTickyDynThunk :: FCode () -> FCode () -ifTickyDynThunk code = tickyDynThunkIsOn >>= \b -> when b code +ifTickyDynThunk = runIfFlag stgToCmmTickyDynThunk bumpTickyCounter :: FastString -> FCode () -bumpTickyCounter lbl = bumpTickyLbl (mkRtsCmmDataLabel lbl) +bumpTickyCounter = bumpTickyLbl . mkRtsCmmDataLabel bumpTickyCounterBy :: FastString -> Int -> FCode () -bumpTickyCounterBy lbl = bumpTickyLblBy (mkRtsCmmDataLabel lbl) +bumpTickyCounterBy = bumpTickyLblBy . mkRtsCmmDataLabel bumpTickyCounterByE :: FastString -> CmmExpr -> FCode () bumpTickyCounterByE lbl = bumpTickyLblByE (mkRtsCmmDataLabel lbl) diff --git a/compiler/GHC/StgToCmm/Types.hs b/compiler/GHC/StgToCmm/Types.hs index fa6a663038..1d50f0ae70 100644 --- a/compiler/GHC/StgToCmm/Types.hs +++ b/compiler/GHC/StgToCmm/Types.hs @@ -8,6 +8,8 @@ module GHC.StgToCmm.Types , ArgDescr (..) , StandardFormInfo (..) , WordOff + , DoSCCProfiling + , DoExtDynRefs ) where import GHC.Prelude @@ -229,3 +231,9 @@ instance Outputable StandardFormInfo where ppr NonStandardThunk = text "RegThunk" ppr (SelectorThunk w) = text "SelThunk:" <> ppr w ppr (ApThunk n) = text "ApThunk:" <> ppr n + +-------------------------------------------------------------------------------- +-- Gaining sight in a sea of blindness +-------------------------------------------------------------------------------- +type DoSCCProfiling = Bool +type DoExtDynRefs = Bool diff --git a/compiler/GHC/StgToCmm/Utils.hs b/compiler/GHC/StgToCmm/Utils.hs index 3d79193de1..4e061ad168 100644 --- a/compiler/GHC/StgToCmm/Utils.hs +++ b/compiler/GHC/StgToCmm/Utils.hs @@ -70,7 +70,6 @@ import GHC.Types.Literal import GHC.Data.Graph.Directed import GHC.Utils.Misc import GHC.Types.Unique -import GHC.Driver.Session import GHC.Data.FastString import GHC.Utils.Outputable import GHC.Utils.Panic @@ -84,7 +83,6 @@ import Data.List (sortBy) import Data.Ord import GHC.Types.Unique.Map import Data.Maybe -import GHC.Driver.Ppr import qualified Data.List.NonEmpty as NE import GHC.Core.DataCon import GHC.Types.Unique.FM @@ -99,7 +97,7 @@ import qualified Data.Map.Strict as Map -------------------------------------------------------------------------- addToMemLbl :: CmmType -> CLabel -> Int -> CmmAGraph -addToMemLbl rep lbl n = addToMem rep (CmmLit (CmmLabel lbl)) n +addToMemLbl rep lbl = addToMem rep (CmmLit (CmmLabel lbl)) addToMemLblE :: CmmType -> CLabel -> CmmExpr -> CmmAGraph addToMemLblE rep lbl = addToMemE rep (CmmLit (CmmLabel lbl)) @@ -157,12 +155,11 @@ tagToClosure platform tycon tag ------------------------------------------------------------------------- emitRtsCall :: UnitId -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode () -emitRtsCall pkg fun args safe = emitRtsCallGen [] (mkCmmCodeLabel pkg fun) args safe +emitRtsCall pkg fun = emitRtsCallGen [] (mkCmmCodeLabel pkg fun) emitRtsCallWithResult :: LocalReg -> ForeignHint -> UnitId -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode () -emitRtsCallWithResult res hint pkg fun args safe - = emitRtsCallGen [(res,hint)] (mkCmmCodeLabel pkg fun) args safe +emitRtsCallWithResult res hint pkg = emitRtsCallGen [(res,hint)] . mkCmmCodeLabel pkg -- Make a call to an RTS C procedure emitRtsCallGen @@ -172,7 +169,7 @@ emitRtsCallGen -> Bool -- True <=> CmmSafe call -> FCode () emitRtsCallGen res lbl args safe - = do { platform <- targetPlatform <$> getDynFlags + = do { platform <- getPlatform ; updfr_off <- getUpdFrameOff ; let (caller_save, caller_load) = callerSaveVolatileRegs platform ; emit caller_save @@ -599,14 +596,14 @@ cmmInfoTableToInfoProvEnt this_mod cmit = -- | Convert source information collected about identifiers in 'GHC.STG.Debug' -- to entries suitable for placing into the info table provenenance table. -convertInfoProvMap :: DynFlags -> [CmmInfoTable] -> Module -> InfoTableProvMap -> [InfoProvEnt] -convertInfoProvMap dflags defns this_mod (InfoTableProvMap (UniqMap dcenv) denv infoTableToSourceLocationMap) = +convertInfoProvMap :: [CmmInfoTable] -> Module -> InfoTableProvMap -> [InfoProvEnt] +convertInfoProvMap defns this_mod (InfoTableProvMap (UniqMap dcenv) denv infoTableToSourceLocationMap) = map (\cmit -> let cl = cit_lbl cmit cn = rtsClosureType (cit_rep cmit) tyString :: Outputable a => a -> String - tyString t = showPpr dflags t + tyString = renderWithContext defaultSDocContext . ppr lookupClosureMap :: Maybe InfoProvEnt lookupClosureMap = case hasHaskellName cl >>= lookupUniqMap denv of @@ -616,7 +613,7 @@ convertInfoProvMap dflags defns this_mod (InfoTableProvMap (UniqMap dcenv) denv lookupDataConMap = do UsageSite _ n <- hasIdLabelInfo cl >>= getConInfoTableLocation -- This is a bit grimy, relies on the DataCon and Name having the same Unique, which they do - (dc, ns) <- (hasHaskellName cl >>= lookupUFM_Directly dcenv . getUnique) + (dc, ns) <- hasHaskellName cl >>= lookupUFM_Directly dcenv . getUnique -- Lookup is linear but lists will be small (< 100) return $ InfoProvEnt cl cn (tyString (dataConTyCon dc)) this_mod (join $ lookup n (NE.toList ns)) diff --git a/compiler/GHC/Types/Name.hs b/compiler/GHC/Types/Name.hs index 2c3cfac8c5..b34f32de43 100644 --- a/compiler/GHC/Types/Name.hs +++ b/compiler/GHC/Types/Name.hs @@ -56,6 +56,7 @@ module GHC.Types.Name ( localiseName, nameSrcLoc, nameSrcSpan, pprNameDefnLoc, pprDefinedAt, + pprFullName, pprTickyName, -- ** Predicates on 'Name's isSystemName, isInternalName, isExternalName, @@ -623,6 +624,31 @@ pprName (Name {n_sort = sort, n_uniq = uniq, n_occ = occ}) System -> pprSystem debug sty uniq occ Internal -> pprInternal debug sty uniq occ +-- | Print fully qualified name (with unit-id, module and unique) +pprFullName :: Module -> Name -> SDoc +pprFullName this_mod Name{n_sort = sort, n_uniq = uniq, n_occ = occ} = + let mod = case sort of + WiredIn m _ _ -> m + External m -> m + System -> this_mod + Internal -> this_mod + in ftext (unitIdFS (moduleUnitId mod)) + <> colon <> ftext (moduleNameFS $ moduleName mod) + <> dot <> ftext (occNameFS occ) + <> char '_' <> pprUniqueAlways uniq + + +-- | Print a ticky ticky styled name +-- +-- Module argument is the module to use for internal and system names. When +-- printing the name in a ticky profile, the module name is included even for +-- local things. However, ticky uses the format "x (M)" rather than "M.x". +-- Hence, this function provides a separation from normal styling. +pprTickyName :: Module -> Name -> SDoc +pprTickyName this_mod name + | isInternalName name = pprName name <+> parens (ppr this_mod) + | otherwise = pprName name + -- | Print the string of Name unqualifiedly directly. pprNameUnqualified :: Name -> SDoc pprNameUnqualified Name { n_occ = occ } = ppr_occ_name occ diff --git a/compiler/GHC/Utils/Monad.hs b/compiler/GHC/Utils/Monad.hs index 056651bdde..a6ada16c41 100644 --- a/compiler/GHC/Utils/Monad.hs +++ b/compiler/GHC/Utils/Monad.hs @@ -347,9 +347,9 @@ The pattern synonym approach is due to Sebastian Graaf (#18238) Do note that for monads for multiple arguments more than one oneShot function might be required. For example in FCode we use: - newtype FCode a = FCode' { doFCode :: CgInfoDownwards -> CgState -> (a, CgState) } + newtype FCode a = FCode' { doFCode :: StgToCmmConfig -> CgState -> (a, CgState) } - pattern FCode :: (CgInfoDownwards -> CgState -> (a, CgState)) + pattern FCode :: (StgToCmmConfig -> CgState -> (a, CgState)) -> FCode a pattern FCode m <- FCode' m where diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 31981f8116..ff90538a0f 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -378,6 +378,7 @@ Library GHC.Driver.Config.HsToCore GHC.Driver.Config.Logger GHC.Driver.Config.Parser + GHC.Driver.Config.StgToCmm GHC.Driver.Env GHC.Driver.Env.KnotVars GHC.Driver.Env.Types @@ -549,6 +550,7 @@ Library GHC.StgToCmm.Bind GHC.StgToCmm.CgUtils GHC.StgToCmm.Closure + GHC.StgToCmm.Config GHC.StgToCmm.DataCon GHC.StgToCmm.Env GHC.StgToCmm.Expr @@ -561,6 +563,7 @@ Library GHC.StgToCmm.Monad GHC.StgToCmm.Prim GHC.StgToCmm.Prof + GHC.StgToCmm.Sequel GHC.StgToCmm.Ticky GHC.StgToCmm.Types GHC.StgToCmm.Utils diff --git a/testsuite/tests/codeGen/should_compile/T13233_orig.hs b/testsuite/tests/codeGen/should_compile/T13233_orig.hs index e9447ec2c0..7539417911 100644 --- a/testsuite/tests/codeGen/should_compile/T13233_orig.hs +++ b/testsuite/tests/codeGen/should_compile/T13233_orig.hs @@ -5,29 +5,29 @@ module T13233_orig where import Control.Monad ( ap, liftM ) -newtype FCode a = FCode (CgInfoDownwards -> CgState -> (# a, CgState #)) +newtype FCode a = FCode (StgToCmmConfig -> CgState -> (# a, CgState #)) -data CgInfoDownwards - = MkCgInfoDown { cgd_dflags :: DynFlags } +data StgToCmmConfig + = StgToCmmConfig { } data CgState = MkCgState returnFC :: a -> FCode a -returnFC val = FCode (\_info_down state -> (# val, state #)) +returnFC val = FCode (\_cfg state -> (# val, state #)) thenC :: FCode () -> FCode a -> FCode a thenC (FCode m) (FCode k) = - FCode $ \ info_down state -> - case m info_down state of - (# _, new_state #) -> k info_down new_state + FCode $ \ cfg state -> + case m cfg state of + (# _, new_state #) -> k cfg new_state thenFC :: FCode a -> (a -> FCode c) -> FCode c thenFC (FCode m) k = - FCode $ \ info_down state -> - case m info_down state of + FCode $ \ cfg state -> + case m cfg state of (# m_result, new_state #) -> case k m_result of - FCode kcode -> kcode info_down new_state + FCode kcode -> kcode cfg new_state infixr 9 `thenC` infixr 9 `thenFC` @@ -46,13 +46,5 @@ instance Applicative FCode where instance Monad FCode where (>>=) = thenFC -instance HasDynFlags FCode where - getDynFlags = liftM cgd_dflags getInfoDown - -getInfoDown :: FCode CgInfoDownwards -getInfoDown = FCode $ \ info_down state -> (# info_down, state #) - -class HasDynFlags m where - getDynFlags :: m DynFlags - -data DynFlags = DynFlags +getStgToCmmConfig :: FCode StgToCmmConfig +getStgToCmmConfig = FCode $ \ cfg state -> (# cfg, state #) diff --git a/testsuite/tests/count-deps/CountDepsAst.stdout b/testsuite/tests/count-deps/CountDepsAst.stdout index 013fc246c6..f6956a5213 100644 --- a/testsuite/tests/count-deps/CountDepsAst.stdout +++ b/testsuite/tests/count-deps/CountDepsAst.stdout @@ -1,4 +1,4 @@ -Found 278 Language.Haskell.Syntax module dependencies +Found 279 Language.Haskell.Syntax module dependencies GHC.Builtin.Names GHC.Builtin.PrimOps GHC.Builtin.PrimOps.Ids @@ -154,6 +154,7 @@ GHC.Settings GHC.Settings.Config GHC.Settings.Constants GHC.Stg.Syntax +GHC.StgToCmm.Config GHC.StgToCmm.Types GHC.SysTools.BaseDir GHC.SysTools.Terminal diff --git a/testsuite/tests/count-deps/CountDepsParser.stdout b/testsuite/tests/count-deps/CountDepsParser.stdout index 58db04dc19..fd2910dc92 100644 --- a/testsuite/tests/count-deps/CountDepsParser.stdout +++ b/testsuite/tests/count-deps/CountDepsParser.stdout @@ -1,4 +1,4 @@ -Found 284 GHC.Parser module dependencies +Found 285 GHC.Parser module dependencies GHC.Builtin.Names GHC.Builtin.PrimOps GHC.Builtin.PrimOps.Ids @@ -160,6 +160,7 @@ GHC.Settings GHC.Settings.Config GHC.Settings.Constants GHC.Stg.Syntax +GHC.StgToCmm.Config GHC.StgToCmm.Types GHC.SysTools.BaseDir GHC.SysTools.Terminal |