[Git][ghc/ghc][master] 3 commits: Put CFG weights into their own module (#17957)
Marge Bot
gitlab at gitlab.haskell.org
Fri Aug 21 13:36:46 UTC 2020
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
293c7fba by Sylvain Henry at 2020-08-21T09:36:38-04:00
Put CFG weights into their own module (#17957)
It avoids having to query DynFlags to get them
- - - - -
50eb4460 by Sylvain Henry at 2020-08-21T09:36:38-04:00
Don't use DynFlags in CmmToAsm.BlockLayout (#17957)
- - - - -
659eb31b by Sylvain Henry at 2020-08-21T09:36:38-04:00
NCG: Dwarf configuration
* remove references to DynFlags in GHC.CmmToAsm.Dwarf
* add specific Dwarf options in NCGConfig instead of directly querying
the debug level
- - - - -
22 changed files:
- compiler/GHC/Cmm/Info/Build.hs
- compiler/GHC/CmmToAsm.hs
- compiler/GHC/CmmToAsm/BlockLayout.hs
- compiler/GHC/CmmToAsm/CFG.hs
- + compiler/GHC/CmmToAsm/CFG/Weight.hs
- compiler/GHC/CmmToAsm/Config.hs
- compiler/GHC/CmmToAsm/Dwarf.hs
- compiler/GHC/CmmToAsm/Monad.hs
- compiler/GHC/CmmToAsm/PPC/Ppr.hs
- compiler/GHC/CmmToAsm/X86/CodeGen.hs
- compiler/GHC/CmmToAsm/X86/Ppr.hs
- compiler/GHC/CmmToLlvm/Base.hs
- compiler/GHC/CmmToLlvm/CodeGen.hs
- compiler/GHC/Driver/Backpack.hs
- compiler/GHC/Driver/Ppr.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Unit/State.hs
- compiler/GHC/Utils/Outputable.hs
- compiler/ghc.cabal.in
- testsuite/tests/hiefile/should_run/HieQueries.hs
- testsuite/tests/parser/should_run/CountParserDeps.hs
- testsuite/tests/regalloc/regalloc_unit_tests.hs
Changes:
=====================================
compiler/GHC/Cmm/Info/Build.hs
=====================================
@@ -34,7 +34,7 @@ import GHC.Runtime.Heap.Layout
import GHC.Types.Unique.Supply
import GHC.Types.CostCentre
import GHC.StgToCmm.Heap
-import GHC.CmmToAsm.Monad
+import GHC.CmmToAsm
import Control.Monad
import Data.Map.Strict (Map)
@@ -933,7 +933,7 @@ oneSRT dflags staticFuns lbls caf_lbls isCAF cafs static_data = do
topSRT <- get
let
- config = initConfig dflags
+ config = initNCGConfig dflags
profile = targetProfile dflags
platform = profilePlatform profile
srtMap = moduleSRTMap topSRT
=====================================
compiler/GHC/CmmToAsm.hs
=====================================
@@ -72,6 +72,7 @@ module GHC.CmmToAsm
-- cmmNativeGen emits
, cmmNativeGen
, NcgImpl(..)
+ , initNCGConfig
)
where
@@ -147,11 +148,11 @@ nativeCodeGen :: forall a . DynFlags -> Module -> ModLocation -> Handle -> UniqS
-> Stream IO RawCmmGroup a
-> IO a
nativeCodeGen dflags this_mod modLoc h us cmms
- = let config = initConfig dflags
+ = let config = initNCGConfig dflags
platform = ncgPlatform config
nCG' :: ( Outputable statics, Outputable jumpDest, Instruction instr)
=> NcgImpl statics instr jumpDest -> IO a
- nCG' ncgImpl = nativeCodeGen' dflags this_mod modLoc ncgImpl h us cmms
+ nCG' ncgImpl = nativeCodeGen' dflags config this_mod modLoc ncgImpl h us cmms
in case platformArch platform of
ArchX86 -> nCG' (X86.ncgX86 config)
ArchX86_64 -> nCG' (X86.ncgX86_64 config)
@@ -215,39 +216,42 @@ See also Note [What is this unwinding business?] in "GHC.Cmm.DebugBlock".
nativeCodeGen' :: (Outputable statics, Outputable jumpDest, Instruction instr)
=> DynFlags
+ -> NCGConfig
-> Module -> ModLocation
-> NcgImpl statics instr jumpDest
-> Handle
-> UniqSupply
-> Stream IO RawCmmGroup a
-> IO a
-nativeCodeGen' dflags this_mod modLoc ncgImpl h us cmms
+nativeCodeGen' dflags config this_mod modLoc ncgImpl h us cmms
= do
-- BufHandle is a performance hack. We could hide it inside
-- Pretty if it weren't for the fact that we do lots of little
-- printDocs here (in order to do codegen in constant space).
bufh <- newBufHandle h
let ngs0 = NGS [] [] [] [] [] [] emptyUFM mapEmpty
- (ngs, us', a) <- cmmNativeGenStream dflags this_mod modLoc ncgImpl bufh us
+ (ngs, us', a) <- cmmNativeGenStream dflags config this_mod modLoc ncgImpl bufh us
cmms ngs0
- _ <- finishNativeGen dflags modLoc bufh us' ngs
+ _ <- finishNativeGen dflags config modLoc bufh us' ngs
return a
finishNativeGen :: Instruction instr
=> DynFlags
+ -> NCGConfig
-> ModLocation
-> BufHandle
-> UniqSupply
-> NativeGenAcc statics instr
-> IO UniqSupply
-finishNativeGen dflags modLoc bufh@(BufHandle _ _ h) us ngs
+finishNativeGen dflags config modLoc bufh@(BufHandle _ _ h) us ngs
= withTimingSilent dflags (text "NCG") (`seq` ()) $ do
-- Write debug data and finish
- let emitDw = debugLevel dflags > 0
- us' <- if not emitDw then return us else do
- (dwarf, us') <- dwarfGen dflags modLoc us (ngs_debug ngs)
- emitNativeCode dflags bufh dwarf
- return us'
+ us' <- if not (ncgDwarfEnabled config)
+ then return us
+ else do
+ (dwarf, us') <- dwarfGen config modLoc us (ngs_debug ngs)
+ emitNativeCode dflags config bufh dwarf
+ return us'
bFlush bufh
-- dump global NCG stats for graph coloring allocator
@@ -262,7 +266,7 @@ finishNativeGen dflags modLoc bufh@(BufHandle _ _ h) us ngs
dump_stats (Color.pprStats stats graphGlobal)
- let platform = targetPlatform dflags
+ let platform = ncgPlatform config
dumpIfSet_dyn dflags
Opt_D_dump_asm_conflicts "Register conflict graph"
FormatText
@@ -280,7 +284,7 @@ finishNativeGen dflags modLoc bufh@(BufHandle _ _ h) us ngs
dump_stats (Linear.pprStats (concat (ngs_natives ngs)) linearStats)
-- write out the imports
- let ctx = initSDocContext dflags (mkCodeStyle AsmStyle)
+ let ctx = ncgAsmContext config
printSDocLn ctx Pretty.LeftMode h
$ makeImportsDoc dflags (concat (ngs_imports ngs))
return us'
@@ -291,6 +295,7 @@ finishNativeGen dflags modLoc bufh@(BufHandle _ _ h) us ngs
cmmNativeGenStream :: (Outputable statics, Outputable jumpDest, Instruction instr)
=> DynFlags
+ -> NCGConfig
-> Module -> ModLocation
-> NcgImpl statics instr jumpDest
-> BufHandle
@@ -299,7 +304,7 @@ cmmNativeGenStream :: (Outputable statics, Outputable jumpDest, Instruction inst
-> NativeGenAcc statics instr
-> IO (NativeGenAcc statics instr, UniqSupply, a)
-cmmNativeGenStream dflags this_mod modLoc ncgImpl h us cmm_stream ngs
+cmmNativeGenStream dflags config this_mod modLoc ncgImpl h us cmm_stream ngs
= do r <- Stream.runStream cmm_stream
case r of
Left a ->
@@ -316,13 +321,12 @@ cmmNativeGenStream dflags this_mod modLoc ncgImpl h us cmm_stream ngs
dflags
ncglabel (\(a, b) -> a `seq` b `seq` ()) $ do
-- Generate debug information
- let debugFlag = debugLevel dflags > 0
- !ndbgs | debugFlag = cmmDebugGen modLoc cmms
- | otherwise = []
+ let !ndbgs | ncgDwarfEnabled config = cmmDebugGen modLoc cmms
+ | otherwise = []
dbgMap = debugToMap ndbgs
-- Generate native code
- (ngs',us') <- cmmNativeGens dflags this_mod modLoc ncgImpl h
+ (ngs',us') <- cmmNativeGens dflags config this_mod modLoc ncgImpl h
dbgMap us cmms ngs 0
-- Link native code information into debug blocks
@@ -336,7 +340,7 @@ cmmNativeGenStream dflags this_mod modLoc ncgImpl h us cmm_stream ngs
let ngs'' = ngs' { ngs_debug = ngs_debug ngs' ++ ldbgs, ngs_labels = [] }
return (us', ngs'')
- cmmNativeGenStream dflags this_mod modLoc ncgImpl h us'
+ cmmNativeGenStream dflags config this_mod modLoc ncgImpl h us'
cmm_stream' ngs''
where ncglabel = text "NCG"
@@ -346,6 +350,7 @@ cmmNativeGenStream dflags this_mod modLoc ncgImpl h us cmm_stream ngs
cmmNativeGens :: forall statics instr jumpDest.
(Outputable statics, Outputable jumpDest, Instruction instr)
=> DynFlags
+ -> NCGConfig
-> Module -> ModLocation
-> NcgImpl statics instr jumpDest
-> BufHandle
@@ -356,7 +361,7 @@ cmmNativeGens :: forall statics instr jumpDest.
-> Int
-> IO (NativeGenAcc statics instr, UniqSupply)
-cmmNativeGens dflags this_mod modLoc ncgImpl h dbgMap = go
+cmmNativeGens dflags config this_mod modLoc ncgImpl h dbgMap = go
where
go :: UniqSupply -> [RawCmmDecl]
-> NativeGenAcc statics instr -> Int
@@ -381,14 +386,14 @@ cmmNativeGens dflags this_mod modLoc ncgImpl h dbgMap = go
pprDecl (f,n) = text "\t.file " <> ppr n <+>
pprFilePathString (unpackFS f)
- emitNativeCode dflags h $ vcat $
+ emitNativeCode dflags config h $ vcat $
map pprDecl newFileIds ++
map (pprNatCmmDecl ncgImpl) native
-- force evaluation all this stuff to avoid space leaks
{-# SCC "seqString" #-} evaluate $ seqList (showSDoc dflags $ vcat $ map ppr imports) ()
- let !labels' = if debugLevel dflags > 0
+ let !labels' = if ncgDwarfEnabled config
then cmmDebugLabels isMetaInstr native else []
!natives' = if dopt Opt_D_dump_asm_stats dflags
then native : ngs_natives ngs else []
@@ -405,10 +410,10 @@ cmmNativeGens dflags this_mod modLoc ncgImpl h dbgMap = go
go us' cmms ngs' (count + 1)
-emitNativeCode :: DynFlags -> BufHandle -> SDoc -> IO ()
-emitNativeCode dflags h sdoc = do
+emitNativeCode :: DynFlags -> NCGConfig -> BufHandle -> SDoc -> IO ()
+emitNativeCode dflags config h sdoc = do
- let ctx = initSDocContext dflags (mkCodeStyle AsmStyle)
+ let ctx = ncgAsmContext config
{-# SCC "pprNativeCode" #-} bufLeftRenderSDoc ctx h sdoc
-- dump native code
@@ -442,6 +447,7 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
= do
let config = ncgConfig ncgImpl
let platform = ncgPlatform config
+ let weights = ncgCfgWeights config
let proc_name = case cmm of
(CmmProc _ entry_label _ _) -> ppr entry_label
@@ -462,12 +468,12 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
(pprCmmGroup [opt_cmm])
let cmmCfg = {-# SCC "getCFG" #-}
- getCfgProc (cfgWeightInfo dflags) opt_cmm
+ getCfgProc weights opt_cmm
-- generate native code from cmm
let ((native, lastMinuteImports, fileIds', nativeCfgWeights), usGen) =
{-# SCC "genMachCode" #-}
- initUs us $ genMachCode dflags this_mod modLoc
+ initUs us $ genMachCode config this_mod modLoc
(cmmTopCodeGen ncgImpl)
fileIds dbgMap opt_cmm cmmCfg
@@ -594,11 +600,11 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
cfgRegAllocUpdates = (concatMap Linear.ra_fixupList raStats)
let cfgWithFixupBlks =
- (\cfg -> addNodesBetween dflags cfg cfgRegAllocUpdates) <$> livenessCfg
+ (\cfg -> addNodesBetween weights cfg cfgRegAllocUpdates) <$> livenessCfg
-- Insert stack update blocks
let postRegCFG =
- pure (foldl' (\m (from,to) -> addImmediateSuccessor dflags from to m ))
+ pure (foldl' (\m (from,to) -> addImmediateSuccessor weights from to m ))
<*> cfgWithFixupBlks
<*> pure stack_updt_blks
@@ -620,7 +626,7 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
let optimizedCFG :: Maybe CFG
optimizedCFG =
- optimizeCFG (gopt Opt_CmmStaticPred dflags) (cfgWeightInfo dflags) cmm <$!> postShortCFG
+ optimizeCFG (gopt Opt_CmmStaticPred dflags) weights cmm <$!> postShortCFG
maybeDumpCfg dflags optimizedCFG "CFG Weights - Final" proc_name
@@ -642,7 +648,6 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
checkLayout shorted $
{-# SCC "sequenceBlocks" #-}
map (BlockLayout.sequenceTop
- dflags
ncgImpl optimizedCFG)
shorted
@@ -768,7 +773,7 @@ makeImportsDoc dflags imports
else Outputable.empty)
where
- config = initConfig dflags
+ config = initNCGConfig dflags
platform = ncgPlatform config
-- Generate "symbol stubs" for all external symbols that might
@@ -790,10 +795,9 @@ makeImportsDoc dflags imports
| otherwise
= Outputable.empty
- doPpr lbl = (lbl, renderWithStyle
- (initSDocContext dflags astyle)
+ doPpr lbl = (lbl, renderWithContext
+ (ncgAsmContext config)
(pprCLabel_NCG platform lbl))
- astyle = mkCodeStyle AsmStyle
-- -----------------------------------------------------------------------------
-- Generate jump tables
@@ -904,7 +908,7 @@ apply_mapping ncgImpl ufm (CmmProc info lbl live (ListGraph blocks))
-- Unique supply breaks abstraction. Is that bad?
genMachCode
- :: DynFlags
+ :: NCGConfig
-> Module -> ModLocation
-> (RawCmmDecl -> NatM [NatCmmDecl statics instr])
-> DwarfFiles
@@ -918,9 +922,9 @@ genMachCode
, CFG
)
-genMachCode dflags this_mod modLoc cmmTopCodeGen fileIds dbgMap cmm_top cmm_cfg
+genMachCode config this_mod modLoc cmmTopCodeGen fileIds dbgMap cmm_top cmm_cfg
= do { initial_us <- getUniqueSupplyM
- ; let initial_st = mkNatM_State initial_us 0 dflags this_mod
+ ; let initial_st = mkNatM_State initial_us 0 config this_mod
modLoc fileIds dbgMap cmm_cfg
(new_tops, final_st) = initNat initial_st (cmmTopCodeGen cmm_top)
final_delta = natm_delta final_st
@@ -1134,3 +1138,54 @@ cmmExprNative referenceKind expr = do
other
-> return other
+
+-- | Initialize the native code generator configuration from the DynFlags
+initNCGConfig :: DynFlags -> NCGConfig
+initNCGConfig dflags = NCGConfig
+ { ncgPlatform = targetPlatform dflags
+ , ncgAsmContext = initSDocContext dflags (mkCodeStyle AsmStyle)
+ , ncgProcAlignment = cmmProcAlignment dflags
+ , ncgExternalDynamicRefs = gopt Opt_ExternalDynamicRefs dflags
+ , ncgPIC = positionIndependent dflags
+ , ncgInlineThresholdMemcpy = fromIntegral $ maxInlineMemcpyInsns dflags
+ , ncgInlineThresholdMemset = fromIntegral $ maxInlineMemsetInsns dflags
+ , ncgSplitSections = gopt Opt_SplitSections dflags
+ , ncgRegsIterative = gopt Opt_RegsIterative dflags
+ , ncgAsmLinting = gopt Opt_DoAsmLinting dflags
+ , ncgCfgWeights = cfgWeights dflags
+ , ncgCfgBlockLayout = gopt Opt_CfgBlocklayout dflags
+ , ncgCfgWeightlessLayout = gopt Opt_WeightlessBlocklayout dflags
+
+ -- With -O1 and greater, the cmmSink pass does constant-folding, so
+ -- we don't need to do it again in the native code generator.
+ , ncgDoConstantFolding = optLevel dflags < 1
+
+ , ncgDumpRegAllocStages = dopt Opt_D_dump_asm_regalloc_stages dflags
+ , ncgDumpAsmStats = dopt Opt_D_dump_asm_stats dflags
+ , ncgDumpAsmConflicts = dopt Opt_D_dump_asm_conflicts dflags
+ , ncgBmiVersion = case platformArch (targetPlatform dflags) of
+ ArchX86_64 -> bmiVersion dflags
+ ArchX86 -> bmiVersion dflags
+ _ -> Nothing
+
+ -- We Assume SSE1 and SSE2 operations are available on both
+ -- x86 and x86_64. Historically we didn't default to SSE2 and
+ -- SSE1 on x86, which results in defacto nondeterminism for how
+ -- rounding behaves in the associated x87 floating point instructions
+ -- because variations in the spill/fpu stack placement of arguments for
+ -- operations would change the precision and final result of what
+ -- would otherwise be the same expressions with respect to single or
+ -- double precision IEEE floating point computations.
+ , ncgSseVersion =
+ let v | sseVersion dflags < Just SSE2 = Just SSE2
+ | otherwise = sseVersion dflags
+ in case platformArch (targetPlatform dflags) of
+ ArchX86_64 -> v
+ ArchX86 -> v
+ _ -> Nothing
+
+ , ncgDwarfEnabled = debugLevel dflags > 0
+ , ncgDwarfUnwindings = debugLevel dflags >= 1
+ , ncgDwarfStripBlockInfo = debugLevel dflags < 2 -- We strip out block information when running with -g0 or -g1.
+ }
+
=====================================
compiler/GHC/CmmToAsm/BlockLayout.hs
=====================================
@@ -8,6 +8,7 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE MultiWayIf #-}
module GHC.CmmToAsm.BlockLayout
( sequenceTop, backendMaintainsCfg)
@@ -16,13 +17,13 @@ where
#include "HsVersions.h"
import GHC.Prelude
-import GHC.Driver.Session (gopt, GeneralFlag(..), DynFlags, targetPlatform)
import GHC.Driver.Ppr (pprTrace)
import GHC.CmmToAsm.Instr
import GHC.CmmToAsm.Monad
import GHC.CmmToAsm.CFG
import GHC.CmmToAsm.Types
+import GHC.CmmToAsm.Config
import GHC.Cmm.BlockId
import GHC.Cmm
@@ -817,30 +818,32 @@ dropJumps info ((BasicBlock lbl ins):todo)
sequenceTop
:: Instruction instr
- => DynFlags -- Determine which layout algo to use
- -> NcgImpl statics instr jumpDest
+ => NcgImpl statics instr jumpDest
-> Maybe CFG -- ^ CFG if we have one.
-> NatCmmDecl statics instr -- ^ Function to serialize
-> NatCmmDecl statics instr
-sequenceTop _ _ _ top@(CmmData _ _) = top
-sequenceTop dflags ncgImpl edgeWeights
- (CmmProc info lbl live (ListGraph blocks))
- | (gopt Opt_CfgBlocklayout dflags) && backendMaintainsCfg (targetPlatform dflags)
- --Use chain based algorithm
- , Just cfg <- edgeWeights
- = CmmProc info lbl live ( ListGraph $ ncgMakeFarBranches ncgImpl info $
- {-# SCC layoutBlocks #-}
- sequenceChain info cfg blocks )
- | otherwise
- --Use old algorithm
- = let cfg = if dontUseCfg then Nothing else edgeWeights
- in CmmProc info lbl live ( ListGraph $ ncgMakeFarBranches ncgImpl info $
- {-# SCC layoutBlocks #-}
- sequenceBlocks cfg info blocks)
- where
- dontUseCfg = gopt Opt_WeightlessBlocklayout dflags ||
- (not $ backendMaintainsCfg (targetPlatform dflags))
+sequenceTop _ _ top@(CmmData _ _) = top
+sequenceTop ncgImpl edgeWeights (CmmProc info lbl live (ListGraph blocks))
+ = let
+ config = ncgConfig ncgImpl
+ platform = ncgPlatform config
+
+ in CmmProc info lbl live $ ListGraph $ ncgMakeFarBranches ncgImpl info $
+ if -- Chain based algorithm
+ | ncgCfgBlockLayout config
+ , backendMaintainsCfg platform
+ , Just cfg <- edgeWeights
+ -> {-# SCC layoutBlocks #-} sequenceChain info cfg blocks
+
+ -- Old algorithm without edge weights
+ | ncgCfgWeightlessLayout config
+ || not (backendMaintainsCfg platform)
+ -> {-# SCC layoutBlocks #-} sequenceBlocks Nothing info blocks
+
+ -- Old algorithm with edge weights (if any)
+ | otherwise
+ -> {-# SCC layoutBlocks #-} sequenceBlocks edgeWeights info blocks
-- The old algorithm:
-- It is very simple (and stupid): We make a graph out of
=====================================
compiler/GHC/CmmToAsm/CFG.hs
=====================================
@@ -62,6 +62,7 @@ import GHC.Data.Maybe
import GHC.Types.Unique
import qualified GHC.CmmToAsm.CFG.Dominators as Dom
+import GHC.CmmToAsm.CFG.Weight
import Data.IntMap.Strict (IntMap)
import Data.IntSet (IntSet)
@@ -79,7 +80,6 @@ import GHC.Utils.Panic
--import GHC.Data.OrdList
--import GHC.Cmm.DebugBlock.Trace
import GHC.Cmm.Ppr () -- For Outputable instances
-import qualified GHC.Driver.Session as D
import Data.List (sort, nub, partition)
import Data.STRef.Strict
@@ -329,12 +329,11 @@ shortcutWeightMap cuts cfg =
-- \ \
-- -> C => -> C
--
-addImmediateSuccessor :: D.DynFlags -> BlockId -> BlockId -> CFG -> CFG
-addImmediateSuccessor dflags node follower cfg
- = updateEdges . addWeightEdge node follower uncondWeight $ cfg
+addImmediateSuccessor :: Weights -> BlockId -> BlockId -> CFG -> CFG
+addImmediateSuccessor weights node follower cfg
+ = updateEdges . addWeightEdge node follower weight $ cfg
where
- uncondWeight = fromIntegral . D.uncondWeight .
- D.cfgWeightInfo $ dflags
+ weight = fromIntegral (uncondWeight weights)
targets = getSuccessorEdges cfg node
successors = map fst targets :: [BlockId]
updateEdges = addNewSuccs . remOldSuccs
@@ -509,13 +508,12 @@ mapWeights f cfg =
-- these cases.
-- We assign the old edge info to the edge A -> B and assign B -> C the
-- weight of an unconditional jump.
-addNodesBetween :: D.DynFlags -> CFG -> [(BlockId,BlockId,BlockId)] -> CFG
-addNodesBetween dflags m updates =
+addNodesBetween :: Weights -> CFG -> [(BlockId,BlockId,BlockId)] -> CFG
+addNodesBetween weights m updates =
foldl' updateWeight m .
weightUpdates $ updates
where
- weight = fromIntegral . D.uncondWeight .
- D.cfgWeightInfo $ dflags
+ weight = fromIntegral (uncondWeight weights)
-- We might add two blocks for different jumps along a single
-- edge. So we end up with edges: A -> B -> C , A -> D -> C
-- in this case after applying the first update the weight for A -> C
@@ -585,24 +583,24 @@ addNodesBetween dflags m updates =
-}
-- | Generate weights for a Cmm proc based on some simple heuristics.
-getCfgProc :: D.CfgWeights -> RawCmmDecl -> CFG
+getCfgProc :: Weights -> RawCmmDecl -> CFG
getCfgProc _ (CmmData {}) = mapEmpty
getCfgProc weights (CmmProc _info _lab _live graph) = getCfg weights graph
-getCfg :: D.CfgWeights -> CmmGraph -> CFG
+getCfg :: Weights -> CmmGraph -> CFG
getCfg weights graph =
foldl' insertEdge edgelessCfg $ concatMap getBlockEdges blocks
where
- D.CFGWeights
- { D.uncondWeight = uncondWeight
- , D.condBranchWeight = condBranchWeight
- , D.switchWeight = switchWeight
- , D.callWeight = callWeight
- , D.likelyCondWeight = likelyCondWeight
- , D.unlikelyCondWeight = unlikelyCondWeight
+ Weights
+ { uncondWeight = uncondWeight
+ , condBranchWeight = condBranchWeight
+ , switchWeight = switchWeight
+ , callWeight = callWeight
+ , likelyCondWeight = likelyCondWeight
+ , unlikelyCondWeight = unlikelyCondWeight
-- Last two are used in other places
- --, D.infoTablePenalty = infoTablePenalty
- --, D.backEdgeBonus = backEdgeBonus
+ --, infoTablePenalty = infoTablePenalty
+ --, backEdgeBonus = backEdgeBonus
} = weights
-- Explicitly add all nodes to the cfg to ensure they are part of the
-- CFG.
@@ -631,7 +629,7 @@ getCfg weights graph =
mkEdge target weight = ((bid,target), mkEdgeInfo weight)
branchInfo =
foldRegsUsed
- (panic "foldRegsDynFlags")
+ (panic "GHC.CmmToAsm.CFG.getCfg: foldRegsUsed")
(\info r -> if r == SpLim || r == HpLim || r == BaseReg
then HeapStackCheck else info)
NoInfo cond
@@ -671,7 +669,7 @@ findBackEdges root cfg =
typedEdges =
classifyEdges root getSuccs edges :: [((BlockId,BlockId),EdgeType)]
-optimizeCFG :: Bool -> D.CfgWeights -> RawCmmDecl -> CFG -> CFG
+optimizeCFG :: Bool -> Weights -> RawCmmDecl -> CFG -> CFG
optimizeCFG _ _ (CmmData {}) cfg = cfg
optimizeCFG doStaticPred weights proc@(CmmProc _info _lab _live graph) cfg =
(if doStaticPred then staticPredCfg (g_entry graph) else id) $
@@ -682,7 +680,7 @@ optimizeCFG doStaticPred weights proc@(CmmProc _info _lab _live graph) cfg =
-- performance.
--
-- Most importantly we penalize jumps across info tables.
-optHsPatterns :: D.CfgWeights -> RawCmmDecl -> CFG -> CFG
+optHsPatterns :: Weights -> RawCmmDecl -> CFG -> CFG
optHsPatterns _ (CmmData {}) cfg = cfg
optHsPatterns weights (CmmProc info _lab _live graph) cfg =
{-# SCC optHsPatterns #-}
@@ -704,7 +702,7 @@ optHsPatterns weights (CmmProc info _lab _live graph) cfg =
--Keep irrelevant edges irrelevant
| weight <= 0 = 0
| otherwise
- = weight + fromIntegral (D.backEdgeBonus weights)
+ = weight + fromIntegral (backEdgeBonus weights)
in foldl' (\cfg edge -> updateEdgeWeight update edge cfg)
cfg backedges
@@ -716,7 +714,7 @@ optHsPatterns weights (CmmProc info _lab _live graph) cfg =
fupdate :: BlockId -> BlockId -> EdgeWeight -> EdgeWeight
fupdate _ to weight
| mapMember to info
- = weight - (fromIntegral $ D.infoTablePenalty weights)
+ = weight - (fromIntegral $ infoTablePenalty weights)
| otherwise = weight
-- | If a block has two successors, favour the one with fewer
=====================================
compiler/GHC/CmmToAsm/CFG/Weight.hs
=====================================
@@ -0,0 +1,78 @@
+module GHC.CmmToAsm.CFG.Weight
+ ( Weights (..)
+ , defaultWeights
+ , parseWeights
+ )
+where
+
+import GHC.Prelude
+import GHC.Utils.Panic
+
+-- | Edge weights to use when generating a CFG from CMM
+data Weights = Weights
+ { uncondWeight :: Int
+ , condBranchWeight :: Int
+ , switchWeight :: Int
+ , callWeight :: Int
+ , likelyCondWeight :: Int
+ , unlikelyCondWeight :: Int
+ , infoTablePenalty :: Int
+ , backEdgeBonus :: Int
+ }
+
+-- | Default edge weights
+defaultWeights :: Weights
+defaultWeights = Weights
+ { uncondWeight = 1000
+ , condBranchWeight = 800
+ , switchWeight = 1
+ , callWeight = -10
+ , likelyCondWeight = 900
+ , unlikelyCondWeight = 300
+ , infoTablePenalty = 300
+ , backEdgeBonus = 400
+ }
+
+parseWeights :: String -> Weights -> Weights
+parseWeights s oldWeights =
+ foldl' (\cfg (n,v) -> update n v cfg) oldWeights assignments
+ where
+ assignments = map assignment $ settings s
+ update "uncondWeight" n w =
+ w {uncondWeight = n}
+ update "condBranchWeight" n w =
+ w {condBranchWeight = n}
+ update "switchWeight" n w =
+ w {switchWeight = n}
+ update "callWeight" n w =
+ w {callWeight = n}
+ update "likelyCondWeight" n w =
+ w {likelyCondWeight = n}
+ update "unlikelyCondWeight" n w =
+ w {unlikelyCondWeight = n}
+ update "infoTablePenalty" n w =
+ w {infoTablePenalty = n}
+ update "backEdgeBonus" n w =
+ w {backEdgeBonus = n}
+ update other _ _
+ = panic $ other ++
+ " is not a CFG weight parameter. " ++
+ exampleString
+ settings s
+ | (s1,rest) <- break (== ',') s
+ , null rest
+ = [s1]
+ | (s1,rest) <- break (== ',') s
+ = s1 : settings (drop 1 rest)
+
+ assignment as
+ | (name, _:val) <- break (== '=') as
+ = (name,read val)
+ | otherwise
+ = panic $ "Invalid CFG weight parameters." ++ exampleString
+
+ exampleString = "Example parameters: uncondWeight=1000," ++
+ "condBranchWeight=800,switchWeight=0,callWeight=300" ++
+ ",likelyCondWeight=900,unlikelyCondWeight=300" ++
+ ",infoTablePenalty=300,backEdgeBonus=400"
+
=====================================
compiler/GHC/CmmToAsm/Config.hs
=====================================
@@ -10,12 +10,14 @@ where
import GHC.Prelude
import GHC.Platform
import GHC.Cmm.Type (Width(..))
+import GHC.CmmToAsm.CFG.Weight
+import GHC.Utils.Outputable
-- | Native code generator configuration
data NCGConfig = NCGConfig
{ ncgPlatform :: !Platform -- ^ Target platform
+ , ncgAsmContext :: !SDocContext -- ^ Context for ASM code generation
, ncgProcAlignment :: !(Maybe Int) -- ^ Mandatory proc alignment
- , ncgDebugLevel :: !Int -- ^ Debug level
, ncgExternalDynamicRefs :: !Bool -- ^ Generate code to link against dynamic libraries
, ncgPIC :: !Bool -- ^ Enable Position-Independent Code
, ncgInlineThresholdMemcpy :: !Word -- ^ If inlining `memcpy` produces less than this threshold (in pseudo-instruction unit), do it
@@ -29,6 +31,12 @@ data NCGConfig = NCGConfig
, ncgDumpRegAllocStages :: !Bool
, ncgDumpAsmStats :: !Bool
, ncgDumpAsmConflicts :: !Bool
+ , ncgCfgWeights :: !Weights -- ^ CFG edge weights
+ , ncgCfgBlockLayout :: !Bool -- ^ Use CFG based block layout algorithm
+ , ncgCfgWeightlessLayout :: !Bool -- ^ Layout based on last instruction per block.
+ , ncgDwarfEnabled :: !Bool -- ^ Enable Dwarf generation
+ , ncgDwarfUnwindings :: !Bool -- ^ Enable unwindings
+ , ncgDwarfStripBlockInfo :: !Bool -- ^ Strip out block information from generated Dwarf
}
-- | Return Word size
=====================================
compiler/GHC/CmmToAsm/Dwarf.hs
=====================================
@@ -4,9 +4,6 @@ module GHC.CmmToAsm.Dwarf (
import GHC.Prelude
-import GHC.Driver.Session
-import GHC.Driver.Ppr
-
import GHC.Cmm.CLabel
import GHC.Cmm.Expr ( GlobalReg(..) )
import GHC.Settings.Config ( cProjectName, cProjectVersion )
@@ -20,6 +17,7 @@ import GHC.Types.Unique.Supply
import GHC.CmmToAsm.Dwarf.Constants
import GHC.CmmToAsm.Dwarf.Types
+import GHC.CmmToAsm.Config
import Control.Arrow ( first )
import Control.Monad ( mfilter )
@@ -34,23 +32,22 @@ import qualified GHC.Cmm.Dataflow.Label as H
import qualified GHC.Cmm.Dataflow.Collections as H
-- | Generate DWARF/debug information
-dwarfGen :: DynFlags -> ModLocation -> UniqSupply -> [DebugBlock]
+dwarfGen :: NCGConfig -> ModLocation -> UniqSupply -> [DebugBlock]
-> IO (SDoc, UniqSupply)
-dwarfGen _ _ us [] = return (empty, us)
-dwarfGen df modLoc us blocks = do
- let platform = targetPlatform df
+dwarfGen _ _ us [] = return (empty, us)
+dwarfGen config modLoc us blocks = do
+ let platform = ncgPlatform config
-- Convert debug data structures to DWARF info records
- -- We strip out block information when running with -g0 or -g1.
let procs = debugSplitProcs blocks
stripBlocks dbg
- | debugLevel df < 2 = dbg { dblBlocks = [] }
- | otherwise = dbg
+ | ncgDwarfStripBlockInfo config = dbg { dblBlocks = [] }
+ | otherwise = dbg
compPath <- getCurrentDirectory
let lowLabel = dblCLabel $ head procs
highLabel = mkAsmTempEndLabel $ dblCLabel $ last procs
dwarfUnit = DwarfCompileUnit
- { dwChildren = map (procToDwarf df) (map stripBlocks procs)
+ { dwChildren = map (procToDwarf config) (map stripBlocks procs)
, dwName = fromMaybe "" (ml_hs_file modLoc)
, dwCompDir = addTrailingPathSeparator compPath
, dwProducer = cProjectName ++ " " ++ cProjectVersion
@@ -91,8 +88,8 @@ dwarfGen df modLoc us blocks = do
pprDwarfFrame platform (debugFrame framesU procs)
-- .aranges section: Information about the bounds of compilation units
- let aranges' | gopt Opt_SplitSections df = map mkDwarfARange procs
- | otherwise = [DwarfARange lowLabel highLabel]
+ let aranges' | ncgSplitSections config = map mkDwarfARange procs
+ | otherwise = [DwarfARange lowLabel highLabel]
let aranges = dwarfARangesSection platform $$ pprDwarfARanges platform aranges' unitU
return (infoSct $$ abbrevSct $$ lineSct $$ frameSct $$ aranges, us'')
@@ -177,12 +174,14 @@ parent, B.
-}
-- | Generate DWARF info for a procedure debug block
-procToDwarf :: DynFlags -> DebugBlock -> DwarfInfo
-procToDwarf df prc
+procToDwarf :: NCGConfig -> DebugBlock -> DwarfInfo
+procToDwarf config prc
= DwarfSubprogram { dwChildren = map blockToDwarf (dblBlocks prc)
, dwName = case dblSourceTick prc of
Just s at SourceNote{} -> sourceName s
- _otherwise -> showSDocDump df $ ppr $ dblLabel prc
+ _otherwise -> renderWithContext defaultSDocContext
+ $ withPprStyle defaultDumpStyle
+ $ ppr (dblLabel prc)
, dwLabel = dblCLabel prc
, dwParent = fmap mkAsmTempDieLabel
$ mfilter goodParent
@@ -192,9 +191,9 @@ procToDwarf df prc
goodParent a | a == dblCLabel prc = False
-- Omit parent if it would be self-referential
goodParent a | not (externallyVisibleCLabel a)
- , debugLevel df < 2 = False
- -- We strip block information when running -g0 or -g1, don't
- -- refer to blocks in that case. Fixes #14894.
+ , ncgDwarfStripBlockInfo config = False
+ -- If we strip block information, don't refer to blocks.
+ -- Fixes #14894.
goodParent _ = True
-- | Generate DWARF info for a block
=====================================
compiler/GHC/CmmToAsm/Monad.hs
=====================================
@@ -16,7 +16,6 @@ module GHC.CmmToAsm.Monad (
NatM, -- instance Monad
initNat,
- initConfig,
addImportNat,
addNodeBetweenNat,
addImmediateSuccessorNat,
@@ -34,7 +33,7 @@ module GHC.CmmToAsm.Monad (
getNewRegPairNat,
getPicBaseMaybeNat,
getPicBaseNat,
- getDynFlags,
+ getCfgWeights,
getModLoc,
getFileId,
getDebugBlock,
@@ -64,7 +63,6 @@ import GHC.Data.FastString ( FastString )
import GHC.Types.Unique.FM
import GHC.Types.Unique.Supply
import GHC.Types.Unique ( Unique )
-import GHC.Driver.Session
import GHC.Unit.Module
import Control.Monad ( ap )
@@ -72,6 +70,7 @@ import Control.Monad ( ap )
import GHC.Utils.Outputable (SDoc, ppr)
import GHC.Utils.Panic (pprPanic)
import GHC.CmmToAsm.CFG
+import GHC.CmmToAsm.CFG.Weight
data NcgImpl statics instr jumpDest = NcgImpl {
ncgConfig :: !NCGConfig,
@@ -107,7 +106,6 @@ data NatM_State
natm_delta :: Int,
natm_imports :: [(CLabel)],
natm_pic :: Maybe Reg,
- natm_dflags :: DynFlags,
natm_config :: NCGConfig,
natm_this_module :: Module,
natm_modloc :: ModLocation,
@@ -127,17 +125,16 @@ newtype NatM result = NatM (NatM_State -> (result, NatM_State))
unNat :: NatM a -> NatM_State -> (a, NatM_State)
unNat (NatM a) = a
-mkNatM_State :: UniqSupply -> Int -> DynFlags -> Module -> ModLocation ->
+mkNatM_State :: UniqSupply -> Int -> NCGConfig -> Module -> ModLocation ->
DwarfFiles -> LabelMap DebugBlock -> CFG -> NatM_State
-mkNatM_State us delta dflags this_mod
+mkNatM_State us delta config this_mod
= \loc dwf dbg cfg ->
NatM_State
{ natm_us = us
, natm_delta = delta
, natm_imports = []
, natm_pic = Nothing
- , natm_dflags = dflags
- , natm_config = initConfig dflags
+ , natm_config = config
, natm_this_module = this_mod
, natm_modloc = loc
, natm_fileid = dwf
@@ -145,49 +142,6 @@ mkNatM_State us delta dflags this_mod
, natm_cfg = cfg
}
--- | Initialize the native code generator configuration from the DynFlags
-initConfig :: DynFlags -> NCGConfig
-initConfig dflags = NCGConfig
- { ncgPlatform = targetPlatform dflags
- , ncgProcAlignment = cmmProcAlignment dflags
- , ncgDebugLevel = debugLevel dflags
- , ncgExternalDynamicRefs = gopt Opt_ExternalDynamicRefs dflags
- , ncgPIC = positionIndependent dflags
- , ncgInlineThresholdMemcpy = fromIntegral $ maxInlineMemcpyInsns dflags
- , ncgInlineThresholdMemset = fromIntegral $ maxInlineMemsetInsns dflags
- , ncgSplitSections = gopt Opt_SplitSections dflags
- , ncgRegsIterative = gopt Opt_RegsIterative dflags
- , ncgAsmLinting = gopt Opt_DoAsmLinting dflags
-
- -- With -O1 and greater, the cmmSink pass does constant-folding, so
- -- we don't need to do it again in the native code generator.
- , ncgDoConstantFolding = optLevel dflags < 1
-
- , ncgDumpRegAllocStages = dopt Opt_D_dump_asm_regalloc_stages dflags
- , ncgDumpAsmStats = dopt Opt_D_dump_asm_stats dflags
- , ncgDumpAsmConflicts = dopt Opt_D_dump_asm_conflicts dflags
- , ncgBmiVersion = case platformArch (targetPlatform dflags) of
- ArchX86_64 -> bmiVersion dflags
- ArchX86 -> bmiVersion dflags
- _ -> Nothing
-
- -- We Assume SSE1 and SSE2 operations are available on both
- -- x86 and x86_64. Historically we didn't default to SSE2 and
- -- SSE1 on x86, which results in defacto nondeterminism for how
- -- rounding behaves in the associated x87 floating point instructions
- -- because variations in the spill/fpu stack placement of arguments for
- -- operations would change the precision and final result of what
- -- would otherwise be the same expressions with respect to single or
- -- double precision IEEE floating point computations.
- , ncgSseVersion =
- let v | sseVersion dflags < Just SSE2 = Just SSE2
- | otherwise = sseVersion dflags
- in case platformArch (targetPlatform dflags) of
- ArchX86_64 -> v
- ArchX86 -> v
- _ -> Nothing
- }
-
initNat :: NatM_State -> NatM a -> (a, NatM_State)
initNat init_st m
= case unNat m init_st of { (r,st) -> (r,st) }
@@ -234,13 +188,12 @@ getUniqueNat = NatM $ \ st ->
case takeUniqFromSupply $ natm_us st of
(uniq, us') -> (uniq, st {natm_us = us'})
-instance HasDynFlags NatM where
- getDynFlags = NatM $ \ st -> (natm_dflags st, st)
-
-
getDeltaNat :: NatM Int
getDeltaNat = NatM $ \ st -> (natm_delta st, st)
+-- | Get CFG edge weights
+getCfgWeights :: NatM Weights
+getCfgWeights = NatM $ \ st -> (ncgCfgWeights (natm_config st), st)
setDeltaNat :: Int -> NatM ()
setDeltaNat delta = NatM $ \ st -> ((), st {natm_delta = delta})
@@ -262,9 +215,8 @@ updateCfgNat f
-- | Record that we added a block between `from` and `old`.
addNodeBetweenNat :: BlockId -> BlockId -> BlockId -> NatM ()
addNodeBetweenNat from between to
- = do df <- getDynFlags
- let jmpWeight = fromIntegral . uncondWeight .
- cfgWeightInfo $ df
+ = do weights <- getCfgWeights
+ let jmpWeight = fromIntegral (uncondWeight weights)
updateCfgNat (updateCfg jmpWeight from between to)
where
-- When transforming A -> B to A -> A' -> B
@@ -284,8 +236,8 @@ addNodeBetweenNat from between to
-- block -> X to `succ` -> X
addImmediateSuccessorNat :: BlockId -> BlockId -> NatM ()
addImmediateSuccessorNat block succ = do
- dflags <- getDynFlags
- updateCfgNat (addImmediateSuccessor dflags block succ)
+ weights <- getCfgWeights
+ updateCfgNat (addImmediateSuccessor weights block succ)
getBlockIdNat :: NatM BlockId
getBlockIdNat
=====================================
compiler/GHC/CmmToAsm/PPC/Ppr.hs
=====================================
@@ -64,7 +64,7 @@ pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) =
_ -> pprLabel platform lbl) $$ -- blocks guaranteed not null,
-- so label needed
vcat (map (pprBasicBlock config top_info) blocks) $$
- (if ncgDebugLevel config > 0
+ (if ncgDwarfEnabled config
then ppr (mkAsmTempEndLabel lbl) <> char ':' else empty) $$
pprSizeDecl platform lbl
@@ -131,7 +131,7 @@ pprBasicBlock config info_env (BasicBlock blockid instrs)
= maybe_infotable $$
pprLabel platform asmLbl $$
vcat (map (pprInstr platform) instrs) $$
- (if ncgDebugLevel config > 0
+ (if ncgDwarfEnabled config
then ppr (mkAsmTempEndLabel asmLbl) <> char ':'
else empty
)
=====================================
compiler/GHC/CmmToAsm/X86/CodeGen.hs
=====================================
@@ -57,6 +57,7 @@ import GHC.CmmToAsm.Monad
, getDeltaNat, getBlockIdNat, getPicBaseNat, getNewRegPairNat
, getPicBaseMaybeNat, getDebugBlock, getFileId
, addImmediateSuccessorNat, updateCfgNat, getConfig, getPlatform
+ , getCfgWeights
)
import GHC.CmmToAsm.CFG
import GHC.CmmToAsm.Format
@@ -228,7 +229,7 @@ basicBlockCodeGen block = do
addSpUnwindings :: Instr -> NatM (OrdList Instr)
addSpUnwindings instr@(DELTA d) = do
config <- getConfig
- if ncgDebugLevel config >= 1
+ if ncgDwarfUnwindings config
then do lbl <- mkAsmTempLabel <$> getUniqueM
let unwind = M.singleton MachSp (Just $ UwReg MachSp $ negate d)
return $ toOL [ instr, UNWIND lbl unwind ]
@@ -2106,10 +2107,10 @@ genCCall is32Bit (PrimTarget (MO_Ctz width)) [dst] [src] bid
-- bid -> lbl2
-- bid -> lbl1 -> lbl2
-- We also changes edges originating at bid to start at lbl2 instead.
- dflags <- getDynFlags
+ weights <- getCfgWeights
updateCfgNat (addWeightEdge bid lbl1 110 .
addWeightEdge lbl1 lbl2 110 .
- addImmediateSuccessor dflags bid lbl2)
+ addImmediateSuccessor weights bid lbl2)
-- The following instruction sequence corresponds to the pseudo-code
--
=====================================
compiler/GHC/CmmToAsm/X86/Ppr.hs
=====================================
@@ -91,7 +91,7 @@ pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) =
pprProcAlignment config $$
pprLabel platform lbl $$ -- blocks guaranteed not null, so label needed
vcat (map (pprBasicBlock config top_info) blocks) $$
- (if ncgDebugLevel config > 0
+ (if ncgDwarfEnabled config
then ppr (mkAsmTempEndLabel lbl) <> char ':' else empty) $$
pprSizeDecl platform lbl
@@ -125,7 +125,7 @@ pprBasicBlock config info_env (BasicBlock blockid instrs)
= maybe_infotable $
pprLabel platform asmLbl $$
vcat (map (pprInstr platform) instrs) $$
- (if ncgDebugLevel config > 0
+ (if ncgDwarfEnabled config
then ppr (mkAsmTempEndLabel asmLbl) <> char ':'
else empty
)
@@ -140,7 +140,7 @@ pprBasicBlock config info_env (BasicBlock blockid instrs)
vcat (map (pprData config) info) $$
pprLabel platform infoLbl $$
c $$
- (if ncgDebugLevel config > 0
+ (if ncgDwarfEnabled config
then ppr (mkAsmTempEndLabel infoLbl) <> char ':'
else empty
)
=====================================
compiler/GHC/CmmToLlvm/Base.hs
=====================================
@@ -498,7 +498,7 @@ strCLabel_llvm lbl = do
dflags <- getDynFlags
platform <- getPlatform
let sdoc = pprCLabel_LLVM platform lbl
- str = Outp.renderWithStyle
+ str = Outp.renderWithContext
(initSDocContext dflags (Outp.mkCodeStyle Outp.CStyle))
sdoc
return (fsLit str)
=====================================
compiler/GHC/CmmToLlvm/CodeGen.hs
=====================================
@@ -1566,7 +1566,7 @@ genMachOp_slow opt op [x, y] = case op of
-- Error. Continue anyway so we can debug the generated ll file.
dflags <- getDynFlags
let style = mkCodeStyle CStyle
- toString doc = renderWithStyle (initSDocContext dflags style) doc
+ toString doc = renderWithContext (initSDocContext dflags style) doc
cmmToStr = (lines . toString . PprCmm.pprExpr platform)
statement $ Comment $ map fsLit $ cmmToStr x
statement $ Comment $ map fsLit $ cmmToStr y
=====================================
compiler/GHC/Driver/Backpack.hs
=====================================
@@ -539,7 +539,7 @@ msgUnitId pk = do
dflags <- getDynFlags
level <- getBkpLevel
liftIO . backpackProgressMsg level dflags
- $ "Instantiating " ++ renderWithStyle
+ $ "Instantiating " ++ renderWithContext
(initSDocContext dflags backpackStyle)
(ppr pk)
@@ -550,7 +550,7 @@ msgInclude (i,n) uid = do
level <- getBkpLevel
liftIO . backpackProgressMsg level dflags
$ showModuleIndex (i, n) ++ "Including " ++
- renderWithStyle (initSDocContext dflags backpackStyle)
+ renderWithContext (initSDocContext dflags backpackStyle)
(ppr uid)
-- ----------------------------------------------------------------------------
=====================================
compiler/GHC/Driver/Ppr.hs
=====================================
@@ -36,7 +36,7 @@ import Control.Monad.IO.Class
-- | Show a SDoc as a String with the default user style
showSDoc :: DynFlags -> SDoc -> String
-showSDoc dflags sdoc = renderWithStyle (initSDocContext dflags defaultUserStyle) sdoc
+showSDoc dflags sdoc = renderWithContext (initSDocContext dflags defaultUserStyle) sdoc
showPpr :: Outputable a => DynFlags -> a -> String
showPpr dflags thing = showSDoc dflags (ppr thing)
@@ -46,13 +46,13 @@ showPprUnsafe a = showPpr unsafeGlobalDynFlags a
-- | Allows caller to specify the PrintUnqualified to use
showSDocForUser :: DynFlags -> PrintUnqualified -> SDoc -> String
-showSDocForUser dflags unqual doc = renderWithStyle (initSDocContext dflags (mkUserStyle unqual AllTheWay)) doc
+showSDocForUser dflags unqual doc = renderWithContext (initSDocContext dflags (mkUserStyle unqual AllTheWay)) doc
showSDocDump :: DynFlags -> SDoc -> String
-showSDocDump dflags d = renderWithStyle (initSDocContext dflags defaultDumpStyle) d
+showSDocDump dflags d = renderWithContext (initSDocContext dflags defaultDumpStyle) d
showSDocDebug :: DynFlags -> SDoc -> String
-showSDocDebug dflags d = renderWithStyle ctx d
+showSDocDebug dflags d = renderWithContext ctx d
where
ctx = (initSDocContext dflags defaultDumpStyle)
{ sdocPprDebug = True
=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -226,9 +226,6 @@ module GHC.Driver.Session (
-- * SDoc
initSDocContext, initDefaultSDocContext,
-
- -- * Make use of the Cmm CFG
- CfgWeights(..)
) where
#include "HsVersions.h"
@@ -268,6 +265,7 @@ import GHC.Data.FastString
import GHC.Utils.Fingerprint
import GHC.Utils.Outputable
import GHC.Settings
+import GHC.CmmToAsm.CFG.Weight
import {-# SOURCE #-} GHC.Utils.Error
( Severity(..), MsgDoc, mkLocMessageAnn
@@ -777,78 +775,9 @@ data DynFlags = DynFlags {
uniqueIncrement :: Int,
-- | Temporary: CFG Edge weights for fast iterations
- cfgWeightInfo :: CfgWeights
+ cfgWeights :: Weights
}
--- | Edge weights to use when generating a CFG from CMM
-data CfgWeights
- = CFGWeights
- { uncondWeight :: Int
- , condBranchWeight :: Int
- , switchWeight :: Int
- , callWeight :: Int
- , likelyCondWeight :: Int
- , unlikelyCondWeight :: Int
- , infoTablePenalty :: Int
- , backEdgeBonus :: Int
- }
-
-defaultCfgWeights :: CfgWeights
-defaultCfgWeights
- = CFGWeights
- { uncondWeight = 1000
- , condBranchWeight = 800
- , switchWeight = 1
- , callWeight = -10
- , likelyCondWeight = 900
- , unlikelyCondWeight = 300
- , infoTablePenalty = 300
- , backEdgeBonus = 400
- }
-
-parseCfgWeights :: String -> CfgWeights -> CfgWeights
-parseCfgWeights s oldWeights =
- foldl' (\cfg (n,v) -> update n v cfg) oldWeights assignments
- where
- assignments = map assignment $ settings s
- update "uncondWeight" n w =
- w {uncondWeight = n}
- update "condBranchWeight" n w =
- w {condBranchWeight = n}
- update "switchWeight" n w =
- w {switchWeight = n}
- update "callWeight" n w =
- w {callWeight = n}
- update "likelyCondWeight" n w =
- w {likelyCondWeight = n}
- update "unlikelyCondWeight" n w =
- w {unlikelyCondWeight = n}
- update "infoTablePenalty" n w =
- w {infoTablePenalty = n}
- update "backEdgeBonus" n w =
- w {backEdgeBonus = n}
- update other _ _
- = panic $ other ++
- " is not a cfg weight parameter. " ++
- exampleString
- settings s
- | (s1,rest) <- break (== ',') s
- , null rest
- = [s1]
- | (s1,rest) <- break (== ',') s
- = s1 : settings (drop 1 rest)
-
- assignment as
- | (name, _:val) <- break (== '=') as
- = (name,read val)
- | otherwise
- = panic $ "Invalid cfg parameters." ++ exampleString
-
- exampleString = "Example parameters: uncondWeight=1000," ++
- "condBranchWeight=800,switchWeight=0,callWeight=300" ++
- ",likelyCondWeight=900,unlikelyCondWeight=300" ++
- ",infoTablePenalty=300,backEdgeBonus=400"
-
class HasDynFlags m where
getDynFlags :: m DynFlags
@@ -1430,7 +1359,7 @@ defaultDynFlags mySettings llvmConfig =
reverseErrors = False,
maxErrors = Nothing,
- cfgWeightInfo = defaultCfgWeights
+ cfgWeights = defaultWeights
}
defaultWays :: Settings -> Ways
@@ -2949,8 +2878,8 @@ dynamic_flags_deps = [
(intSuffix (\n d -> d { cmmProcAlignment = Just n }))
, make_ord_flag defFlag "fblock-layout-weights"
(HasArg (\s ->
- upd (\d -> d { cfgWeightInfo =
- parseCfgWeights s (cfgWeightInfo d)})))
+ upd (\d -> d { cfgWeights =
+ parseWeights s (cfgWeights d)})))
, make_ord_flag defFlag "fhistory-size"
(intSuffix (\n d -> d { historySize = n }))
, make_ord_flag defFlag "funfolding-creation-threshold"
=====================================
compiler/GHC/Unit/State.hs
=====================================
@@ -980,7 +980,7 @@ packageFlagErr' :: SDocContext
-> [(UnitInfo, UnusableUnitReason)]
-> IO a
packageFlagErr' ctx flag_doc reasons
- = throwGhcExceptionIO (CmdLineError (renderWithStyle ctx $ err))
+ = throwGhcExceptionIO (CmdLineError (renderWithContext ctx $ err))
where err = text "cannot satisfy " <> flag_doc <>
(if null reasons then Outputable.empty else text ": ") $$
nest 4 (ppr_reasons $$
@@ -1712,7 +1712,7 @@ mkModuleNameProvidersMap ctx cfg pkg_map closure vis_map =
rnBinding (orig, new) = (new, setOrigins origEntry fromFlag)
where origEntry = case lookupUFM esmap orig of
Just r -> r
- Nothing -> throwGhcException (CmdLineError (renderWithStyle ctx
+ Nothing -> throwGhcException (CmdLineError (renderWithContext ctx
(text "package flag: could not find module name" <+>
ppr orig <+> text "in package" <+> ppr pk)))
@@ -2058,7 +2058,7 @@ getPreloadUnitsAnd ctx unit_state home_unit ids0 =
throwErr :: SDocContext -> MaybeErr MsgDoc a -> IO a
throwErr ctx m = case m of
- Failed e -> throwGhcExceptionIO (CmdLineError (renderWithStyle ctx e))
+ Failed e -> throwGhcExceptionIO (CmdLineError (renderWithContext ctx e))
Succeeded r -> return r
-- | Takes a list of UnitIds (and their "parent" dependency, used for error
=====================================
compiler/GHC/Utils/Outputable.hs
=====================================
@@ -47,7 +47,7 @@ module GHC.Utils.Outputable (
bufLeftRenderSDoc,
pprCode, mkCodeStyle,
showSDocOneLine,
- renderWithStyle,
+ renderWithContext,
pprInfixVar, pprPrefixVar,
pprHsChar, pprHsString, pprHsBytes,
@@ -71,7 +71,7 @@ module GHC.Utils.Outputable (
QualifyName(..), queryQual,
sdocWithDynFlags, sdocOption,
updSDocContext,
- SDocContext (..), sdocWithContext,
+ SDocContext (..), sdocWithContext, defaultSDocContext,
getPprStyle, withPprStyle, setStyleColoured,
pprDeeper, pprDeeperList, pprSetDepth,
codeStyle, userStyle, dumpStyle, asmStyle,
@@ -302,7 +302,7 @@ code (either C or assembly), or generating interface files.
-- | Represents a pretty-printable document.
--
-- To display an 'SDoc', use 'printSDoc', 'printSDocLn', 'bufLeftRenderSDoc',
--- or 'renderWithStyle'. Avoid calling 'runSDoc' directly as it breaks the
+-- or 'renderWithContext'. Avoid calling 'runSDoc' directly as it breaks the
-- abstraction layer.
newtype SDoc = SDoc { runSDoc :: SDocContext -> Doc }
@@ -354,6 +354,44 @@ instance IsString SDoc where
instance Outputable SDoc where
ppr = id
+-- | Default pretty-printing options
+defaultSDocContext :: SDocContext
+defaultSDocContext = SDC
+ { sdocStyle = defaultDumpStyle
+ , sdocColScheme = Col.defaultScheme
+ , sdocLastColour = Col.colReset
+ , sdocShouldUseColor = False
+ , sdocDefaultDepth = 5
+ , sdocLineLength = 100
+ , sdocCanUseUnicode = False
+ , sdocHexWordLiterals = False
+ , sdocPprDebug = False
+ , sdocPrintUnicodeSyntax = False
+ , sdocPrintCaseAsLet = False
+ , sdocPrintTypecheckerElaboration = False
+ , sdocPrintAxiomIncomps = False
+ , sdocPrintExplicitKinds = False
+ , sdocPrintExplicitCoercions = False
+ , sdocPrintExplicitRuntimeReps = False
+ , sdocPrintExplicitForalls = False
+ , sdocPrintPotentialInstances = False
+ , sdocPrintEqualityRelations = False
+ , sdocSuppressTicks = False
+ , sdocSuppressTypeSignatures = False
+ , sdocSuppressTypeApplications = False
+ , sdocSuppressIdInfo = False
+ , sdocSuppressCoercions = False
+ , sdocSuppressUnfoldings = False
+ , sdocSuppressVarKinds = False
+ , sdocSuppressUniques = False
+ , sdocSuppressModulePrefixes = False
+ , sdocSuppressStgExts = False
+ , sdocErrorSpans = False
+ , sdocStarIsType = False
+ , sdocImpredicativeTypes = False
+ , sdocLinearTypes = False
+ , sdocDynFlags = error "defaultSDocContext: DynFlags not available"
+ }
withPprStyle :: PprStyle -> SDoc -> SDoc
withPprStyle sty d = SDoc $ \ctxt -> runSDoc d ctxt{sdocStyle=sty}
@@ -490,8 +528,8 @@ pprCode cs d = withPprStyle (PprCode cs) d
mkCodeStyle :: CodeStyle -> PprStyle
mkCodeStyle = PprCode
-renderWithStyle :: SDocContext -> SDoc -> String
-renderWithStyle ctx sdoc
+renderWithContext :: SDocContext -> SDoc -> String
+renderWithContext ctx sdoc
= let s = Pretty.style{ Pretty.mode = PageMode,
Pretty.lineLength = sdocLineLength ctx }
in Pretty.renderStyle s $ runSDoc sdoc ctx
=====================================
compiler/ghc.cabal.in
=====================================
@@ -581,6 +581,7 @@ Library
GHC.CmmToAsm.Instr
GHC.CmmToAsm.BlockLayout
GHC.CmmToAsm.CFG
+ GHC.CmmToAsm.CFG.Weight
GHC.CmmToAsm.CFG.Dominators
GHC.CmmToAsm.Format
GHC.Platform.Reg
=====================================
testsuite/tests/hiefile/should_run/HieQueries.hs
=====================================
@@ -14,7 +14,7 @@ import GHC.Iface.Ext.Utils
import Data.Maybe (fromJust)
import GHC.Driver.Session
import GHC.SysTools
-import GHC.Utils.Outputable ( Outputable, renderWithStyle, ppr, defaultUserStyle, text)
+import GHC.Utils.Outputable ( Outputable, renderWithContext, ppr, defaultUserStyle, text)
import qualified Data.Map as M
import Data.Foldable
@@ -78,5 +78,5 @@ explainEv df hf refmap point = do
pretty = unlines . (++["└"]) . ("┌":) . map ("│ "++) . lines
- pprint = pretty . renderWithStyle (initSDocContext df sty) . ppr
+ pprint = pretty . renderWithContext (initSDocContext df sty) . ppr
sty = defaultUserStyle
=====================================
testsuite/tests/parser/should_run/CountParserDeps.hs
=====================================
@@ -30,7 +30,7 @@ main = do
let num = sizeUniqSet modules
-- print num
-- print (map moduleNameString $ nonDetEltsUniqSet modules)
- unless (num < 200) $ exitWith (ExitFailure num)
+ unless (num <= 200) $ exitWith (ExitFailure num)
parserDeps :: FilePath -> IO (UniqSet ModuleName)
parserDeps libdir =
=====================================
testsuite/tests/regalloc/regalloc_unit_tests.hs
=====================================
@@ -28,7 +28,6 @@ import GHC.Driver.Main
import GHC.StgToCmm.CgUtils
import GHC.CmmToAsm
import GHC.CmmToAsm.Config
-import GHC.CmmToAsm.Monad as NCGConfig
import GHC.Cmm.Info.Build
import GHC.Cmm.Pipeline
import GHC.Cmm.Parser
@@ -106,7 +105,7 @@ compileCmmForRegAllocStats ::
IO [( Maybe [Color.RegAllocStats (Alignment, RawCmmStatics) X86.Instr.Instr]
, Maybe [Linear.RegAllocStats])]
compileCmmForRegAllocStats dflags' cmmFile ncgImplF us = do
- let ncgImpl = ncgImplF (NCGConfig.initConfig dflags)
+ let ncgImpl = ncgImplF (initNCGConfig dflags)
hscEnv <- newHscEnv dflags
-- parse the cmm file and output any warnings or errors
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/eb9bdaef6024558696e1e50b12d7fefb70483a9f...659eb31b7a40f0aa2ba43c3454b5d9006fde837d
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/eb9bdaef6024558696e1e50b12d7fefb70483a9f...659eb31b7a40f0aa2ba43c3454b5d9006fde837d
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200821/2e523a9d/attachment-0001.html>
More information about the ghc-commits
mailing list