Pretty-print # on unboxed literals in core

Summary:
Ticket #10104 dealt with showing the '#'s on types with unboxed fields. This
commit pretty prints the '#'s on unboxed literals in core output.

Test Plan: simplCore/should_compile/T8274

Reviewers: jstolarek, simonpj, austin

Reviewed By: simonpj, austin

Subscribers: simonpj, thomie

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

GHC Trac Issues: #8274

4 files changed, 89 insertions, 32 deletions

diff --git a/compiler/basicTypes/Literal.hs b/compiler/basicTypes/Literal.hs
index 8198f81078..2c71be499b 100644
--- a/compiler/basicTypes/Literal.hs
+++ b/compiler/basicTypes/Literal.hs
@@ -440,33 +440,66 @@ litTag (LitInteger  {})    = _ILIT(11)
 {-
         Printing
         ~~~~~~~~
-* MachX (i.e. unboxed) things are printed unadornded (e.g. 3, 'a', "foo")
-  exceptions: MachFloat gets an initial keyword prefix.
+* See Note [Printing of literals in Core]
 -}
 
 pprLiteral :: (SDoc -> SDoc) -> Literal -> SDoc
--- The function is used on non-atomic literals
--- to wrap parens around literals that occur in
--- a context requiring an atomic thing
-pprLiteral _       (MachChar ch)    = pprHsChar ch
+pprLiteral _       (MachChar c)     = pprPrimChar c
 pprLiteral _       (MachStr s)      = pprHsBytes s
-pprLiteral _       (MachInt i)      = pprIntVal i
-pprLiteral _       (MachDouble d)   = double (fromRat d)
 pprLiteral _       (MachNullAddr)   = ptext (sLit "__NULL")
-pprLiteral add_par (LitInteger i _) = add_par (ptext (sLit "__integer") <+> integer i)
-pprLiteral add_par (MachInt64 i)    = add_par (ptext (sLit "__int64") <+> integer i)
-pprLiteral add_par (MachWord w)     = add_par (ptext (sLit "__word") <+> integer w)
-pprLiteral add_par (MachWord64 w)   = add_par (ptext (sLit "__word64") <+> integer w)
-pprLiteral add_par (MachFloat f)    = add_par (ptext (sLit "__float") <+> float (fromRat f))
+pprLiteral _       (MachInt i)      = pprPrimInt i
+pprLiteral _       (MachInt64 i)    = pprPrimInt64 i
+pprLiteral _       (MachWord w)     = pprPrimWord w
+pprLiteral _       (MachWord64 w)   = pprPrimWord64 w
+pprLiteral _       (MachFloat f)    = float (fromRat f) <> primFloatSuffix
+pprLiteral _       (MachDouble d)   = double (fromRat d) <> primDoubleSuffix
+pprLiteral add_par (LitInteger i _) = pprIntegerVal add_par i
 pprLiteral add_par (MachLabel l mb fod) = add_par (ptext (sLit "__label") <+> b <+> ppr fod)
     where b = case mb of
               Nothing -> pprHsString l
               Just x  -> doubleQuotes (text (unpackFS l ++ '@':show x))
 
-pprIntVal :: Integer -> SDoc
--- ^ Print negative integers with parens to be sure it's unambiguous
-pprIntVal i | i < 0     = parens (integer i)
-            | otherwise = integer i
+pprIntegerVal :: (SDoc -> SDoc) -> Integer -> SDoc
+-- See Note [Printing of literals in Core].
+pprIntegerVal add_par i | i < 0     = add_par (integer i)
+                        | otherwise = integer i
+
+{-
+Note [Printing of literals in Core]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The function `add_par` is used to wrap parenthesis around negative integers
+(`LitInteger`) and labels (`MachLabel`), if they occur in a context requiring
+an atomic thing (for example function application).
+
+Although not all Core literals would be valid Haskell, we are trying to stay
+as close as possible to Haskell syntax in the printing of Core, to make it
+easier for a Haskell user to read Core.
+
+To that end:
+  * We do print parenthesis around negative `LitInteger`, because we print
+  `LitInteger` using plain number literals (no prefix or suffix), and plain
+  number literals in Haskell require parenthesis in contexts like function
+  application (i.e. `1 - -1` is not valid Haskell).
+
+  * We don't print parenthesis around other (negative) literals, because they
+  aren't needed in GHC/Haskell either (i.e. `1# -# -1#` is accepted by GHC's
+  parser).
+
+Literal         Output             Output if context requires
+                                   an atom (if different)
+-------         -------            ----------------------
+MachChar        'a'#
+MachStr         "aaa"#
+MachNullAddr    "__NULL"
+MachInt         -1#
+MachInt64       -1L#
+MachWord         1##
+MachWord64       1L##
+MachFloat       -1.0#
+MachDouble      -1.0##
+LitInteger      -1                 (-1)
+MachLabel       "__label" ...      ("__label" ...)
+-}
 
 {-
 ************************************************************************
diff --git a/compiler/hsSyn/HsLit.hs b/compiler/hsSyn/HsLit.hs
index 2a910ad86b..a53c67c103 100644
--- a/compiler/hsSyn/HsLit.hs
+++ b/compiler/hsSyn/HsLit.hs
@@ -151,20 +151,19 @@ instance Ord OverLitVal where
   compare (HsIsString _ _)    (HsFractional _)    = GT
 
 instance Outputable HsLit where
-        -- Use "show" because it puts in appropriate escapes
     ppr (HsChar _ c)       = pprHsChar c
-    ppr (HsCharPrim _ c)   = pprHsChar c <> char '#'
+    ppr (HsCharPrim _ c)   = pprPrimChar c
     ppr (HsString _ s)     = pprHsString s
-    ppr (HsStringPrim _ s) = pprHsBytes s <> char '#'
+    ppr (HsStringPrim _ s) = pprHsBytes s
     ppr (HsInt _ i)        = integer i
     ppr (HsInteger _ i _)  = integer i
     ppr (HsRat f _)        = ppr f
-    ppr (HsFloatPrim f)    = ppr f <> char '#'
-    ppr (HsDoublePrim d)   = ppr d <> text "##"
-    ppr (HsIntPrim _ i)    = integer i  <> char '#'
-    ppr (HsWordPrim _ w)   = integer w  <> text "##"
-    ppr (HsInt64Prim _ i)  = integer i  <> text "L#"
-    ppr (HsWord64Prim _ w) = integer w  <> text "L##"
+    ppr (HsFloatPrim f)    = ppr f <> primFloatSuffix
+    ppr (HsDoublePrim d)   = ppr d <> primDoubleSuffix
+    ppr (HsIntPrim _ i)    = pprPrimInt i
+    ppr (HsWordPrim _ w)   = pprPrimWord w
+    ppr (HsInt64Prim _ i)  = pprPrimInt64 i
+    ppr (HsWord64Prim _ w) = pprPrimWord64 w
 
 -- in debug mode, print the expression that it's resolved to, too
 instance OutputableBndr id => Outputable (HsOverLit id) where
diff --git a/compiler/prelude/PrelRules.hs b/compiler/prelude/PrelRules.hs
index 03df3b6f9d..5c6b70072b 100644
--- a/compiler/prelude/PrelRules.hs
+++ b/compiler/prelude/PrelRules.hs
@@ -562,13 +562,13 @@ Consider this code:
 This optimises to:
 Shift.$wgo = \ (w_sCS :: GHC.Prim.Int#) (w1_sCT :: [GHC.Types.Bool]) ->
     case w1_sCT of _ {
-      [] -> __word 0;
+      [] -> 0##;
       : x_aAW xs_aAX ->
         case x_aAW of _ {
           GHC.Types.False ->
             case w_sCS of wild2_Xh {
               __DEFAULT -> Shift.$wgo (GHC.Prim.+# wild2_Xh 1) xs_aAX;
-              9223372036854775807 -> __word 0  };
+              9223372036854775807 -> 0## };
           GHC.Types.True ->
             case GHC.Prim.>=# w_sCS 64 of _ {
               GHC.Types.False ->
@@ -576,17 +576,17 @@ Shift.$wgo = \ (w_sCS :: GHC.Prim.Int#) (w1_sCT :: [GHC.Types.Bool]) ->
                   __DEFAULT ->
                     case Shift.$wgo (GHC.Prim.+# wild3_Xh 1) xs_aAX of ww_sCW { __DEFAULT ->
                       GHC.Prim.or# (GHC.Prim.narrow32Word#
-                                      (GHC.Prim.uncheckedShiftL# (__word 1) wild3_Xh))
+                                      (GHC.Prim.uncheckedShiftL# 1## wild3_Xh))
                                    ww_sCW
                      };
                   9223372036854775807 ->
                     GHC.Prim.narrow32Word#
-!!!!-->                  (GHC.Prim.uncheckedShiftL# (__word 1) 9223372036854775807)
+!!!!-->                  (GHC.Prim.uncheckedShiftL# 1## 9223372036854775807)
                 };
               GHC.Types.True ->
                 case w_sCS of wild3_Xh {
                   __DEFAULT -> Shift.$wgo (GHC.Prim.+# wild3_Xh 1) xs_aAX;
-                  9223372036854775807 -> __word 0
+                  9223372036854775807 -> 0##
                 } } } }
 
 Note the massive shift on line "!!!!".  It can't happen, because we've checked
diff --git a/compiler/utils/Outputable.hs b/compiler/utils/Outputable.hs
index 488094a498..6c7ae08379 100644
--- a/compiler/utils/Outputable.hs
+++ b/compiler/utils/Outputable.hs
@@ -47,6 +47,10 @@ module Outputable (
 
         pprInfixVar, pprPrefixVar,
         pprHsChar, pprHsString, pprHsBytes,
+
+        primFloatSuffix, primDoubleSuffix,
+        pprPrimChar, pprPrimInt, pprPrimWord, pprPrimInt64, pprPrimWord64,
+
         pprFastFilePath,
 
         -- * Controlling the style in which output is printed
@@ -808,7 +812,7 @@ pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) ::
 pprHsString :: FastString -> SDoc
 pprHsString fs = vcat (map text (showMultiLineString (unpackFS fs)))
 
--- | Special combinator for showing string literals.
+-- | Special combinator for showing bytestring literals.
 pprHsBytes :: ByteString -> SDoc
 pprHsBytes bs = let escaped = concatMap escape $ BS.unpack bs
                 in vcat (map text (showMultiLineString escaped)) <> char '#'
@@ -818,6 +822,27 @@ pprHsBytes bs = let escaped = concatMap escape $ BS.unpack bs
                         then [c]
                         else '\\' : show w
 
+-- Postfix modifiers for unboxed literals.
+-- See Note [Printing of literals in Core] in `basicTypes/Literal.hs`.
+primCharSuffix, primFloatSuffix, primIntSuffix :: SDoc
+primDoubleSuffix, primWordSuffix, primInt64Suffix, primWord64Suffix :: SDoc
+primCharSuffix   = char '#'
+primFloatSuffix  = char '#'
+primIntSuffix    = char '#'
+primDoubleSuffix = text "##"
+primWordSuffix   = text "##"
+primInt64Suffix  = text "L#"
+primWord64Suffix = text "L##"
+
+-- | Special combinator for showing unboxed literals.
+pprPrimChar :: Char -> SDoc
+pprPrimInt, pprPrimWord, pprPrimInt64, pprPrimWord64 :: Integer -> SDoc
+pprPrimChar c   = pprHsChar c <> primCharSuffix
+pprPrimInt i    = integer i   <> primIntSuffix
+pprPrimWord w   = integer w   <> primWordSuffix
+pprPrimInt64 i  = integer i   <> primInt64Suffix
+pprPrimWord64 w = integer w   <> primWord64Suffix
+
 ---------------------
 -- Put a name in parens if it's an operator
 pprPrefixVar :: Bool -> SDoc -> SDoc