diff options
| -rw-r--r-- | compiler/cmm/CLabel.hs | 30 | ||||
| -rw-r--r-- | compiler/ghc.cabal.in | 3 | ||||
| -rw-r--r-- | compiler/nativeGen/AsmCodeGen.hs | 73 | ||||
| -rw-r--r-- | compiler/nativeGen/Dwarf.hs | 120 | ||||
| -rw-r--r-- | compiler/nativeGen/Dwarf/Constants.hs | 132 | ||||
| -rw-r--r-- | compiler/nativeGen/Dwarf/Types.hs | 186 | ||||
| -rw-r--r-- | compiler/nativeGen/X86/Ppr.hs | 15 |
7 files changed, 519 insertions, 40 deletions
diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs index 37b8ada75b..603f2130e0 100644 --- a/compiler/cmm/CLabel.hs +++ b/compiler/cmm/CLabel.hs @@ -44,6 +44,8 @@ module CLabel ( mkStringLitLabel, mkAsmTempLabel, + mkAsmTempDerivedLabel, + mkAsmTempEndLabel, mkPlainModuleInitLabel, @@ -99,7 +101,7 @@ module CLabel ( mkHpcTicksLabel, hasCAF, - needsCDecl, isAsmTemp, maybeAsmTemp, externallyVisibleCLabel, + needsCDecl, maybeAsmTemp, externallyVisibleCLabel, isMathFun, isCFunctionLabel, isGcPtrLabel, labelDynamic, @@ -123,6 +125,7 @@ import FastString import DynFlags import Platform import UniqSet +import PprCore ( {- instances -} ) -- ----------------------------------------------------------------------------- -- The CLabel type @@ -190,6 +193,10 @@ data CLabel | AsmTempLabel {-# UNPACK #-} !Unique + | AsmTempDerivedLabel + CLabel + FastString -- suffix + | StringLitLabel {-# UNPACK #-} !Unique @@ -547,6 +554,11 @@ mkStringLitLabel = StringLitLabel mkAsmTempLabel :: Uniquable a => a -> CLabel mkAsmTempLabel a = AsmTempLabel (getUnique a) +mkAsmTempDerivedLabel :: CLabel -> FastString -> CLabel +mkAsmTempDerivedLabel = AsmTempDerivedLabel + +mkAsmTempEndLabel :: CLabel -> CLabel +mkAsmTempEndLabel l = mkAsmTempDerivedLabel l (fsLit "_end") mkPlainModuleInitLabel :: Module -> CLabel mkPlainModuleInitLabel mod = PlainModuleInitLabel mod @@ -634,6 +646,7 @@ needsCDecl (PlainModuleInitLabel _) = True needsCDecl (StringLitLabel _) = False needsCDecl (AsmTempLabel _) = False +needsCDecl (AsmTempDerivedLabel _ _) = False needsCDecl (RtsLabel _) = False needsCDecl (CmmLabel pkgId _ _) @@ -652,12 +665,6 @@ needsCDecl (DynamicLinkerLabel {}) = panic "needsCDecl DynamicLinkerLabel" needsCDecl PicBaseLabel = panic "needsCDecl PicBaseLabel" needsCDecl (DeadStripPreventer {}) = panic "needsCDecl DeadStripPreventer" --- | Check whether a label is a local temporary for native code generation -isAsmTemp :: CLabel -> Bool -isAsmTemp (AsmTempLabel _) = True -isAsmTemp _ = False - - -- | If a label is a local temporary used for native code generation -- then return just its unique, otherwise nothing. maybeAsmTemp :: CLabel -> Maybe Unique @@ -763,6 +770,7 @@ externallyVisibleCLabel :: CLabel -> Bool -- not C "static" externallyVisibleCLabel (CaseLabel _ _) = False externallyVisibleCLabel (StringLitLabel _) = False externallyVisibleCLabel (AsmTempLabel _) = False +externallyVisibleCLabel (AsmTempDerivedLabel _ _)= False externallyVisibleCLabel (PlainModuleInitLabel _)= True externallyVisibleCLabel (RtsLabel _) = True externallyVisibleCLabel (CmmLabel _ _ _) = True @@ -982,6 +990,13 @@ pprCLabel platform (AsmTempLabel u) else char '_' <> pprUnique u +pprCLabel platform (AsmTempDerivedLabel l suf) + | cGhcWithNativeCodeGen == "YES" + = ptext (asmTempLabelPrefix platform) + <> case l of AsmTempLabel u -> pprUnique u + _other -> pprCLabel platform l + <> ftext suf + pprCLabel platform (DynamicLinkerLabel info lbl) | cGhcWithNativeCodeGen == "YES" = pprDynamicLinkerAsmLabel platform info lbl @@ -1107,6 +1122,7 @@ pprCLbl (HpcTicksLabel mod) = ptext (sLit "_hpc_tickboxes_") <> ppr mod <> ptext (sLit "_hpc") pprCLbl (AsmTempLabel {}) = panic "pprCLbl AsmTempLabel" +pprCLbl (AsmTempDerivedLabel {})= panic "pprCLbl AsmTempDerivedLabel" pprCLbl (DynamicLinkerLabel {}) = panic "pprCLbl DynamicLinkerLabel" pprCLbl (PicBaseLabel {}) = panic "pprCLbl PicBaseLabel" pprCLbl (DeadStripPreventer {}) = panic "pprCLbl DeadStripPreventer" diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index a6a49e547e..a6624ff25f 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -558,6 +558,9 @@ Library RegAlloc.Linear.X86_64.FreeRegs RegAlloc.Linear.PPC.FreeRegs RegAlloc.Linear.SPARC.FreeRegs + Dwarf + Dwarf.Types + Dwarf.Constants if flag(ghci) Exposed-Modules: diff --git a/compiler/nativeGen/AsmCodeGen.hs b/compiler/nativeGen/AsmCodeGen.hs index daaeaa217c..4080398e1f 100644 --- a/compiler/nativeGen/AsmCodeGen.hs +++ b/compiler/nativeGen/AsmCodeGen.hs @@ -47,6 +47,7 @@ import Instruction import PIC import Reg import NCGMonad +import Dwarf import Debug import BlockId @@ -286,41 +287,46 @@ nativeCodeGen' dflags this_mod modLoc ncgImpl h us cmms let ngs0 = NGS [] [] [] [] [] [] emptyUFM (ngs, us') <- cmmNativeGenStream dflags this_mod modLoc ncgImpl bufh us cmms ngs0 - finishNativeGen dflags bufh ngs - - return us' + finishNativeGen dflags modLoc bufh us' ngs finishNativeGen :: Instruction instr => DynFlags + -> ModLocation -> BufHandle + -> UniqSupply -> NativeGenAcc statics instr - -> IO () -finishNativeGen dflags bufh@(BufHandle _ _ h) ngs + -> IO UniqSupply +finishNativeGen dflags modLoc bufh@(BufHandle _ _ h) us ngs = do + -- Write debug data and finish + let emitDw = gopt Opt_Debug dflags && not (gopt Opt_SplitObjs dflags) + us' <- if not emitDw then return us else do + (dwarf, us') <- dwarfGen dflags modLoc us (ngs_debug ngs) + emitNativeCode dflags bufh dwarf + return us' bFlush bufh - let platform = targetPlatform dflags - -- dump global NCG stats for graph coloring allocator let stats = concat (ngs_colorStats ngs) when (not (null stats)) $ do - -- build the global register conflict graph - let graphGlobal - = foldl Color.union Color.initGraph - $ [ Color.raGraph stat - | stat@Color.RegAllocStatsStart{} <- stats] + -- build the global register conflict graph + let graphGlobal + = foldl Color.union Color.initGraph + $ [ Color.raGraph stat + | stat@Color.RegAllocStatsStart{} <- stats] - dump_stats (Color.pprStats stats graphGlobal) + dump_stats (Color.pprStats stats graphGlobal) - dumpIfSet_dyn dflags - Opt_D_dump_asm_conflicts "Register conflict graph" - $ Color.dotGraph - (targetRegDotColor platform) - (Color.trivColorable platform - (targetVirtualRegSqueeze platform) - (targetRealRegSqueeze platform)) - $ graphGlobal + let platform = targetPlatform dflags + dumpIfSet_dyn dflags + Opt_D_dump_asm_conflicts "Register conflict graph" + $ Color.dotGraph + (targetRegDotColor platform) + (Color.trivColorable platform + (targetVirtualRegSqueeze platform) + (targetRealRegSqueeze platform)) + $ graphGlobal -- dump global NCG stats for linear allocator @@ -332,6 +338,7 @@ finishNativeGen dflags bufh@(BufHandle _ _ h) ngs Pretty.printDoc Pretty.LeftMode (pprCols dflags) h $ withPprStyleDoc dflags (mkCodeStyle AsmStyle) $ makeImportsDoc dflags (concat (ngs_imports ngs)) + return us' where dump_stats = dumpSDoc dflags alwaysQualify Opt_D_dump_asm_stats "NCG stats" @@ -377,15 +384,21 @@ cmmNativeGenStream dflags this_mod modLoc ncgImpl h us cmm_stream ngs dumpIfSet_dyn dflags Opt_D_dump_debug "Debug Infos" (vcat $ map ppr ldbgs) - -- Clear DWARF info when generating split object files - let ngs'' | debugFlag && splitFlag - = ngs' { ngs_debug = [] - , ngs_dwarfFiles = emptyUFM - , ngs_labels = [] } - | otherwise - = ngs' { ngs_debug = ngs_debug ngs' ++ ldbgs - , ngs_labels = [] } - cmmNativeGenStream dflags this_mod modLoc ncgImpl h us' + -- Emit & clear DWARF information when generating split + -- object files, as we need it to land in the same object file + (ngs'', us'') <- + if debugFlag && splitFlag + then do (dwarf, us'') <- dwarfGen dflags modLoc us ldbgs + emitNativeCode dflags h dwarf + return (ngs' { ngs_debug = [] + , ngs_dwarfFiles = emptyUFM + , ngs_labels = [] }, + us'') + else return (ngs' { ngs_debug = ngs_debug ngs' ++ ldbgs + , ngs_labels = [] }, + us') + + cmmNativeGenStream dflags this_mod modLoc ncgImpl h us'' cmm_stream' ngs'' -- | Do native code generation on all these cmms. diff --git a/compiler/nativeGen/Dwarf.hs b/compiler/nativeGen/Dwarf.hs new file mode 100644 index 0000000000..9420424080 --- /dev/null +++ b/compiler/nativeGen/Dwarf.hs @@ -0,0 +1,120 @@ +module Dwarf ( + dwarfGen + ) where + +import CLabel +import Config ( cProjectName, cProjectVersion ) +import CoreSyn ( Tickish(..) ) +import Debug +import DynFlags +import FastString +import Module +import Outputable +import Platform +import Unique +import UniqSupply + +import Dwarf.Constants +import Dwarf.Types + +import Data.Maybe +import System.FilePath +import System.Directory ( getCurrentDirectory ) + +import qualified Compiler.Hoopl as H + +-- | Generate DWARF/debug information +dwarfGen :: DynFlags -> ModLocation -> UniqSupply -> [DebugBlock] + -> IO (SDoc, UniqSupply) +dwarfGen df modLoc us blocks = do + + -- Convert debug data structures to DWARF info records + let procs = debugSplitProcs blocks + compPath <- getCurrentDirectory + let dwarfUnit = DwarfCompileUnit + { dwChildren = map (procToDwarf df) procs + , dwName = fromMaybe "" (ml_hs_file modLoc) + , dwCompDir = addTrailingPathSeparator compPath + , dwProducer = cProjectName ++ " " ++ cProjectVersion + , 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 haveSrc + + -- .debug_info section: Information records on procedures and blocks + let (unitU, us') = takeUniqFromSupply us + infoSct = vcat [ dwarfInfoSection + , compileUnitHeader unitU + , pprDwarfInfo haveSrc dwarfUnit + , compileUnitFooter unitU + ] + + -- .debug_line section: Generated mainly by the assembler, but we + -- need to label it + let lineSct = dwarfLineSection $$ + ptext dwarfLineLabel <> colon + + return (infoSct $$ abbrevSct $$ lineSct, us') + +-- | Header for a compilation unit, establishing global format +-- parameters +compileUnitHeader :: Unique -> SDoc +compileUnitHeader unitU = sdocWithPlatform $ \plat -> + let cuLabel = mkAsmTempLabel unitU + length = ppr (mkAsmTempEndLabel cuLabel) <> char '-' <> ppr cuLabel + in vcat [ ptext (sLit "\t.long ") <> length -- compilation unit size + , ppr cuLabel <> colon + , ptext (sLit "\t.word 3") -- DWARF version + , pprDwWord (ptext dwarfAbbrevLabel <> char '-' <> + ptext dwarfAbbrevLabel) -- pointer to our abbrevs + , ptext (sLit "\t.byte ") <> ppr (platformWordSize plat) -- word size + ] + +-- | Compilation unit footer, mainly establishing size of debug sections +compileUnitFooter :: Unique -> SDoc +compileUnitFooter unitU = + let cuEndLabel = mkAsmTempEndLabel $ mkAsmTempLabel unitU + in ppr cuEndLabel <> colon + +-- | Splits the blocks by procedures. In the result all nested blocks +-- will come from the same procedure as the top-level block. +debugSplitProcs :: [DebugBlock] -> [DebugBlock] +debugSplitProcs b = concat $ H.mapElems $ mergeMaps $ map split b + where mergeMaps = foldr (H.mapUnionWithKey (const (++))) H.mapEmpty + split :: DebugBlock -> H.LabelMap [DebugBlock] + split blk = H.mapInsert prc [blk {dblBlocks = own_blks}] nested + where prc = dblProcedure blk + own_blks = fromMaybe [] $ H.mapLookup prc nested + nested = mergeMaps $ map split $ dblBlocks blk + -- Note that we are rebuilding the tree here, so tick scopes + -- might change. We could fix that - but we actually only care + -- about dblSourceTick in the result, so this is okay. + +-- | Generate DWARF info for a procedure debug block +procToDwarf :: DynFlags -> DebugBlock -> DwarfInfo +procToDwarf df prc + = DwarfSubprogram { dwChildren = foldr blockToDwarf [] $ dblBlocks prc + , dwName = case dblSourceTick prc of + Just s@SourceNote{} -> sourceName s + _otherwise -> showSDocDump df $ ppr $ dblLabel prc + , dwLabel = dblCLabel prc + } + +-- | Generate DWARF info for a block +blockToDwarf :: DebugBlock -> [DwarfInfo] -> [DwarfInfo] +blockToDwarf blk dws + | isJust (dblPosition blk) = dw : dws + | otherwise = nested ++ dws -- block was optimized out, flatten + where nested = foldr blockToDwarf [] $ dblBlocks blk + dw = DwarfBlock { dwChildren = nested + , dwLabel = dblCLabel blk + , dwMarker = mkAsmTempLabel (dblLabel blk) + } diff --git a/compiler/nativeGen/Dwarf/Constants.hs b/compiler/nativeGen/Dwarf/Constants.hs new file mode 100644 index 0000000000..b6a688d657 --- /dev/null +++ b/compiler/nativeGen/Dwarf/Constants.hs @@ -0,0 +1,132 @@ +-- | Constants describing the DWARF format. Most of this simply +-- mirrors /usr/include/dwarf.h. + +module Dwarf.Constants where + +import FastString +import Platform +import Outputable + +import Data.Word + +-- | Language ID used for Haskell. +dW_LANG_Haskell :: Word +dW_LANG_Haskell = 0x18 + -- Thanks to Nathan Howell for getting us our very own language ID! + +-- | Dwarf tags +dW_TAG_compile_unit, dW_TAG_subroutine_type, + dW_TAG_file_type, dW_TAG_subprogram, dW_TAG_lexical_block, + dW_TAG_base_type, dW_TAG_structure_type, dW_TAG_pointer_type, + dW_TAG_array_type, dW_TAG_subrange_type, dW_TAG_typedef, + dW_TAG_variable, dW_TAG_arg_variable, dW_TAG_auto_variable :: Word +dW_TAG_array_type = 1 +dW_TAG_lexical_block = 11 +dW_TAG_pointer_type = 15 +dW_TAG_compile_unit = 17 +dW_TAG_structure_type = 19 +dW_TAG_typedef = 22 +dW_TAG_subroutine_type = 32 +dW_TAG_subrange_type = 33 +dW_TAG_base_type = 36 +dW_TAG_file_type = 41 +dW_TAG_subprogram = 46 +dW_TAG_variable = 52 +dW_TAG_auto_variable = 256 +dW_TAG_arg_variable = 257 + +-- | Dwarf attributes +dW_AT_name, dW_AT_stmt_list, dW_AT_low_pc, dW_AT_high_pc, dW_AT_language, + dW_AT_comp_dir, dW_AT_producer, dW_AT_external, dW_AT_frame_base, + dW_AT_MIPS_linkage_name :: Word +dW_AT_name = 0x03 +dW_AT_stmt_list = 0x10 +dW_AT_low_pc = 0x11 +dW_AT_high_pc = 0x12 +dW_AT_language = 0x13 +dW_AT_comp_dir = 0x1b +dW_AT_producer = 0x25 +dW_AT_external = 0x3f +dW_AT_frame_base = 0x40 +dW_AT_MIPS_linkage_name = 0x2007 + +-- | Abbrev declaration +dW_CHILDREN_no, dW_CHILDREN_yes :: Word8 +dW_CHILDREN_no = 0 +dW_CHILDREN_yes = 1 + +dW_FORM_addr, dW_FORM_data4, dW_FORM_string, dW_FORM_flag, + dW_FORM_block1, dW_FORM_ref4 :: Word +dW_FORM_addr = 0x01 +dW_FORM_data4 = 0x06 +dW_FORM_string = 0x08 +dW_FORM_flag = 0x0c +dW_FORM_block1 = 0x0a +dW_FORM_ref4 = 0x13 + +-- | Dwarf native types +dW_ATE_address, dW_ATE_boolean, dW_ATE_float, dW_ATE_signed, + dW_ATE_signed_char, dW_ATE_unsigned, dW_ATE_unsigned_char :: Word +dW_ATE_address = 1 +dW_ATE_boolean = 2 +dW_ATE_float = 4 +dW_ATE_signed = 5 +dW_ATE_signed_char = 6 +dW_ATE_unsigned = 7 +dW_ATE_unsigned_char = 8 + +-- | Call frame information +dW_CFA_set_loc, dW_CFA_undefined, dW_CFA_same_value, + dW_CFA_def_cfa, dW_CFA_def_cfa_offset, dW_CFA_def_cfa_expression, + dW_CFA_expression, dW_CFA_offset_extended_sf, dW_CFA_def_cfa_offset_sf, + dW_CFA_def_cfa_sf, dW_CFA_val_offset, dW_CFA_val_expression, + dW_CFA_offset :: Word8 +dW_CFA_set_loc = 0x01 +dW_CFA_undefined = 0x07 +dW_CFA_same_value = 0x08 +dW_CFA_def_cfa = 0x0c +dW_CFA_def_cfa_offset = 0x0e +dW_CFA_def_cfa_expression = 0x0f +dW_CFA_expression = 0x10 +dW_CFA_offset_extended_sf = 0x11 +dW_CFA_def_cfa_sf = 0x12 +dW_CFA_def_cfa_offset_sf = 0x13 +dW_CFA_val_offset = 0x14 +dW_CFA_val_expression = 0x16 +dW_CFA_offset = 0x80 + +-- | Operations +dW_OP_deref, dW_OP_consts, + dW_OP_minus, dW_OP_mul, dW_OP_plus, + dW_OP_lit0, dW_OP_breg0, dW_OP_call_frame_cfa :: Word8 +dW_OP_deref = 0x06 +dW_OP_consts = 0x11 +dW_OP_minus = 0x1c +dW_OP_mul = 0x1e +dW_OP_plus = 0x22 +dW_OP_lit0 = 0x30 +dW_OP_breg0 = 0x70 +dW_OP_call_frame_cfa = 0x9c + +-- | Dwarf section declarations +dwarfInfoSection, dwarfAbbrevSection, dwarfLineSection, + dwarfFrameSection, dwarfGhcSection :: SDoc +dwarfInfoSection = dwarfSection "info" +dwarfAbbrevSection = dwarfSection "abbrev" +dwarfLineSection = dwarfSection "line" +dwarfFrameSection = dwarfSection "frame" +dwarfGhcSection = dwarfSection "ghc" + +dwarfSection :: String -> SDoc +dwarfSection name = sdocWithPlatform $ \plat -> + case platformOS plat of + OSDarwin -> ftext $ mkFastString $ + ".section __DWARF,__debug_" ++ name ++ ",regular,debug" + _other -> ftext $ mkFastString $ + ".section .debug_" ++ name ++ ",\"\",@progbits" + +-- | Dwarf section labels +dwarfInfoLabel, dwarfAbbrevLabel, dwarfLineLabel :: LitString +dwarfInfoLabel = sLit ".Lsection_info" +dwarfAbbrevLabel = sLit ".Lsection_abbrev" +dwarfLineLabel = sLit ".Lsection_line" diff --git a/compiler/nativeGen/Dwarf/Types.hs b/compiler/nativeGen/Dwarf/Types.hs new file mode 100644 index 0000000000..1d564f30c0 --- /dev/null +++ b/compiler/nativeGen/Dwarf/Types.hs @@ -0,0 +1,186 @@ +module Dwarf.Types + ( DwarfInfo(..) + , pprDwarfInfo + , pprAbbrevDecls + , pprByte + , pprWord + , pprDwWord + , pprLEBWord + , pprLEBInt + ) + where + +import CLabel +import FastString +import Outputable +import Platform + +import Dwarf.Constants + +import Data.Bits +import Data.Word +import Data.Char + +-- | Individual dwarf records. Each one will be encoded as an entry in +-- the .debug_info section. +data DwarfInfo + = DwarfCompileUnit { dwChildren :: [DwarfInfo] + , dwName :: String + , dwProducer :: String + , dwCompDir :: String + , dwLineLabel :: LitString } + | DwarfSubprogram { dwChildren :: [DwarfInfo] + , dwName :: String + , dwLabel :: CLabel } + | DwarfBlock { dwChildren :: [DwarfInfo] + , dwLabel :: CLabel + , dwMarker :: CLabel } + +-- | Abbreviation codes used for encoding above records in the +-- .debug_info section. +data DwarfAbbrev + = DwAbbrNull -- ^ Pseudo, used for marking the end of lists + | DwAbbrCompileUnit + | DwAbbrSubprogram + | DwAbbrBlock + deriving (Eq, Enum) + +-- | Generate assembly for the given abbreviation code +pprAbbrev :: DwarfAbbrev -> SDoc +pprAbbrev = pprLEBWord . fromIntegral . fromEnum + +-- | Abbreviation declaration. This explains the binary encoding we +-- use for representing @DwarfInfo@. +pprAbbrevDecls :: Bool -> SDoc +pprAbbrevDecls haveDebugLine = + let mkAbbrev abbr tag chld flds = + let fld (tag, form) = pprLEBWord tag $$ pprLEBWord form + in pprAbbrev abbr $$ pprLEBWord tag $$ pprByte chld $$ + vcat (map fld flds) $$ pprByte 0 $$ pprByte 0 + in dwarfAbbrevSection $$ + ptext dwarfAbbrevLabel <> colon $$ + mkAbbrev DwAbbrCompileUnit dW_TAG_compile_unit dW_CHILDREN_yes + ([ (dW_AT_name, dW_FORM_string) + , (dW_AT_producer, dW_FORM_string) + , (dW_AT_language, dW_FORM_data4) + , (dW_AT_comp_dir, dW_FORM_string) + ] ++ + (if haveDebugLine + then [ (dW_AT_stmt_list, dW_FORM_data4) ] + else [])) $$ + mkAbbrev DwAbbrSubprogram dW_TAG_subprogram dW_CHILDREN_yes + [ (dW_AT_name, dW_FORM_string) + , (dW_AT_MIPS_linkage_name, dW_FORM_string) + , (dW_AT_external, dW_FORM_flag) + , (dW_AT_low_pc, dW_FORM_addr) + , (dW_AT_high_pc, dW_FORM_addr) + ] $$ + mkAbbrev DwAbbrBlock dW_TAG_lexical_block dW_CHILDREN_yes + [ (dW_AT_name, dW_FORM_string) + , (dW_AT_low_pc, dW_FORM_addr) + , (dW_AT_high_pc, dW_FORM_addr) + ] +-- | Generate assembly for DWARF data +pprDwarfInfo :: Bool -> DwarfInfo -> SDoc +pprDwarfInfo haveSrc d + = pprDwarfInfoOpen haveSrc d $$ + vcat (map (pprDwarfInfo haveSrc) (dwChildren d)) $$ + pprDwarfInfoClose + +-- | Prints assembler data corresponding to DWARF info records. Note +-- that the binary format of this is paramterized in @abbrevDecls@ and +-- has to be kept in synch. +pprDwarfInfoOpen :: Bool -> DwarfInfo -> SDoc +pprDwarfInfoOpen haveSrc (DwarfCompileUnit _ name producer compDir lineLbl) = + pprAbbrev DwAbbrCompileUnit + $$ pprString name + $$ pprString producer + $$ pprData4 dW_LANG_Haskell + $$ pprString compDir + $$ if haveSrc + then pprData4' (ptext lineLbl <> char '-' <> ptext dwarfLineLabel) + else empty +pprDwarfInfoOpen _ (DwarfSubprogram _ name label) = sdocWithDynFlags $ \df -> + pprAbbrev DwAbbrSubprogram + $$ pprString name + $$ pprString (renderWithStyle df (ppr label) (mkCodeStyle CStyle)) + $$ pprFlag (externallyVisibleCLabel label) + $$ pprWord (ppr label) + $$ pprWord (ppr $ mkAsmTempEndLabel label) +pprDwarfInfoOpen _ (DwarfBlock _ label marker) = sdocWithDynFlags $ \df -> + pprAbbrev DwAbbrBlock + $$ pprString (renderWithStyle df (ppr label) (mkCodeStyle CStyle)) + $$ pprWord (ppr marker) + $$ pprWord (ppr $ mkAsmTempEndLabel marker) + +-- | Close a DWARF info record with children +pprDwarfInfoClose :: SDoc +pprDwarfInfoClose = pprAbbrev DwAbbrNull + +-- | Assembly for a single byte of constant DWARF data +pprByte :: Word8 -> SDoc +pprByte x = ptext (sLit "\t.byte ") <> ppr (fromIntegral x :: Word) + +-- | Assembly for a constant DWARF flag +pprFlag :: Bool -> SDoc +pprFlag f = pprByte (if f then 0xff else 0x00) + +-- | Assembly for 4 bytes of dynamic DWARF data +pprData4' :: SDoc -> SDoc +pprData4' x = ptext (sLit "\t.long ") <> x + +-- | Assembly for 4 bytes of constant DWARF data +pprData4 :: Word -> SDoc +pprData4 = pprData4' . ppr + +-- | Assembly for a DWARF word of dynamic data. This means 32 bit, as +-- we are generating 32 bit DWARF. +pprDwWord :: SDoc -> SDoc +pprDwWord = pprData4' + +-- | Assembly for a machine word of dynamic data. Depends on the +-- architecture we are currently generating code for. +pprWord :: SDoc -> SDoc +pprWord s = (<> s) . sdocWithPlatform $ \plat -> + case platformWordSize plat of + 4 -> ptext (sLit "\t.long ") + 8 -> ptext (sLit "\t.quad ") + n -> panic $ "pprWord: Unsupported target platform word length " ++ + show n ++ "!" + +-- | Prints a number in "little endian base 128" format. The idea is +-- to optimize for small numbers by stopping once all further bytes +-- would be 0. The highest bit in every byte signals whether there +-- are further bytes to read. +pprLEBWord :: Word -> SDoc +pprLEBWord x | x < 128 = pprByte (fromIntegral x) + | otherwise = pprByte (fromIntegral $ 128 .|. (x .&. 127)) $$ + pprLEBWord (x `shiftR` 7) + +-- | Same as @pprLEBWord@, but for a signed number +pprLEBInt :: Int -> SDoc +pprLEBInt x | x >= -64 && x < 64 + = pprByte (fromIntegral (x .&. 127)) + | otherwise = pprByte (fromIntegral $ 128 .|. (x .&. 127)) $$ + pprLEBInt (x `shiftR` 7) + +-- | Generates a dynamic null-terminated string. If required the +-- caller needs to make sure that the string is escaped properly. +pprString' :: SDoc -> SDoc +pprString' str = ptext (sLit "\t.asciz \"") <> str <> char '"' + +-- | Generate a string constant. We take care to escape the string. +pprString :: String -> SDoc +pprString = pprString' . hcat . map escape + where escape '\\' = ptext (sLit "\\\\") + escape '\"' = ptext (sLit "\\\"") + escape '\n' = ptext (sLit "\\n") + escape c | isAscii c && isPrint c && c /= '?' + -- escaping '?' prevents trigraph warnings + = char c + | otherwise + = let ch = ord c + in char '\\' <> + char (intToDigit (ch `div` 64)) <> + char (intToDigit ((ch `div` 8) `mod` 8)) <> + char (intToDigit (ch `mod` 8)) diff --git a/compiler/nativeGen/X86/Ppr.hs b/compiler/nativeGen/X86/Ppr.hs index 5b4eccd845..982f79a561 100644 --- a/compiler/nativeGen/X86/Ppr.hs +++ b/compiler/nativeGen/X86/Ppr.hs @@ -56,6 +56,7 @@ pprNatCmmDecl (CmmData section dats) = pprSectionHeader section $$ pprDatas dats pprNatCmmDecl proc@(CmmProc top_info lbl _ (ListGraph blocks)) = + sdocWithDynFlags $ \dflags -> case topInfoTable proc of Nothing -> case blocks of @@ -65,6 +66,8 @@ pprNatCmmDecl proc@(CmmProc top_info lbl _ (ListGraph blocks)) = pprSectionHeader Text $$ pprLabel lbl $$ -- blocks guaranteed not null, so label needed vcat (map (pprBasicBlock top_info) blocks) $$ + (if gopt Opt_Debug dflags + then ppr (mkAsmTempEndLabel lbl) <> char ':' else empty) $$ pprSizeDecl lbl Just (Statics info_lbl _) -> @@ -84,6 +87,8 @@ pprNatCmmDecl proc@(CmmProc top_info lbl _ (ListGraph blocks)) = <+> char '-' <+> ppr (mkDeadStripPreventer info_lbl) else empty) $$ + (if gopt Opt_Debug dflags + then ppr (mkAsmTempEndLabel info_lbl) <> char ':' else empty) $$ pprSizeDecl info_lbl -- | Output the ELF .size directive. @@ -97,10 +102,14 @@ pprSizeDecl lbl pprBasicBlock :: BlockEnv CmmStatics -> NatBasicBlock Instr -> SDoc pprBasicBlock info_env (BasicBlock blockid instrs) - = maybe_infotable $$ - pprLabel (mkAsmTempLabel (getUnique blockid)) $$ - vcat (map pprInstr instrs) + = sdocWithDynFlags $ \dflags -> + maybe_infotable $$ + pprLabel asmLbl $$ + vcat (map pprInstr instrs) $$ + (if gopt Opt_Debug dflags + then ppr (mkAsmTempEndLabel asmLbl) <> char ':' else empty) where + asmLbl = mkAsmTempLabel (getUnique blockid) maybe_infotable = case mapLookup blockid info_env of Nothing -> empty Just (Statics info_lbl info) -> |