Avoid strictness in accumulator for unpackFoldr

The seq on the accumulator for unpackFoldr will break in the presence of
head/build rewrite rules. The empty list case will be forced, producing
an exception. This is a known issue with seq and rewrite rules that we
just stumbled on to.

diff --git a/Data/ByteString.hs b/Data/ByteString.hs
index f6e1b3e..f030970 100644 (file)
--- a/Data/ByteString.hs
+++ b/Data/ByteString.hs
@@ -280,7 +280,7 @@ import qualified Foreign.Concurrent as FC (newForeignPtr)
 
 import GHC.Handle
 import GHC.Prim                 (Word#, (+#), writeWord8OffAddr#)
--- import GHC.Base                 (build)
+import GHC.Base                 (build)
 import GHC.Word hiding (Word8)
 import GHC.Ptr                  (Ptr(..))
 import GHC.ST                   (ST(..))
@@ -432,7 +432,7 @@ pack str = unsafeCreate (P.length str) $ \(Ptr p) -> stToIO (go p 0# str)
 -- | /O(n)/ Converts a 'ByteString' to a '[Word8]'.
 unpack :: ByteString -> [Word8]
 
--- #if !defined(__GLASGOW_HASKELL__)
+#if !defined(__GLASGOW_HASKELL__)
 
 unpack (PS _  _ 0) = []
 unpack (PS ps s l) = inlinePerformIO $ withForeignPtr ps $ \p ->
@@ -443,14 +443,29 @@ unpack (PS ps s l) = inlinePerformIO $ withForeignPtr ps $ \p ->
         go p n acc = peekByteOff p n >>= \e -> go p (n-1) (e : acc)
 {-# INLINE unpack #-}
 
--- #else
+#else
 
 --
 -- Interacting with head/build fusion rule in ghc 6.5. Disable for now
 --
 
--- unpack ps = build (unpackFoldr ps)
--- {-# INLINE unpack #-}
+unpack ps = build (unpackFoldr ps)
+{-# INLINE unpack #-}
+
+--
+-- critical this isn't strict in the acc
+-- as it will break in the presence of list fusion. this is a known
+-- issue with seq and rewrite rules
+--
+unpackFoldr :: ByteString -> (Word8 -> a -> a) -> a -> a
+unpackFoldr (PS fp off len) f ch = withPtr fp $ \p -> do
+    let loop q n    _   | q `seq` n `seq` False = undefined -- n.b.
+        loop _ (-1) acc = return acc
+        loop q n    acc = do
+           a <- peekByteOff q n
+           loop q (n-1) (a `f` acc)
+    loop (p `plusPtr` off) (len-1) ch
+{-# INLINE [0] unpackFoldr #-}
 
 unpackList :: ByteString -> [Word8]
 unpackList (PS fp off len) = withPtr fp $ \p -> do
@@ -465,17 +480,7 @@ unpackList (PS fp off len) = withPtr fp $ \p -> do
 "unpack-list"  [1]  forall p  . unpackFoldr p (:) [] = unpackList p
  #-}
 
-unpackFoldr :: ByteString -> (Word8 -> a -> a) -> a -> a
-unpackFoldr (PS fp off len) f ch = withPtr fp $ \p -> do
-    let STRICT3(loop)
-        loop _ (-1) acc = return acc
-        loop q n    acc = do
-           a <- peekByteOff q n
-           loop q (n-1) (a `f` acc)
-    loop (p `plusPtr` off) (len-1) ch
-{-# INLINE [0] unpackFoldr #-}
-
--- #endif
+#endif
 
 ------------------------------------------------------------------------