Implement -dword-hex-literals

Provide flag for showing showing Word# and Word64# as hexadecimal when
dumping GHC core.  The only affects Word, not Int, and it prefixes the
hexadecimal with enough zeroes to make the total character count a power
of two. For example:

- 0x0C0C instead of 0xC0C
- 0x00BA00BA instead of 0xBA00BA

This also affects the presentation of Word# and Word64# in GHC's error
messages. It is not expected that the flag will be used for this, but
it is a side-effect worth noting.

Test Plan: none

Reviewers: bgamari, simonpj

Reviewed By: simonpj

Subscribers: simonpj, mpickering, rwbarton, thomie, carter, andrewthad

GHC Trac Issues: #14872

Differential Revision: https://phabricator.haskell.org/D4465

4 files changed, 90 insertions, 14 deletions

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 7b9cb13254..f9d2bfb9da 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -59,6 +59,7 @@ module DynFlags (
         tablesNextToCode, mkTablesNextToCode,
         makeDynFlagsConsistent,
         shouldUseColor,
+        shouldUseHexWordLiterals,
         positionIndependent,
         optimisationFlags,
 
@@ -566,6 +567,7 @@ data GeneralFlag
    | Opt_NoSortValidSubstitutions
    | Opt_AbstractRefSubstitutions
    | Opt_ShowLoadedModules
+   | Opt_HexWordLiterals -- See Note [Print Hexadecimal Literals]
 
    -- Suppress all coercions, them replacing with '...'
    | Opt_SuppressCoercions
@@ -1482,6 +1484,10 @@ data RtsOptsEnabled
 shouldUseColor :: DynFlags -> Bool
 shouldUseColor dflags = overrideWith (canUseColor dflags) (useColor dflags)
 
+shouldUseHexWordLiterals :: DynFlags -> Bool
+shouldUseHexWordLiterals dflags =
+  Opt_HexWordLiterals `EnumSet.member` generalFlags dflags
+
 -- | Are we building with @-fPIE@ or @-fPIC@ enabled?
 positionIndependent :: DynFlags -> Bool
 positionIndependent dflags = gopt Opt_PIC dflags || gopt Opt_PIE dflags
@@ -3007,6 +3013,8 @@ dynamic_flags_deps = [
         (NoArg (setRtsOptsEnabled RtsOptsNone))
   , make_ord_flag defGhcFlag "no-rtsopts-suggestions"
       (noArg (\d -> d {rtsOptsSuggestions = False}))
+  , make_ord_flag defGhcFlag "dhex-word-literals"
+        (NoArg (setGeneralFlag Opt_HexWordLiterals))
 
   , make_ord_flag defGhcFlag "ghcversion-file"      (hasArg addGhcVersionFile)
   , make_ord_flag defGhcFlag "main-is"              (SepArg setMainIs)
diff --git a/compiler/main/DynFlags.hs-boot b/compiler/main/DynFlags.hs-boot
index a8efb6013d..7440e5db00 100644
--- a/compiler/main/DynFlags.hs-boot
+++ b/compiler/main/DynFlags.hs-boot
@@ -5,13 +5,15 @@ import Platform
 
 data DynFlags
 data DumpFlag
+data GeneralFlag
 
-targetPlatform       :: DynFlags -> Platform
-pprUserLength        :: DynFlags -> Int
-pprCols              :: DynFlags -> Int
-unsafeGlobalDynFlags :: DynFlags
-useUnicode           :: DynFlags -> Bool
-useUnicodeSyntax     :: DynFlags -> Bool
-shouldUseColor       :: DynFlags -> Bool
-hasPprDebug          :: DynFlags -> Bool
-hasNoDebugOutput     :: DynFlags -> Bool
+targetPlatform           :: DynFlags -> Platform
+pprUserLength            :: DynFlags -> Int
+pprCols                  :: DynFlags -> Int
+unsafeGlobalDynFlags     :: DynFlags
+useUnicode               :: DynFlags -> Bool
+useUnicodeSyntax         :: DynFlags -> Bool
+shouldUseColor           :: DynFlags -> Bool
+shouldUseHexWordLiterals :: DynFlags -> Bool
+hasPprDebug              :: DynFlags -> Bool
+hasNoDebugOutput         :: DynFlags -> Bool
diff --git a/compiler/utils/Outputable.hs b/compiler/utils/Outputable.hs
index 793b8fb139..2b03555bab 100644
--- a/compiler/utils/Outputable.hs
+++ b/compiler/utils/Outputable.hs
@@ -22,7 +22,7 @@ module Outputable (
         empty, isEmpty, nest,
         char,
         text, ftext, ptext, ztext,
-        int, intWithCommas, integer, float, double, rational, doublePrec,
+        int, intWithCommas, integer, word, float, double, rational, doublePrec,
         parens, cparen, brackets, braces, quotes, quote,
         doubleQuotes, angleBrackets, paBrackets,
         semi, comma, colon, dcolon, space, equals, dot, vbar,
@@ -91,7 +91,8 @@ import GhcPrelude
 import {-# SOURCE #-}   DynFlags( DynFlags, hasPprDebug, hasNoDebugOutput,
                                   targetPlatform, pprUserLength, pprCols,
                                   useUnicode, useUnicodeSyntax,
-                                  shouldUseColor, unsafeGlobalDynFlags )
+                                  shouldUseColor, unsafeGlobalDynFlags,
+                                  shouldUseHexWordLiterals )
 import {-# SOURCE #-}   Module( UnitId, Module, ModuleName, moduleName )
 import {-# SOURCE #-}   OccName( OccName )
 
@@ -555,6 +556,7 @@ ptext    :: LitString  -> SDoc
 ztext    :: FastZString -> SDoc
 int      :: Int        -> SDoc
 integer  :: Integer    -> SDoc
+word     :: Integer    -> SDoc
 float    :: Float      -> SDoc
 double   :: Double     -> SDoc
 rational :: Rational   -> SDoc
@@ -573,6 +575,11 @@ integer n   = docToSDoc $ Pretty.integer n
 float n     = docToSDoc $ Pretty.float n
 double n    = docToSDoc $ Pretty.double n
 rational n  = docToSDoc $ Pretty.rational n
+word n      = sdocWithDynFlags $ \dflags ->
+    -- See Note [Print Hexadecimal Literals] in Pretty.hs
+    if shouldUseHexWordLiterals dflags
+        then docToSDoc $ Pretty.hex n
+        else docToSDoc $ Pretty.integer n
 
 -- | @doublePrec p n@ shows a floating point number @n@ with @p@
 -- digits of precision after the decimal point.
@@ -969,9 +976,9 @@ pprPrimChar :: Char -> SDoc
 pprPrimInt, pprPrimWord, pprPrimInt64, pprPrimWord64 :: Integer -> SDoc
 pprPrimChar c   = pprHsChar c <> primCharSuffix
 pprPrimInt i    = integer i   <> primIntSuffix
-pprPrimWord w   = integer w   <> primWordSuffix
+pprPrimWord w   = word    w   <> primWordSuffix
 pprPrimInt64 i  = integer i   <> primInt64Suffix
-pprPrimWord64 w = integer w   <> primWord64Suffix
+pprPrimWord64 w = word    w   <> primWord64Suffix
 
 ---------------------
 -- Put a name in parens if it's an operator
diff --git a/compiler/utils/Pretty.hs b/compiler/utils/Pretty.hs
index f4987d3751..9a12c7dae9 100644
--- a/compiler/utils/Pretty.hs
+++ b/compiler/utils/Pretty.hs
@@ -72,7 +72,7 @@ module Pretty (
 
         -- ** Converting values into documents
         char, text, ftext, ptext, ztext, sizedText, zeroWidthText,
-        int, integer, float, double, rational,
+        int, integer, float, double, rational, hex,
 
         -- ** Simple derived documents
         semi, comma, colon, space, equals,
@@ -117,6 +117,7 @@ import BufWrite
 import FastString
 import Panic
 import System.IO
+import Numeric (showHex)
 
 --for a RULES
 import GHC.Base ( unpackCString# )
@@ -404,11 +405,18 @@ integer  :: Integer  -> Doc -- ^ @integer n = text (show n)@
 float    :: Float    -> Doc -- ^ @float n = text (show n)@
 double   :: Double   -> Doc -- ^ @double n = text (show n)@
 rational :: Rational -> Doc -- ^ @rational n = text (show n)@
+hex      :: Integer  -> Doc -- ^ See Note [Print Hexadecimal Literals]
 int      n = text (show n)
 integer  n = text (show n)
 float    n = text (show n)
 double   n = text (show n)
 rational n = text (show n)
+hex      n = text ('0' : 'x' : padded)
+    where
+    str = showHex n ""
+    strLen = max 1 (length str)
+    len = 2 ^ (ceiling (logBase 2 (fromIntegral strLen :: Double)) :: Int)
+    padded = replicate (len - strLen) '0' ++ str
 
 parens       :: Doc -> Doc -- ^ Wrap document in @(...)@
 brackets     :: Doc -> Doc -- ^ Wrap document in @[...]@
@@ -423,6 +431,57 @@ parens p       = char '(' <> p <> char ')'
 brackets p     = char '[' <> p <> char ']'
 braces p       = char '{' <> p <> char '}'
 
+{-
+Note [Print Hexadecimal Literals]
+
+Relevant discussions:
+ * Phabricator: https://phabricator.haskell.org/D4465
+ * GHC Trac: https://ghc.haskell.org/trac/ghc/ticket/14872
+
+There is a flag `-dword-hex-literals` that causes literals of
+type `Word#` or `Word64#` to be displayed in hexadecimal instead
+of decimal when dumping GHC core. It also affects the presentation
+of these in GHC's error messages. Additionally, the hexadecimal
+encoding of these numbers is zero-padded so that its length is
+a power of two. As an example of what this does,
+consider the following haskell file `Literals.hs`:
+
+    module Literals where
+
+    alpha :: Int
+    alpha = 100 + 200
+
+    beta :: Word -> Word
+    beta x = x + div maxBound 255 + div 0xFFFFFFFF 255 + 0x0202
+
+We get the following dumped core when we compile on a 64-bit
+machine with ghc -O2 -fforce-recomp -ddump-simpl -dsuppress-all
+-dhex-word-literals literals.hs:
+
+    ==================== Tidy Core ====================
+
+    ... omitted for brevity ...
+
+    -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+    alpha
+    alpha = I# 300#
+
+    -- RHS size: {terms: 12, types: 3, coercions: 0, joins: 0/0}
+    beta
+    beta
+      = \ x_aYE ->
+          case x_aYE of { W# x#_a1v0 ->
+          W#
+            (plusWord#
+               (plusWord# (plusWord# x#_a1v0 0x0101010101010101##) 0x01010101##)
+               0x0202##)
+          }
+
+Notice that the word literals are in hexadecimals and that they have
+been padded with zeroes so that their lengths are 16, 8, and 4, respectively.
+
+-}
+
 -- | Apply 'parens' to 'Doc' if boolean is true.
 maybeParens :: Bool -> Doc -> Doc
 maybeParens False = id