[commit: ghc] ghc-7.10: Dwarf generation fixed pt 2 (4ab5702)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : ghc-7.10
Link       : http://ghc.haskell.org/trac/ghc/changeset/4ab57024548c32a64baf069c8d78ffba073750e4/ghc

>---------------------------------------------------------------

commit 4ab57024548c32a64baf069c8d78ffba073750e4
Author: Peter Wortmann <scpmw at leeds.ac.uk>
Date:   Thu Jan 8 22:19:56 2015 +0100

    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)


>---------------------------------------------------------------

4ab57024548c32a64baf069c8d78ffba073750e4
 compiler/hsSyn/HsExpr.hs              |  2 +-
 compiler/nativeGen/Dwarf.hs           |  5 ++++-
 compiler/nativeGen/Dwarf/Constants.hs |  3 ++-
 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 384222b..795837c 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 70fca4f..d7c2f61 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 a5bbeac..2cd54a7 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 47e0bd1..520b5ae 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