summaryrefslogtreecommitdiff
path: root/compiler/cmm
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/cmm')
-rw-r--r--compiler/cmm/CmmCommonBlockElim.hs35
-rw-r--r--compiler/cmm/CmmLint.hs1
-rw-r--r--compiler/cmm/CmmNode.hs14
-rw-r--r--compiler/cmm/CmmParse.y30
-rw-r--r--compiler/cmm/CmmUtils.hs20
-rw-r--r--compiler/cmm/PprC.hs2
-rw-r--r--compiler/cmm/PprCmm.hs10
7 files changed, 98 insertions, 14 deletions
diff --git a/compiler/cmm/CmmCommonBlockElim.hs b/compiler/cmm/CmmCommonBlockElim.hs
index 34e22cecfb..e8fc5da50e 100644
--- a/compiler/cmm/CmmCommonBlockElim.hs
+++ b/compiler/cmm/CmmCommonBlockElim.hs
@@ -13,8 +13,10 @@ import Prelude hiding (iterate, succ, unzip, zip)
import Hoopl hiding (ChangeFlag)
import Data.Bits
+import Data.Maybe (fromJust)
import qualified Data.List as List
import Data.Word
+import qualified Data.Map as M
import Outputable
import UniqFM
@@ -37,7 +39,7 @@ my_trace = if False then pprTrace else \_ _ a -> a
-- TODO: Use optimization fuel
elimCommonBlocks :: CmmGraph -> CmmGraph
-elimCommonBlocks g = replaceLabels env g
+elimCommonBlocks g = replaceLabels env $ copyTicks env g
where
env = iterate hashed_blocks mapEmpty
hashed_blocks = map (\b -> (hash_block b, b)) $ postorderDfs g
@@ -89,7 +91,7 @@ hash_block block =
hash_lst m h = hash_node m + h `shiftL` 1
hash_node :: CmmNode O x -> Word32
- hash_node (CmmComment _) = 0 -- don't care
+ hash_node n | dont_care n = 0 -- don't care
hash_node (CmmAssign r e) = hash_reg r + hash_e e
hash_node (CmmStore e e') = hash_e e + hash_e e'
hash_node (CmmUnsafeForeignCall t _ as) = hash_tgt t + hash_list hash_e as
@@ -98,6 +100,7 @@ hash_block block =
hash_node (CmmCall e _ _ _ _ _) = hash_e e
hash_node (CmmForeignCall t _ _ _ _ _ _) = hash_tgt t
hash_node (CmmSwitch e _) = hash_e e
+ hash_node _ = error "hash_node: unknown Cmm node!"
hash_reg :: CmmReg -> Word32
hash_reg (CmmLocal _) = 117
@@ -127,6 +130,13 @@ hash_block block =
hash_list f = foldl (\z x -> f x + z) (0::Word32)
cvt = fromInteger . toInteger
+
+-- | Ignore these node types for equality
+dont_care :: CmmNode O x -> Bool
+dont_care CmmComment {} = True
+dont_care CmmTick {} = True
+dont_care _other = False
+
-- Utilities: equality and substitution on the graph.
-- Given a map ``subst'' from BlockID -> BlockID, we define equality.
@@ -143,7 +153,6 @@ lookupBid subst bid = case mapLookup bid subst of
--
eqMiddleWith :: (BlockId -> BlockId -> Bool)
-> CmmNode O O -> CmmNode O O -> Bool
-eqMiddleWith _ (CmmComment _) (CmmComment _) = True
eqMiddleWith eqBid (CmmAssign r1 e1) (CmmAssign r2 e2)
= r1 == r2 && eqExprWith eqBid e1 e2
eqMiddleWith eqBid (CmmStore l1 r1) (CmmStore l2 r2)
@@ -178,10 +187,12 @@ eqExprWith eqBid = eq
-- IDs to block IDs.
eqBlockBodyWith :: (BlockId -> BlockId -> Bool) -> CmmBlock -> CmmBlock -> Bool
eqBlockBodyWith eqBid block block'
- = and (zipWith (eqMiddleWith eqBid) (blockToList m) (blockToList m')) &&
+ = and (zipWith (eqMiddleWith eqBid) nodes nodes') &&
eqLastWith eqBid l l'
where (_,m,l) = blockSplit block
+ nodes = filter (not . dont_care) (blockToList m)
(_,m',l') = blockSplit block'
+ nodes' = filter (not . dont_care) (blockToList m')
@@ -202,3 +213,19 @@ eqMaybeWith :: (a -> b -> Bool) -> Maybe a -> Maybe b -> Bool
eqMaybeWith eltEq (Just e) (Just e') = eltEq e e'
eqMaybeWith _ Nothing Nothing = True
eqMaybeWith _ _ _ = False
+
+-- | Given a block map, ensure that all "target" blocks are covered by
+-- the same ticks as the respective "source" blocks. This not only
+-- means copying ticks, but also adjusting tick scopes where
+-- necessary.
+copyTicks :: BlockEnv BlockId -> CmmGraph -> CmmGraph
+copyTicks env g
+ | mapNull env = g
+ | otherwise = ofBlockMap (g_entry g) $ mapMap f blockMap
+ where 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
+ Nothing -> block
+ Just ls -> let findTicks l = blockTicks $ fromJust $ mapLookup l blockMap
+ in annotateBlock (concatMap findTicks ls) block
diff --git a/compiler/cmm/CmmLint.hs b/compiler/cmm/CmmLint.hs
index d329243ad7..4ab726ea87 100644
--- a/compiler/cmm/CmmLint.hs
+++ b/compiler/cmm/CmmLint.hs
@@ -140,6 +140,7 @@ notNodeReg _ = True
lintCmmMiddle :: CmmNode O O -> CmmLint ()
lintCmmMiddle node = case node of
CmmComment _ -> return ()
+ CmmTick _ -> return ()
CmmAssign reg expr -> do
dflags <- getDynFlags
diff --git a/compiler/cmm/CmmNode.hs b/compiler/cmm/CmmNode.hs
index 7eb2b61d9a..50268ee8be 100644
--- a/compiler/cmm/CmmNode.hs
+++ b/compiler/cmm/CmmNode.hs
@@ -10,7 +10,7 @@
-- CmmNode type for representation using Hoopl graphs.
module CmmNode (
- CmmNode(..), CmmFormal, CmmActual,
+ CmmNode(..), CmmFormal, CmmActual, CmmTickish,
UpdFrameOffset, Convention(..),
ForeignConvention(..), ForeignTarget(..), foreignTargetHints,
CmmReturnInfo(..),
@@ -24,6 +24,7 @@ import DynFlags
import FastString
import ForeignCall
import SMRep
+import CoreSyn (Tickish)
import Compiler.Hoopl
import Data.Maybe
@@ -41,6 +42,10 @@ data CmmNode e x where
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@).
+ CmmTick :: !CmmTickish -> CmmNode O O
+
CmmAssign :: !CmmReg -> !CmmExpr -> CmmNode O O
-- Assign to register
@@ -437,6 +442,7 @@ wrapRecExp f e = f e
mapExp :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
mapExp _ f@(CmmEntry _) = f
mapExp _ m@(CmmComment _) = m
+mapExp _ m@(CmmTick _) = m
mapExp f (CmmAssign r e) = CmmAssign r (f e)
mapExp f (CmmStore addr e) = CmmStore (f addr) (f e)
mapExp f (CmmUnsafeForeignCall tgt fs as) = CmmUnsafeForeignCall (mapForeignTarget f tgt) fs (map f as)
@@ -466,6 +472,7 @@ wrapRecExpM f e = f e
mapExpM :: (CmmExpr -> Maybe CmmExpr) -> CmmNode e x -> Maybe (CmmNode e x)
mapExpM _ (CmmEntry _) = Nothing
mapExpM _ (CmmComment _) = Nothing
+mapExpM _ (CmmTick _) = Nothing
mapExpM f (CmmAssign r e) = CmmAssign r `fmap` f e
mapExpM f (CmmStore addr e) = (\[addr', e'] -> CmmStore addr' e') `fmap` mapListM f [addr, e]
mapExpM _ (CmmBranch _) = Nothing
@@ -517,6 +524,7 @@ wrapRecExpf f e z = f e z
foldExp :: (CmmExpr -> z -> z) -> CmmNode e x -> z -> z
foldExp _ (CmmEntry {}) z = z
foldExp _ (CmmComment {}) z = z
+foldExp _ (CmmTick {}) z = z
foldExp f (CmmAssign _ e) z = f e z
foldExp f (CmmStore addr e) z = f addr $ f e z
foldExp f (CmmUnsafeForeignCall t _ as) z = foldr f (foldExpForeignTarget f t z) as
@@ -537,3 +545,7 @@ mapSuccessors f (CmmCondBranch p y n) = CmmCondBranch p (f y) (f n)
mapSuccessors f (CmmSwitch e arms) = CmmSwitch e (map (fmap f) arms)
mapSuccessors _ n = n
+-- -----------------------------------------------------------------------------
+
+-- | Tickish in Cmm context (annotations only)
+type CmmTickish = Tickish ()
diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y
index 803333001c..0973e306b0 100644
--- a/compiler/cmm/CmmParse.y
+++ b/compiler/cmm/CmmParse.y
@@ -220,6 +220,7 @@ import StgCmmClosure
import StgCmmLayout hiding (ArgRep(..))
import StgCmmTicky
import StgCmmBind ( emitBlackHoleCode, emitUpdateFrame )
+import CoreSyn ( Tickish(SourceNote) )
import CmmOpt
import MkGraph
@@ -430,8 +431,10 @@ cmmproc :: { CmmParse () }
{ do ((entry_ret_label, info, stk_formals, formals), agraph) <-
getCodeR $ loopDecls $ do {
(entry_ret_label, info, stk_formals) <- $1;
+ dflags <- getDynFlags;
formals <- sequence (fromMaybe [] $3);
- $4;
+ withName (showSDoc dflags (ppr entry_ret_label))
+ $4;
return (entry_ret_label, info, stk_formals, formals) }
let do_layout = isJust $3
code (emitProcWithStackFrame $2 info
@@ -444,7 +447,7 @@ maybe_conv :: { Convention }
maybe_body :: { CmmParse () }
: ';' { return () }
- | '{' body '}' { $2 }
+ | '{' body '}' { withSourceNote $1 $3 $2 }
info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
: NAME
@@ -626,7 +629,7 @@ stmt :: { CmmParse () }
| 'if' bool_expr 'goto' NAME
{ do l <- lookupLabel $4; cmmRawIf $2 l }
| 'if' bool_expr '{' body '}' else
- { cmmIfThenElse $2 $4 $6 }
+ { cmmIfThenElse $2 (withSourceNote $3 $5 $4) $6 }
| 'push' '(' exprs0 ')' maybe_body
{ pushStackFrame $3 $5 }
| 'reserve' expr '=' lreg maybe_body
@@ -679,7 +682,7 @@ arm :: { CmmParse ([Int],Either BlockId (CmmParse ())) }
: 'case' ints ':' arm_body { do b <- $4; return ($2, b) }
arm_body :: { CmmParse (Either BlockId (CmmParse ())) }
- : '{' body '}' { return (Right $2) }
+ : '{' body '}' { return (Right (withSourceNote $1 $3 $2)) }
| 'goto' NAME ';' { do l <- lookupLabel $2; return (Left l) }
ints :: { [Int] }
@@ -687,7 +690,7 @@ ints :: { [Int] }
| INT ',' ints { fromIntegral $1 : $3 }
default :: { Maybe (CmmParse ()) }
- : 'default' ':' '{' body '}' { Just $4 }
+ : 'default' ':' '{' body '}' { Just (withSourceNote $3 $5 $4) }
-- taking a few liberties with the C-- syntax here; C-- doesn't have
-- 'default' branches
| {- empty -} { Nothing }
@@ -696,7 +699,7 @@ default :: { Maybe (CmmParse ()) }
-- CmmNode does.
else :: { CmmParse () }
: {- empty -} { return () }
- | 'else' '{' body '}' { $3 }
+ | 'else' '{' body '}' { withSourceNote $2 $4 $3 }
-- we have to write this out longhand so that Happy's precedence rules
-- can kick in.
@@ -1275,6 +1278,18 @@ emitCond (e1 `BoolAnd` e2) then_id = do
emitCond e2 then_id
emitLabel else_id
+-- -----------------------------------------------------------------------------
+-- Source code notes
+
+-- | Generate a source note spanning from "a" to "b" (inclusive), then
+-- proceed with parsing. This allows debugging tools to reason about
+-- locations in Cmm code.
+withSourceNote :: Located a -> Located b -> CmmParse c -> CmmParse c
+withSourceNote a b parse = do
+ name <- getName
+ case combineSrcSpans (getLoc a) (getLoc b) of
+ RealSrcSpan span -> code (emitTick (SourceNote span name)) >> parse
+ _other -> parse
-- -----------------------------------------------------------------------------
-- Table jumps
@@ -1354,7 +1369,8 @@ parseCmmFile dflags filename = do
return ((emptyBag, unitBag msg), Nothing)
POk pst code -> do
st <- initC
- let (cmm,_) = runC dflags no_module st (getCmm (unEC code (initEnv dflags) [] >> return ()))
+ let fcode = getCmm $ unEC code "global" (initEnv dflags) [] >> return ()
+ (cmm,_) = runC dflags no_module st fcode
let ms = getMessages pst
if (errorsFound dflags ms)
then return (ms, Nothing)
diff --git a/compiler/cmm/CmmUtils.hs b/compiler/cmm/CmmUtils.hs
index 1f6d1ac0e3..043ccf0ff5 100644
--- a/compiler/cmm/CmmUtils.hs
+++ b/compiler/cmm/CmmUtils.hs
@@ -55,7 +55,10 @@ module CmmUtils(
analFwd, analBwd, analRewFwd, analRewBwd,
dataflowPassFwd, dataflowPassBwd, dataflowAnalFwd, dataflowAnalBwd,
- dataflowAnalFwdBlocks
+ dataflowAnalFwdBlocks,
+
+ -- * Ticks
+ blockTicks, annotateBlock
) where
#include "HsVersions.h"
@@ -567,3 +570,18 @@ dataflowPassBwd :: NonLocal n =>
dataflowPassBwd (CmmGraph {g_entry=entry, g_graph=graph}) facts bwd = do
(graph, facts, NothingO) <- analyzeAndRewriteBwd bwd (JustC [entry]) graph (mkFactBase (bp_lattice bwd) facts)
return (CmmGraph {g_entry=entry, g_graph=graph}, facts)
+
+-------------------------------------------------
+-- Tick utilities
+
+-- | Extract all tick annotations from the given block
+blockTicks :: Block CmmNode C C -> [CmmTickish]
+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/PprC.hs b/compiler/cmm/PprC.hs
index 23d23ff9bb..d808341304 100644
--- a/compiler/cmm/PprC.hs
+++ b/compiler/cmm/PprC.hs
@@ -178,6 +178,8 @@ pprStmt stmt =
-- some debugging option is on. They can get quite
-- large.
+ CmmTick _ -> empty
+
CmmAssign dest src -> pprAssign dflags dest src
CmmStore dest src
diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs
index cc3124028a..f350a8a5f9 100644
--- a/compiler/cmm/PprCmm.hs
+++ b/compiler/cmm/PprCmm.hs
@@ -43,11 +43,13 @@ import BlockId ()
import CLabel
import Cmm
import CmmUtils
+import DynFlags
import FastString
import Outputable
import PprCmmDecl
import PprCmmExpr
import Util
+import PprCore ()
import BasicTypes
import Compiler.Hoopl
@@ -179,13 +181,18 @@ pprNode :: CmmNode e x -> SDoc
pprNode node = pp_node <+> pp_debug
where
pp_node :: SDoc
- pp_node = case node of
+ pp_node = sdocWithDynFlags $ \dflags -> case node of
-- label:
CmmEntry id -> ppr id <> colon
-- // text
CmmComment s -> text "//" <+> ftext s
+ -- //tick bla<...>
+ CmmTick t -> if gopt Opt_PprShowTicks dflags
+ then ptext (sLit "//tick") <+> ppr t
+ else empty
+
-- reg = expr;
CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
@@ -268,6 +275,7 @@ pprNode node = pp_node <+> pp_debug
else case node of
CmmEntry {} -> empty -- Looks terrible with text " // CmmEntry"
CmmComment {} -> empty -- Looks also terrible with text " // CmmComment"
+ CmmTick {} -> empty
CmmAssign {} -> text " // CmmAssign"
CmmStore {} -> text " // CmmStore"
CmmUnsafeForeignCall {} -> text " // CmmUnsafeForeignCall"
View Lorry Controller Status