Permalink
Browse files

Merge

  • Loading branch information...
2 parents d94a657 + 93b68ce commit e3827d743279f41cf9d632aa742d47fe3df321c5 @bos committed Jun 29, 2011
Showing with 40 additions and 18 deletions.
  1. +26 −9 Data/Text/Format.hs
  2. +2 −2 Data/Text/Format/Types/Internal.hs
  3. +12 −7 benchmarks/Simple.hs
View
@@ -48,30 +48,46 @@ import qualified Data.Text.Buildable as B
import qualified Data.Text.Lazy as LT
import qualified Data.Text.Lazy.IO as LT
+-- Format strings are almost always constants, and they're expensive
+-- to interpret (which we refer to as "cracking" here). We'd really
+-- like to have GHC memoize the cracking of a known-constant format
+-- string, so that it occurs at most once.
+--
+-- To achieve this, we arrange to have the cracked version of a format
+-- string let-floated out as a CAF, by inlining the definitions of
+-- build and functions that invoke it. This works well with GHC 7.
+
-- | Render a format string and arguments to a 'Builder'.
build :: Params ps => Format -> ps -> Builder
-build (Format fmt) ps = zipParams (map fromText . ST.splitOn "{}" $ fmt) xs
- where zipParams (f:fs) (y:ys) = f <> y <> zipParams fs ys
- zipParams [f] [] = f
- zipParams _ _ = error . LT.unpack $ format
- "Data.Text.Format.build: {} sites, but {} parameters"
- (ST.count "{}" fmt, length xs)
- xs = buildParams ps
+build fmt ps = zipParams fmt (crack fmt) (buildParams ps)
+{-# INLINE build #-}
+
+zipParams :: Format -> [Builder] -> [Builder] -> Builder
+zipParams fmt xs = go xs
+ where go (f:fs) (y:ys) = f <> y <> go fs ys
+ go [f] [] = f
+ go _ _ = error . LT.unpack $ format
+ "Data.Text.Format.build: {} sites, but {} parameters"
+ (ST.count "{}" (fromFormat fmt), length xs)
+
+crack :: Format -> [Builder]
+crack = map fromText . ST.splitOn "{}" . fromFormat
-- | Render a format string and arguments to a 'LT.Text'.
format :: Params ps => Format -> ps -> LT.Text
format fmt ps = toLazyText $ build fmt ps
+{-# INLINE format #-}
-- | Render a format string and arguments, then print the result.
print :: (MonadIO m, Params ps) => Format -> ps -> m ()
-{-# SPECIALIZE print :: (Params ps) => Format -> ps -> IO () #-}
print fmt ps = liftIO . LT.putStr . toLazyText $ build fmt ps
+{-# INLINE print #-}
-- | Render a format string and arguments, then print the result to
-- the given file handle.
hprint :: (MonadIO m, Params ps) => Handle -> Format -> ps -> m ()
-{-# SPECIALIZE hprint :: (Params ps) => Handle -> Format -> ps -> IO () #-}
hprint h fmt ps = liftIO . LT.hPutStr h . toLazyText $ build fmt ps
+{-# INLINE hprint #-}
-- | Pad the left hand side of a string until it reaches @k@
-- characters wide, if necessary filling with character @c@.
@@ -120,3 +136,4 @@ expt decs = B.build . C.toExponential decs . realToFrac
-- is added.)
hex :: Integral a => a -> Builder
hex = B.build . Hex
+{-# INLINE hex #-}
@@ -43,8 +43,8 @@ import Data.Typeable (Typeable)
--
-- The underlying type is 'Text', so literal Haskell strings that
-- contain Unicode characters will be correctly handled.
-newtype Format = Format Text
- deriving (Eq, Ord, Typeable)
+newtype Format = Format { fromFormat :: Text }
+ deriving (Eq, Ord, Typeable, Show)
instance Monoid Format where
Format a `mappend` Format b = Format (a `mappend` b)
View
@@ -3,6 +3,7 @@
--module Main (main) where
import Control.Monad
+import Data.Char
import Data.Bits
import System.Environment
import Data.Text.Format as T
@@ -41,28 +42,32 @@ p6 count = counting count $ \i x -> do
L.putStr . encodeUtf8 $ t
arg :: Int -> Text
-arg i = T.replicate (i.&.4) "fnord"
+arg i = "fnord" `T.append` (T.take (i `mod` 6) "foobar")
{-# NOINLINE arg #-}
one count = counting count $ \i x -> do
- let t = T.format "hi mom {}\n" (Only (arg i))
+ let k = arg i
+ let t = {-# SCC "one/format" #-} T.format "hi mom {}\n" (Only k)
L.putStr . encodeUtf8 $ t
two count = counting count $ \i x -> do
- let t = T.format "hi mom {} {}\n" (arg i,arg (i+1))
+ let k = arg i
+ let t = {-# SCC "two/format" #-} T.format "hi mom {} {}\n" (k,k)
L.putStr . encodeUtf8 $ t
three count = counting count $ \i x -> do
- let t = T.format "hi mom {} {} {}\n" (arg i,arg (i+1),arg (i+2))
+ let k = arg i
+ let t = {-# SCC "three/format" #-} T.format "hi mom {} {} {}\n" (k,k,k)
L.putStr . encodeUtf8 $ t
four count = counting count $ \i x -> do
- let t = T.format "hi mom {} {} {} {}\n" (arg i,arg (i+1),arg (i+2),arg (i+3))
+ let k = arg i
+ let t = {-# SCC "four/format" #-} T.format "hi mom {} {} {} {}\n" (k,k,k,k)
L.putStr . encodeUtf8 $ t
five count = counting count $ \i x -> do
- let t = T.format "hi mom {} {} {} {} {}\n"
- (arg i,arg (i+1),arg (i+2),arg (i+3),arg (i+4))
+ let k = arg i
+ let t = {-# SCC "five/format" #-} T.format "hi mom {} {} {} {} {}\n" (k,k,k,k,k)
L.putStr . encodeUtf8 $ t
dpi :: Double

0 comments on commit e3827d7

Please sign in to comment.