diff options
Diffstat (limited to 'compiler/utils')
| -rw-r--r-- | compiler/utils/Outputable.hs | 15 | ||||
| -rw-r--r-- | compiler/utils/Pretty.hs | 61 | ||||
| -rw-r--r-- | compiler/utils/UniqFM.hs | 9 |
3 files changed, 73 insertions, 12 deletions
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 diff --git a/compiler/utils/UniqFM.hs b/compiler/utils/UniqFM.hs index 2a9b806178..a80880f4e5 100644 --- a/compiler/utils/UniqFM.hs +++ b/compiler/utils/UniqFM.hs @@ -78,12 +78,10 @@ import Outputable import Data.List (foldl') import qualified Data.IntMap as M -import qualified Data.IntMap.Merge.Lazy as M -import Control.Applicative (Const (..)) -import qualified Data.Monoid as Mon import qualified Data.IntSet as S import Data.Data import qualified Data.Semigroup as Semi +import Data.Functor.Classes (Eq1 (..)) newtype UniqFM ele = UFM (M.IntMap ele) @@ -342,10 +340,7 @@ ufmToIntMap (UFM m) = m -- Determines whether two 'UniqFm's contain the same keys. equalKeysUFM :: UniqFM a -> UniqFM b -> Bool -equalKeysUFM (UFM m1) (UFM m2) = Mon.getAll $ getConst $ - M.mergeA (M.traverseMissing (\_ _ -> Const (Mon.All False))) - (M.traverseMissing (\_ _ -> Const (Mon.All False))) - (M.zipWithAMatched (\_ _ _ -> Const (Mon.All True))) m1 m2 +equalKeysUFM (UFM m1) (UFM m2) = liftEq (\_ _ -> True) m1 m2 -- Instances |