Refactor LitString

Refactor LitString so that the string length is computed at most once
and then stored.

Also remove strlen and memcmp wrappers (it seems like they were a
workaround for a very old GCC when using -fvia-C).

Bumps haddock submodule.

Reviewers: bgamari, dfeuer, nickkuk

Reviewed By: bgamari, nickkuk

Subscribers: nickkuk, dfeuer, thomie, carter

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

5 files changed, 83 insertions, 81 deletions

diff --git a/compiler/parser/cutils.c b/compiler/parser/cutils.c
index fdaea44cc7..eca3e3d25c 100644
--- a/compiler/parser/cutils.c
+++ b/compiler/parser/cutils.c
@@ -13,23 +13,6 @@ places in the GHC library.
 #include <unistd.h>
 #endif
 
-/*
-Calling 'strlen' and 'memcpy' directly gives problems with GCC's inliner,
-and causes gcc to require too many registers on x84
-*/
-
-HsInt
-ghc_strlen( HsPtr a )
-{
-    return (strlen((char *)a));
-}
-
-HsInt
-ghc_memcmp( HsPtr a1, HsPtr a2, HsInt len )
-{
-    return (memcmp((char *)a1, a2, len));
-}
-
 void
 enableTimingStats( void )       /* called from the driver */
 {
diff --git a/compiler/parser/cutils.h b/compiler/parser/cutils.h
index 0c8ab12a2c..009fffa86f 100644
--- a/compiler/parser/cutils.h
+++ b/compiler/parser/cutils.h
@@ -6,10 +6,5 @@
 
 #include "HsFFI.h"
 
-// Out-of-line string functions, see compiler/utils/FastString.hs
-HsInt ghc_strlen( HsAddr a );
-HsInt ghc_memcmp( HsAddr a1, HsAddr a2, HsInt len );
-
-
 void enableTimingStats( void );
 void setHeapSize( HsInt size );
diff --git a/compiler/utils/BufWrite.hs b/compiler/utils/BufWrite.hs
index e25bf06c4c..99c043ce41 100644
--- a/compiler/utils/BufWrite.hs
+++ b/compiler/utils/BufWrite.hs
@@ -20,6 +20,7 @@ module BufWrite (
         bPutFS,
         bPutFZS,
         bPutLitString,
+        bPutReplicate,
         bFlush,
   ) where
 
@@ -97,19 +98,45 @@ bPutCStringLen b@(BufHandle buf r hdl) cstr@(ptr, len) = do
                 copyBytes (buf `plusPtr` i) ptr len
                 writeFastMutInt r (i + len)
 
-bPutLitString :: BufHandle -> LitString -> Int -> IO ()
-bPutLitString b@(BufHandle buf r hdl) a len = a `seq` do
+bPutLitString :: BufHandle -> LitString -> IO ()
+bPutLitString b@(BufHandle buf r hdl) l@(LitString a len) = l `seq` do
   i <- readFastMutInt r
   if (i+len) >= buf_size
         then do hPutBuf hdl buf i
                 writeFastMutInt r 0
                 if (len >= buf_size)
                     then hPutBuf hdl a len
-                    else bPutLitString b a len
+                    else bPutLitString b l
         else do
                 copyBytes (buf `plusPtr` i) a len
                 writeFastMutInt r (i+len)
 
+-- | Replicate an 8-bit character
+bPutReplicate :: BufHandle -> Int -> Char -> IO ()
+bPutReplicate (BufHandle buf r hdl) len c = do
+  i <- readFastMutInt r
+  let oc = fromIntegral (ord c)
+  if (i+len) < buf_size
+    then do
+      fillBytes (buf `plusPtr` i) oc len
+      writeFastMutInt r (i+len)
+    else do
+      -- flush the current buffer
+      when (i /= 0) $ hPutBuf hdl buf i
+      if (len < buf_size)
+        then do
+          fillBytes buf oc len
+          writeFastMutInt r len
+        else do
+          -- fill a full buffer
+          fillBytes buf oc buf_size
+          -- flush it as many times as necessary
+          let go n | n >= buf_size = do
+                                       hPutBuf hdl buf buf_size
+                                       go (n-buf_size)
+                   | otherwise     = writeFastMutInt r n
+          go len
+
 bFlush :: BufHandle -> IO ()
 bFlush (BufHandle buf r hdl) = do
   i <- readFastMutInt r
diff --git a/compiler/utils/FastString.hs b/compiler/utils/FastString.hs
index f16b32779f..6ca3043668 100644
--- a/compiler/utils/FastString.hs
+++ b/compiler/utils/FastString.hs
@@ -18,7 +18,7 @@
 --
 -- ['LitString']
 --
---   * Just a wrapper for the @Addr#@ of a C string (@Ptr CChar@).
+--   * Pointer and size of a Latin-1 encoded string.
 --   * Practically no operations.
 --   * Outputing them is fast.
 --   * Generated by 'sLit'.
@@ -81,7 +81,7 @@ module FastString
         hasZEncoding,
 
         -- * LitStrings
-        LitString,
+        LitString (..),
 
         -- ** Construction
         sLit,
@@ -130,7 +130,7 @@ import Foreign
 import GHC.Conc.Sync    (sharedCAF)
 #endif
 
-import GHC.Base         ( unpackCString# )
+import GHC.Base         ( unpackCString#, unpackNBytes# )
 
 #define hASH_TBL_SIZE          4091
 #define hASH_TBL_SIZE_UNBOXED  4091#
@@ -227,7 +227,7 @@ cmpFS f1@(FastString u1 _ _ _) f2@(FastString u2 _ _ _) =
   if u1 == u2 then EQ else
   compare (fastStringToByteString f1) (fastStringToByteString f2)
 
-foreign import ccall unsafe "ghc_memcmp"
+foreign import ccall unsafe "memcmp"
   memcmp :: Ptr a -> Ptr b -> Int -> IO Int
 
 -- -----------------------------------------------------------------------------
@@ -568,15 +568,12 @@ hPutFS handle fs = BS.hPut handle $ fastStringToByteString fs
 -- -----------------------------------------------------------------------------
 -- LitStrings, here for convenience only.
 
--- | A 'LitString' is a pointer to some null-terminated array of bytes.
-type LitString = Ptr Word8
---Why do we recalculate length every time it's requested?
---If it's commonly needed, we should perhaps have
---data LitString = LitString {-#UNPACK#-}!Addr# {-#UNPACK#-}!Int#
+-- | A 'LitString' is a pointer to some array of Latin-1 encoded chars.
+data LitString = LitString !(Ptr Word8) !Int
 
 -- | Wrap an unboxed address into a 'LitString'.
 mkLitString# :: Addr# -> LitString
-mkLitString# a# = Ptr a#
+mkLitString# a# = LitString (Ptr a#) (ptrStrLength (Ptr a#))
 
 -- | Encode a 'String' into a newly allocated 'LitString' using Latin-1
 -- encoding.  The original string must not contain non-Latin-1 characters
@@ -584,32 +581,34 @@ mkLitString# a# = Ptr a#
 {-# INLINE mkLitString #-}
 mkLitString :: String -> LitString
 mkLitString s =
+ -- we don't use `unsafeDupablePerformIO` here to avoid potential memory leaks
+ -- and because someone might be using `eqAddr#` to check for string equality.
  unsafePerformIO (do
-   p <- mallocBytes (length s + 1)
+   let len = length s
+   p <- mallocBytes len
    let
      loop :: Int -> String -> IO ()
-     loop !n [] = pokeByteOff p n (0 :: Word8)
+     loop !_ []    = return ()
      loop n (c:cs) = do
         pokeByteOff p n (fromIntegral (ord c) :: Word8)
         loop (1+n) cs
    loop 0 s
-   return p
+   return (LitString p len)
  )
 
 -- | Decode a 'LitString' back into a 'String' using Latin-1 encoding.
 -- This does not free the memory associated with 'LitString'.
 unpackLitString :: LitString -> String
-unpackLitString (Ptr p) = unpackCString# p
+unpackLitString (LitString (Ptr p#) (I# n#)) = unpackNBytes# p# n#
 
--- | Compute the length of a 'LitString', which must necessarily be
--- null-terminated.
+-- | Return the length of a 'LitString'
 lengthLS :: LitString -> Int
-lengthLS = ptrStrLength
+lengthLS (LitString _ n) = n
 
 -- -----------------------------------------------------------------------------
 -- under the carpet
 
-foreign import ccall unsafe "ghc_strlen"
+foreign import ccall unsafe "strlen"
   ptrStrLength :: Ptr Word8 -> Int
 
 {-# NOINLINE sLit #-}
diff --git a/compiler/utils/Pretty.hs b/compiler/utils/Pretty.hs
index 9a12c7dae9..1a8bc23205 100644
--- a/compiler/utils/Pretty.hs
+++ b/compiler/utils/Pretty.hs
@@ -103,7 +103,7 @@ module Pretty (
         Mode(..),
 
         -- ** General rendering
-        fullRender,
+        fullRender, txtPrinter,
 
         -- ** GHC-specific rendering
         printDoc, printDoc_,
@@ -120,7 +120,7 @@ import System.IO
 import Numeric (showHex)
 
 --for a RULES
-import GHC.Base ( unpackCString# )
+import GHC.Base ( unpackCString#, unpackNBytes#, Int(..) )
 import GHC.Ptr  ( Ptr(..) )
 
 -- Don't import Util( assertPanic ) because it makes a loop in the module structure
@@ -270,8 +270,10 @@ 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 {-#UNPACK #-} !Int
+                 | LStr {-# UNPACK #-} !LitString
                    -- a '\0'-terminated array of bytes
+                 | RStr {-# UNPACK #-} !Int {-# UNPACK #-} !Char
+                   -- a repeated character (e.g., ' ')
 
 instance Show Doc where
   showsPrec _ doc cont = fullRender (mode style) (lineLength style)
@@ -296,25 +298,28 @@ char c = textBeside_ (Chr c) 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 length s of {sl -> textBeside_ (Str s)  sl Empty}
+text s = textBeside_ (Str s) (length s) Empty
 {-# NOINLINE [0] text #-}   -- Give the RULE a chance to fire
                             -- It must wait till after phase 1 when
                             -- the unpackCString first is manifested
 
 -- RULE that turns (text "abc") into (ptext (A# "abc"#)) to avoid the
 -- intermediate packing/unpacking of the string.
-{-# RULES
-  "text/str" forall a. text (unpackCString# a) = ptext (Ptr a)
- #-}
+{-# RULES "text/str"
+    forall a. text (unpackCString# a)  = ptext (mkLitString# a)
+  #-}
+{-# RULES "text/unpackNBytes#"
+    forall p n. text (unpackNBytes# p n) = ptext (LitString (Ptr p) (I# n))
+  #-}
 
 ftext :: FastString -> Doc
-ftext s = case lengthFS s of {sl -> textBeside_ (PStr s) sl Empty}
+ftext s = textBeside_ (PStr s) (lengthFS s) Empty
 
 ptext :: LitString -> Doc
-ptext s = case lengthLS s of {sl -> textBeside_ (LStr s sl) sl Empty}
+ptext s = textBeside_ (LStr s) (lengthLS s) Empty
 
 ztext :: FastZString -> Doc
-ztext s = case lengthFZS s of {sl -> textBeside_ (ZStr s) sl Empty}
+ztext s = textBeside_ (ZStr s) (lengthFZS s) Empty
 
 -- | Some text with any width. (@text s = sizedText (length s) s@)
 sizedText :: Int -> String -> Doc
@@ -336,12 +341,6 @@ isEmpty :: Doc -> Bool
 isEmpty Empty = True
 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 = replicate n ' '
-
 {-
 Q: What is the reason for negative indentation (i.e. argument to indent
    is < 0) ?
@@ -655,7 +654,7 @@ 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 > 0      -- No newline if no overlap
-                             = textBeside_ (Str (spaces k)) k q
+                             = textBeside_ (RStr k ' ') k q
                              | otherwise           -- Put them really above
                              = nilAbove_ (mkNest k q)
 
@@ -938,11 +937,12 @@ renderStyle s = fullRender (mode s) (lineLength s) (ribbonsPerLine s)
 
 -- | Default TextDetails printer
 txtPrinter :: TextDetails -> String -> String
-txtPrinter (Chr c)   s  = c:s
-txtPrinter (Str s1)  s2 = s1 ++ s2
-txtPrinter (PStr s1) s2 = unpackFS s1 ++ s2
-txtPrinter (ZStr s1) s2 = zString s1 ++ s2
-txtPrinter (LStr s1 _) s2 = unpackLitString s1 ++ s2
+txtPrinter (Chr c)    s  = c:s
+txtPrinter (Str s1)   s2 = s1 ++ s2
+txtPrinter (PStr s1)  s2 = unpackFS s1 ++ s2
+txtPrinter (ZStr s1)  s2 = zString s1 ++ s2
+txtPrinter (LStr s1)  s2 = unpackLitString s1 ++ s2
+txtPrinter (RStr n c) s2 = replicate n c ++ s2
 
 -- | The general rendering interface.
 fullRender :: Mode                     -- ^ Rendering mode
@@ -1028,10 +1028,7 @@ display m !page_width !ribbon_width txt end doc
         lay2 _ NoDoc               = error "display lay2 NoDoc"
         lay2 _ (Union {})          = error "display lay2 Union"
 
-        -- optimise long indentations using LitString chunks of 8 spaces
-        indent !n r | n >= 8    = LStr (sLit "        ") 8 `txt`
-                                  indent (n - 8) r
-                    | otherwise = Str (spaces n) `txt` r
+        indent !n r                = RStr n ' ' `txt` r
     in
     lay 0 doc
     }}
@@ -1050,21 +1047,21 @@ printDoc_ mode pprCols hdl doc
   = do { fullRender mode pprCols 1.5 put done doc ;
          hFlush hdl }
   where
-    put (Chr c)  next = hPutChar hdl c >> next
-    put (Str s)  next = hPutStr  hdl s >> next
-    put (PStr s) next = hPutStr  hdl (unpackFS s) >> next
-                        -- NB. not hPutFS, we want this to go through
-                        -- the I/O library's encoding layer. (#3398)
-    put (ZStr s) next = hPutFZS  hdl s >> next
-    put (LStr s l) next = hPutLitString hdl s l >> next
+    put (Chr c)    next = hPutChar hdl c >> next
+    put (Str s)    next = hPutStr  hdl s >> next
+    put (PStr s)   next = hPutStr  hdl (unpackFS s) >> next
+                          -- NB. not hPutFS, we want this to go through
+                          -- the I/O library's encoding layer. (#3398)
+    put (ZStr s)   next = hPutFZS  hdl s >> next
+    put (LStr s)   next = hPutLitString hdl s >> next
+    put (RStr n c) next = hPutStr hdl (replicate n c) >> next
 
     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 == 0
-                            then return ()
-                            else hPutBuf handle a l
+hPutLitString :: Handle -> LitString -> IO ()
+hPutLitString _handle (LitString _ 0) = return ()
+hPutLitString handle  (LitString a l) = 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
@@ -1102,7 +1099,8 @@ layLeft b (TextBeside s _ p) = s `seq` (put b s >> layLeft b p)
     put b (Str s)    = bPutStr  b s
     put b (PStr s)   = bPutFS   b s
     put b (ZStr s)   = bPutFZS  b s
-    put b (LStr s l) = bPutLitString b s l
+    put b (LStr s)   = bPutLitString b s
+    put b (RStr n c) = bPutReplicate b n c
 layLeft _ _                  = panic "layLeft: Unhandled case"
 
 -- Define error=panic, for easier comparison with libraries/pretty.