Commit 5fecd767 authored by Peter Wortmann's avatar Peter Wortmann Committed by Austin Seipp

Tick scopes

This patch solves the scoping problem of CmmTick nodes: If we just put
CmmTicks into blocks we have no idea what exactly they are meant to
cover.  Here we introduce tick scopes, which allow us to create
sub-scopes and merged scopes easily.

Notes:

* Given that the code often passes Cmm around "head-less", we have to
  make sure that its intended scope does not get lost. To keep the amount
  of passing-around to a minimum we define a CmmAGraphScoped type synonym
  here that just bundles the scope with a portion of Cmm to be assembled
  later.

* We introduce new scopes at somewhat random places, aligning with
  getCode calls. This works surprisingly well, but we might have to
  add new scopes into the mix later on if we find things too be too
  coarse-grained.

(From Phabricator D169)
parent 7ceaf96f
...@@ -13,7 +13,7 @@ import Prelude hiding (iterate, succ, unzip, zip) ...@@ -13,7 +13,7 @@ import Prelude hiding (iterate, succ, unzip, zip)
import Hoopl hiding (ChangeFlag) import Hoopl hiding (ChangeFlag)
import Data.Bits import Data.Bits
import Data.Maybe (fromJust) import Data.Maybe (mapMaybe)
import qualified Data.List as List import qualified Data.List as List
import Data.Word import Data.Word
import qualified Data.Map as M import qualified Data.Map as M
...@@ -221,11 +221,18 @@ eqMaybeWith _ _ _ = False ...@@ -221,11 +221,18 @@ eqMaybeWith _ _ _ = False
copyTicks :: BlockEnv BlockId -> CmmGraph -> CmmGraph copyTicks :: BlockEnv BlockId -> CmmGraph -> CmmGraph
copyTicks env g copyTicks env g
| mapNull env = g | mapNull env = g
| otherwise = ofBlockMap (g_entry g) $ mapMap f blockMap | otherwise = ofBlockMap (g_entry g) $ mapMap copyTo blockMap
where blockMap = toBlockMap g where -- Reverse block merge map
blockMap = toBlockMap g
revEnv = mapFoldWithKey insertRev M.empty env revEnv = mapFoldWithKey insertRev M.empty env
insertRev k x = M.insertWith (const (k:)) x [k] insertRev k x = M.insertWith (const (k:)) x [k]
f block = case M.lookup (entryLabel block) revEnv of -- Copy ticks and scopes into the given block
copyTo block = case M.lookup (entryLabel block) revEnv of
Nothing -> block Nothing -> block
Just ls -> let findTicks l = blockTicks $ fromJust $ mapLookup l blockMap Just ls -> foldr copy block $ mapMaybe (flip mapLookup blockMap) ls
in annotateBlock (concatMap findTicks ls) block copy from to =
let ticks = blockTicks from
CmmEntry _ scp0 = firstNode from
(CmmEntry lbl scp1, code) = blockSplitHead to
in CmmEntry lbl (combineTickScopes scp0 scp1) `blockJoinHead`
foldr blockCons code (map CmmTick ticks)
...@@ -317,18 +317,22 @@ decPreds bid edges = case mapLookup bid edges of ...@@ -317,18 +317,22 @@ decPreds bid edges = case mapLookup bid edges of
canShortcut :: CmmBlock -> Maybe BlockId canShortcut :: CmmBlock -> Maybe BlockId
canShortcut block canShortcut block
| (_, middle, CmmBranch dest) <- blockSplit block | (_, middle, CmmBranch dest) <- blockSplit block
, isEmptyBlock middle , all dont_care $ blockToList middle
= Just dest = Just dest
| otherwise | otherwise
= Nothing = Nothing
where dont_care CmmComment{} = True
dont_care CmmTick{} = True
dont_care _other = False
-- Concatenates two blocks. First one is assumed to be open on exit, the second -- Concatenates two blocks. First one is assumed to be open on exit, the second
-- is assumed to be closed on entry (i.e. it has a label attached to it, which -- is assumed to be closed on entry (i.e. it has a label attached to it, which
-- the splice function removes by calling snd on result of blockSplitHead). -- the splice function removes by calling snd on result of blockSplitHead).
splice :: Block CmmNode C O -> CmmBlock -> CmmBlock splice :: Block CmmNode C O -> CmmBlock -> CmmBlock
splice head rest = head `blockAppend` snd (blockSplitHead rest) splice head rest = entry `blockJoinHead` code0 `blockAppend` code1
where (CmmEntry lbl sc0, code0) = blockSplitHead head
(CmmEntry _ sc1, code1) = blockSplitHead rest
entry = CmmEntry lbl (combineTickScopes sc0 sc1)
-- If node is a call with continuation call return Just label of that -- If node is a call with continuation call return Just label of that
-- continuation. Otherwise return Nothing. -- continuation. Otherwise return Nothing.
......
...@@ -240,7 +240,7 @@ layout dflags procpoints liveness entry entry_args final_stackmaps final_sp_high ...@@ -240,7 +240,7 @@ layout dflags procpoints liveness entry entry_args final_stackmaps final_sp_high
go (b0 : bs) acc_stackmaps acc_hwm acc_blocks go (b0 : bs) acc_stackmaps acc_hwm acc_blocks
= do = do
let (entry0@(CmmEntry entry_lbl), middle0, last0) = blockSplit b0 let (entry0@(CmmEntry entry_lbl tscope), middle0, last0) = blockSplit b0
let stack0@StackMap { sm_sp = sp0 } let stack0@StackMap { sm_sp = sp0 }
= mapFindWithDefault = mapFindWithDefault
...@@ -264,7 +264,7 @@ layout dflags procpoints liveness entry entry_args final_stackmaps final_sp_high ...@@ -264,7 +264,7 @@ layout dflags procpoints liveness entry entry_args final_stackmaps final_sp_high
-- details. -- details.
(middle2, sp_off, last1, fixup_blocks, out) (middle2, sp_off, last1, fixup_blocks, out)
<- handleLastNode dflags procpoints liveness cont_info <- handleLastNode dflags procpoints liveness cont_info
acc_stackmaps stack1 middle0 last0 acc_stackmaps stack1 tscope middle0 last0
-- (d) Manifest Sp: run over the nodes in the block and replace -- (d) Manifest Sp: run over the nodes in the block and replace
-- CmmStackSlot with CmmLoad from Sp with a concrete offset. -- CmmStackSlot with CmmLoad from Sp with a concrete offset.
...@@ -386,7 +386,7 @@ getStackLoc (Young l) n stackmaps = ...@@ -386,7 +386,7 @@ getStackLoc (Young l) n stackmaps =
handleLastNode handleLastNode
:: DynFlags -> ProcPointSet -> BlockEnv CmmLocalLive -> BlockEnv ByteOff :: DynFlags -> ProcPointSet -> BlockEnv CmmLocalLive -> BlockEnv ByteOff
-> BlockEnv StackMap -> StackMap -> BlockEnv StackMap -> StackMap -> CmmTickScope
-> Block CmmNode O O -> Block CmmNode O O
-> CmmNode O C -> CmmNode O C
-> UniqSM -> UniqSM
...@@ -398,7 +398,7 @@ handleLastNode ...@@ -398,7 +398,7 @@ handleLastNode
) )
handleLastNode dflags procpoints liveness cont_info stackmaps handleLastNode dflags procpoints liveness cont_info stackmaps
stack0@StackMap { sm_sp = sp0 } middle last stack0@StackMap { sm_sp = sp0 } tscp middle last
= case last of = case last of
-- At each return / tail call, -- At each return / tail call,
-- adjust Sp to point to the last argument pushed, which -- adjust Sp to point to the last argument pushed, which
...@@ -496,7 +496,7 @@ handleLastNode dflags procpoints liveness cont_info stackmaps ...@@ -496,7 +496,7 @@ handleLastNode dflags procpoints liveness cont_info stackmaps
| Just stack2 <- mapLookup l stackmaps | Just stack2 <- mapLookup l stackmaps
= do = do
let assigs = fixupStack stack0 stack2 let assigs = fixupStack stack0 stack2
(tmp_lbl, block) <- makeFixupBlock dflags sp0 l stack2 assigs (tmp_lbl, block) <- makeFixupBlock dflags sp0 l stack2 tscp assigs
return (l, tmp_lbl, stack2, block) return (l, tmp_lbl, stack2, block)
-- (b) if the successor is a proc point, save everything -- (b) if the successor is a proc point, save everything
...@@ -507,7 +507,7 @@ handleLastNode dflags procpoints liveness cont_info stackmaps ...@@ -507,7 +507,7 @@ handleLastNode dflags procpoints liveness cont_info stackmaps
(stack2, assigs) = (stack2, assigs) =
setupStackFrame dflags l liveness (sm_ret_off stack0) setupStackFrame dflags l liveness (sm_ret_off stack0)
cont_args stack0 cont_args stack0
(tmp_lbl, block) <- makeFixupBlock dflags sp0 l stack2 assigs (tmp_lbl, block) <- makeFixupBlock dflags sp0 l stack2 tscp assigs
return (l, tmp_lbl, stack2, block) return (l, tmp_lbl, stack2, block)
-- (c) otherwise, the current StackMap is the StackMap for -- (c) otherwise, the current StackMap is the StackMap for
...@@ -521,14 +521,15 @@ handleLastNode dflags procpoints liveness cont_info stackmaps ...@@ -521,14 +521,15 @@ handleLastNode dflags procpoints liveness cont_info stackmaps
is_live (r,_) = r `elemRegSet` live is_live (r,_) = r `elemRegSet` live
makeFixupBlock :: DynFlags -> ByteOff -> Label -> StackMap -> [CmmNode O O] makeFixupBlock :: DynFlags -> ByteOff -> Label -> StackMap
-> CmmTickScope -> [CmmNode O O]
-> UniqSM (Label, [CmmBlock]) -> UniqSM (Label, [CmmBlock])
makeFixupBlock dflags sp0 l stack assigs makeFixupBlock dflags sp0 l stack tscope assigs
| null assigs && sp0 == sm_sp stack = return (l, []) | null assigs && sp0 == sm_sp stack = return (l, [])
| otherwise = do | otherwise = do
tmp_lbl <- liftM mkBlockId $ getUniqueM tmp_lbl <- liftM mkBlockId $ getUniqueM
let sp_off = sp0 - sm_sp stack let sp_off = sp0 - sm_sp stack
block = blockJoin (CmmEntry tmp_lbl) block = blockJoin (CmmEntry tmp_lbl tscope)
(maybeAddSpAdj dflags sp_off (blockFromList assigs)) (maybeAddSpAdj dflags sp_off (blockFromList assigs))
(CmmBranch l) (CmmBranch l)
return (tmp_lbl, [block]) return (tmp_lbl, [block])
...@@ -985,7 +986,7 @@ that safe foreign call is replace by an unsafe one in the Cmm graph. ...@@ -985,7 +986,7 @@ that safe foreign call is replace by an unsafe one in the Cmm graph.
lowerSafeForeignCall :: DynFlags -> CmmBlock -> UniqSM CmmBlock lowerSafeForeignCall :: DynFlags -> CmmBlock -> UniqSM CmmBlock
lowerSafeForeignCall dflags block lowerSafeForeignCall dflags block
| (entry, middle, CmmForeignCall { .. }) <- blockSplit block | (entry@(CmmEntry _ tscp), middle, CmmForeignCall { .. }) <- blockSplit block
= do = do
-- Both 'id' and 'new_base' are KindNonPtr because they're -- Both 'id' and 'new_base' are KindNonPtr because they're
-- RTS-only objects and are not subject to garbage collection -- RTS-only objects and are not subject to garbage collection
...@@ -1026,11 +1027,11 @@ lowerSafeForeignCall dflags block ...@@ -1026,11 +1027,11 @@ lowerSafeForeignCall dflags block
, cml_ret_args = ret_args , cml_ret_args = ret_args
, cml_ret_off = ret_off } , cml_ret_off = ret_off }
graph' <- lgraphOfAGraph $ suspend <*> graph' <- lgraphOfAGraph ( suspend <*>
midCall <*> midCall <*>
resume <*> resume <*>
copyout <*> copyout <*>
mkLast jump mkLast jump, tscp)
case toBlockList graph' of case toBlockList graph' of
[one] -> let (_, middle', last) = blockSplit one [one] -> let (_, middle', last) = blockSplit one
......
...@@ -15,7 +15,10 @@ module CmmNode ( ...@@ -15,7 +15,10 @@ module CmmNode (
ForeignConvention(..), ForeignTarget(..), foreignTargetHints, ForeignConvention(..), ForeignTarget(..), foreignTargetHints,
CmmReturnInfo(..), CmmReturnInfo(..),
mapExp, mapExpDeep, wrapRecExp, foldExp, foldExpDeep, wrapRecExpf, mapExp, mapExpDeep, wrapRecExp, foldExp, foldExpDeep, wrapRecExpf,
mapExpM, mapExpDeepM, wrapRecExpM, mapSuccessors mapExpM, mapExpDeepM, wrapRecExpM, mapSuccessors,
-- * Tick scopes
CmmTickScope(..), isTickSubScope, combineTickScopes,
) where ) where
import CodeGen.Platform import CodeGen.Platform
...@@ -23,12 +26,14 @@ import CmmExpr ...@@ -23,12 +26,14 @@ import CmmExpr
import DynFlags import DynFlags
import FastString import FastString
import ForeignCall import ForeignCall
import Outputable
import SMRep import SMRep
import CoreSyn (Tickish) import CoreSyn (Tickish)
import qualified Unique as U
import Compiler.Hoopl import Compiler.Hoopl
import Data.Maybe import Data.Maybe
import Data.List (tails) import Data.List (tails,sort)
import Prelude hiding (succ) import Prelude hiding (succ)
...@@ -38,12 +43,13 @@ import Prelude hiding (succ) ...@@ -38,12 +43,13 @@ import Prelude hiding (succ)
#define ULabel {-# UNPACK #-} !Label #define ULabel {-# UNPACK #-} !Label
data CmmNode e x where data CmmNode e x where
CmmEntry :: ULabel -> CmmNode C O CmmEntry :: ULabel -> CmmTickScope -> CmmNode C O
CmmComment :: FastString -> CmmNode O O CmmComment :: FastString -> CmmNode O O
-- Tick annotation, covering Cmm code in our tick scope. We only -- Tick annotation, covering Cmm code in our tick scope. We only
-- expect non-code @Tickish@ at this point (e.g. @SourceNote@). -- expect non-code @Tickish@ at this point (e.g. @SourceNote@).
-- See Note [CmmTick scoping details]
CmmTick :: !CmmTickish -> CmmNode O O CmmTick :: !CmmTickish -> CmmNode O O
CmmAssign :: !CmmReg -> !CmmExpr -> CmmNode O O CmmAssign :: !CmmReg -> !CmmExpr -> CmmNode O O
...@@ -211,7 +217,7 @@ deriving instance Eq (CmmNode e x) ...@@ -211,7 +217,7 @@ deriving instance Eq (CmmNode e x)
-- Hoopl instances of CmmNode -- Hoopl instances of CmmNode
instance NonLocal CmmNode where instance NonLocal CmmNode where
entryLabel (CmmEntry l) = l entryLabel (CmmEntry l _) = l
successors (CmmBranch l) = [l] successors (CmmBranch l) = [l]
successors (CmmCondBranch {cml_true=t, cml_false=f}) = [f, t] -- meets layout constraint successors (CmmCondBranch {cml_true=t, cml_false=f}) = [f, t] -- meets layout constraint
...@@ -440,7 +446,7 @@ wrapRecExp f (CmmLoad addr ty) = f (CmmLoad (wrapRecExp f addr) ty) ...@@ -440,7 +446,7 @@ wrapRecExp f (CmmLoad addr ty) = f (CmmLoad (wrapRecExp f addr) ty)
wrapRecExp f e = f e wrapRecExp f e = f e
mapExp :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x mapExp :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
mapExp _ f@(CmmEntry _) = f mapExp _ f@(CmmEntry{}) = f
mapExp _ m@(CmmComment _) = m mapExp _ m@(CmmComment _) = m
mapExp _ m@(CmmTick _) = m mapExp _ m@(CmmTick _) = m
mapExp f (CmmAssign r e) = CmmAssign r (f e) mapExp f (CmmAssign r e) = CmmAssign r (f e)
...@@ -470,7 +476,7 @@ wrapRecExpM f n@(CmmLoad addr ty) = maybe (f n) (f . flip CmmLoad ty) (wrapRecE ...@@ -470,7 +476,7 @@ wrapRecExpM f n@(CmmLoad addr ty) = maybe (f n) (f . flip CmmLoad ty) (wrapRecE
wrapRecExpM f e = f e wrapRecExpM f e = f e
mapExpM :: (CmmExpr -> Maybe CmmExpr) -> CmmNode e x -> Maybe (CmmNode e x) mapExpM :: (CmmExpr -> Maybe CmmExpr) -> CmmNode e x -> Maybe (CmmNode e x)
mapExpM _ (CmmEntry _) = Nothing mapExpM _ (CmmEntry{}) = Nothing
mapExpM _ (CmmComment _) = Nothing mapExpM _ (CmmComment _) = Nothing
mapExpM _ (CmmTick _) = Nothing mapExpM _ (CmmTick _) = Nothing
mapExpM f (CmmAssign r e) = CmmAssign r `fmap` f e mapExpM f (CmmAssign r e) = CmmAssign r `fmap` f e
...@@ -549,3 +555,120 @@ mapSuccessors _ n = n ...@@ -549,3 +555,120 @@ mapSuccessors _ n = n
-- | Tickish in Cmm context (annotations only) -- | Tickish in Cmm context (annotations only)
type CmmTickish = Tickish () type CmmTickish = Tickish ()
-- | Tick scope identifier, allowing us to reason about what
-- annotations in a Cmm block should scope over. We especially take
-- care to allow optimisations to reorganise blocks without losing
-- tick association in the process.
data CmmTickScope
= GlobalScope
-- ^ The global scope is the "root" of the scope graph. Every
-- scope is a sub-scope of the global scope. It doesn't make sense
-- to add ticks to this scope. On the other hand, this means that
-- setting this scope on a block means no ticks apply to it.
| SubScope U.Unique CmmTickScope
-- ^ Constructs a new sub-scope to an existing scope. This allows
-- us to translate Core-style scoping rules (see @tickishScoped@)
-- into the Cmm world. Suppose the following code:
--
-- tick<1> case ... of
-- A -> tick<2> ...
-- B -> tick<3> ...
--
-- We want the top-level tick annotation to apply to blocks
-- generated for the A and B alternatives. We can achieve that by
-- generating tick<1> into a block with scope a, while the code
-- for alternatives A and B gets generated into sub-scopes a/b and
-- a/c respectively.
| CombinedScope CmmTickScope CmmTickScope
-- ^ A combined scope scopes over everything that the two given
-- scopes cover. It is therefore a sub-scope of either scope. This
-- is required for optimisations. Consider common block elimination:
--
-- A -> tick<2> case ... of
-- C -> [common]
-- B -> tick<3> case ... of
-- D -> [common]
--
-- We will generate code for the C and D alternatives, and figure
-- out afterwards that it's actually common code. Scoping rules
-- dictate that the resulting common block needs to be covered by
-- both tick<2> and tick<3>, therefore we need to construct a
-- scope that is a child to *both* scope. Now we can do that - if
-- we assign the scopes a/c and b/d to the common-ed up blocks,
-- the new block could have a combined tick scope a/c+b/d, which
-- both tick<2> and tick<3> apply to.
-- Note [CmmTick scoping details]:
--
-- The scope of a @CmmTick@ is given by the @CmmEntry@ node of the
-- same block. Note that as a result of this, optimisations making
-- tick scopes more specific can *reduce* the amount of code a tick
-- scopes over. Fixing this would require a separate @CmmTickScope@
-- field for @CmmTick@. Right now we do not do this simply because I
-- couldn't find an example where it actually mattered -- multiple
-- blocks within the same scope generally jump to each other, which
-- prevents common block elimination from happening in the first
-- place. But this is no strong reason, so if Cmm optimisations become
-- more involved in future this might have to be revisited.
-- | Output all scope paths.
scopeToPaths :: CmmTickScope -> [[U.Unique]]
scopeToPaths GlobalScope = [[]]
scopeToPaths (SubScope u s) = map (u:) (scopeToPaths s)
scopeToPaths (CombinedScope s1 s2) = scopeToPaths s1 ++ scopeToPaths s2
-- | Returns the head uniques of the scopes. This is based on the
-- assumption that the @Unique@ of @SubScope@ identifies the
-- underlying super-scope. Used for efficient equality and comparison,
-- see below.
scopeUniques :: CmmTickScope -> [U.Unique]
scopeUniques GlobalScope = []
scopeUniques (SubScope u _) = [u]
scopeUniques (CombinedScope s1 s2) = scopeUniques s1 ++ scopeUniques s2
-- Equality and order is based on the head uniques defined above. We
-- take care to short-cut the (extremly) common cases.
instance Eq CmmTickScope where
GlobalScope == GlobalScope = True
GlobalScope == _ = False
_ == GlobalScope = False
(SubScope u _) == (SubScope u' _) = u == u'
(SubScope _ _) == _ = False
_ == (SubScope _ _) = False
scope == scope' = sort (scopeUniques scope) ==
sort (scopeUniques scope')
instance Ord CmmTickScope where
compare GlobalScope GlobalScope = EQ
compare GlobalScope _ = LT
compare _ GlobalScope = GT
compare (SubScope u _) (SubScope u' _) = compare u u'
compare scope scope' = compare (sort $ scopeUniques scope)
(sort $ scopeUniques scope')
instance Outputable CmmTickScope where
ppr GlobalScope = text "global"
ppr (SubScope us s) = ppr s <> char '/' <> ppr us
ppr combined = parens $ hcat $ punctuate (char '+') $
map (hcat . punctuate (char '/') . map ppr . reverse) $
scopeToPaths combined
-- | Checks whether two tick scopes are sub-scopes of each other. True
-- if the two scopes are equal.
isTickSubScope :: CmmTickScope -> CmmTickScope -> Bool
isTickSubScope = cmp
where cmp _ GlobalScope = True
cmp GlobalScope _ = False
cmp (CombinedScope s1 s2) s' = cmp s1 s' && cmp s2 s'
cmp s (CombinedScope s1' s2') = cmp s s1' || cmp s s2'
cmp (SubScope u s) s'@(SubScope u' _) = u == u' || cmp s s'
-- | Combine two tick scopes. This smart constructor will catch cases
-- where one tick scope is a sub-scope of the other already.
combineTickScopes :: CmmTickScope -> CmmTickScope -> CmmTickScope
combineTickScopes s1 s2
| s1 `isTickSubScope` s2 = s2
| s2 `isTickSubScope` s1 = s1
| otherwise = CombinedScope s1 s2
...@@ -209,7 +209,7 @@ import StgCmmExtCode ...@@ -209,7 +209,7 @@ import StgCmmExtCode
import CmmCallConv import CmmCallConv
import StgCmmProf import StgCmmProf
import StgCmmHeap import StgCmmHeap
import StgCmmMonad hiding ( getCode, getCodeR, emitLabel, emit, emitStore import StgCmmMonad hiding ( getCode, getCodeR, getCodeScoped, emitLabel, emit, emitStore
, emitAssign, emitOutOfLine, withUpdFrameOff , emitAssign, emitOutOfLine, withUpdFrameOff
, getUpdFrameOff ) , getUpdFrameOff )
import qualified StgCmmMonad as F import qualified StgCmmMonad as F
...@@ -429,7 +429,7 @@ lits :: { [CmmParse CmmExpr] } ...@@ -429,7 +429,7 @@ lits :: { [CmmParse CmmExpr] }
cmmproc :: { CmmParse () } cmmproc :: { CmmParse () }
: info maybe_conv maybe_formals maybe_body : info maybe_conv maybe_formals maybe_body
{ do ((entry_ret_label, info, stk_formals, formals), agraph) <- { do ((entry_ret_label, info, stk_formals, formals), agraph) <-
getCodeR $ loopDecls $ do { getCodeScoped $ loopDecls $ do {
(entry_ret_label, info, stk_formals) <- $1; (entry_ret_label, info, stk_formals) <- $1;
dflags <- getDynFlags; dflags <- getDynFlags;
formals <- sequence (fromMaybe [] $3); formals <- sequence (fromMaybe [] $3);
...@@ -1336,7 +1336,7 @@ doSwitch mb_range scrut arms deflt ...@@ -1336,7 +1336,7 @@ doSwitch mb_range scrut arms deflt
forkLabelledCode :: CmmParse () -> CmmParse BlockId forkLabelledCode :: CmmParse () -> CmmParse BlockId
forkLabelledCode p = do forkLabelledCode p = do
ag <- getCode p (_,ag) <- getCodeScoped p
l <- newBlockId l <- newBlockId
emitOutOfLine l ag emitOutOfLine l ag
return l return l
......
...@@ -145,7 +145,7 @@ forward :: FwdTransfer CmmNode Status ...@@ -145,7 +145,7 @@ forward :: FwdTransfer CmmNode Status
forward = mkFTransfer3 first middle last forward = mkFTransfer3 first middle last
where where
first :: CmmNode C O -> Status -> Status first :: CmmNode C O -> Status -> Status
first (CmmEntry id) ProcPoint = ReachedBy $ setSingleton id first (CmmEntry id _) ProcPoint = ReachedBy $ setSingleton id
first _ x = x first _ x = x
middle _ x = x middle _ x = x
...@@ -282,7 +282,7 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap ...@@ -282,7 +282,7 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap
-- and replace branches to procpoints with branches to the jump-off blocks -- and replace branches to procpoints with branches to the jump-off blocks
let add_jump_block (env, bs) (pp, l) = let add_jump_block (env, bs) (pp, l) =
do bid <- liftM mkBlockId getUniqueM do bid <- liftM mkBlockId getUniqueM
let b = blockJoin (CmmEntry bid) emptyBlock jump let b = blockJoin (CmmEntry bid GlobalScope) emptyBlock jump
live = ppLiveness pp live = ppLiveness pp
jump = CmmCall (CmmLit (CmmLabel l)) Nothing live 0 0 0 jump = CmmCall (CmmLit (CmmLabel l)) Nothing live 0 0 0
return (mapInsert pp bid env, b : bs) return (mapInsert pp bid env, b : bs)
......
...@@ -58,7 +58,7 @@ module CmmUtils( ...@@ -58,7 +58,7 @@ module CmmUtils(
dataflowAnalFwdBlocks, dataflowAnalFwdBlocks,
-- * Ticks -- * Ticks
blockTicks, annotateBlock blockTicks
) where ) where
#include "HsVersions.h" #include "HsVersions.h"
...@@ -496,7 +496,8 @@ mapGraphNodes :: ( CmmNode C O -> CmmNode C O ...@@ -496,7 +496,8 @@ mapGraphNodes :: ( CmmNode C O -> CmmNode C O
, CmmNode O C -> CmmNode O C) , CmmNode O C -> CmmNode O C)
-> CmmGraph -> CmmGraph -> CmmGraph -> CmmGraph
mapGraphNodes funs@(mf,_,_) g = mapGraphNodes funs@(mf,_,_) g =
ofBlockMap (entryLabel $ mf $ CmmEntry $ g_entry g) $ mapMap (mapBlock3' funs) $ toBlockMap g ofBlockMap (entryLabel $ mf $ CmmEntry (g_entry g) GlobalScope) $
mapMap (mapBlock3' funs) $ toBlockMap g
mapGraphNodes1 :: (forall e x. CmmNode e x -> CmmNode e x) -> CmmGraph -> CmmGraph mapGraphNodes1 :: (forall e x. CmmNode e x -> CmmNode e x) -> CmmGraph -> CmmGraph
mapGraphNodes1 f = modifyGraph (mapGraph f) mapGraphNodes1 f = modifyGraph (mapGraph f)
...@@ -580,8 +581,3 @@ blockTicks b = reverse $ foldBlockNodesF goStmt b [] ...@@ -580,8 +581,3 @@ blockTicks b = reverse $ foldBlockNodesF goStmt b []
where goStmt :: CmmNode e x -> [CmmTickish] -> [CmmTickish] where goStmt :: CmmNode e x -> [CmmTickish] -> [CmmTickish]
goStmt (CmmTick t) ts = t:ts goStmt (CmmTick t) ts = t:ts
goStmt _other ts = ts goStmt _other ts = ts
annotateBlock :: [CmmTickish] -> Block CmmNode C C -> Block CmmNode C C
annotateBlock ts b = blockJoin hd (tstmts `blockAppend` mid) tl
where (hd, mid, tl) = blockSplit b
tstmts = foldr blockCons emptyBlock $ map CmmTick ts
{-# LANGUAGE BangPatterns, CPP, GADTs #-} {-# LANGUAGE BangPatterns, CPP, GADTs #-}
module MkGraph module MkGraph
( CmmAGraph, CgStmt(..) ( CmmAGraph, CmmAGraphScoped, CgStmt(..)
, (<*>), catAGraphs , (<*>), catAGraphs
, mkLabel, mkMiddle, mkLast, outOfLine , mkLabel, mkMiddle, mkLast, outOfLine
, lgraphOfAGraph, labelAGraph , lgraphOfAGraph, labelAGraph
...@@ -58,22 +58,24 @@ import Prelude (($),Int,Eq(..)) -- avoid importing (<*>) ...@@ -58,22 +58,24 @@ import Prelude (($),Int,Eq(..)) -- avoid importing (<*>)
-- control flows from the first to the second. -- control flows from the first to the second.
-- --
-- A 'CmmAGraph' can be turned into a 'CmmGraph' (closed at both ends) -- A 'CmmAGraph' can be turned into a 'CmmGraph' (closed at both ends)
-- by providing a label for the entry point; see 'labelAGraph'. -- by providing a label for the entry point and a tick scope; see
-- -- 'labelAGraph'.
type CmmAGraph = OrdList CgStmt type CmmAGraph = OrdList CgStmt
-- | Unlabeled graph with tick scope
type CmmAGraphScoped = (CmmAGraph, CmmTickScope)
data CgStmt data CgStmt
= CgLabel BlockId = CgLabel BlockId CmmTickScope
| CgStmt (CmmNode O O) | CgStmt (CmmNode O O)
| CgLast (CmmNode O C) | CgLast (CmmNode O C)
| CgFork BlockId CmmAGraph | CgFork BlockId CmmAGraph CmmTickScope
flattenCmmAGraph :: BlockId -> CmmAGraph -> CmmGraph flattenCmmAGraph :: BlockId -> CmmAGraphScoped -> CmmGraph
flattenCmmAGraph id stmts = flattenCmmAGraph id (stmts_t, tscope) =
CmmGraph { g_entry = id, CmmGraph { g_entry = id,
g_graph = GMany NothingO body NothingO } g_graph = GMany NothingO body NothingO }
where where
body = foldr addBlock emptyBody $ flatten id stmts [] body = foldr addBlock emptyBody $ flatten id stmts_t tscope []
-- --
-- flatten: given an entry label and a CmmAGraph, make a list of blocks. -- flatten: given an entry label and a CmmAGraph, make a list of blocks.
...@@ -81,10 +83,11 @@ flattenCmmAGraph id stmts = ...@@ -81,10 +83,11 @@ flattenCmmAGraph id stmts =
-- NB. avoid the quadratic-append trap by passing in the tail of the -- NB. avoid the quadratic-append trap by passing in the tail of the
-- list. This is important for Very Long Functions (e.g. in T783). -- list. This is important for Very Long Functions (e.g. in T783).
-- --
flatten :: Label -> CmmAGraph -> [Block CmmNode C C] -> [Block CmmNode C C] flatten :: Label -> CmmAGraph -> CmmTickScope -> [Block CmmNode C C]
flatten id g blocks -> [Block CmmNode C C]
= flatten1 (fromOL g) (blockJoinHead (CmmEntry id) emptyBlock) blocks flatten id g tscope blocks
= flatten1 (fromOL g) block' blocks
where !block' = blockJoinHead (CmmEntry id tscope) emptyBlock
-- --
-- flatten0: we are outside a block at this point: any code before -- flatten0: we are outside a block at this point: any code before
-- the first label is unreachable, so just drop it. -- the first label is unreachable, so just drop it.
...@@ -92,12 +95,12 @@ flattenCmmAGraph id stmts = ...@@ -92,12 +95,12 @@ flattenCmmAGraph id stmts =
flatten0 :: [CgStmt] -> [Block CmmNode C C] -> [Block CmmNode C C] flatten0 :: [CgStmt] -> [Block CmmNode C C] -> [Block CmmNode C C]
flatten0 [] blocks = blocks flatten0 [] blocks = blocks
flatten0 (CgLabel id : stmts) blocks flatten0 (CgLabel id tscope : stmts) blocks
= flatten1 stmts block blocks = flatten1 stmts block blocks
where !block = blockJoinHead (CmmEntry id) emptyBlock where !block = blockJoinHead (CmmEntry id tscope) emptyBlock
flatten0 (CgFork fork_id stmts : rest) blocks flatten0 (CgFork fork_id stmts_t tscope : rest) blocks
= flatten fork_id stmts $ flatten0 rest blocks = flatten fork_id stmts_t tscope $ flatten0 rest blocks
flatten0 (CgLast _ : stmts) blocks = flatten0 stmts blocks flatten0 (CgLast _ : stmts) blocks = flatten0 stmts blocks
flatten0 (CgStmt _ : stmts) blocks = flatten0 stmts blocks flatten0 (CgStmt _ : stmts) blocks = flatten0 stmts blocks
...@@ -127,14 +130,14 @@ flattenCmmAGraph id stmts = ...@@ -127,14 +130,14 @@ flattenCmmAGraph id stmts =
= flatten1 stmts block' blocks = flatten1 stmts block' blocks
where !block' = blockSnoc block stmt where !block' = blockSnoc block stmt
flatten1 (CgFork fork_id stmts : rest) block blocks flatten1 (CgFork fork_id stmts_t tscope : rest) block blocks
= flatten fork_id stmts $ flatten1 rest block blocks = flatten fork_id stmts_t tscope $ flatten1 rest block blocks
-- a label here means that we should start a new block, and the -- a label here means that we should start a new block, and the
-- current block should fall through to the new block. -- current block should fall through to the new block.
flatten1 (CgLabel id : stmts) block blocks flatten1 (CgLabel id tscp : stmts) block blocks
= blockJoinTail block (CmmBranch id) : = blockJoinTail block (CmmBranch id) :
flatten1 stmts (blockJoinHead (CmmEntry id) emptyBlock) blocks flatten1 stmts (blockJoinHead (CmmEntry id tscp) emptyBlock) blocks
...@@ -147,8 +150,8 @@ catAGraphs :: [CmmAGraph] -> CmmAGraph ...@@ -147,8 +150,8 @@ catAGraphs :: [CmmAGraph] -> CmmAGraph
catAGraphs = concatOL catAGraphs = concatOL
-- | created a sequence "goto id; id:" as an AGraph -- | created a sequence "goto id; id:" as an AGraph
mkLabel :: BlockId -> CmmAGraph mkLabel :: BlockId -> CmmTickScope -> CmmAGraph
mkLabel bid = unitOL (CgLabel bid) mkLabel bid scp = unitOL (CgLabel bid scp)
-- | creates an open AGraph from a given node -- | creates an open AGraph from a given node
mkMiddle :: CmmNode O O -> CmmAGraph mkMiddle :: CmmNode O O -> CmmAGraph
...@@ -159,16 +162,17 @@ mkLast :: CmmNode O C -> CmmAGraph ...@@ -159,16 +162,17 @@ mkLast :: CmmNode O C -> CmmAGraph
mkLast last = unitOL (CgLast last) mkLast last = unitOL (CgLast last)
-- | A labelled code block; should end in a last node -- | A labelled code block; should end in a last node
outOfLine :: BlockId -> CmmAGraph -> CmmAGraph outOfLine :: BlockId -> CmmAGraphScoped -> CmmAGraph
outOfLine l g = unitOL (CgFork l g) outOfLine l (c,s) = unitOL (CgFork l c