module Debug (
DebugBlock(..), dblIsEntry,
UnwindTable, UnwindExpr(..),
cmmDebugGen,
cmmDebugLabels,
cmmDebugLink,
debugToMap
) where
import BlockId ( blockLbl )
import CLabel
import Cmm
import CmmUtils
import CoreSyn
import FastString ( nilFS, mkFastString )
import Module
import Outputable
import PprCore ()
import PprCmmExpr ( pprExpr )
import SrcLoc
import Util
import Compiler.Hoopl
import Data.Maybe
import Data.List ( minimumBy, nubBy )
import Data.Ord ( comparing )
import qualified Data.Map as Map
data DebugBlock =
DebugBlock
{ dblProcedure :: !Label
, dblLabel :: !Label
, dblCLabel :: !CLabel
, dblHasInfoTbl :: !Bool
, dblParent :: !(Maybe DebugBlock)
, dblTicks :: ![CmmTickish]
, dblSourceTick
:: !(Maybe CmmTickish)
, dblPosition :: !(Maybe Int)
, dblUnwind :: !UnwindTable
, dblBlocks :: ![DebugBlock]
}
dblIsEntry :: DebugBlock -> Bool
dblIsEntry blk = dblProcedure blk == dblLabel blk
instance Outputable DebugBlock where
ppr blk = (if dblProcedure blk == dblLabel blk
then text "proc "
else if dblHasInfoTbl blk
then text "pp-blk "
else text "blk ") <>
ppr (dblLabel blk) <+> parens (ppr (dblCLabel blk)) <+>
(maybe empty ppr (dblSourceTick blk)) <+>
(maybe (text "removed") ((text "pos " <>) . ppr)
(dblPosition blk)) <+>
pprUwMap (dblUnwind blk) $$
(if null (dblBlocks blk) then empty else ppr (dblBlocks blk))
where pprUw (g, expr) = ppr g <> char '=' <> ppr expr
pprUwMap = braces . hsep . punctuate comma . map pprUw . Map.toList
type BlockContext = (CmmBlock, RawCmmDecl, UnwindTable)
cmmDebugGen :: ModLocation -> RawCmmGroup -> [DebugBlock]
cmmDebugGen modLoc decls = map (blocksForScope Nothing) topScopes
where
blockCtxs :: Map.Map CmmTickScope [BlockContext]
blockCtxs = blockContexts decls
(topScopes, childScopes)
= splitEithers $ map (\a -> findP a a) $ Map.keys blockCtxs
findP tsc GlobalScope = Left tsc
findP tsc scp | scp' `Map.member` blockCtxs = Right (scp', tsc)
| otherwise = findP tsc scp'
where
scp' | SubScope _ scp' <- scp = scp'
| CombinedScope scp' _ <- scp = scp'
| otherwise = panic "findP impossible"
scopeMap = foldr (uncurry insertMulti) Map.empty childScopes
ticksToCopy :: CmmTickScope -> [CmmTickish]
ticksToCopy (CombinedScope scp s) = go s
where go s | scp `isTickSubScope` s = []
| SubScope _ s' <- s = ticks ++ go s'
| CombinedScope s1 s2 <- s = ticks ++ go s1 ++ go s2
| otherwise = panic "ticksToCopy impossible"
where ticks = bCtxsTicks $ fromMaybe [] $ Map.lookup s blockCtxs
ticksToCopy _ = []
bCtxsTicks = concatMap (blockTicks . fstOf3)
bestSrcTick = minimumBy (comparing rangeRating)
rangeRating (SourceNote span _)
| srcSpanFile span == thisFile = 1
| otherwise = 2 :: Int
rangeRating note = pprPanic "rangeRating" (ppr note)
thisFile = maybe nilFS mkFastString $ ml_hs_file modLoc
blocksForScope :: Maybe CmmTickish -> CmmTickScope -> DebugBlock
blocksForScope cstick scope = mkBlock True (head bctxs)
where bctxs = fromJust $ Map.lookup scope blockCtxs
nested = fromMaybe [] $ Map.lookup scope scopeMap
childs = map (mkBlock False) (tail bctxs) ++
map (blocksForScope stick) nested
mkBlock top (block, prc, unwind)
= DebugBlock { dblProcedure = g_entry graph
, dblLabel = label
, dblCLabel = case info of
Just (Statics infoLbl _) -> infoLbl
Nothing
| g_entry graph == label -> entryLbl
| otherwise -> blockLbl label
, dblHasInfoTbl = isJust info
, dblParent = Nothing
, dblTicks = ticks
, dblPosition = Nothing
, dblUnwind = unwind
, dblSourceTick = stick
, dblBlocks = blocks
}
where (CmmProc infos entryLbl _ graph) = prc
label = entryLabel block
info = mapLookup label infos
blocks | top = seqList childs childs
| otherwise = []
isSourceTick SourceNote {} = True
isSourceTick _ = False
ticks = nubBy (flip tickishContains) $
bCtxsTicks bctxs ++ ticksToCopy scope
stick = case filter isSourceTick ticks of
[] -> cstick
sticks -> Just $! bestSrcTick (sticks ++ maybeToList cstick)
blockContexts :: RawCmmGroup -> Map.Map CmmTickScope [BlockContext]
blockContexts decls = Map.map reverse $ foldr walkProc Map.empty decls
where walkProc CmmData{} m = m
walkProc prc@(CmmProc _ _ _ graph) m
| mapNull blocks = m
| otherwise = snd $ walkBlock prc entry Map.empty (emptyLbls, m)
where blocks = toBlockMap graph
entry = [mapFind (g_entry graph) blocks]
emptyLbls = setEmpty :: LabelSet
walkBlock _ [] _ c = c
walkBlock prc (block:blocks) unwind (visited, m)
| lbl `setMember` visited
= walkBlock prc blocks unwind (visited, m)
| otherwise
= walkBlock prc blocks unwind $
walkBlock prc succs unwind'
(lbl `setInsert` visited,
insertMulti scope (block, prc, unwind') m)
where CmmEntry lbl scope = firstNode block
unwind' = extractUnwind block `Map.union` unwind
(CmmProc _ _ _ graph) = prc
succs = map (flip mapFind (toBlockMap graph))
(successors (lastNode block))
mapFind = mapFindWithDefault (error "contextTree: block not found!")
insertMulti :: Ord k => k -> a -> Map.Map k [a] -> Map.Map k [a]
insertMulti k v = Map.insertWith (const (v:)) k [v]
cmmDebugLabels :: (i -> Bool) -> GenCmmGroup d g (ListGraph i) -> [Label]
cmmDebugLabels isMeta nats = seqList lbls lbls
where
lbls = map blockId $ filter (not . allMeta) $ concatMap getBlocks nats
getBlocks (CmmProc _ _ _ (ListGraph bs)) = bs
getBlocks _other = []
allMeta (BasicBlock _ instrs) = all isMeta instrs
cmmDebugLink :: [Label] -> [DebugBlock] -> [DebugBlock]
cmmDebugLink labels blocks = map link blocks
where blockPos :: LabelMap Int
blockPos = mapFromList $ flip zip [0..] labels
link block = block { dblPosition = mapLookup (dblLabel block) blockPos
, dblBlocks = map link (dblBlocks block)
}
debugToMap :: [DebugBlock] -> LabelMap DebugBlock
debugToMap = mapUnions . map go
where go b = mapInsert (dblLabel b) b $ mapUnions $ map go (dblBlocks b)
type UnwindTable = Map.Map GlobalReg UnwindExpr
data UnwindExpr = UwConst Int
| UwReg GlobalReg Int
| UwDeref UnwindExpr
| UwPlus UnwindExpr UnwindExpr
| UwMinus UnwindExpr UnwindExpr
| UwTimes UnwindExpr UnwindExpr
deriving (Eq)
instance Outputable UnwindExpr where
pprPrec _ (UwConst i) = ppr i
pprPrec _ (UwReg g 0) = ppr g
pprPrec p (UwReg g x) = pprPrec p (UwPlus (UwReg g 0) (UwConst x))
pprPrec _ (UwDeref e) = char '*' <> pprPrec 3 e
pprPrec p (UwPlus e0 e1) | p <= 0
= pprPrec 0 e0 <> char '+' <> pprPrec 0 e1
pprPrec p (UwMinus e0 e1) | p <= 0
= pprPrec 1 e0 <> char '-' <> pprPrec 1 e1
pprPrec p (UwTimes e0 e1) | p <= 1
= pprPrec 2 e0 <> char '*' <> pprPrec 2 e1
pprPrec _ other = parens (pprPrec 0 other)
extractUnwind :: CmmBlock -> UnwindTable
extractUnwind b = go $ blockToList mid
where (_, mid, _) = blockSplit b
go :: [CmmNode O O] -> UnwindTable
go [] = Map.empty
go (x : xs) = case x of
CmmUnwind g so -> Map.insert g (toUnwindExpr so) $! go xs
CmmTick {} -> go xs
_other -> Map.empty
toUnwindExpr :: CmmExpr -> UnwindExpr
toUnwindExpr (CmmLit (CmmInt i _)) = UwConst (fromIntegral i)
toUnwindExpr (CmmRegOff (CmmGlobal g) i) = UwReg g i
toUnwindExpr (CmmReg (CmmGlobal g)) = UwReg g 0
toUnwindExpr (CmmLoad e _) = UwDeref (toUnwindExpr e)
toUnwindExpr e@(CmmMachOp op [e1, e2]) =
case (op, toUnwindExpr e1, toUnwindExpr e2) of
(MO_Add{}, UwReg r x, UwConst y) -> UwReg r (x + y)
(MO_Sub{}, UwReg r x, UwConst y) -> UwReg r (x y)
(MO_Add{}, UwConst x, UwReg r y) -> UwReg r (x + y)
(MO_Add{}, UwConst x, UwConst y) -> UwConst (x + y)
(MO_Sub{}, UwConst x, UwConst y) -> UwConst (x y)
(MO_Mul{}, UwConst x, UwConst y) -> UwConst (x * y)
(MO_Add{}, u1, u2 ) -> UwPlus u1 u2
(MO_Sub{}, u1, u2 ) -> UwMinus u1 u2
(MO_Mul{}, u1, u2 ) -> UwTimes u1 u2
_otherwise -> pprPanic "Unsupported operator in unwind expression!"
(pprExpr e)
toUnwindExpr e
= pprPanic "Unsupported unwind expression!" (ppr e)