#4978: Continuation passing style loop doesn't compile into a loop
---------------------------------+------------------------------------------
Reporter: tibbe | Owner:
Type: bug | Status: new
Priority: normal | Milestone:
Component: Compiler | Version: 7.0.1
Keywords: | Testcase:
Blockedby: | Difficulty:
Os: Unknown/Multiple | Blocking:
Architecture: Unknown/Multiple | Failure: None/Unknown
---------------------------------+------------------------------------------
Changes (by tibbe):
* cc: johan.tibell@… (added)
Comment:
Ignore the comment about using the static argument transformation. This
was just my guess at a solution to the problem (get rid of the
continuation being passed around by hoisting it.)
I have a more realistic test case (taken directly from
`Data.Binary.Builder` and then simplified). Your one line fix doesn't work
here.
{{{
module Repro2 (test) where
import qualified Data.ByteString as S
import Data.ByteString.Internal (inlinePerformIO)
import Data.Monoid
import Foreign
newtype Builder = Builder {
runBuilder :: (Buffer -> [S.ByteString]) -> Buffer ->
[S.ByteString]
}
instance Monoid Builder where
mempty = empty
{-# INLINE mempty #-}
mappend = append
{-# INLINE mappend #-}
mconcat = foldr mappend mempty
{-# INLINE mconcat #-}
empty :: Builder
empty = Builder (\ k b -> k b)
{-# INLINE empty #-}
singleton :: Word8 -> Builder
singleton = writeN 1 . flip poke
{-# INLINE singleton #-}
append :: Builder -> Builder -> Builder
append (Builder f) (Builder g) = Builder (f . g)
{-# INLINE append #-}
-- Our internal buffer type
data Buffer = Buffer {-# UNPACK #-} !(ForeignPtr Word8)
{-# UNPACK #-} !Int -- offset
{-# UNPACK #-} !Int -- used bytes
{-# UNPACK #-} !Int -- length left
-- | Sequence an IO operation on the buffer
unsafeLiftIO :: (Buffer -> IO Buffer) -> Builder
unsafeLiftIO f = Builder $ \ k buf -> inlinePerformIO $ do
buf' <- f buf
return (k buf')
{-# INLINE unsafeLiftIO #-}
-- | Get the size of the buffer
withSize :: (Int -> Builder) -> Builder
withSize f = Builder $ \ k buf@(Buffer _ _ _ l) -> runBuilder (f l) k buf
-- | Ensure that there are at least @n@ many bytes available.
ensureFree :: Int -> Builder
ensureFree n = n `seq` withSize $ \ l ->
if n <= l then empty
else error "Stub implementation: not enough space in buffer"
{-# INLINE ensureFree #-}
-- | Ensure that @n@ many bytes are available, and then use @f@ to write
some
-- bytes into the memory.
writeN :: Int -> (Ptr Word8 -> IO ()) -> Builder
writeN n f = ensureFree n `append` unsafeLiftIO (writeNBuffer n f)
{-# INLINE writeN #-}
writeNBuffer :: Int -> (Ptr Word8 -> IO ()) -> Buffer -> IO Buffer
writeNBuffer n f (Buffer fp o u l) = do
withForeignPtr fp (\p -> f (p `plusPtr` (o+u)))
return (Buffer fp o (u+n) (l-n))
{-# INLINE writeNBuffer #-}
-- Test case
fromWord8s :: [Word8] -> Builder
fromWord8s [] = mempty
fromWord8s (x:xs) = singleton x `mappend` fromWord8s xs
word8s :: [Word8]
word8s = replicate 10000 97
{-# NOINLINE word8s #-}
test :: Builder
test = fromWord8s word8s
}}}
The problem is the same as before (a continuation getting in the way of a
simple loop). In particular, lets look at the core for `fromWord8s`:
{{{
fromWord8s [Occ=LoopBreaker]
:: [Word8] -> Builder
[GblId, Arity=1, Str=DmdType S]
fromWord8s =
\ (ys :: [Word8]) ->
case ys of _ {
[] -> empty;
: x xs ->
let {
a1_sTE [Dmd=Just L] :: Builder
[LclId, Str=DmdType]
a1_sTE = fromWord8s xs } in
(\ (x2_aN1
:: Buffer -> [Data.ByteString.Internal.ByteString]) ->
let {
k [Dmd=Just L]
:: Buffer -> [Data.ByteString.Internal.ByteString]
[LclId, Str=DmdType]
k = (a1_sTE `cast` ...) x2_aN1 } in
\ (buf :: Buffer) ->
case buf
of _ { Buffer addr# rb1_dMB o u l ->
case <=# 1 l of _ { -- Buffer size check
False -> lvl1_rU0 `cast` ...;
True ->
case x of _ { W8# x# ->
case writeWord8OffAddr#
@ RealWorld
(plusAddr# addr# (+# o u))
0
x#
realWorld#
of s2_aQv { __DEFAULT ->
case touch#
@ ForeignPtrContents rb1_dMB s2_aQv
of _ { __DEFAULT ->
k
(Buffer
addr#
rb1_dMB
o
(+# u 1)
(-# l 1))
}
}
}
}
})
`cast` ...
}
}}}
I don't understand why `empty` hasn't been inlined here and whether that's
the reason we don't get a nice loop.
This particular performance bug is pretty important. The performance
difference is almost 10x in my benchmarks, which are quite representative
for what people actually use the package for (e.g. serializing lists of
things).
--
Ticket URL: <http://hackage.haskell.org/trac/ghc/ticket/4978#comment:2>
GHC <http://www.haskell.org/ghc/>
The Glasgow Haskell Compiler
_______________________________________________
Glasgow-haskell-bugs mailing list
[email protected]
http://www.haskell.org/mailman/listinfo/glasgow-haskell-bugs
