GHCI segfaults with Data.Binary instances
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
Trac metadata
Trac field | Value |
---|---|
Version | 7.6.2 |
Type | Bug |
TypeOfFailure | OtherFailure |
Priority | normal |
Resolution | Unresolved |
Component | Compiler |
Test case | |
Differential revisions | |
BlockedBy | |
Related | |
Blocking | |
CC | |
Operating system | Unknown/Multiple |
Architecture | Unknown/Multiple |