Commit 912fd2b6 authored by Andreas Klebinger's avatar Andreas Klebinger

NCG: New code layout algorithm.

Summary:
This patch implements a new code layout algorithm.
It has been tested for x86 and is disabled on other platforms.

Performance varies slightly be CPU/Machine but in general seems to be better
by around 2%.
Nofib shows only small differences of about +/- ~0.5% overall depending on
flags/machine performance in other benchmarks improved significantly.

Other benchmarks includes at least the benchmarks of: aeson, vector, megaparsec, attoparsec,
containers, text and xeno.

While the magnitude of gains differed three different CPUs where tested with
all getting faster although to differing degrees. I tested: Sandy Bridge(Xeon), Haswell,
Skylake

* Library benchmark results summarized:
  * containers: ~1.5% faster
  * aeson: ~2% faster
  * megaparsec: ~2-5% faster
  * xml library benchmarks: 0.2%-1.1% faster
  * vector-benchmarks: 1-4% faster
  * text: 5.5% faster

On average GHC compile times go down, as GHC compiled with the new layout
is faster than the overhead introduced by using the new layout algorithm,

Things this patch does:

* Move code responsilbe for block layout in it's own module.
* Move the NcgImpl Class into the NCGMonad module.
* Extract a control flow graph from the input cmm.
* Update this cfg to keep it in sync with changes during
  asm codegen. This has been tested on x64 but should work on x86.
  Other platforms still use the old codelayout.
* Assign weights to the edges in the CFG based on type and limited static
  analysis which are then used for block layout.
* Once we have the final code layout eliminate some redundant jumps.

  In particular turn a sequences of:
      jne .foo
      jmp .bar
    foo:
  into
      je bar
    foo:
      ..

Test Plan: ci

Reviewers: bgamari, jmct, jrtc27, simonmar, simonpj, RyanGlScott

Reviewed By: RyanGlScott

Subscribers: RyanGlScott, trommler, jmct, carter, thomie, rwbarton

GHC Trac Issues: #15124

Differential Revision: https://phabricator.haskell.org/D4726
parent 6ba9aa5d
......@@ -2,7 +2,7 @@ module CmmMachOp
( MachOp(..)
, pprMachOp, isCommutableMachOp, isAssociativeMachOp
, isComparisonMachOp, maybeIntComparison, machOpResultType
, machOpArgReps, maybeInvertComparison
, machOpArgReps, maybeInvertComparison, isFloatComparison
-- MachOp builders
, mo_wordAdd, mo_wordSub, mo_wordEq, mo_wordNe,mo_wordMul, mo_wordSQuot
......@@ -322,6 +322,17 @@ maybeIntComparison mop =
MO_U_Lt w -> Just w
_ -> Nothing
isFloatComparison :: MachOp -> Bool
isFloatComparison mop =
case mop of
MO_F_Eq {} -> True
MO_F_Ne {} -> True
MO_F_Ge {} -> True
MO_F_Le {} -> True
MO_F_Gt {} -> True
MO_F_Lt {} -> True
_other -> False
-- -----------------------------------------------------------------------------
-- Inverting conditions
......
......@@ -7,6 +7,8 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- CmmNode type for representation using Hoopl graphs.
......@@ -16,7 +18,7 @@ module CmmNode (
ForeignConvention(..), ForeignTarget(..), foreignTargetHints,
CmmReturnInfo(..),
mapExp, mapExpDeep, wrapRecExp, foldExp, foldExpDeep, wrapRecExpf,
mapExpM, mapExpDeepM, wrapRecExpM, mapSuccessors,
mapExpM, mapExpDeepM, wrapRecExpM, mapSuccessors, mapCollectSuccessors,
-- * Tick scopes
CmmTickScope(..), isTickSubScope, combineTickScopes,
......@@ -37,6 +39,7 @@ import qualified Unique as U
import Hoopl.Block
import Hoopl.Graph
import Hoopl.Collections
import Hoopl.Label
import Data.Maybe
import Data.List (tails,sortBy)
......@@ -569,6 +572,24 @@ mapSuccessors f (CmmCondBranch p y n l) = CmmCondBranch p (f y) (f n) l
mapSuccessors f (CmmSwitch e ids) = CmmSwitch e (mapSwitchTargets f ids)
mapSuccessors _ n = n
mapCollectSuccessors :: forall a. (Label -> (Label,a)) -> CmmNode O C
-> (CmmNode O C, [a])
mapCollectSuccessors f (CmmBranch bid)
= let (bid', acc) = f bid in (CmmBranch bid', [acc])
mapCollectSuccessors f (CmmCondBranch p y n l)
= let (bidt, acct) = f y
(bidf, accf) = f n
in (CmmCondBranch p bidt bidf l, [accf, acct])
mapCollectSuccessors f (CmmSwitch e ids)
= let lbls = switchTargetsToList ids :: [Label]
lblMap = mapFromList $ zip lbls (map f lbls) :: LabelMap (Label, a)
in ( CmmSwitch e
(mapSwitchTargets
(\l -> fst $ mapFindWithDefault (error "impossible") l lblMap) ids)
, map snd (mapElems lblMap)
)
mapCollectSuccessors _ n = (n, [])
-- -----------------------------------------------------------------------------
-- | Tickish in Cmm context (annotations only)
......
......@@ -156,7 +156,6 @@ cpsTop hsc_env proc =
return g
else return g
-- we don't need to split proc points for the NCG, unless
-- tablesNextToCode is off. The latter is because we have no
-- label to put on info tables for basic blocks that are not
......
......@@ -35,6 +35,7 @@ class IsSet set where
setDifference :: set -> set -> set
setIntersection :: set -> set -> set
setIsSubsetOf :: set -> set -> Bool
setFilter :: (ElemOf set -> Bool) -> set -> set
setFoldl :: (b -> ElemOf set -> b) -> b -> set -> b
setFoldr :: (ElemOf set -> b -> b) -> b -> set -> b
......@@ -69,6 +70,7 @@ class IsMap map where
mapInsertWith :: (a -> a -> a) -> KeyOf map -> a -> map a -> map a
mapDelete :: KeyOf map -> map a -> map a
mapAlter :: (Maybe a -> Maybe a) -> KeyOf map -> map a -> map a
mapAdjust :: (a -> a) -> KeyOf map -> map a -> map a
mapUnion :: map a -> map a -> map a
mapUnionWithKey :: (KeyOf map -> a -> a -> a) -> map a -> map a -> map a
......@@ -81,7 +83,10 @@ class IsMap map where
mapFoldl :: (b -> a -> b) -> b -> map a -> b
mapFoldr :: (a -> b -> b) -> b -> map a -> b
mapFoldlWithKey :: (b -> KeyOf map -> a -> b) -> b -> map a -> b
mapFoldMapWithKey :: Monoid m => (KeyOf map -> a -> m) -> map a -> m
mapFilter :: (a -> Bool) -> map a -> map a
mapFilterWithKey :: (KeyOf map -> a -> Bool) -> map a -> map a
mapElems :: map a -> [a]
mapKeys :: map a -> [KeyOf map]
......@@ -104,7 +109,7 @@ mapUnions maps = foldl1' mapUnion maps
-- Basic instances
-----------------------------------------------------------------------------
newtype UniqueSet = US S.IntSet deriving (Eq, Ord, Show)
newtype UniqueSet = US S.IntSet deriving (Eq, Ord, Show, Semigroup, Monoid)
instance IsSet UniqueSet where
type ElemOf UniqueSet = Int
......@@ -122,6 +127,7 @@ instance IsSet UniqueSet where
setDifference (US x) (US y) = US (S.difference x y)
setIntersection (US x) (US y) = US (S.intersection x y)
setIsSubsetOf (US x) (US y) = S.isSubsetOf x y
setFilter f (US s) = US (S.filter f s)
setFoldl k z (US s) = S.foldl' k z s
setFoldr k z (US s) = S.foldr k z s
......@@ -147,6 +153,7 @@ instance IsMap UniqueMap where
mapInsertWith f k v (UM m) = UM (M.insertWith f k v m)
mapDelete k (UM m) = UM (M.delete k m)
mapAlter f k (UM m) = UM (M.alter f k m)
mapAdjust f k (UM m) = UM (M.adjust f k m)
mapUnion (UM x) (UM y) = UM (M.union x y)
mapUnionWithKey f (UM x) (UM y) = UM (M.unionWithKey f x y)
......@@ -159,7 +166,9 @@ instance IsMap UniqueMap where
mapFoldl k z (UM m) = M.foldl' k z m
mapFoldr k z (UM m) = M.foldr k z m
mapFoldlWithKey k z (UM m) = M.foldlWithKey' k z m
mapFoldMapWithKey f (UM m) = M.foldMapWithKey f m
mapFilter f (UM m) = UM (M.filter f m)
mapFilterWithKey f (UM m) = UM (M.filterWithKey f m)
mapElems (UM m) = M.elems m
mapKeys (UM m) = M.keys m
......
......@@ -46,7 +46,7 @@ instance Outputable Label where
-----------------------------------------------------------------------------
-- LabelSet
newtype LabelSet = LS UniqueSet deriving (Eq, Ord, Show)
newtype LabelSet = LS UniqueSet deriving (Eq, Ord, Show, Monoid, Semigroup)
instance IsSet LabelSet where
type ElemOf LabelSet = Label
......@@ -64,7 +64,7 @@ instance IsSet LabelSet where
setDifference (LS x) (LS y) = LS (setDifference x y)
setIntersection (LS x) (LS y) = LS (setIntersection x y)
setIsSubsetOf (LS x) (LS y) = setIsSubsetOf x y
setFilter f (LS s) = LS (setFilter (f . mkHooplLabel) s)
setFoldl k z (LS s) = setFoldl (\a v -> k a (mkHooplLabel v)) z s
setFoldr k z (LS s) = setFoldr (\v a -> k (mkHooplLabel v) a) z s
......@@ -92,6 +92,7 @@ instance IsMap LabelMap where
mapInsertWith f (Label k) v (LM m) = LM (mapInsertWith f k v m)
mapDelete (Label k) (LM m) = LM (mapDelete k m)
mapAlter f (Label k) (LM m) = LM (mapAlter f k m)
mapAdjust f (Label k) (LM m) = LM (mapAdjust f k m)
mapUnion (LM x) (LM y) = LM (mapUnion x y)
mapUnionWithKey f (LM x) (LM y) = LM (mapUnionWithKey (f . mkHooplLabel) x y)
......@@ -105,7 +106,9 @@ instance IsMap LabelMap where
mapFoldr k z (LM m) = mapFoldr k z m
mapFoldlWithKey k z (LM m) =
mapFoldlWithKey (\a v -> k a (mkHooplLabel v)) z m
mapFoldMapWithKey f (LM m) = mapFoldMapWithKey (\k v -> f (mkHooplLabel k) v) m
mapFilter f (LM m) = LM (mapFilter f m)
mapFilterWithKey f (LM m) = LM (mapFilterWithKey (f . mkHooplLabel) m)
mapElems (LM m) = mapElems m
mapKeys (LM m) = map mkHooplLabel (mapKeys m)
......
......@@ -558,6 +558,8 @@ Library
TargetReg
NCGMonad
Instruction
BlockLayout
CFG
Format
Reg
RegClass
......
......@@ -171,7 +171,11 @@ module DynFlags (
FilesToClean(..), emptyFilesToClean,
-- * Include specifications
IncludeSpecs(..), addGlobalInclude, addQuoteInclude, flattenIncludes
IncludeSpecs(..), addGlobalInclude, addQuoteInclude, flattenIncludes,
-- * Make use of the Cmm CFG
CfgWeights(..), backendMaintainsCfg
) where
#include "HsVersions.h"
......@@ -344,6 +348,7 @@ data DumpFlag
| Opt_D_dump_cmm_info
| Opt_D_dump_cmm_cps
-- end cmm subflags
| Opt_D_dump_cfg_weights -- ^ Dump the cfg used for block layout.
| Opt_D_dump_asm
| Opt_D_dump_asm_native
| Opt_D_dump_asm_liveness
......@@ -484,6 +489,8 @@ data GeneralFlag
| Opt_DictsStrict -- be strict in argument dictionaries
| Opt_DmdTxDictSel -- use a special demand transformer for dictionary selectors
| Opt_Loopification -- See Note [Self-recursive tail calls]
| Opt_CfgBlocklayout -- ^ Use the cfg based block layout algorithm.
| Opt_WeightlessBlocklayout -- ^ Layout based on last instruction per block.
| Opt_CprAnal
| Opt_WorkerWrapper
| Opt_SolveConstantDicts
......@@ -689,6 +696,8 @@ optimisationFlags = EnumSet.fromList
, Opt_DictsStrict
, Opt_DmdTxDictSel
, Opt_Loopification
, Opt_CfgBlocklayout
, Opt_WeightlessBlocklayout
, Opt_CprAnal
, Opt_WorkerWrapper
, Opt_SolveConstantDicts
......@@ -1127,9 +1136,86 @@ data DynFlags = DynFlags {
-- | Unique supply configuration for testing build determinism
initialUnique :: Int,
uniqueIncrement :: Int
uniqueIncrement :: Int,
-- | Temporary: CFG Edge weights for fast iterations
cfgWeightInfo :: CfgWeights
}
-- | 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)
| otherwise = panic $ "Invalid cfg parameters." ++ exampleString
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"
backendMaintainsCfg :: DynFlags -> Bool
backendMaintainsCfg dflags = case (platformArch $ targetPlatform dflags) of
-- ArchX86 -- Should work but not tested so disabled currently.
ArchX86_64 -> True
_otherwise -> False
class HasDynFlags m where
getDynFlags :: m DynFlags
......@@ -1935,7 +2021,8 @@ defaultDynFlags mySettings (myLlvmTargets, myLlvmPasses) =
uniqueIncrement = 1,
reverseErrors = False,
maxErrors = Nothing
maxErrors = Nothing,
cfgWeightInfo = defaultCfgWeights
}
defaultWays :: Settings -> [Way]
......@@ -3117,6 +3204,8 @@ dynamic_flags_deps = [
(setDumpFlag Opt_D_dump_cmm_info)
, make_ord_flag defGhcFlag "ddump-cmm-cps"
(setDumpFlag Opt_D_dump_cmm_cps)
, make_ord_flag defGhcFlag "ddump-cfg-weights"
(setDumpFlag Opt_D_dump_cfg_weights)
, make_ord_flag defGhcFlag "ddump-core-stats"
(setDumpFlag Opt_D_dump_core_stats)
, make_ord_flag defGhcFlag "ddump-asm"
......@@ -3430,8 +3519,10 @@ dynamic_flags_deps = [
(noArg (\d -> d { floatLamArgs = Nothing }))
, make_ord_flag defFlag "fproc-alignment"
(intSuffix (\n d -> d { cmmProcAlignment = Just n }))
, make_ord_flag defFlag "fblock-layout-weights"
(HasArg (\s ->
upd (\d -> d { cfgWeightInfo =
parseCfgWeights s (cfgWeightInfo d)})))
, make_ord_flag defFlag "fhistory-size"
(intSuffix (\n d -> d { historySize = n }))
, make_ord_flag defFlag "funfolding-creation-threshold"
......@@ -3963,6 +4054,8 @@ fFlagsDeps = [
flagHiddenSpec "llvm-tbaa" Opt_LlvmTBAA,
flagHiddenSpec "llvm-fill-undef-with-garbage" Opt_LlvmFillUndefWithGarbage,
flagSpec "loopification" Opt_Loopification,
flagSpec "block-layout-cfg" Opt_CfgBlocklayout,
flagSpec "block-layout-weightless" Opt_WeightlessBlocklayout,
flagSpec "omit-interface-pragmas" Opt_OmitInterfacePragmas,
flagSpec "omit-yields" Opt_OmitYields,
flagSpec "optimal-applicative-do" Opt_OptimalApplicativeDo,
......@@ -4452,6 +4545,8 @@ optLevelFlags -- see Note [Documenting optimisation flags]
, ([1,2], Opt_FullLaziness)
, ([1,2], Opt_IgnoreAsserts)
, ([1,2], Opt_Loopification)
, ([1,2], Opt_CfgBlocklayout) -- Experimental
, ([1,2], Opt_Specialise)
, ([1,2], Opt_CrossModuleSpecialise)
, ([1,2], Opt_Strictness)
......
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
......@@ -9,11 +9,15 @@
-- -----------------------------------------------------------------------------
module NCGMonad (
NcgImpl(..),
NatM_State(..), mkNatM_State,
NatM, -- instance Monad
initNat,
addImportNat,
addNodeBetweenNat,
addImmediateSuccessorNat,
updateCfgNat,
getUniqueNat,
mapAccumLNat,
setDeltaNat,
......@@ -57,6 +61,39 @@ import Module
import Control.Monad ( liftM, ap )
import Instruction
import Outputable (SDoc, pprPanic, ppr)
import Cmm (RawCmmDecl, CmmStatics)
import CFG
data NcgImpl statics instr jumpDest = NcgImpl {
cmmTopCodeGen :: RawCmmDecl -> NatM [NatCmmDecl statics instr],
generateJumpTableForInstr :: instr -> Maybe (NatCmmDecl statics instr),
getJumpDestBlockId :: jumpDest -> Maybe BlockId,
canShortcut :: instr -> Maybe jumpDest,
shortcutStatics :: (BlockId -> Maybe jumpDest) -> statics -> statics,
shortcutJump :: (BlockId -> Maybe jumpDest) -> instr -> instr,
pprNatCmmDecl :: NatCmmDecl statics instr -> SDoc,
maxSpillSlots :: Int,
allocatableRegs :: [RealReg],
ncg_x86fp_kludge :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr],
ncgExpandTop :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr],
ncgAllocMoreStack :: Int -> NatCmmDecl statics instr
-> UniqSM (NatCmmDecl statics instr, [(BlockId,BlockId)]),
-- ^ The list of block ids records the redirected jumps to allow us to update
-- the CFG.
ncgMakeFarBranches :: LabelMap CmmStatics -> [NatBasicBlock instr] -> [NatBasicBlock instr],
extractUnwindPoints :: [instr] -> [UnwindPoint],
-- ^ given the instruction sequence of a block, produce a list of
-- the block's 'UnwindPoint's
-- See Note [What is this unwinding business?] in Debug
-- and Note [Unwinding information in the NCG] in this module.
invertCondBranches :: CFG -> LabelMap CmmStatics -> [NatBasicBlock instr]
-> [NatBasicBlock instr]
-- ^ Turn the sequence of `jcc l1; jmp l2` into `jncc l2; <block_l1>`
-- when possible.
}
data NatM_State
= NatM_State {
natm_us :: UniqSupply,
......@@ -67,7 +104,11 @@ data NatM_State
natm_this_module :: Module,
natm_modloc :: ModLocation,
natm_fileid :: DwarfFiles,
natm_debug_map :: LabelMap DebugBlock
natm_debug_map :: LabelMap DebugBlock,
natm_cfg :: CFG
-- ^ Having a CFG with additional information is essential for some
-- operations. However we can't reconstruct all information once we
-- generated instructions. So instead we update the CFG as we go.
}
type DwarfFiles = UniqFM (FastString, Int)
......@@ -78,9 +119,21 @@ unNat :: NatM a -> NatM_State -> (a, NatM_State)
unNat (NatM a) = a
mkNatM_State :: UniqSupply -> Int -> DynFlags -> Module -> ModLocation ->
DwarfFiles -> LabelMap DebugBlock -> NatM_State
DwarfFiles -> LabelMap DebugBlock -> CFG -> NatM_State
mkNatM_State us delta dflags this_mod
= NatM_State us delta [] Nothing dflags this_mod
= \loc dwf dbg cfg ->
NatM_State
{ natm_us = us
, natm_delta = delta
, natm_imports = []
, natm_pic = Nothing
, natm_dflags = dflags
, natm_this_module = this_mod
, natm_modloc = loc
, natm_fileid = dwf
, natm_debug_map = dbg
, natm_cfg = cfg
}
initNat :: NatM_State -> NatM a -> (a, NatM_State)
initNat init_st m
......@@ -151,6 +204,36 @@ addImportNat :: CLabel -> NatM ()
addImportNat imp
= NatM $ \ st -> ((), st {natm_imports = imp : natm_imports st})
updateCfgNat :: (CFG -> CFG) -> NatM ()
updateCfgNat f
= NatM $ \ st -> ((), st { natm_cfg = f (natm_cfg st) })
-- | 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
updateCfgNat (updateCfg jmpWeight from between to)
where
-- When transforming A -> B to A -> A' -> B
-- A -> A' keeps the old edge info while
-- A' -> B gets the info for an unconditional
-- jump.
updateCfg weight from between old m
| Just info <- getEdgeInfo from old m
= addEdge from between info .
addWeightEdge between old weight .
delEdge from old $ m
| otherwise
= pprPanic "Faild to update cfg: Untracked edge" (ppr (from,to))
-- | Place `succ` after `block` and change any edges
-- block -> X to `succ` -> X
addImmediateSuccessorNat :: BlockId -> BlockId -> NatM ()
addImmediateSuccessorNat block succ
= updateCfgNat (addImmediateSuccessor block succ)
getBlockIdNat :: NatM BlockId
getBlockIdNat
......
......@@ -32,7 +32,9 @@ import PPC.Instr
import PPC.Cond
import PPC.Regs
import CPrim
import NCGMonad
import NCGMonad ( NatM, getNewRegNat, getNewLabelNat
, getBlockIdNat, getPicBaseNat, getNewRegPairNat
, getPicBaseMaybeNat )
import Instruction
import PIC
import Format
......
......@@ -100,9 +100,9 @@ allocMoreStack
:: Platform
-> Int
-> NatCmmDecl statics PPC.Instr.Instr
-> UniqSM (NatCmmDecl statics PPC.Instr.Instr)
-> UniqSM (NatCmmDecl statics PPC.Instr.Instr, [(BlockId,BlockId)])
allocMoreStack _ _ top@(CmmData _ _) = return top
allocMoreStack _ _ top@(CmmData _ _) = return (top,[])
allocMoreStack platform slots (CmmProc info lbl live (ListGraph code)) = do
let
infos = mapKeys info
......@@ -121,8 +121,10 @@ allocMoreStack platform slots (CmmProc info lbl live (ListGraph code)) = do
alloc = mkStackAllocInstr platform delta
dealloc = mkStackDeallocInstr platform delta
retargetList = (zip entries (map mkBlockId uniqs))
new_blockmap :: LabelMap BlockId
new_blockmap = mapFromList (zip entries (map mkBlockId uniqs))
new_blockmap = mapFromList retargetList
insert_stack_insns (BasicBlock id insns)
| Just new_blockid <- mapLookup id new_blockmap
......@@ -156,7 +158,7 @@ allocMoreStack platform slots (CmmProc info lbl live (ListGraph code)) = do
= concatMap insert_stack_insns code
-- in
return (CmmProc info lbl live (ListGraph new_code))
return (CmmProc info lbl live (ListGraph new_code),retargetList)
-- -----------------------------------------------------------------------------
......
......@@ -29,9 +29,14 @@ import Cmm
import CLabel
import Unique
import Outputable (ppr, text, Outputable, (<>))
data JumpDest = DestBlockId BlockId
-- Debug Instance
instance Outputable JumpDest where
ppr (DestBlockId bid) = text "jd<blk>:" <> ppr bid
getJumpDestBlockId :: JumpDest -> Maybe BlockId
getJumpDestBlockId (DestBlockId bid) = Just bid
......
......@@ -28,6 +28,7 @@ import Outputable
import Unique
import UniqFM
import UniqSupply
import BlockId
-- | Used to store the register assignment on entry to a basic block.
......@@ -98,7 +99,10 @@ data SpillReason
-- | Used to carry interesting stats out of the register allocator.
data RegAllocStats
= RegAllocStats
{ ra_spillInstrs :: UniqFM [Int] }
{ ra_spillInstrs :: UniqFM [Int]
, ra_fixupList :: [(BlockId,BlockId,BlockId)]
-- ^ (from,fixup,to) : We inserted fixup code between from and to
}
-- | The register allocator state
......@@ -129,6 +133,9 @@ data RA_State freeRegs
-- Just keep a list here instead of a map of regs -> reasons.
-- We don't want to slow down the allocator if we're not going to emit the stats.
, ra_spills :: [SpillReason]
, ra_DynFlags :: DynFlags }
, ra_DynFlags :: DynFlags
-- | (from,fixup,to) : We inserted fixup code between from and to
, ra_fixups :: [(BlockId,BlockId,BlockId)] }
......@@ -33,7 +33,7 @@ import Data.Foldable (foldl')
-- vregs are in the correct regs for its destination.
--
joinToTargets
:: (FR freeRegs, Instruction instr)
:: (FR freeRegs, Instruction instr, Outputable instr)
=> BlockMap RegSet -- ^ maps the unique of the blockid to the set of vregs
-- that are known to be live on the entry to each block.
......@@ -57,7 +57,7 @@ joinToTargets block_live id instr
-----
joinToTargets'
:: (FR freeRegs, Instruction instr)
:: (FR freeRegs, Instruction instr, Outputable instr)
=> BlockMap RegSet -- ^ maps the unique of the blockid to the set of vregs
-- that are known to be live on the entry to each block.
......@@ -111,7 +111,7 @@ joinToTargets' block_live new_blocks block_id instr (dest:dests)
-- this is the first time we jumped to this block.
joinToTargets_first :: (FR freeRegs, Instruction instr)
joinToTargets_first :: (FR freeRegs, Instruction instr, Outputable instr)
=> BlockMap RegSet
-> [NatBasicBlock instr]
-> BlockId
......@@ -140,7 +140,7 @@ joinToTargets_first block_live new_blocks block_id instr dest dests
-- we've jumped to this block before
joinToTargets_again :: (Instruction instr, FR freeRegs)
joinToTargets_again :: (Instruction instr, FR freeRegs, Outputable instr)
=> BlockMap RegSet
-> [NatBasicBlock instr]