diff options
author | Peter Wortmann <scpmw@leeds.ac.uk> | 2015-01-08 22:19:56 +0100 |
---|---|---|
committer | Austin Seipp <aseipp@pobox.com> | 2015-01-19 07:00:56 -0600 |
commit | 4ab57024548c32a64baf069c8d78ffba073750e4 (patch) | |
tree | e52d86376efc61ee49f885f1db0d621e1a710f92 | |
parent | d33e2ffbe33a99252708a9761995109ddac04a7f (diff) | |
download | haskell-4ab57024548c32a64baf069c8d78ffba073750e4.tar.gz |
Dwarf generation fixed pt 2
- Don't bracket HsTick expression uneccessarily
- Generate debug information in UTF8
- Reduce amount of information generated - we do not currently need
block information, for example.
Special thanks to slyfox for the reports!
(cherry picked from commit 36df0988444bdf0555a842ce94f4d597b741923d)
-rw-r--r-- | compiler/hsSyn/HsExpr.hs | 2 | ||||
-rw-r--r-- | compiler/nativeGen/Dwarf.hs | 5 | ||||
-rw-r--r-- | compiler/nativeGen/Dwarf/Constants.hs | 3 | ||||
-rw-r--r-- | compiler/nativeGen/Dwarf/Types.hs | 35 |
4 files changed, 29 insertions, 16 deletions
diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs index 384222b6a0..795837c07e 100644 --- a/compiler/hsSyn/HsExpr.hs +++ b/compiler/hsSyn/HsExpr.hs @@ -665,7 +665,7 @@ ppr_expr (HsStatic e) ppr_expr (HsTick tickish exp) = pprTicks (ppr exp) $ - ppr tickish <+> ppr exp + ppr tickish <+> ppr_lexpr exp ppr_expr (HsBinTick tickIdTrue tickIdFalse exp) = pprTicks (ppr exp) $ hcat [ptext (sLit "bintick<"), diff --git a/compiler/nativeGen/Dwarf.hs b/compiler/nativeGen/Dwarf.hs index 70fca4fdb7..d7c2f61c14 100644 --- a/compiler/nativeGen/Dwarf.hs +++ b/compiler/nativeGen/Dwarf.hs @@ -33,7 +33,10 @@ dwarfGen :: DynFlags -> ModLocation -> UniqSupply -> [DebugBlock] dwarfGen df modLoc us blocks = do -- Convert debug data structures to DWARF info records - let procs = debugSplitProcs blocks + -- We strip out block information, as it is not currently useful for + -- anything. In future we might want to only do this for -g1. + let procs = map stripBlocks $ debugSplitProcs blocks + stripBlocks dbg = dbg { dblBlocks = [] } compPath <- getCurrentDirectory let dwarfUnit = DwarfCompileUnit { dwChildren = map (procToDwarf df) procs diff --git a/compiler/nativeGen/Dwarf/Constants.hs b/compiler/nativeGen/Dwarf/Constants.hs index a5bbeac477..2cd54a7ceb 100644 --- a/compiler/nativeGen/Dwarf/Constants.hs +++ b/compiler/nativeGen/Dwarf/Constants.hs @@ -41,7 +41,7 @@ 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_use_UTF8, dW_AT_MIPS_linkage_name :: Word dW_AT_name = 0x03 dW_AT_stmt_list = 0x10 dW_AT_low_pc = 0x11 @@ -51,6 +51,7 @@ dW_AT_comp_dir = 0x1b dW_AT_producer = 0x25 dW_AT_external = 0x3f dW_AT_frame_base = 0x40 +dW_AT_use_UTF8 = 0x53 dW_AT_MIPS_linkage_name = 0x2007 -- | Abbrev declaration diff --git a/compiler/nativeGen/Dwarf/Types.hs b/compiler/nativeGen/Dwarf/Types.hs index 47e0bd1265..520b5ae027 100644 --- a/compiler/nativeGen/Dwarf/Types.hs +++ b/compiler/nativeGen/Dwarf/Types.hs @@ -21,6 +21,7 @@ module Dwarf.Types import Debug import CLabel import CmmExpr ( GlobalReg(..) ) +import Encoding import FastString import Outputable import Platform @@ -79,6 +80,7 @@ pprAbbrevDecls haveDebugLine = , (dW_AT_producer, dW_FORM_string) , (dW_AT_language, dW_FORM_data4) , (dW_AT_comp_dir, dW_FORM_string) + , (dW_AT_use_UTF8, dW_FORM_flag) ] ++ (if haveDebugLine then [ (dW_AT_stmt_list, dW_FORM_data4) ] @@ -115,6 +117,7 @@ pprDwarfInfoOpen haveSrc (DwarfCompileUnit _ name producer compDir lineLbl) = $$ pprString producer $$ pprData4 dW_LANG_Haskell $$ pprString compDir + $$ pprFlag True -- use UTF8 $$ if haveSrc then pprData4' (sectionOffset lineLbl dwarfLineLabel) else empty @@ -406,19 +409,25 @@ 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)) +pprString str + = pprString' $ hcat $ map escapeChar $ + if utf8EncodedLength str == length str + then str + else map (chr . fromIntegral) $ bytesFS $ mkFastString str + +-- | Escape a single non-unicode character +escapeChar :: Char -> SDoc +escapeChar '\\' = ptext (sLit "\\\\") +escapeChar '\"' = ptext (sLit "\\\"") +escapeChar '\n' = ptext (sLit "\\n") +escapeChar c + | isAscii c && isPrint c && c /= '?' -- prevents trigraph warnings + = char c + | otherwise + = char '\\' <> char (intToDigit (ch `div` 64)) <> + char (intToDigit ((ch `div` 8) `mod` 8)) <> + char (intToDigit (ch `mod` 8)) + where ch = ord c -- | Generate an offset into another section. This is tricky because -- this is handled differently depending on platform: Mac Os expects |