GHCI segfaults with Data.Binary instances

[BigEndian]

The following code seems to crash GHCi

I apologize for the long test case, but I'll need to rebuild ghc with symbols first before I can reduce the test case.

GHCi's output is

eric@sagacity ~/prog/haskell/tasks master > ghci
GHCi, version 7.6.2: http://www.haskell.org/ghc/  :? for help
Loading package ghc-prim ... linking ... done.
Loading package integer-gmp ... linking ... done.
Loading package base ... linking ... done.
Prelude> :l Segfault.hs
[1 of 1] Compiling Main             ( Segfault.hs, interpreted )
Ok, modules loaded: Main.
*Main> main
Loading package array-0.4.0.1 ... linking ... done.
Loading package deepseq-1.3.0.1 ... linking ... done.
Loading package bytestring-0.10.0.2 ... linking ... done.
Loading package containers-0.5.0.0 ... linking ... done.
Loading package binary-0.5.1.1 ... linking ... done.
"zsh: segmentation fault  ghci

Related code is

module Main where

import qualified Data.ByteString as BW
import Data.Word(Word8(..))
import Data.Binary
import Control.Monad
import Data.Char

convertWord8ToChar :: Word8 -> Char
convertWord8ToChar = chr . fromIntegral

convertCharToWord8 :: Char -> Word8
convertCharToWord8 = fromIntegral . ord

stringToWByteString :: String -> BW.ByteString
stringToWByteString = BW.pack . map convertCharToWord8

wByteStringToString :: BW.ByteString -> String
wByteStringToString = map convertWord8ToChar . BW.unpack

newtype TaskString = TaskString BW.ByteString deriving (Read, Show)

stringToTaskString :: String -> TaskString
stringToTaskString = TaskString . stringToWByteString

word8sToTaskString :: [Word8] -> TaskString
word8sToTaskString = TaskString . BW.pack

instance Binary TaskString where
   get = do
            (return . word8sToTaskString . init) =<< readWord8sUntil 0
         where
            readWord8sUntil :: Word8 -> Get [Word8]
            readWord8sUntil val = do
               w8 <- getWord8
               if w8 == val then
                  return $ [w8]
               else
                  (return . (w8:)) =<< (readWord8sUntil val)

   put (TaskString bws) = mapM_ putWord8 $ (BW.unpack bws) ++ [0]

data Task =
   Task { taskTitle :: TaskString, taskNotes :: TaskString, taskPriority :: Int }
      deriving (Read, Show)                                                                                                                                                                                

instance Binary Task where
   get = do
            tt <- get :: Get TaskString
            tn <- get :: Get TaskString                                                                                                                                                                                tp <- get :: Get Int
            return Task { taskTitle = tt, taskNotes = tn, taskPriority = tp }

   put t = do
            put $ taskTitle t
            put $ taskNotes t
            put $ taskPriority t


exTaskTitle = stringToTaskString "Do the dishes"
exTaskNotes = stringToTaskString "Must be done by 12:00 today"
exTaskPriority = 0
encTaskTitle = encode exTaskTitle
decTaskTitle = decode encTaskTitle :: TaskString

exTask = Task { taskTitle = exTaskTitle,
                taskNotes = exTaskNotes,
                taskPriority = exTaskPriority }

encTask = encode exTask
decTask = decode encTask :: Task

main = do
   putStrLn $ show encTask

[BigEndian]

Also, just to add information, this is in the Gentoo's latest nomultilib hardened profile.

As such, if these patches are contributed by Gentoo developers alone, please feel free to mark this bug as closed.

[simonpj]

Hmm. Works for me on both 32-bit Windows and 64-bit Linux.

Can anyone else reproduce?

Simon

[igloo]

Works here too, on Linux/amd64. In the absence of evidence to the contrary, let's assume that the problem is caused by the Gentoo patches.