module GHC.CmmToAsm.Dwarf (
  dwarfGen
  ) where

import GHC.Prelude

import GHC.Cmm.CLabel
import GHC.Cmm.Expr        ( GlobalReg(..) )
import GHC.Settings.Config ( cProjectName, cProjectVersion )
import GHC.Types.Tickish   ( CmmTickish, GenTickish(..) )
import GHC.Cmm.DebugBlock
import GHC.Unit.Module
import GHC.Utils.Outputable
import GHC.Platform
import GHC.Types.Unique
import GHC.Types.Unique.Supply

import GHC.CmmToAsm.Dwarf.Constants
import GHC.CmmToAsm.Dwarf.Types
import GHC.CmmToAsm.Config

import Control.Arrow    ( first )
import Control.Monad    ( mfilter )
import Data.Maybe
import Data.List        ( sortBy )
import Data.Ord         ( comparing )
import qualified Data.Map as Map
import System.FilePath
import System.Directory ( getCurrentDirectory )

import qualified GHC.Cmm.Dataflow.Label as H
import qualified GHC.Cmm.Dataflow.Collections as H

-- | Generate DWARF/debug information
dwarfGen :: NCGConfig -> ModLocation -> UniqSupply -> [DebugBlock]
            -> IO (SDoc, UniqSupply)
dwarfGen _      _      us []     = return (empty, us)
dwarfGen config modLoc us blocks = do
  let platform = ncgPlatform config

  -- Convert debug data structures to DWARF info records
  let procs = debugSplitProcs blocks
      stripBlocks dbg
        | ncgDwarfStripBlockInfo config = dbg { dblBlocks = [] }
        | otherwise                     = dbg
  compPath <- getCurrentDirectory
  let lowLabel = dblCLabel $ head procs
      highLabel = mkAsmTempProcEndLabel $ dblCLabel $ last procs
      dwarfUnit = DwarfCompileUnit
        { dwChildren = map (procToDwarf config) (map stripBlocks procs)
        , dwName = fromMaybe "" (ml_hs_file modLoc)
        , dwCompDir = addTrailingPathSeparator compPath
        , dwProducer = cProjectName ++ " " ++ cProjectVersion
        , dwLowLabel = lowLabel
        , dwHighLabel = highLabel
        , dwLineLabel = dwarfLineLabel
        }

  -- Check whether we have any source code information, so we do not
  -- end up writing a pointer to an empty .debug_line section
  -- (dsymutil on Mac Os gets confused by this).
  let haveSrcIn blk = isJust (dblSourceTick blk) && isJust (dblPosition blk)
                      || any haveSrcIn (dblBlocks blk)
      haveSrc = any haveSrcIn procs

  -- .debug_abbrev section: Declare the format we're using
  let abbrevSct = pprAbbrevDecls platform haveSrc

  -- .debug_info section: Information records on procedures and blocks
  let -- unique to identify start and end compilation unit .debug_inf
      (unitU, us') = takeUniqFromSupply us
      infoSct = vcat [ ptext dwarfInfoLabel <> colon
                     , dwarfInfoSection platform
                     , compileUnitHeader platform unitU
                     , pprDwarfInfo platform haveSrc dwarfUnit
                     , compileUnitFooter platform unitU
                     ]

  -- .debug_line section: Generated mainly by the assembler, but we
  -- need to label it
  let lineSct = dwarfLineSection platform $$
                ptext dwarfLineLabel <> colon

  -- .debug_frame section: Information about the layout of the GHC stack
  let (framesU, us'') = takeUniqFromSupply us'
      frameSct = dwarfFrameSection platform $$
                 ptext dwarfFrameLabel <> colon $$
                 pprDwarfFrame platform (debugFrame framesU procs)

  -- .aranges section: Information about the bounds of compilation units
  let aranges' | ncgSplitSections config = map mkDwarfARange procs
               | otherwise               = [DwarfARange lowLabel highLabel]
  let aranges = dwarfARangesSection platform $$ pprDwarfARanges platform aranges' unitU

  return (infoSct $$ abbrevSct $$ lineSct $$ frameSct $$ aranges, us'')

-- | Build an address range entry for one proc.
-- With split sections, each proc needs its own entry, since they may get
-- scattered in the final binary. Without split sections, we could make a
-- single arange based on the first/last proc.
mkDwarfARange :: DebugBlock -> DwarfARange
mkDwarfARange proc = DwarfARange lbl end
  where
    lbl = dblCLabel proc
    end = mkAsmTempProcEndLabel lbl

-- | Header for a compilation unit, establishing global format
-- parameters
compileUnitHeader :: Platform -> Unique -> SDoc
compileUnitHeader platform unitU =
  let cuLabel = mkAsmTempLabel unitU  -- sits right before initialLength field
      length = pdoc platform (mkAsmTempEndLabel cuLabel) <> char '-' <> pdoc platform cuLabel
               <> text "-4"       -- length of initialLength field
  in vcat [ pdoc platform cuLabel <> colon
          , text "\t.long " <> length  -- compilation unit size
          , pprHalf 3                          -- DWARF version
          , sectionOffset platform (ptext dwarfAbbrevLabel) (ptext dwarfAbbrevLabel)
                                               -- abbrevs offset
          , text "\t.byte " <> ppr (platformWordSizeInBytes platform) -- word size
          ]

-- | Compilation unit footer, mainly establishing size of debug sections
compileUnitFooter :: Platform -> Unique -> SDoc
compileUnitFooter platform unitU =
  let cuEndLabel = mkAsmTempEndLabel $ mkAsmTempLabel unitU
  in pdoc platform cuEndLabel <> colon

-- | Splits the blocks by procedures. In the result all nested blocks
-- will come from the same procedure as the top-level block. See
-- Note [Splitting DebugBlocks] for details.
debugSplitProcs :: [DebugBlock] -> [DebugBlock]
debugSplitProcs b = concat $ H.mapElems $ mergeMaps $ map (split Nothing) b
  where mergeMaps = foldr (H.mapUnionWithKey (const (++))) H.mapEmpty
        split :: Maybe DebugBlock -> DebugBlock -> H.LabelMap [DebugBlock]
        split parent blk = H.mapInsert prc [blk'] nested
          where prc = dblProcedure blk
                blk' = blk { dblBlocks = own_blks
                           , dblParent = parent
                           }
                own_blks = fromMaybe [] $ H.mapLookup prc nested
                nested = mergeMaps $ map (split parent') $ dblBlocks blk
                -- Figure out who should be the parent of nested blocks.
                -- If @blk@ is optimized out then it isn't a good choice
                -- and we just use its parent.
                parent'
                  | Nothing <- dblPosition blk = parent
                  | otherwise                  = Just blk

{-
Note [Splitting DebugBlocks]

DWARF requires that we break up the nested DebugBlocks produced from
the C-- AST. For instance, we begin with tick trees containing nested procs.
For example,

    proc A [tick1, tick2]
      block B [tick3]
        proc C [tick4]

when producing DWARF we need to procs (which are represented in DWARF as
TAG_subprogram DIEs) to be top-level DIEs. debugSplitProcs is responsible for
this transform, pulling out the nested procs into top-level procs.

However, in doing this we need to be careful to preserve the parentage of the
nested procs. This is the reason DebugBlocks carry the dblParent field, allowing
us to reorganize the above tree as,

    proc A [tick1, tick2]
      block B [tick3]
    proc C [tick4] parent=B

Here we have annotated the new proc C with an attribute giving its original
parent, B.
-}

-- | Generate DWARF info for a procedure debug block
procToDwarf :: NCGConfig -> DebugBlock -> DwarfInfo
procToDwarf config prc
  = DwarfSubprogram { dwChildren = map (blockToDwarf config) (dblBlocks prc)
                    , dwName     = case dblSourceTick prc of
                         Just s@SourceNote{} -> sourceName s
                         _otherwise -> show (dblLabel prc)
                    , dwLabel    = dblCLabel prc
                    , dwParent   = fmap mkAsmTempDieLabel
                                   $ mfilter goodParent
                                   $ fmap dblCLabel (dblParent prc)
                    }
  where
  goodParent a | a == dblCLabel prc = False
               -- Omit parent if it would be self-referential
  goodParent a | not (externallyVisibleCLabel a)
               , ncgDwarfStripBlockInfo config = False
               -- If we strip block information, don't refer to blocks.
               -- Fixes #14894.
  goodParent _ = True

-- | Generate DWARF info for a block
blockToDwarf :: NCGConfig -> DebugBlock -> DwarfInfo
blockToDwarf config blk
  = DwarfBlock { dwChildren = map (blockToDwarf config) (dblBlocks blk) ++ srcNotes
               , dwLabel    = dblCLabel blk
               , dwMarker   = marker
               }
  where
    srcNotes
      | ncgDwarfSourceNotes config = concatMap tickToDwarf (dblTicks blk)
      | otherwise                  = []

    marker
      | Just _ <- dblPosition blk = Just $ mkAsmTempLabel $ dblLabel blk
      | otherwise                 = Nothing   -- block was optimized out

tickToDwarf :: CmmTickish -> [DwarfInfo]
tickToDwarf  (SourceNote ss _) = [DwarfSrcNote ss]
tickToDwarf _ = []

-- | Generates the data for the debug frame section, which encodes the
-- desired stack unwind behaviour for the debugger
debugFrame :: Unique -> [DebugBlock] -> DwarfFrame
debugFrame u procs
  = DwarfFrame { dwCieLabel = mkAsmTempLabel u
               , dwCieInit  = initUws
               , dwCieProcs = map (procToFrame initUws) procs
               }
  where
    initUws :: UnwindTable
    initUws = Map.fromList [(Sp, Just (UwReg Sp 0))]

-- | Generates unwind information for a procedure debug block
procToFrame :: UnwindTable -> DebugBlock -> DwarfFrameProc
procToFrame initUws blk
  = DwarfFrameProc { dwFdeProc    = dblCLabel blk
                   , dwFdeHasInfo = dblHasInfoTbl blk
                   , dwFdeBlocks  = map (uncurry blockToFrame)
                                        (setHasInfo blockUws)
                   }
  where blockUws :: [(DebugBlock, [UnwindPoint])]
        blockUws = map snd $ sortBy (comparing fst) $ flatten blk

        flatten :: DebugBlock
                -> [(Int, (DebugBlock, [UnwindPoint]))]
        flatten b@DebugBlock{ dblPosition=pos, dblUnwind=uws, dblBlocks=blocks }
          | Just p <- pos  = (p, (b, uws')):nested
          | otherwise      = nested -- block was optimized out
          where uws'   = addDefaultUnwindings initUws uws
                nested = concatMap flatten blocks

        -- | If the current procedure has an info table, then we also say that
        -- its first block has one to ensure that it gets the necessary -1
        -- offset applied to its start address.
        -- See Note [Info Offset] in "GHC.CmmToAsm.Dwarf.Types".
        setHasInfo :: [(DebugBlock, [UnwindPoint])]
                   -> [(DebugBlock, [UnwindPoint])]
        setHasInfo [] = []
        setHasInfo (c0:cs) = first setIt c0 : cs
          where
            setIt child =
              child { dblHasInfoTbl = dblHasInfoTbl child
                                      || dblHasInfoTbl blk }

blockToFrame :: DebugBlock -> [UnwindPoint] -> DwarfFrameBlock
blockToFrame blk uws
  = DwarfFrameBlock { dwFdeBlkHasInfo = dblHasInfoTbl blk
                    , dwFdeUnwind     = uws
                    }

addDefaultUnwindings :: UnwindTable -> [UnwindPoint] -> [UnwindPoint]
addDefaultUnwindings tbl pts =
    [ UnwindPoint lbl (tbl' `mappend` tbl)
      -- mappend is left-biased
    | UnwindPoint lbl tbl' <- pts
    ]