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)
import Hoopl hiding (ChangeFlag)
import Data.Bits
import Data.Maybe (fromJust)
import Data.Maybe (mapMaybe)
import qualified Data.List as List
import Data.Word
import qualified Data.Map as M
......@@ -221,11 +221,18 @@ eqMaybeWith _ _ _ = False
copyTicks :: BlockEnv BlockId -> CmmGraph -> CmmGraph
copyTicks env g
| mapNull env = g
| otherwise = ofBlockMap (g_entry g) $ mapMap f blockMap
where blockMap = toBlockMap g
| otherwise = ofBlockMap (g_entry g) $ mapMap copyTo blockMap
where -- Reverse block merge map
blockMap = toBlockMap g
revEnv = mapFoldWithKey insertRev M.empty env
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
Just ls -> let findTicks l = blockTicks $ fromJust $ mapLookup l blockMap
in annotateBlock (concatMap findTicks ls) block
Just ls -> foldr copy block $ mapMaybe (flip mapLookup blockMap) ls
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
canShortcut :: CmmBlock -> Maybe BlockId
canShortcut block
| (_, middle, CmmBranch dest) <- blockSplit block
, isEmptyBlock middle
, all dont_care $ blockToList middle
= Just dest
| otherwise
= 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
-- 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).
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
-- continuation. Otherwise return Nothing.
......
......@@ -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
= 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 }
= mapFindWithDefault
......@@ -264,7 +264,7 @@ layout dflags procpoints liveness entry entry_args final_stackmaps final_sp_high
-- details.
(middle2, sp_off, last1, fixup_blocks, out)
<- 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
-- CmmStackSlot with CmmLoad from Sp with a concrete offset.
......@@ -386,7 +386,7 @@ getStackLoc (Young l) n stackmaps =
handleLastNode
:: DynFlags -> ProcPointSet -> BlockEnv CmmLocalLive -> BlockEnv ByteOff
-> BlockEnv StackMap -> StackMap
-> BlockEnv StackMap -> StackMap -> CmmTickScope
-> Block CmmNode O O
-> CmmNode O C
-> UniqSM
......@@ -398,7 +398,7 @@ handleLastNode
)
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
-- At each return / tail call,
-- adjust Sp to point to the last argument pushed, which
......@@ -496,7 +496,7 @@ handleLastNode dflags procpoints liveness cont_info stackmaps
| Just stack2 <- mapLookup l stackmaps
= do
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)
-- (b) if the successor is a proc point, save everything
......@@ -507,7 +507,7 @@ handleLastNode dflags procpoints liveness cont_info stackmaps
(stack2, assigs) =
setupStackFrame dflags l liveness (sm_ret_off 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)
-- (c) otherwise, the current StackMap is the StackMap for
......@@ -521,14 +521,15 @@ handleLastNode dflags procpoints liveness cont_info stackmaps
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])
makeFixupBlock dflags sp0 l stack assigs
makeFixupBlock dflags sp0 l stack tscope assigs
| null assigs && sp0 == sm_sp stack = return (l, [])
| otherwise = do
tmp_lbl <- liftM mkBlockId $ getUniqueM
let sp_off = sp0 - sm_sp stack
block = blockJoin (CmmEntry tmp_lbl)
block = blockJoin (CmmEntry tmp_lbl tscope)
(maybeAddSpAdj dflags sp_off (blockFromList assigs))
(CmmBranch l)
return (tmp_lbl, [block])
......@@ -985,7 +986,7 @@ that safe foreign call is replace by an unsafe one in the Cmm graph.
lowerSafeForeignCall :: DynFlags -> CmmBlock -> UniqSM CmmBlock
lowerSafeForeignCall dflags block
| (entry, middle, CmmForeignCall { .. }) <- blockSplit block
| (entry@(CmmEntry _ tscp), middle, CmmForeignCall { .. }) <- blockSplit block
= do
-- Both 'id' and 'new_base' are KindNonPtr because they're
-- RTS-only objects and are not subject to garbage collection
......@@ -1026,11 +1027,11 @@ lowerSafeForeignCall dflags block
, cml_ret_args = ret_args
, cml_ret_off = ret_off }
graph' <- lgraphOfAGraph $ suspend <*>
graph' <- lgraphOfAGraph ( suspend <*>
midCall <*>
resume <*>
copyout <*>
mkLast jump
mkLast jump, tscp)
case toBlockList graph' of
[one] -> let (_, middle', last) = blockSplit one
......
......@@ -15,7 +15,10 @@ module CmmNode (
ForeignConvention(..), ForeignTarget(..), foreignTargetHints,
CmmReturnInfo(..),
mapExp, mapExpDeep, wrapRecExp, foldExp, foldExpDeep, wrapRecExpf,
mapExpM, mapExpDeepM, wrapRecExpM, mapSuccessors
mapExpM, mapExpDeepM, wrapRecExpM, mapSuccessors,
-- * Tick scopes
CmmTickScope(..), isTickSubScope, combineTickScopes,
) where
import CodeGen.Platform
......@@ -23,12 +26,14 @@ import CmmExpr
import DynFlags
import FastString
import ForeignCall
import Outputable
import SMRep
import CoreSyn (Tickish)
import qualified Unique as U
import Compiler.Hoopl
import Data.Maybe
import Data.List (tails)
import Data.List (tails,sort)
import Prelude hiding (succ)
......@@ -38,12 +43,13 @@ import Prelude hiding (succ)
#define ULabel {-# UNPACK #-} !Label
data CmmNode e x where
CmmEntry :: ULabel -> CmmNode C O
CmmEntry :: ULabel -> CmmTickScope -> CmmNode C O
CmmComment :: FastString -> CmmNode O O
-- Tick annotation, covering Cmm code in our tick scope. We only
-- expect non-code @Tickish@ at this point (e.g. @SourceNote@).
-- See Note [CmmTick scoping details]
CmmTick :: !CmmTickish -> CmmNode O O
CmmAssign :: !CmmReg -> !CmmExpr -> CmmNode O O
......@@ -211,7 +217,7 @@ deriving instance Eq (CmmNode e x)
-- Hoopl instances of CmmNode
instance NonLocal CmmNode where
entryLabel (CmmEntry l) = l
entryLabel (CmmEntry l _) = l
successors (CmmBranch l) = [l]
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)
wrapRecExp f e = f e
mapExp :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
mapExp _ f@(CmmEntry _) = f
mapExp _ f@(CmmEntry{}) = f
mapExp _ m@(CmmComment _) = m
mapExp _ m@(CmmTick _) = m
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
wrapRecExpM f e = f e
mapExpM :: (CmmExpr -> Maybe CmmExpr) -> CmmNode e x -> Maybe (CmmNode e x)
mapExpM _ (CmmEntry _) = Nothing
mapExpM _ (CmmEntry{}) = Nothing
mapExpM _ (CmmComment _) = Nothing
mapExpM _ (CmmTick _) = Nothing
mapExpM f (CmmAssign r e) = CmmAssign r `fmap` f e
......@@ -549,3 +555,120 @@ mapSuccessors _ n = n
-- | Tickish in Cmm context (annotations only)
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
import CmmCallConv
import StgCmmProf
import StgCmmHeap
import StgCmmMonad hiding ( getCode, getCodeR, emitLabel, emit, emitStore
import StgCmmMonad hiding ( getCode, getCodeR, getCodeScoped, emitLabel, emit, emitStore
, emitAssign, emitOutOfLine, withUpdFrameOff
, getUpdFrameOff )
import qualified StgCmmMonad as F
......@@ -429,7 +429,7 @@ lits :: { [CmmParse CmmExpr] }
cmmproc :: { CmmParse () }
: info maybe_conv maybe_formals maybe_body
{ do ((entry_ret_label, info, stk_formals, formals), agraph) <-
getCodeR $ loopDecls $ do {
getCodeScoped $ loopDecls $ do {
(entry_ret_label, info, stk_formals) <- $1;
dflags <- getDynFlags;
formals <- sequence (fromMaybe [] $3);
......@@ -1336,7 +1336,7 @@ doSwitch mb_range scrut arms deflt
forkLabelledCode :: CmmParse () -> CmmParse BlockId
forkLabelledCode p = do
ag <- getCode p
(_,ag) <- getCodeScoped p
l <- newBlockId
emitOutOfLine l ag
return l
......
......@@ -145,7 +145,7 @@ forward :: FwdTransfer CmmNode Status
forward = mkFTransfer3 first middle last
where
first :: CmmNode C O -> Status -> Status
first (CmmEntry id) ProcPoint = ReachedBy $ setSingleton id
first (CmmEntry id _) ProcPoint = ReachedBy $ setSingleton id
first _ x = x
middle _ x = x
......@@ -282,7 +282,7 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap
-- and replace branches to procpoints with branches to the jump-off blocks
let add_jump_block (env, bs) (pp, l) =
do bid <- liftM mkBlockId getUniqueM
let b = blockJoin (CmmEntry bid) emptyBlock jump
let b = blockJoin (CmmEntry bid GlobalScope) emptyBlock jump
live = ppLiveness pp
jump = CmmCall (CmmLit (CmmLabel l)) Nothing live 0 0 0
return (mapInsert pp bid env, b : bs)
......
......@@ -58,7 +58,7 @@ module CmmUtils(
dataflowAnalFwdBlocks,
-- * Ticks
blockTicks, annotateBlock
blockTicks
) where
#include "HsVersions.h"
......@@ -496,7 +496,8 @@ mapGraphNodes :: ( CmmNode C O -> CmmNode C O
, CmmNode O C -> CmmNode O C)
-> CmmGraph -> CmmGraph
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 f = modifyGraph (mapGraph f)
......@@ -580,8 +581,3 @@ blockTicks b = reverse $ foldBlockNodesF goStmt b []
where goStmt :: CmmNode e x -> [CmmTickish] -> [CmmTickish]
goStmt (CmmTick t) ts = t: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 #-}
module MkGraph
( CmmAGraph, CgStmt(..)
( CmmAGraph, CmmAGraphScoped, CgStmt(..)
, (<*>), catAGraphs
, mkLabel, mkMiddle, mkLast, outOfLine
, lgraphOfAGraph, labelAGraph
......@@ -58,22 +58,24 @@ import Prelude (($),Int,Eq(..)) -- avoid importing (<*>)
-- control flows from the first to the second.
--
-- 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
-- | Unlabeled graph with tick scope
type CmmAGraphScoped = (CmmAGraph, CmmTickScope)
data CgStmt
= CgLabel BlockId
= CgLabel BlockId CmmTickScope
| CgStmt (CmmNode O O)
| CgLast (CmmNode O C)
| CgFork BlockId CmmAGraph
| CgFork BlockId CmmAGraph CmmTickScope
flattenCmmAGraph :: BlockId -> CmmAGraph -> CmmGraph
flattenCmmAGraph id stmts =
flattenCmmAGraph :: BlockId -> CmmAGraphScoped -> CmmGraph
flattenCmmAGraph id (stmts_t, tscope) =
CmmGraph { g_entry = id,
g_graph = GMany NothingO body NothingO }
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.
......@@ -81,10 +83,11 @@ flattenCmmAGraph id stmts =
-- 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).
--
flatten :: Label -> CmmAGraph -> [Block CmmNode C C] -> [Block CmmNode C C]
flatten id g blocks
= flatten1 (fromOL g) (blockJoinHead (CmmEntry id) emptyBlock) blocks
flatten :: Label -> CmmAGraph -> CmmTickScope -> [Block CmmNode C C]
-> [Block CmmNode C C]
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
-- the first label is unreachable, so just drop it.
......@@ -92,12 +95,12 @@ flattenCmmAGraph id stmts =
flatten0 :: [CgStmt] -> [Block CmmNode C C] -> [Block CmmNode C C]
flatten0 [] blocks = blocks
flatten0 (CgLabel id : stmts) blocks
flatten0 (CgLabel id tscope : stmts) 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
= flatten fork_id stmts $ flatten0 rest blocks
flatten0 (CgFork fork_id stmts_t tscope : rest) blocks
= flatten fork_id stmts_t tscope $ flatten0 rest blocks
flatten0 (CgLast _ : stmts) blocks = flatten0 stmts blocks
flatten0 (CgStmt _ : stmts) blocks = flatten0 stmts blocks
......@@ -127,14 +130,14 @@ flattenCmmAGraph id stmts =
= flatten1 stmts block' blocks
where !block' = blockSnoc block stmt
flatten1 (CgFork fork_id stmts : rest) block blocks
= flatten fork_id stmts $ flatten1 rest block blocks
flatten1 (CgFork fork_id stmts_t tscope : 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
-- 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) :
flatten1 stmts (blockJoinHead (CmmEntry id) emptyBlock) blocks
flatten1 stmts (blockJoinHead (CmmEntry id tscp) emptyBlock) blocks
......@@ -147,8 +150,8 @@ catAGraphs :: [CmmAGraph] -> CmmAGraph
catAGraphs = concatOL
-- | created a sequence "goto id; id:" as an AGraph
mkLabel :: BlockId -> CmmAGraph
mkLabel bid = unitOL (CgLabel bid)
mkLabel :: BlockId -> CmmTickScope -> CmmAGraph
mkLabel bid scp = unitOL (CgLabel bid scp)
-- | creates an open AGraph from a given node
mkMiddle :: CmmNode O O -> CmmAGraph
......@@ -159,16 +162,17 @@ mkLast :: CmmNode O C -> CmmAGraph
mkLast last = unitOL (CgLast last)
-- | A labelled code block; should end in a last node
outOfLine :: BlockId -> CmmAGraph -> CmmAGraph
outOfLine l g = unitOL (CgFork l g)
outOfLine :: BlockId -> CmmAGraphScoped -> CmmAGraph
outOfLine l (c,s) = unitOL (CgFork l c s)
-- | allocate a fresh label for the entry point
lgraphOfAGraph :: CmmAGraph -> UniqSM CmmGraph
lgraphOfAGraph g = do u <- getUniqueM
return (labelAGraph (mkBlockId u) g)
lgraphOfAGraph :: CmmAGraphScoped -> UniqSM CmmGraph
lgraphOfAGraph g = do
u <- getUniqueM
return (labelAGraph (mkBlockId u) g)
-- | use the given BlockId as the label of the entry point
labelAGraph :: BlockId -> CmmAGraph -> CmmGraph
labelAGraph :: BlockId -> CmmAGraphScoped -> CmmGraph
labelAGraph lbl ag = flattenCmmAGraph lbl ag
---------- No-ops
......
......@@ -138,10 +138,10 @@ pprTop (CmmData _section (Statics lbl lits)) =
pprBBlock :: CmmBlock -> SDoc
pprBBlock block =
nest 4 (pprBlockId lbl <> colon) $$
nest 4 (pprBlockId (entryLabel block) <> colon) $$
nest 8 (vcat (map pprStmt (blockToList nodes)) $$ pprStmt last)
where
(CmmEntry lbl, nodes, last) = blockSplit block
(_, nodes, last) = blockSplit block
-- --------------------------------------------------------------------------
-- Info tables. Just arrays of words.
......@@ -171,7 +171,7 @@ pprStmt :: CmmNode e x -> SDoc
pprStmt stmt =
sdocWithDynFlags $ \dflags ->
case stmt of
CmmEntry _ -> empty
CmmEntry{} -> empty
CmmComment _ -> empty -- (hang (ptext (sLit "/*")) 3 (ftext s)) $$ ptext (sLit "*/")
-- XXX if the string contains "*/", we need to fix it
-- XXX we probably want to emit these comments when
......
......@@ -183,7 +183,9 @@ pprNode node = pp_node <+> pp_debug
pp_node :: SDoc
pp_node = sdocWithDynFlags $ \dflags -> case node of
-- label:
CmmEntry id -> ppr id <> colon
CmmEntry id tscope -> ppr id <> colon <+>
(sdocWithDynFlags $ \dflags ->
ppWhen (gopt Opt_PprShowTicks dflags) (text "//" <+> ppr tscope))
-- // text
CmmComment s -> text "//" <+> ftext s
......
......@@ -553,7 +553,9 @@ mkSlowEntryCode bndr cl_info arg_regs -- function closure is already in `Node'
(mkLblExpr fast_lbl)
(map (CmmReg . CmmLocal) (node : arg_regs))
(initUpdFrameOff dflags)
emitProcWithConvention Slow Nothing slow_lbl (node : arg_regs) jump
tscope <- getTickScope
emitProcWithConvention Slow Nothing slow_lbl
(node : arg_regs) (jump, tscope)
| otherwise = return ()
-----------------------------------------
......
......@@ -47,6 +47,7 @@ import FastString
import Outputable
import Control.Monad (when,void)
import Control.Arrow (first)
#if __GLASGOW_HASKELL__ >= 709
import Prelude hiding ((<*>))
......@@ -130,8 +131,8 @@ cgLetNoEscapeRhs
cgLetNoEscapeRhs join_id local_cc bndr rhs =
do { (info, rhs_code) <- cgLetNoEscapeRhsBody local_cc bndr rhs
; let (bid, _) = expectJust "cgLetNoEscapeRhs" $ maybeLetNoEscape info
; let code = do { body <- getCode rhs_code
; emitOutOfLine bid (body <*> mkBranch join_id) }
; let code = do { (_, body) <- getCodeScoped rhs_code
; emitOutOfLine bid (first (<*> mkBranch join_id) body) }
; return (info, code)
}
......@@ -588,8 +589,8 @@ cgAlts _ _ _ _ = panic "cgAlts"
-------------------
cgAlgAltRhss :: (GcPlan,ReturnKind) -> NonVoid Id -> [StgAlt]
-> FCode ( Maybe CmmAGraph
, [(ConTagZ, CmmAGraph)] )
-> FCode ( Maybe CmmAGraphScoped
, [(ConTagZ, CmmAGraphScoped)] )
cgAlgAltRhss gc_plan bndr alts
= do { tagged_cmms <- cgAltRhss gc_plan bndr alts
......@@ -608,14 +609,14 @@ cgAlgAltRhss gc_plan bndr alts
-------------------
cgAltRhss :: (GcPlan,ReturnKind) -> NonVoid Id -> [StgAlt]
-> FCode [(AltCon, CmmAGraph)]
-> FCode [(AltCon, CmmAGraphScoped)]
cgAltRhss gc_plan bndr alts = do
dflags <- getDynFlags
let
base_reg = idToReg dflags bndr
cg_alt :: StgAlt -> FCode (AltCon, CmmAGraph)
cg_alt :: StgAlt -> FCode (AltCon, CmmAGraphScoped)
cg_alt (con, bndrs, _uses, rhs)
= getCodeR $
= getCodeScoped $
maybeAltHeapCheck gc_plan $
do { _ <- bindConArgs con base_reg bndrs
; _ <- cgExpr rhs
......@@ -840,11 +841,12 @@ emitEnter fun = do
-- inlined in the RHS of the R1 assignment.
; let entry = entryCode dflags (closureInfoPtr dflags (CmmReg nodeReg))
the_call = toCall entry (Just lret) updfr_off off outArgs regs
; tscope <- getTickScope
; emit $
copyout <*>
mkCbranch (cmmIsTagged dflags (CmmReg nodeReg)) lret lcall <*>
outOfLine lcall the_call <*>
mkLabel lret <*>
outOfLine lcall (the_call,tscope) <*>
mkLabel lret tscope <*>
copyin
; return (ReturnedTo lret off)
}
......
......@@ -31,7 +31,7 @@ module StgCmmExtCode (
code,
emit, emitLabel, emitAssign, emitStore,
getCode, getCodeR,
getCode, getCodeR, getCodeScoped,
emitOutOfLine,
withUpdFrameOff, getUpdFrameOff
)
......@@ -110,7 +110,8 @@ instance HasDynFlags CmmParse where
loopDecls :: CmmParse a -> CmmParse a
loopDecls (EC fcode) =
EC $ \c e globalDecls -> do
(_, a) <- F.fixC (\ ~(decls, _) -> fcode c (addListToUFM e decls) globalDecls)
(_, a) <- F.fixC $ \ ~(decls, _) ->
fcode c (addListToUFM e decls) globalDecls
return (globalDecls, a)
......@@ -219,7 +220,7 @@ emit :: CmmAGraph -> CmmParse ()
emit = code . F.emit
emitLabel :: BlockId -> CmmParse ()
emitLabel = code. F.emitLabel
emitLabel = code . F.emitLabel
emitAssign :: CmmReg -> CmmExpr -> CmmParse ()
emitAssign l r = code (F.emitAssign l r)
......@@ -237,7 +238,12 @@ getCodeR (EC ec) = EC $ \c e s -> do
((s', r), gr) <- F.getCodeR (ec c e s)
return (s', (r,gr))
emitOutOfLine :: BlockId -> CmmAGraph -> CmmParse ()
getCodeScoped :: CmmParse a -> CmmParse (a, CmmAGraphScoped)
getCodeScoped (EC ec) = EC $ \c e s -> do
((s', r), gr) <- F.getCodeScoped (ec c e s)
return (s', (r,gr))
emitOutOfLine :: BlockId -> CmmAGraphScoped -> CmmParse ()
emitOutOfLine l g = code (F.emitOutOfLine l g)
withUpdFrameOff :: UpdFrameOffset -> CmmParse () -> CmmParse ()
......
......@@ -228,6 +228,7 @@ emitForeignCall safety results target args
k <- newLabelC
let (off, _, copyout) = copyInOflow dflags NativeReturn (Young k) results []
-- see Note [safe foreign call convention]
tscope <- getTickScope
emit $
( mkStore (CmmStackSlot (Young k) (widthInBytes (wordWidth dflags)))
(CmmLit (CmmBlock k))
......@@ -238,7 +239,7 @@ emitForeignCall safety results target args
, ret_args = off
, ret_off = updfr_off