Commit 7ceaf96f authored by Peter Wortmann's avatar Peter Wortmann Committed by Austin Seipp

Source notes (Cmm support)

This patch adds CmmTick nodes to Cmm code. This is relatively
straight-forward, but also not very useful, as many blocks will simply
end up with no annotations whatosever.

Notes:

* We use this design over, say, putting ticks into the entry node of all
  blocks, as it seems to work better alongside existing optimisations.
  Now granted, the reason for this is that currently GHC's main Cmm
  optimisations seem to mainly reorganize and merge code, so this might
  change in the future.

* We have the Cmm parser generate a few source notes as well. This is
  relatively easy to do - worst part is that it complicates the CmmParse
  implementation a bit.

(From Phabricator D169)
parent a0895fcb
......@@ -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
......@@ -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
......
......@@ -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 ()
......@@ -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)
......
......@@ -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
......@@ -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
......
......@@ -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"
......
......@@ -863,5 +863,6 @@ cgTick tick
; case tick of
ProfNote cc t p -> emitSetCCC cc t p
HpcTick m n -> emit (mkTickBox dflags m n)
SourceNote s n -> emitTick $ SourceNote s n
_other -> return () -- ignore
}
......@@ -18,6 +18,9 @@ module StgCmmExtCode (
loopDecls,
getEnv,
withName,
getName,
newLocal,
newLabel,
newBlockId,
......@@ -72,15 +75,15 @@ type Decls = [(FastString,Named)]
-- | Does a computation in the FCode monad, with a current environment
-- and a list of local declarations. Returns the resulting list of declarations.
newtype CmmParse a
= EC { unEC :: Env -> Decls -> FCode (Decls, a) }
= EC { unEC :: String -> Env -> Decls -> FCode (Decls, a) }
type ExtCode = CmmParse ()
returnExtFC :: a -> CmmParse a
returnExtFC a = EC $ \_ s -> return (s, a)
returnExtFC a = EC $ \_ _ s -> return (s, a)
thenExtFC :: CmmParse a -> (a -> CmmParse b) -> CmmParse b
thenExtFC (EC m) k = EC $ \e s -> do (s',r) <- m e s; unEC (k r) e s'
thenExtFC (EC m) k = EC $ \c e s -> do (s',r) <- m c e s; unEC (k r) c e s'
instance Functor CmmParse where
fmap = liftM
......@@ -94,8 +97,8 @@ instance Monad CmmParse where
return = returnExtFC
instance HasDynFlags CmmParse where
getDynFlags = EC (\_ d -> do dflags <- getDynFlags
return (d, dflags))
getDynFlags = EC (\_ _ d -> do dflags <- getDynFlags
return (d, dflags))
-- | Takes the variable decarations and imports from the monad
......@@ -106,18 +109,25 @@ instance HasDynFlags CmmParse where
--
loopDecls :: CmmParse a -> CmmParse a
loopDecls (EC fcode) =
EC $ \e globalDecls -> do
(_, a) <- F.fixC (\ ~(decls, _) -> fcode (addListToUFM e decls) globalDecls)
EC $ \c e globalDecls -> do
(_, a) <- F.fixC (\ ~(decls, _) -> fcode c (addListToUFM e decls) globalDecls)
return (globalDecls, a)
-- | Get the current environment from the monad.
getEnv :: CmmParse Env
getEnv = EC $ \e s -> return (s, e)
getEnv = EC $ \_ e s -> return (s, e)
-- | Get the current context name from the monad
getName :: CmmParse String
getName = EC $ \c _ s -> return (s, c)
-- | Set context name for a sub-parse
withName :: String -> CmmParse a -> CmmParse a
withName c' (EC fcode) = EC $ \_ e s -> fcode c' e s
addDecl :: FastString -> Named -> ExtCode
addDecl name named = EC $ \_ s -> return ((name, named) : s, ())
addDecl name named = EC $ \_ _ s -> return ((name, named) : s, ())
-- | Add a new variable to the list of local declarations.
......@@ -201,7 +211,7 @@ lookupName name = do
-- | Lift an FCode computation into the CmmParse monad
code :: FCode a -> CmmParse a
code fc = EC $ \_ s -> do
code fc = EC $ \_ _ s -> do
r <- fc
return (s, r)
......@@ -218,13 +228,13 @@ emitStore :: CmmExpr -> CmmExpr -> CmmParse ()
emitStore l r = code (F.emitStore l r)
getCode :: CmmParse a -> CmmParse CmmAGraph
getCode (EC ec) = EC $ \e s -> do
((s',_), gr) <- F.getCodeR (ec e s)
getCode (EC ec) = EC $ \c e s -> do
((s',_), gr) <- F.getCodeR (ec c e s)
return (s', gr)
getCodeR :: CmmParse a -> CmmParse (a, CmmAGraph)
getCodeR (EC ec) = EC $ \e s -> do
((s', r), gr) <- F.getCodeR (ec e s)
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 ()
......@@ -232,7 +242,7 @@ emitOutOfLine l g = code (F.emitOutOfLine l g)
withUpdFrameOff :: UpdFrameOffset -> CmmParse () -> CmmParse ()
withUpdFrameOff size inner
= EC $ \e s -> F.withUpdFrameOff size $ (unEC inner) e s
= EC $ \c e s -> F.withUpdFrameOff size $ (unEC inner) c e s
getUpdFrameOff :: CmmParse UpdFrameOffset
getUpdFrameOff = code $ F.getUpdFrameOff
......@@ -20,6 +20,7 @@ module StgCmmMonad (
emit, emitDecl, emitProc,
emitProcWithConvention, emitProcWithStackFrame,
emitOutOfLine, emitAssign, emitStore, emitComment,
emitTick,
getCmm, aGraphToGraph,
getCodeR, getCode, getHeapUsage,
......@@ -683,6 +684,9 @@ emitComment s = emitCgStmt (CgStmt (CmmComment s))
emitComment _ = return ()
#endif
emitTick :: CmmTickish -> FCode ()
emitTick = emitCgStmt . CgStmt . CmmTick
emitAssign :: CmmReg -> CmmExpr -> FCode ()
emitAssign l r = emitCgStmt (CgStmt (CmmAssign l r))
......
......@@ -494,7 +494,6 @@ data Tickish id =
deriving (Eq, Ord, Data, Typeable)
-- | A "counting tick" (where tickishCounts is True) is one that
-- counts evaluations in some way. We cannot discard a counting tick,
-- and the compiler should preserve the number of counting ticks as
......
......@@ -102,6 +102,7 @@ stmtToInstrs :: CmmNode e x -> LlvmM StmtData
stmtToInstrs stmt = case stmt of
CmmComment _ -> return (nilOL, []) -- nuke comments
CmmTick _ -> return (nilOL, [])
CmmAssign reg src -> genAssign reg src
CmmStore addr src -> genStore addr src
......
......@@ -125,6 +125,7 @@ stmtToInstrs stmt = do
dflags <- getDynFlags
case stmt of
CmmComment s -> return (unitOL (COMMENT s))
CmmTick {} -> return nilOL
CmmAssign reg src
| isFloatType ty -> assignReg_FltCode size reg src
......
......@@ -125,6 +125,7 @@ stmtToInstrs stmt = do
dflags <- getDynFlags
case stmt of
CmmComment s -> return (unitOL (COMMENT s))
CmmTick {} -> return nilOL
CmmAssign reg src
| isFloatType ty -> assignReg_FltCode size reg src
......
......@@ -144,6 +144,7 @@ stmtToInstrs stmt = do
is32Bit <- is32BitPlatform
case stmt of
CmmComment s -> return (unitOL (COMMENT s))
CmmTick {} -> return nilOL
CmmAssign reg src
| isFloatType ty -> assignReg_FltCode size reg src
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment