Pretty: use BangPatterns instead of manual unboxing Ints (#10735)

Follow same style as libraries/pretty, although some of it is pretty
archaic, and could be improved with BangPatterns:
   * `get w _ | w == 0 && False = undefined`
   * `mkNest k _ | k `seq` False = undefined`

1 files changed, 88 insertions, 80 deletions

diff --git a/compiler/utils/Pretty.hs b/compiler/utils/Pretty.hs
index 12a8a531fb..9a85cc002e 100644
--- a/compiler/utils/Pretty.hs
+++ b/compiler/utils/Pretty.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE BangPatterns #-}
 {-
 *********************************************************************************
 *                                                                               *
@@ -200,7 +201,6 @@ module Pretty (
 
 import BufWrite
 import FastString
-import FastTypes
 import Panic
 import Numeric (fromRat)
 import System.IO
@@ -208,7 +208,6 @@ import Prelude hiding (error)
 
 --for a RULES
 import GHC.Base ( unpackCString# )
-import GHC.Exts ( Int# )
 import GHC.Ptr  ( Ptr(..) )
 
 -- Don't import Util( assertPanic ) because it makes a loop in the module structure
@@ -306,8 +305,8 @@ infixl 5 $$, $+$
 data Doc
   = Empty                                            -- empty
   | NilAbove Doc                                     -- text "" $$ x
-  | TextBeside !TextDetails FastInt Doc              -- text s <> x
-  | Nest FastInt Doc                                 -- nest k x
+  | TextBeside !TextDetails {-# UNPACK #-} !Int Doc  -- text s <> x
+  | Nest {-# UNPACK #-} !Int Doc                     -- nest k x
   | Union Doc Doc                                    -- ul `union` ur
   | NoDoc                                            -- The empty set of documents
   | Beside Doc Bool Doc                              -- True <=> space between
@@ -358,8 +357,8 @@ data TextDetails = Chr  {-# UNPACK #-} !Char -- ^ A single Char fragment
                  | Str  String -- ^ A whole String fragment
                  | PStr FastString                      -- a hashed string
                  | ZStr FastZString                     -- a z-encoded string
-                 | LStr {-#UNPACK#-}!LitString FastInt  -- a '\0'-terminated
-                                                        -- array of bytes
+                 | LStr {-# UNPACK #-} !LitString {-#UNPACK #-} !Int
+                   -- a '\0'-terminated array of bytes
 
 instance Show Doc where
   showsPrec _ doc cont = showDocPlus PageMode 100 doc cont
@@ -375,7 +374,7 @@ showDocPlus mode cols doc rest = fullRender mode cols 1.5 txtPrinter rest doc
 
 -- | A document of height and width 1, containing a literal character.
 char :: Char -> Doc
-char c = textBeside_ (Chr c) (_ILIT(1)) Empty
+char c = textBeside_ (Chr c) 1 Empty
 
 -- | A document of height 1 containing a literal string.
 -- 'text' satisfies the following laws:
@@ -387,7 +386,7 @@ char c = textBeside_ (Chr c) (_ILIT(1)) Empty
 -- The side condition on the last law is necessary because @'text' \"\"@
 -- has height 1, while 'empty' has no height.
 text :: String -> Doc
-text s = case iUnbox (length s) of {sl -> textBeside_ (Str s)  sl Empty}
+text s = case length s of {sl -> textBeside_ (Str s)  sl Empty}
 {-# NOINLINE [0] text #-}   -- Give the RULE a chance to fire
                             -- It must wait till after phase 1 when
                             -- the unpackCString first is manifested
@@ -399,18 +398,18 @@ text s = case iUnbox (length s) of {sl -> textBeside_ (Str s)  sl Empty}
  #-}
 
 ftext :: FastString -> Doc
-ftext s = case iUnbox (lengthFS s) of {sl -> textBeside_ (PStr s) sl Empty}
+ftext s = case lengthFS s of {sl -> textBeside_ (PStr s) sl Empty}
 
 ptext :: LitString -> Doc
-ptext s = case iUnbox (lengthLS s) of {sl -> textBeside_ (LStr s sl) sl Empty}
+ptext s = case lengthLS s of {sl -> textBeside_ (LStr s sl) sl Empty}
 
 ztext :: FastZString -> Doc
-ztext s = case iUnbox (lengthFZS s) of {sl -> textBeside_ (ZStr s) sl Empty}
+ztext s = case lengthFZS s of {sl -> textBeside_ (ZStr s) sl Empty}
 
 -- | Some text, but without any width. Use for non-printing text
 -- such as a HTML or Latex tags
 zeroWidthText :: String -> Doc
-zeroWidthText s = textBeside_ (Str s) (_ILIT(0)) Empty
+zeroWidthText s = textBeside_ (Str s) 0 Empty
 
 -- | The empty document, with no height and no width.
 -- 'empty' is the identity for '<>', '<+>', '$$' and '$+$', and anywhere
@@ -426,9 +425,9 @@ isEmpty _     = False
 -- | Produce spacing for indenting the amount specified.
 --
 -- an old version inserted tabs being 8 columns apart in the output.
-spaces :: Int# -> String
-spaces n | n <=# _ILIT(0) = ""
-         | otherwise      = ' ' : spaces (n -# _ILIT(1))
+spaces :: Int -> String
+spaces !n | n <= 0    = ""
+          | otherwise = ' ' : spaces (n - 1)
 
 {-
 Q: What is the reason for negative indentation (i.e. argument to indent
@@ -557,7 +556,7 @@ vcat = foldr ($$)  empty
 -- The side condition on the last law is needed because
 -- 'empty' is a left identity for '<>'.
 nest :: Int -> Doc -> Doc
-nest k p = mkNest (iUnbox k) (reduceDoc p)
+nest k p = mkNest k (reduceDoc p)
 
 -- | @hang d1 n d2 = sep [d1, nest n d2]@
 hang :: Doc -> Int -> Doc -> Doc
@@ -571,11 +570,12 @@ punctuate p (x:xs) = go x xs
                          go y (z:zs) = (y <> p) : go z zs
 
 -- mkNest checks for Nest's invariant that it doesn't have an Empty inside it
-mkNest :: Int# -> Doc -> Doc
-mkNest k (Nest k1 p)       = mkNest (k +# k1) p
+mkNest :: Int -> Doc -> Doc
+mkNest k _ | k `seq` False = undefined
+mkNest k (Nest k1 p)       = mkNest (k + k1) p
 mkNest _ NoDoc             = NoDoc
 mkNest _ Empty             = Empty
-mkNest k p  | k ==# _ILIT(0)  = p       -- Worth a try!
+mkNest 0 p                 = p
 mkNest k p                 = nest_ k p
 
 -- mkUnion checks for an empty document
@@ -587,10 +587,10 @@ nilAbove_ :: RDoc -> RDoc
 nilAbove_ = NilAbove
 
 -- Arg of a TextBeside is always an RDoc
-textBeside_ :: TextDetails -> FastInt -> RDoc -> RDoc
+textBeside_ :: TextDetails -> Int -> RDoc -> RDoc
 textBeside_ = TextBeside
 
-nest_ :: FastInt -> RDoc -> RDoc
+nest_ :: Int -> RDoc -> RDoc
 nest_ = Nest
 
 union_ :: RDoc -> RDoc -> RDoc
@@ -629,23 +629,24 @@ p $+$ q = Above p True q
 
 above :: Doc -> Bool -> RDoc -> RDoc
 above (Above p g1 q1)  g2 q2 = above p g1 (above q1 g2 q2)
-above p@(Beside{})     g  q  = aboveNest (reduceDoc p) g (_ILIT(0)) (reduceDoc q)
-above p g q                  = aboveNest p             g (_ILIT(0)) (reduceDoc q)
+above p@(Beside{})     g  q  = aboveNest (reduceDoc p) g 0 (reduceDoc q)
+above p g q                  = aboveNest p             g 0 (reduceDoc q)
 
 -- Specfication: aboveNest p g k q = p $g$ (nest k q)
-aboveNest :: RDoc -> Bool -> FastInt -> RDoc -> RDoc
+aboveNest :: RDoc -> Bool -> Int -> RDoc -> RDoc
+aboveNest _                   _ k _ | k `seq` False = undefined
 aboveNest NoDoc               _ _ _ = NoDoc
 aboveNest (p1 `Union` p2)     g k q = aboveNest p1 g k q `union_`
                                       aboveNest p2 g k q
 
 aboveNest Empty               _ k q = mkNest k q
-aboveNest (Nest k1 p)         g k q = nest_ k1 (aboveNest p g (k -# k1) q)
+aboveNest (Nest k1 p)         g k q = nest_ k1 (aboveNest p g (k - k1) q)
                                   -- p can't be Empty, so no need for mkNest
 
 aboveNest (NilAbove p)        g k q = nilAbove_ (aboveNest p g k q)
 aboveNest (TextBeside s sl p) g k q = textBeside_ s sl rest
                                     where
-                                      !k1  = k -# sl
+                                      !k1  = k - sl
                                       rest = case p of
                                                 Empty -> nilAboveNest g k1 q
                                                 _     -> aboveNest  p g k1 q
@@ -654,11 +655,12 @@ aboveNest (Beside {})         _ _ _ = error "aboveNest Beside"
 
 -- Specification: text s <> nilaboveNest g k q
 --              = text s <> (text "" $g$ nest k q)
-nilAboveNest :: Bool -> FastInt -> RDoc -> RDoc
+nilAboveNest :: Bool -> Int -> RDoc -> RDoc
+nilAboveNest _ k _           | k `seq` False = undefined
 nilAboveNest _ _ Empty       = Empty
                                -- Here's why the "text s <>" is in the spec!
-nilAboveNest g k (Nest k1 q) = nilAboveNest g (k +# k1) q
-nilAboveNest g k q           | not g && k ># _ILIT(0)        -- No newline if no overlap
+nilAboveNest g k (Nest k1 q) = nilAboveNest g (k + k1) q
+nilAboveNest g k q           | not g && k > 0      -- No newline if no overlap
                              = textBeside_ (Str (spaces k)) k q
                              | otherwise           -- Put them really above
                              = nilAbove_ (mkNest k q)
@@ -690,7 +692,7 @@ beside (Nest k p)          g q   = nest_ k $! beside p g q
 beside p@(Beside p1 g1 q1) g2 q2
          | g1 == g2              = beside p1 g1 $! beside q1 g2 q2
          | otherwise             = beside (reduceDoc p) g2 q2
-beside p@(Above{})         g q   = let d = reduceDoc p in d `seq` beside d g q
+beside p@(Above{})         g q   = let !d = reduceDoc p in beside d g q
 beside (NilAbove p)        g q   = nilAbove_ $! beside p g q
 beside (TextBeside s sl p) g q   = textBeside_ s sl $! rest
                                where
@@ -703,7 +705,7 @@ beside (TextBeside s sl p) g q   = textBeside_ s sl $! rest
 nilBeside :: Bool -> RDoc -> RDoc
 nilBeside _ Empty         = Empty -- Hence the text "" in the spec
 nilBeside g (Nest _ p)    = nilBeside g p
-nilBeside g p | g         = textBeside_ spaceText (_ILIT(1)) p
+nilBeside g p | g         = textBeside_ spaceText 1 p
               | otherwise = p
 
 
@@ -724,30 +726,31 @@ cat = sepX False  -- Don't
 
 sepX :: Bool -> [Doc] -> Doc
 sepX _ []     = empty
-sepX x (p:ps) = sep1 x (reduceDoc p) (_ILIT(0)) ps
+sepX x (p:ps) = sep1 x (reduceDoc p) 0 ps
 
 
 -- Specification: sep1 g k ys = sep (x : map (nest k) ys)
 --                            = oneLiner (x <g> nest k (hsep ys))
 --                              `union` x $$ nest k (vcat ys)
-sep1 :: Bool -> RDoc -> FastInt -> [Doc] -> RDoc
+sep1 :: Bool -> RDoc -> Int -> [Doc] -> RDoc
+sep1 _ _                   k _  | k `seq` False = undefined
 sep1 _ NoDoc               _ _  = NoDoc
 sep1 g (p `Union` q)       k ys = sep1 g p k ys `union_`
                                   aboveNest q False k (reduceDoc (vcat ys))
 
 sep1 g Empty               k ys = mkNest k (sepX g ys)
-sep1 g (Nest n p)          k ys = nest_ n (sep1 g p (k -# n) ys)
+sep1 g (Nest n p)          k ys = nest_ n (sep1 g p (k - n) ys)
 
 sep1 _ (NilAbove p)        k ys = nilAbove_
                                   (aboveNest p False k (reduceDoc (vcat ys)))
-sep1 g (TextBeside s sl p) k ys = textBeside_ s sl (sepNB g p (k -# sl) ys)
+sep1 g (TextBeside s sl p) k ys = textBeside_ s sl (sepNB g p (k - sl) ys)
 sep1 _ (Above {})          _ _  = error "sep1 Above"
 sep1 _ (Beside {})         _ _  = error "sep1 Beside"
 
 -- Specification: sepNB p k ys = sep1 (text "" <> p) k ys
 -- Called when we have already found some text in the first item
 -- We have to eat up nests
-sepNB :: Bool -> Doc -> FastInt -> [Doc] -> Doc
+sepNB :: Bool -> Doc -> Int -> [Doc] -> Doc
 sepNB g (Nest _ p) k ys
   = sepNB g p k ys -- Never triggered, because of invariant (2)
 sepNB g Empty k ys
@@ -790,20 +793,22 @@ fsep = fill True
 
 fill :: Bool -> [Doc] -> RDoc
 fill _ []     = empty
-fill g (p:ps) = fill1 g (reduceDoc p) (_ILIT(0)) ps
+fill g (p:ps) = fill1 g (reduceDoc p) 0 ps
 
-fill1 :: Bool -> RDoc -> FastInt -> [Doc] -> Doc
+fill1 :: Bool -> RDoc -> Int -> [Doc] -> Doc
+fill1 _ _                   k _  | k `seq` False = undefined
 fill1 _ NoDoc               _ _  = NoDoc
 fill1 g (p `Union` q)       k ys = fill1 g p k ys `union_`
                                    aboveNest q False k (fill g ys)
 fill1 g Empty               k ys = mkNest k (fill g ys)
-fill1 g (Nest n p)          k ys = nest_ n (fill1 g p (k -# n) ys)
+fill1 g (Nest n p)          k ys = nest_ n (fill1 g p (k - n) ys)
 fill1 g (NilAbove p)        k ys = nilAbove_ (aboveNest p False k (fill g ys))
-fill1 g (TextBeside s sl p) k ys = textBeside_ s sl (fillNB g p (k -# sl) ys)
+fill1 g (TextBeside s sl p) k ys = textBeside_ s sl (fillNB g p (k - sl) ys)
 fill1 _ (Above {})          _ _  = error "fill1 Above"
 fill1 _ (Beside {})         _ _  = error "fill1 Beside"
 
-fillNB :: Bool -> Doc -> Int# -> [Doc] -> Doc
+fillNB :: Bool -> Doc -> Int -> [Doc] -> Doc
+fillNB _ _           k _  | k `seq` False = undefined
 fillNB g (Nest _ p)  k ys   = fillNB g p k ys
                               -- Never triggered, because of invariant (2)
 fillNB _ Empty _ []         = Empty
@@ -811,8 +816,8 @@ fillNB g Empty k (y:ys)     = nilBeside g (fill1 g (oneLiner (reduceDoc y)) k' y
                               `mkUnion`
                               nilAboveNest False k (fill g (y:ys))
                             where
-                              !k' | g         = k -# _ILIT(1)
-                                  | otherwise = k
+                              k' | g         = k - 1
+                                 | otherwise = k
 
 fillNB g p k ys             = fill1 g p k ys
 
@@ -824,51 +829,51 @@ best :: Int   -- Line length
      -> Int   -- Ribbon length
      -> RDoc
      -> RDoc  -- No unions in here!
-best w_ r_ p
-  = get (iUnbox w_) p
+best w0 r = get w0
   where
-    !r = iUnbox r_
-    get :: FastInt          -- (Remaining) width of line
+    get :: Int          -- (Remaining) width of line
         -> Doc -> Doc
+    get w _ | w == 0 && False = undefined
     get _ Empty               = Empty
     get _ NoDoc               = NoDoc
     get w (NilAbove p)        = nilAbove_ (get w p)
     get w (TextBeside s sl p) = textBeside_ s sl (get1 w sl p)
-    get w (Nest k p)          = nest_ k (get (w -# k) p)
+    get w (Nest k p)          = nest_ k (get (w - k) p)
     get w (p `Union` q)       = nicest w r (get w p) (get w q)
     get _ (Above {})          = error "best get Above"
     get _ (Beside {})         = error "best get Beside"
 
-    get1 :: FastInt         -- (Remaining) width of line
-         -> FastInt         -- Amount of first line already eaten up
+    get1 :: Int         -- (Remaining) width of line
+         -> Int         -- Amount of first line already eaten up
          -> Doc         -- This is an argument to TextBeside => eat Nests
          -> Doc         -- No unions in here!
 
+    get1 w _ _ | w == 0 && False  = undefined
     get1 _ _  Empty               = Empty
     get1 _ _  NoDoc               = NoDoc
-    get1 w sl (NilAbove p)        = nilAbove_ (get (w -# sl) p)
-    get1 w sl (TextBeside t tl p) = textBeside_ t tl (get1 w (sl +# tl) p)
+    get1 w sl (NilAbove p)        = nilAbove_ (get (w - sl) p)
+    get1 w sl (TextBeside t tl p) = textBeside_ t tl (get1 w (sl + tl) p)
     get1 w sl (Nest _ p)          = get1 w sl p
     get1 w sl (p `Union` q)       = nicest1 w r sl (get1 w sl p)
                                                    (get1 w sl q)
     get1 _ _  (Above {})          = error "best get1 Above"
     get1 _ _  (Beside {})         = error "best get1 Beside"
 
-nicest :: FastInt -> FastInt -> Doc -> Doc -> Doc
-nicest w r p q = nicest1 w r (_ILIT(0)) p q
+nicest :: Int -> Int -> Doc -> Doc -> Doc
+nicest !w !r = nicest1 w r 0
 
-nicest1 :: FastInt -> FastInt -> Int# -> Doc -> Doc -> Doc
-nicest1 w r sl p q | fits ((w `minFastInt` r) -# sl) p = p
-                   | otherwise                   = q
+nicest1 :: Int -> Int -> Int -> Doc -> Doc -> Doc
+nicest1 !w !r !sl p q | fits ((w `min` r) - sl) p = p
+                      | otherwise                 = q
 
-fits :: FastInt     -- Space available
+fits :: Int  -- Space available
      -> Doc
      -> Bool -- True if *first line* of Doc fits in space available
-fits n _   | n <# _ILIT(0) = False
+fits n _ | n < 0           = False
 fits _ NoDoc               = False
 fits _ Empty               = True
 fits _ (NilAbove _)        = True
-fits n (TextBeside _ sl p) = fits (n -# sl) p
+fits n (TextBeside _ sl p) = fits (n - sl) p
 fits _ (Above {})          = error "fits Above"
 fits _ (Beside {})         = error "fits Beside"
 fits _ (Union {})          = error "fits Union"
@@ -962,26 +967,27 @@ fullRender m lineLen ribbons txt rest doc
                       _          -> lineLen
 
 display :: Mode -> Int -> Int -> (TextDetails -> a -> a) -> a -> Doc -> a
-display m page_width ribbon_width txt end doc
-  = case (iUnbox page_width) -# (iUnbox ribbon_width) of { gap_width ->
-    case gap_width `quotFastInt` _ILIT(2) of { shift ->
+display m !page_width !ribbon_width txt end doc
+  = case page_width - ribbon_width of { gap_width ->
+    case gap_width `quot` 2 of { shift ->
     let
-        lay k (Nest k1 p)  = lay (k +# k1) p
+        lay k _            | k `seq` False = undefined
+        lay k (Nest k1 p)  = lay (k + k1) p
         lay _ Empty        = end
         lay k (NilAbove p) = nlText `txt` lay k p
         lay k (TextBeside s sl p)
             = case m of
-                    ZigZagMode |  k >=# gap_width
+                    ZigZagMode |  k >= gap_width
                                -> nlText `txt` (
                                   Str (multi_ch shift '/') `txt` (
                                   nlText `txt`
-                                  lay1 (k -# shift) s sl p ))
+                                  lay1 (k - shift) s sl p ))
 
-                               |  k <# _ILIT(0)
+                               |  k < 0
                                -> nlText `txt` (
                                   Str (multi_ch shift '\\') `txt` (
                                   nlText `txt`
-                                  lay1 (k +# shift) s sl p ))
+                                  lay1 (k + shift) s sl p ))
 
                     _ -> lay1 k s sl p
         lay _ (Above {})   = error "display lay Above"
@@ -989,10 +995,12 @@ display m page_width ribbon_width txt end doc
         lay _ NoDoc        = error "display lay NoDoc"
         lay _ (Union {})   = error "display lay Union"
 
-        lay1 k s sl p = indent k (s `txt` lay2 (k +# sl) p)
+        lay1 !k s !sl p    = let !r = k + sl
+                             in indent k (s `txt` lay2 r p)
 
+        lay2 k _ | k `seq` False   = undefined
         lay2 k (NilAbove p)        = nlText `txt` lay k p
-        lay2 k (TextBeside s sl p) = s `txt` lay2 (k +# sl) p
+        lay2 k (TextBeside s sl p) = s `txt` lay2 (k + sl) p
         lay2 k (Nest _ p)          = lay2 k p
         lay2 _ Empty               = end
         lay2 _ (Above {})          = error "display lay2 Above"
@@ -1001,19 +1009,19 @@ display m page_width ribbon_width txt end doc
         lay2 _ (Union {})          = error "display lay2 Union"
 
         -- optimise long indentations using LitString chunks of 8 spaces
-        indent n r | n >=# _ILIT(8) = LStr (sLit "        ") (_ILIT(8)) `txt`
-                                      indent (n -# _ILIT(8)) r
-                   | otherwise      = Str (spaces n) `txt` r
+        indent !n r | n >= 8    = LStr (sLit "        ") 8 `txt`
+                                  indent (n - 8) r
+                    | otherwise = Str (spaces n) `txt` r
     in
-    lay (_ILIT(0)) doc
+    lay 0 doc
     }}
 
 cant_fail :: a
 cant_fail = error "easy_display: NoDoc"
 
-multi_ch :: Int# -> Char -> String
-multi_ch n ch | n <=# _ILIT(0) = ""
-              | otherwise      = ch : multi_ch (n -# _ILIT(1)) ch
+multi_ch :: Int -> Char -> String
+multi_ch !n ch | n <= 0    = ""
+               | otherwise = ch : multi_ch (n - 1) ch
 
 printDoc :: Mode -> Int -> Handle -> Doc -> IO ()
 -- printDoc adds a newline to the end
@@ -1040,10 +1048,10 @@ printDoc_ mode pprCols hdl doc
     done = return () -- hPutChar hdl '\n'
 
   -- some versions of hPutBuf will barf if the length is zero
-hPutLitString :: Handle -> Ptr a -> Int# -> IO ()
-hPutLitString handle a l = if l ==# _ILIT(0)
+hPutLitString :: Handle -> Ptr a -> Int -> IO ()
+hPutLitString handle a l = if l == 0
                             then return ()
-                            else hPutBuf handle a (iBox l)
+                            else hPutBuf handle a l
 
 -- Printing output in LeftMode is performance critical: it's used when
 -- dumping C and assembly output, so we allow ourselves a few dirty