cmm/Debug.hs

    {-# LANGUAGE GADTs #-}

    -----------------------------------------------------------------------------
    --
    -- Debugging data
    --
    -- Association of debug data on the Cmm level, with methods to encode it in
    -- event log format for later inclusion in profiling event logs.
    --
    -----------------------------------------------------------------------------

    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

    -- | Debug information about a block of code. Ticks scope over nested
    -- blocks.
    data DebugBlock =
      DebugBlock
      { dblProcedure  :: !Label        -- ^ Entry label of containing proc
      , dblLabel      :: !Label        -- ^ Hoopl label
      , dblCLabel     :: !CLabel       -- ^ Output label
      , dblHasInfoTbl :: !Bool         -- ^ Has an info table?
      , dblParent     :: !(Maybe DebugBlock)
        -- ^ The parent of this proc. See Note [Splitting DebugBlocks]
      , dblTicks      :: ![CmmTickish] -- ^ Ticks defined in this block
      , dblSourceTick
                :: !(Maybe CmmTickish) -- ^ Best source tick covering block
      , dblPosition   :: !(Maybe Int)  -- ^ Output position relative to
                                       -- other blocks. @Nothing@ means
                                       -- the block was optimized out
      , dblUnwind     :: !UnwindTable  -- ^ Unwind information
      , dblBlocks     :: ![DebugBlock] -- ^ Nested blocks
      }

    -- | Is this the entry block?
    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

    -- | Intermediate data structure holding debug-relevant context information
    -- about a block.
    type BlockContext = (CmmBlock, RawCmmDecl, UnwindTable)

    -- | Extract debug data from a group of procedures. We will prefer
    -- source notes that come from the given module (presumably the module
    -- that we are currently compiling).
    cmmDebugGen :: ModLocation -> RawCmmGroup -> [DebugBlock]
    cmmDebugGen modLoc decls = map (blocksForScope Nothing) topScopes
      where
          blockCtxs :: Map.Map CmmTickScope [BlockContext]
          blockCtxs = blockContexts decls

          -- Analyse tick scope structure: Each one is either a top-level
          -- tick scope, or the child of another.
          (topScopes, childScopes)
            = splitEithers $ map (\a -> findP a a) $ Map.keys blockCtxs
          findP tsc GlobalScope = Left tsc -- top scope
          findP tsc scp | scp' `Map.member` blockCtxs = Right (scp', tsc)
                        | otherwise                   = findP tsc scp'
            where -- Note that we only following the left parent of
                  -- combined scopes. This loses us ticks, which we will
                  -- recover by copying ticks below.
                  scp' | SubScope _ scp' <- scp      = scp'
                       | CombinedScope scp' _ <- scp = scp'
                       | otherwise                   = panic "findP impossible"

          scopeMap = foldr (uncurry insertMulti) Map.empty childScopes

          -- This allows us to recover ticks that we lost by flattening
          -- the graph. Basically, if the parent is A but the child is
          -- CBA, we know that there is no BA, because it would have taken
          -- priority - but there might be a B scope, with ticks that
          -- would not be associated with our child anymore. Note however
          -- that there might be other childs (DB), which we have to
          -- filter out.
          --
          -- We expect this to be called rarely, which is why we are not
          -- trying too hard to be efficient here. In many cases we won't
          -- have to construct blockCtxsU in the first place.
          ticksToCopy :: CmmTickScope -> [CmmTickish]
          ticksToCopy (CombinedScope scp s) = go s
            where go s | scp `isTickSubScope` s   = [] -- done
                       | 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)

          -- Finding the "best" source tick is somewhat arbitrary -- we
          -- select the first source span, while preferring source ticks
          -- from the same source file.  Furthermore, dumps take priority
          -- (if we generated one, we probably want debug information to
          -- refer to it).
          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

          -- Returns block tree for this scope as well as all nested
          -- scopes. Note that if there are multiple blocks in the (exact)
          -- same scope we elect one as the "branch" node and add the rest
          -- as children.
          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 -- see cmmDebugLink
                                 , 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 = []

                  -- A source tick scopes over all nested blocks. However
                  -- their source ticks might take priority.
                  isSourceTick SourceNote {} = True
                  isSourceTick _             = False
                  -- Collect ticks from all blocks inside the tick scope.
                  -- We attempt to filter out duplicates while we're at it.
                  ticks = nubBy (flip tickishContains) $
                          bCtxsTicks bctxs ++ ticksToCopy scope
                  stick = case filter isSourceTick ticks of
                    []     -> cstick
                    sticks -> Just $! bestSrcTick (sticks ++ maybeToList cstick)

    -- | Build a map of blocks sorted by their tick scopes
    --
    -- This involves a pre-order traversal, as we want blocks in rough
    -- control flow order (so ticks have a chance to be sorted in the
    -- right order). We also use this opportunity to have blocks inherit
    -- unwind information from their predecessor blocks where it is
    -- lacking.
    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 -- Find order in which procedures will be generated by the
            -- back-end (that actually matters for DWARF generation).
            --
            -- Note that we might encounter blocks that are missing or only
            -- consist of meta instructions -- we will declare them missing,
            -- which will skip debug data generation without messing up the
            -- block hierarchy.
            lbls = map blockId $ filter (not . allMeta) $ concatMap getBlocks nats
            getBlocks (CmmProc _ _ _ (ListGraph bs)) = bs
            getBlocks _other                         = []
            allMeta (BasicBlock _ instrs) = all isMeta instrs

    -- | Sets position fields in the debug block tree according to native
    -- generated code.
    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)
                               }

    -- | Converts debug blocks into a label map for easier lookups
    debugToMap :: [DebugBlock] -> LabelMap DebugBlock
    debugToMap = mapUnions . map go
       where go b = mapInsert (dblLabel b) b $ mapUnions $ map go (dblBlocks b)

    -- | Maps registers to expressions that yield their "old" values
    -- further up the stack. Most interesting for the stack pointer Sp,
    -- but might be useful to document saved registers, too.
    type UnwindTable = Map.Map GlobalReg UnwindExpr

    -- | Expressions, used for unwind information
    data UnwindExpr = UwConst Int                   -- ^ literal value
                    | UwReg GlobalReg Int           -- ^ register plus offset
                    | UwDeref UnwindExpr            -- ^ pointer dereferencing
                    | 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
                                -- TODO: Unwind statements after actual instructions

    -- | Conversion of Cmm expressions to unwind expressions. We check for
    -- unsupported operator usages and simplify the expression as far as
    -- possible.
    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)