summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
Diffstat (limited to 'compiler')
-rw-r--r--compiler/cmm/CmmCommonBlockElim.hs19
-rw-r--r--compiler/cmm/CmmContFlowOpt.hs12
-rw-r--r--compiler/cmm/CmmLayoutStack.hs25
-rw-r--r--compiler/cmm/CmmNode.hs135
-rw-r--r--compiler/cmm/CmmParse.y6
-rw-r--r--compiler/cmm/CmmProcPoint.hs4
-rw-r--r--compiler/cmm/CmmUtils.hs10
-rw-r--r--compiler/cmm/MkGraph.hs60
-rw-r--r--compiler/cmm/PprC.hs6
-rw-r--r--compiler/cmm/PprCmm.hs4
-rw-r--r--compiler/codeGen/StgCmmBind.hs4
-rw-r--r--compiler/codeGen/StgCmmExpr.hs20
-rw-r--r--compiler/codeGen/StgCmmExtCode.hs14
-rw-r--r--compiler/codeGen/StgCmmForeign.hs3
-rw-r--r--compiler/codeGen/StgCmmHeap.hs8
-rw-r--r--compiler/codeGen/StgCmmLayout.hs14
-rw-r--r--compiler/codeGen/StgCmmMonad.hs88
-rw-r--r--compiler/codeGen/StgCmmUtils.hs50
-rw-r--r--compiler/llvmGen/LlvmCodeGen/CodeGen.hs3
-rw-r--r--compiler/nativeGen/PPC/CodeGen.hs3
-rw-r--r--compiler/nativeGen/SPARC/CodeGen.hs3
-rw-r--r--compiler/nativeGen/X86/CodeGen.hs3
22 files changed, 349 insertions, 145 deletions
diff --git a/compiler/cmm/CmmCommonBlockElim.hs b/compiler/cmm/CmmCommonBlockElim.hs
index e8fc5da50e..e009ce5171 100644
--- a/compiler/cmm/CmmCommonBlockElim.hs
+++ b/compiler/cmm/CmmCommonBlockElim.hs
@@ -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)
diff --git a/compiler/cmm/CmmContFlowOpt.hs b/compiler/cmm/CmmContFlowOpt.hs
index 4b8ce6f0f3..bcb4cf97b3 100644
--- a/compiler/cmm/CmmContFlowOpt.hs
+++ b/compiler/cmm/CmmContFlowOpt.hs
@@ -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.
diff --git a/compiler/cmm/CmmLayoutStack.hs b/compiler/cmm/CmmLayoutStack.hs
index 5a2891fffc..7df0af6c68 100644
--- a/compiler/cmm/CmmLayoutStack.hs
+++ b/compiler/cmm/CmmLayoutStack.hs
@@ -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
diff --git a/compiler/cmm/CmmNode.hs b/compiler/cmm/CmmNode.hs
index 50268ee8be..2376b422a6 100644
--- a/compiler/cmm/CmmNode.hs
+++ b/compiler/cmm/CmmNode.hs
@@ -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
diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y
index 0973e306b0..c911606825 100644
--- a/compiler/cmm/CmmParse.y
+++ b/compiler/cmm/CmmParse.y
@@ -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
diff --git a/compiler/cmm/CmmProcPoint.hs b/compiler/cmm/CmmProcPoint.hs
index 5f9c27fe7a..2add4741ef 100644
--- a/compiler/cmm/CmmProcPoint.hs
+++ b/compiler/cmm/CmmProcPoint.hs
@@ -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)
diff --git a/compiler/cmm/CmmUtils.hs b/compiler/cmm/CmmUtils.hs
index 043ccf0ff5..65d633e6b7 100644
--- a/compiler/cmm/CmmUtils.hs
+++ b/compiler/cmm/CmmUtils.hs
@@ -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
diff --git a/compiler/cmm/MkGraph.hs b/compiler/cmm/MkGraph.hs
index 9bc2bd9ddc..064577cd0a 100644
--- a/compiler/cmm/MkGraph.hs
+++ b/compiler/cmm/MkGraph.hs
@@ -1,7 +1,7 @@
{-# 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
diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs
index d808341304..a2c3abf320 100644
--- a/compiler/cmm/PprC.hs
+++ b/compiler/cmm/PprC.hs
@@ -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
diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs
index f350a8a5f9..23982127a0 100644
--- a/compiler/cmm/PprCmm.hs
+++ b/compiler/cmm/PprCmm.hs
@@ -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
diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs
index 3c17160750..da87f965d5 100644
--- a/compiler/codeGen/StgCmmBind.hs
+++ b/compiler/codeGen/StgCmmBind.hs
@@ -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 ()
-----------------------------------------
diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs
index 4a11fc98d8..ee635508fb 100644
--- a/compiler/codeGen/StgCmmExpr.hs
+++ b/compiler/codeGen/StgCmmExpr.hs
@@ -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)
}
diff --git a/compiler/codeGen/StgCmmExtCode.hs b/compiler/codeGen/StgCmmExtCode.hs
index ef6540534b..03f6a47d87 100644
--- a/compiler/codeGen/StgCmmExtCode.hs
+++ b/compiler/codeGen/StgCmmExtCode.hs
@@ -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 ()
diff --git a/compiler/codeGen/StgCmmForeign.hs b/compiler/codeGen/StgCmmForeign.hs
index c2e276ed0b..c38519ed13 100644
--- a/compiler/codeGen/StgCmmForeign.hs
+++ b/compiler/codeGen/StgCmmForeign.hs
@@ -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
, intrbl = playInterruptible safety })
- <*> mkLabel k
+ <*> mkLabel k tscope
<*> copyout
)
return (ReturnedTo k off)
diff --git a/compiler/codeGen/StgCmmHeap.hs b/compiler/codeGen/StgCmmHeap.hs
index eca118fd25..0e9eb6d658 100644
--- a/compiler/codeGen/StgCmmHeap.hs
+++ b/compiler/codeGen/StgCmmHeap.hs
@@ -420,7 +420,8 @@ altOrNoEscapeHeapCheck checkYield regs code = do
lret <- newLabelC
let (off, _, copyin) = copyInOflow dflags NativeReturn (Young lret) regs []
lcont <- newLabelC
- emitOutOfLine lret (copyin <*> mkBranch lcont)
+ tscope <- getTickScope
+ emitOutOfLine lret (copyin <*> mkBranch lcont, tscope)
emitLabel lcont
cannedGCReturnsTo checkYield False gc regs lret off code
@@ -651,8 +652,9 @@ do_checks mb_stk_hwm checkYield mb_alloc_lit do_gc = do
CmmLit (zeroCLit dflags)]
emit =<< mkCmmIfGoto yielding gc_id
- emitOutOfLine gc_id $
- do_gc -- this is expected to jump back somewhere
+ tscope <- getTickScope
+ emitOutOfLine gc_id
+ (do_gc, tscope) -- this is expected to jump back somewhere
-- Test for stack pointer exhaustion, then
-- bump heap pointer, and test for heap exhaustion
diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs
index af2d6619ea..c3d8873cfb 100644
--- a/compiler/codeGen/StgCmmLayout.hs
+++ b/compiler/codeGen/StgCmmLayout.hs
@@ -120,7 +120,8 @@ emitCallWithExtraStack (callConv, retConv) fun args extra_stack
(off, _, copyin) = copyInOflow dflags retConv area res_regs []
copyout = mkCallReturnsTo dflags fun callConv args k off updfr_off
extra_stack
- emit (copyout <*> mkLabel k <*> copyin)
+ tscope <- getTickScope
+ emit (copyout <*> mkLabel k tscope <*> copyin)
return (ReturnedTo k off)
}
@@ -224,15 +225,16 @@ slowCall fun stg_args
let correct_arity = cmmEqWord dflags (funInfoArity dflags fun_iptr)
(mkIntExpr dflags n_args)
+ tscope <- getTickScope
emit (mkCbranch (cmmIsTagged dflags funv) is_tagged_lbl slow_lbl
- <*> mkLabel is_tagged_lbl
+ <*> mkLabel is_tagged_lbl tscope
<*> mkCbranch correct_arity fast_lbl slow_lbl
- <*> mkLabel fast_lbl
+ <*> mkLabel fast_lbl tscope
<*> fast_code
<*> mkBranch end_lbl
- <*> mkLabel slow_lbl
+ <*> mkLabel slow_lbl tscope
<*> slow_code
- <*> mkLabel end_lbl)
+ <*> mkLabel end_lbl tscope)
return r
else do
@@ -536,7 +538,7 @@ emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl args body
emitClosureAndInfoTable ::
CmmInfoTable -> Convention -> [LocalReg] -> FCode () -> FCode ()
emitClosureAndInfoTable info_tbl conv args body
- = do { blks <- getCode body
+ = do { (_, blks) <- getCodeScoped body
; let entry_lbl = toEntryLbl (cit_lbl info_tbl)
; emitProcWithConvention conv (Just info_tbl) entry_lbl args blks
}
diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs
index 252a815ee6..cf78d512cc 100644
--- a/compiler/codeGen/StgCmmMonad.hs
+++ b/compiler/codeGen/StgCmmMonad.hs
@@ -23,7 +23,7 @@ module StgCmmMonad (
emitTick,
getCmm, aGraphToGraph,
- getCodeR, getCode, getHeapUsage,
+ getCodeR, getCode, getCodeScoped, getHeapUsage,
mkCmmIfThenElse, mkCmmIfThen, mkCmmIfGoto,
mkCall, mkCmmCall,
@@ -36,6 +36,7 @@ module StgCmmMonad (
withSequel, getSequel,
setTickyCtrLabel, getTickyCtrLabel,
+ tickScope, getTickScope,
withUpdFrameOff, getUpdFrameOff, initUpdFrameOff,
@@ -181,10 +182,11 @@ data CgInfoDownwards -- information only passed *downwards* by the monad
cgd_updfr_off :: UpdFrameOffset, -- Size of current update frame
cgd_ticky :: CLabel, -- Current destination for ticky counts
cgd_sequel :: Sequel, -- What to do at end of basic block
- cgd_self_loop :: Maybe SelfLoopInfo -- Which tail calls can be compiled
+ cgd_self_loop :: Maybe SelfLoopInfo,-- Which tail calls can be compiled
-- as local jumps? See Note
-- [Self-recursive tail calls] in
-- StgCmmExpr
+ cgd_tick_scope:: CmmTickScope -- Tick scope for new blocks & ticks
}
type CgBindings = IdEnv CgIdInfo
@@ -305,7 +307,8 @@ initCgInfoDown dflags mod
, cgd_updfr_off = initUpdFrameOff dflags
, cgd_ticky = mkTopTickyCtrLabel
, cgd_sequel = initSequel
- , cgd_self_loop = Nothing }
+ , cgd_self_loop = Nothing
+ , cgd_tick_scope= GlobalScope }
initSequel :: Sequel
initSequel = Return False
@@ -557,6 +560,27 @@ setTickyCtrLabel ticky code = do
info <- getInfoDown
withInfoDown code (info {cgd_ticky = ticky})
+-- ----------------------------------------------------------------------------
+-- Manage tick scopes
+
+-- | The current tick scope. We will assign this to generated blocks.
+getTickScope :: FCode CmmTickScope
+getTickScope = do
+ info <- getInfoDown
+ return (cgd_tick_scope info)
+
+-- | Places blocks generated by the given code into a fresh
+-- (sub-)scope. This will make sure that Cmm annotations in our scope
+-- will apply to the Cmm blocks generated therein - but not the other
+-- way around.
+tickScope :: FCode a -> FCode a
+tickScope code = do
+ info <- getInfoDown
+ if not (gopt Opt_Debug (cgd_dflags info)) then code else do
+ u <- newUnique
+ let scope' = SubScope u (cgd_tick_scope info)
+ withInfoDown code info{ cgd_tick_scope = scope' }
+
--------------------------------------------------------
-- Forking
@@ -645,6 +669,20 @@ getCodeR fcode
getCode :: FCode a -> FCode CmmAGraph
getCode fcode = do { (_,stmts) <- getCodeR fcode; return stmts }
+-- | Generate code into a fresh tick (sub-)scope and gather generated code
+getCodeScoped :: FCode a -> FCode (a, CmmAGraphScoped)
+getCodeScoped fcode
+ = do { state1 <- getState
+ ; ((a, tscope), state2) <-
+ tickScope $
+ flip withState state1 { cgs_stmts = mkNop } $
+ do { a <- fcode
+ ; scp <- getTickScope
+ ; return (a, scp) }
+ ; setState $ state2 { cgs_stmts = cgs_stmts state1 }
+ ; return (a, (cgs_stmts state2, tscope)) }
+
+
-- 'getHeapUsage' applies a function to the amount of heap that it uses.
-- It initialises the heap usage to zeros, and passes on an unchanged
-- heap usage.
@@ -675,7 +713,8 @@ emitCgStmt stmt
}
emitLabel :: BlockId -> FCode ()
-emitLabel id = emitCgStmt (CgLabel id)
+emitLabel id = do tscope <- getTickScope
+ emitCgStmt (CgLabel id tscope)
emitComment :: FastString -> FCode ()
#if 0 /* def DEBUG */
@@ -708,8 +747,8 @@ emitDecl decl
= do { state <- getState
; setState $ state { cgs_tops = cgs_tops state `snocOL` decl } }
-emitOutOfLine :: BlockId -> CmmAGraph -> FCode ()
-emitOutOfLine l stmts = emitCgStmt (CgFork l stmts)
+emitOutOfLine :: BlockId -> CmmAGraphScoped -> FCode ()
+emitOutOfLine l (stmts, tscope) = emitCgStmt (CgFork l stmts tscope)
emitProcWithStackFrame
:: Convention -- entry convention
@@ -717,7 +756,7 @@ emitProcWithStackFrame
-> CLabel -- label for the proc
-> [CmmFormal] -- stack frame
-> [CmmFormal] -- arguments
- -> CmmAGraph -- code
+ -> CmmAGraphScoped -- code
-> Bool -- do stack layout?
-> FCode ()
@@ -725,26 +764,29 @@ emitProcWithStackFrame _conv mb_info lbl _stk_args [] blocks False
= do { dflags <- getDynFlags
; emitProc_ mb_info lbl [] blocks (widthInBytes (wordWidth dflags)) False
}
-emitProcWithStackFrame conv mb_info lbl stk_args args blocks True -- do layout
+emitProcWithStackFrame conv mb_info lbl stk_args args (graph, tscope) True
+ -- do layout
= do { dflags <- getDynFlags
; let (offset, live, entry) = mkCallEntry dflags conv args stk_args
- ; emitProc_ mb_info lbl live (entry MkGraph.<*> blocks) offset True
+ graph' = entry MkGraph.<*> graph
+ ; emitProc_ mb_info lbl live (graph', tscope) offset True
}
emitProcWithStackFrame _ _ _ _ _ _ _ = panic "emitProcWithStackFrame"
emitProcWithConvention :: Convention -> Maybe CmmInfoTable -> CLabel
-> [CmmFormal]
- -> CmmAGraph
+ -> CmmAGraphScoped
-> FCode ()
emitProcWithConvention conv mb_info lbl args blocks
= emitProcWithStackFrame conv mb_info lbl [] args blocks True
-emitProc :: Maybe CmmInfoTable -> CLabel -> [GlobalReg] -> CmmAGraph -> Int -> FCode ()
+emitProc :: Maybe CmmInfoTable -> CLabel -> [GlobalReg] -> CmmAGraphScoped
+ -> Int -> FCode ()
emitProc mb_info lbl live blocks offset
= emitProc_ mb_info lbl live blocks offset True
-emitProc_ :: Maybe CmmInfoTable -> CLabel -> [GlobalReg] -> CmmAGraph -> Int -> Bool
- -> FCode ()
+emitProc_ :: Maybe CmmInfoTable -> CLabel -> [GlobalReg] -> CmmAGraphScoped
+ -> Int -> Bool -> FCode ()
emitProc_ mb_info lbl live blocks offset do_layout
= do { dflags <- getDynFlags
; l <- newLabelC
@@ -779,24 +821,27 @@ getCmm code
mkCmmIfThenElse :: CmmExpr -> CmmAGraph -> CmmAGraph -> FCode CmmAGraph
mkCmmIfThenElse e tbranch fbranch = do
+ tscp <- getTickScope
endif <- newLabelC
tid <- newLabelC
fid <- newLabelC
- return $ mkCbranch e tid fid MkGraph.<*>
- mkLabel tid MkGraph.<*> tbranch MkGraph.<*> mkBranch endif MkGraph.<*>
- mkLabel fid MkGraph.<*> fbranch MkGraph.<*> mkLabel endif
+ return $ catAGraphs [ mkCbranch e tid fid
+ , mkLabel tid tscp, tbranch, mkBranch endif
+ , mkLabel fid tscp, fbranch, mkLabel endif tscp ]
mkCmmIfGoto :: CmmExpr -> BlockId -> FCode CmmAGraph
mkCmmIfGoto e tid = do
endif <- newLabelC
- return $ mkCbranch e tid endif MkGraph.<*> mkLabel endif
+ tscp <- getTickScope
+ return $ catAGraphs [ mkCbranch e tid endif, mkLabel endif tscp ]
mkCmmIfThen :: CmmExpr -> CmmAGraph -> FCode CmmAGraph
mkCmmIfThen e tbranch = do
endif <- newLabelC
tid <- newLabelC
- return $ mkCbranch e tid endif MkGraph.<*>
- mkLabel tid MkGraph.<*> tbranch MkGraph.<*> mkLabel endif
+ tscp <- getTickScope
+ return $ catAGraphs [ mkCbranch e tid endif
+ , mkLabel tid tscp, tbranch, mkLabel endif tscp ]
mkCall :: CmmExpr -> (Convention, Convention) -> [CmmFormal] -> [CmmActual]
@@ -804,10 +849,11 @@ mkCall :: CmmExpr -> (Convention, Convention) -> [CmmFormal] -> [CmmActual]
mkCall f (callConv, retConv) results actuals updfr_off extra_stack = do
dflags <- getDynFlags
k <- newLabelC
+ tscp <- getTickScope
let area = Young k
(off, _, copyin) = copyInOflow dflags retConv area results []
copyout = mkCallReturnsTo dflags f callConv actuals k off updfr_off extra_stack
- return (copyout MkGraph.<*> mkLabel k MkGraph.<*> copyin)
+ return $ catAGraphs [copyout, mkLabel k tscp, copyin]
mkCmmCall :: CmmExpr -> [CmmFormal] -> [CmmActual] -> UpdFrameOffset
-> FCode CmmAGraph
@@ -818,7 +864,7 @@ mkCmmCall f results actuals updfr_off
-- ----------------------------------------------------------------------------
-- turn CmmAGraph into CmmGraph, for making a new proc.
-aGraphToGraph :: CmmAGraph -> FCode CmmGraph
+aGraphToGraph :: CmmAGraphScoped -> FCode CmmGraph
aGraphToGraph stmts
= do { l <- newLabelC
; return (labelAGraph l stmts) }
diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs
index d47a01661a..5e8944df4a 100644
--- a/compiler/codeGen/StgCmmUtils.hs
+++ b/compiler/codeGen/StgCmmUtils.hs
@@ -453,11 +453,12 @@ mustFollow :: Stmt -> Stmt -> Bool
-------------------------------------------------------------------------
-emitSwitch :: CmmExpr -- Tag to switch on
- -> [(ConTagZ, CmmAGraph)] -- Tagged branches
- -> Maybe CmmAGraph -- Default branch (if any)
- -> ConTagZ -> ConTagZ -- Min and Max possible values; behaviour
- -- outside this range is undefined
+emitSwitch :: CmmExpr -- Tag to switch on
+ -> [(ConTagZ, CmmAGraphScoped)] -- Tagged branches
+ -> Maybe CmmAGraphScoped -- Default branch (if any)
+ -> ConTagZ -> ConTagZ -- Min and Max possible values;
+ -- behaviour outside this range is
+ -- undefined
-> FCode ()
emitSwitch tag_expr branches mb_deflt lo_tag hi_tag
= do { dflags <- getDynFlags
@@ -467,18 +468,19 @@ emitSwitch tag_expr branches mb_deflt lo_tag hi_tag
| otherwise = False
-mkCmmSwitch :: Bool -- True <=> never generate a
- -- conditional tree
- -> CmmExpr -- Tag to switch on
- -> [(ConTagZ, CmmAGraph)] -- Tagged branches
- -> Maybe CmmAGraph -- Default branch (if any)
- -> ConTagZ -> ConTagZ -- Min and Max possible values; behaviour
- -- outside this range is undefined
+mkCmmSwitch :: Bool -- True <=> never generate a
+ -- conditional tree
+ -> CmmExpr -- Tag to switch on
+ -> [(ConTagZ, CmmAGraphScoped)] -- Tagged branches
+ -> Maybe CmmAGraphScoped -- Default branch (if any)
+ -> ConTagZ -> ConTagZ -- Min and Max possible values;
+ -- behaviour outside this range is
+ -- undefined
-> FCode ()
-- First, two rather common cases in which there is no work to do
-mkCmmSwitch _ _ [] (Just code) _ _ = emit code
-mkCmmSwitch _ _ [(_,code)] Nothing _ _ = emit code
+mkCmmSwitch _ _ [] (Just code) _ _ = emit (fst code)
+mkCmmSwitch _ _ [(_,code)] Nothing _ _ = emit (fst code)
-- Right, off we go
mkCmmSwitch via_C tag_expr branches mb_deflt lo_tag hi_tag = do
@@ -634,17 +636,17 @@ mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C
is_lo (t,_) = t < mid_tag
--------------
-emitCmmLitSwitch :: CmmExpr -- Tag to switch on
- -> [(Literal, CmmAGraph)] -- Tagged branches
- -> CmmAGraph -- Default branch (always)
- -> FCode () -- Emit the code
+emitCmmLitSwitch :: CmmExpr -- Tag to switch on
+ -> [(Literal, CmmAGraphScoped)] -- Tagged branches
+ -> CmmAGraphScoped -- Default branch (always)
+ -> FCode () -- Emit the code
-- Used for general literals, whose size might not be a word,
-- where there is always a default case, and where we don't know
-- the range of values for certain. For simplicity we always generate a tree.
--
-- ToDo: for integers we could do better here, perhaps by generalising
-- mk_switch and using that. --SDM 15/09/2004
-emitCmmLitSwitch _scrut [] deflt = emit deflt
+emitCmmLitSwitch _scrut [] deflt = emit $ fst deflt
emitCmmLitSwitch scrut branches deflt = do
scrut' <- assignTemp' scrut
join_lbl <- newLabelC
@@ -685,7 +687,7 @@ mk_lit_switch scrut deflt_blk_id branches
--------------
-label_default :: BlockId -> Maybe CmmAGraph -> FCode (Maybe BlockId)
+label_default :: BlockId -> Maybe CmmAGraphScoped -> FCode (Maybe BlockId)
label_default _ Nothing
= return Nothing
label_default join_lbl (Just code)
@@ -693,7 +695,7 @@ label_default join_lbl (Just code)
return (Just lbl)
--------------
-label_branches :: BlockId -> [(a,CmmAGraph)] -> FCode [(a,BlockId)]
+label_branches :: BlockId -> [(a,CmmAGraphScoped)] -> FCode [(a,BlockId)]
label_branches _join_lbl []
= return []
label_branches join_lbl ((tag,code):branches)
@@ -702,14 +704,14 @@ label_branches join_lbl ((tag,code):branches)
return ((tag,lbl):branches')
--------------
-label_code :: BlockId -> CmmAGraph -> FCode BlockId
+label_code :: BlockId -> CmmAGraphScoped -> FCode BlockId
-- label_code J code
-- generates
-- [L: code; goto J]
-- and returns L
-label_code join_lbl code = do
+label_code join_lbl (code,tsc) = do
lbl <- newLabelC
- emitOutOfLine lbl (code MkGraph.<*> mkBranch join_lbl)
+ emitOutOfLine lbl (code MkGraph.<*> mkBranch join_lbl, tsc)
return lbl
--------------
diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
index 42498fcefb..5a2f90acaf 100644
--- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
+++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
@@ -74,7 +74,8 @@ basicBlocksCodeGen live (entryBlock:cmmBlocks)
-- | Generate code for one block
basicBlockCodeGen :: CmmBlock -> LlvmM ( LlvmBasicBlock, [LlvmCmmDecl] )
basicBlockCodeGen block
- = do let (CmmEntry id, nodes, tail) = blockSplit block
+ = do let (_, nodes, tail) = blockSplit block
+ id = entryLabel block
(mid_instrs, top) <- stmtsToInstrs $ blockToList nodes
(tail_instrs, top') <- stmtToInstrs tail
let instrs = fromOL (mid_instrs `appOL` tail_instrs)
diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs
index 30f04e243e..c04814d2fe 100644
--- a/compiler/nativeGen/PPC/CodeGen.hs
+++ b/compiler/nativeGen/PPC/CodeGen.hs
@@ -95,7 +95,8 @@ basicBlockCodeGen
, [NatCmmDecl CmmStatics Instr])
basicBlockCodeGen block = do
- let (CmmEntry id, nodes, tail) = blockSplit block
+ let (_, nodes, tail) = blockSplit block
+ id = entryLabel block
stmts = blockToList nodes
mid_instrs <- stmtsToInstrs stmts
tail_instrs <- stmtToInstrs tail
diff --git a/compiler/nativeGen/SPARC/CodeGen.hs b/compiler/nativeGen/SPARC/CodeGen.hs
index 836ba70f90..14855ed7fd 100644
--- a/compiler/nativeGen/SPARC/CodeGen.hs
+++ b/compiler/nativeGen/SPARC/CodeGen.hs
@@ -87,7 +87,8 @@ basicBlockCodeGen :: CmmBlock
, [NatCmmDecl CmmStatics Instr])
basicBlockCodeGen block = do
- let (CmmEntry id, nodes, tail) = blockSplit block
+ let (_, nodes, tail) = blockSplit block
+ id = entryLabel block
stmts = blockToList nodes
mid_instrs <- stmtsToInstrs stmts
tail_instrs <- stmtToInstrs tail
diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs
index 9e705c87f9..7c0ba2d4da 100644
--- a/compiler/nativeGen/X86/CodeGen.hs
+++ b/compiler/nativeGen/X86/CodeGen.hs
@@ -111,7 +111,8 @@ basicBlockCodeGen
, [NatCmmDecl (Alignment, CmmStatics) Instr])
basicBlockCodeGen block = do
- let (CmmEntry id, nodes, tail) = blockSplit block
+ let (_, nodes, tail) = blockSplit block
+ id = entryLabel block
stmts = blockToList nodes
mid_instrs <- stmtsToInstrs stmts
tail_instrs <- stmtToInstrs tail
View Lorry Controller Status