SegFault caused by some IO+Arrays+GC interaction

[Tomasz Zielonka]

Hello!

The attached program uses no unsafe operations and yet it segfaults from
time to time. Try it on some file of moderate size, like:

$ ghc --version
The Glorious Glasgow Haskell Compilation System, version 6.2.1
$ ghc -O --make Bug -o Bug
Chasing modules from: Bug
Compiling Main             ( Bug.hs, Bug.o )
Linking ...
$ ls -l /etc/termcap
-rw-r--r--    1 root     root       737535 lip 20  2001 /etc/termcap
$ ./Bug < /etc/termcap > /dev/null
Segmentation fault (core dumped)
$ ./Bug < /etc/termcap > /dev/null
$ ghc --version
The Glorious Glasgow Haskell Compilation System, version 6.2.1
$ gcc --version
gcc (GCC) 3.3.3
Copyright (C) 2003 Free Software Foundation, Inc.
This is free software; see the source for copying conditions.  There is
NO warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR
PURPOSE.

$ uname -a
Linux green.local.gem.pl 2.4.18-10 #1 Wed Aug 7 10:26:48 EDT 2002 i686
unknown

Notice that this program calls performGC after every processed word
and commenting this out seems to eliminate the problem. Perhaps this
is a silly thing to do, but I don't think it should result in SEGV.

If this qualifies as a bug, tell me if I can do anything to help you
nail it down.

Best regards,
Tom

-- 
.signature: Too many levels of symbolic links
-------------- next part --------------

import Data.Array.IO
import Data.Array.Unboxed
import Data.Array.Base
import Data.Array.ST
import Data.Word
import System.IO
import System.IO.Unsafe
import Control.Monad.ST
import Control.Monad
import System.Mem

main :: IO ()
main = do
    ws <- getArrayWords
    (`mapM_` ws) $ \w -> do
	ioarr <- thaw w
	putArray ioarr
	putStrLn ""
	performGC

putArray :: IOUArray Int Word8 -> IO ()
putArray arr = do
    when (rangeSize (bounds arr) > 0) $ hPutArray stdout arr (rangeSize (bounds arr))

getArrays :: IO [UArray Int Word8]
getArrays = {- unsafeInterleaveIO $ -} do
    ioarr <- newArray (0, blockSize-1) 0 :: IO (IOUArray Int Word8)
    n <- hGetArray stdin ioarr blockSize
    case n of
	0 -> do
	    return []
	_ | n > 0 -> do
	    arr0 <- freeze ioarr
	    arr <-
		if n < blockSize
		    then do
			return (array (0, n-1) [ (i, arr0 ! i) | i <- [0..n-1] ])
		    else do
			return arr0
	    arrs <- getArrays
	    return (arr : arrs)
  where
    blockSize :: Int
    blockSize = 2 ^ (16 :: Int)

findInArray p arr pos =
    loop pos
  where
    rbound = snd (bounds arr)
    loop i  | i > rbound		= Nothing
	    | p (arr ! i)		= Just i
	    | otherwise			= loop $! (i + 1)

getArrayWords :: IO [UArray Int Word8]
getArrayWords = do
    blocks <- getArrays
    return (buildWords 0 blocks)
  where
    buildWords pos bs =
	skipWhiteSpace pos bs $
	\pos bs -> 
	    case findInBuffers isWhite pos bs of
		Just (Right whitePos) ->
		    takeArray pos bs whitePos $
			\w pos bs -> w : buildWords pos bs
		Just (Left charsLeft) ->
		    takeArray pos bs charsLeft $
			\w pos bs -> [w]
		Nothing ->
		    []

findInBuffers :: (Word8 -> Bool) -> Int -> [UArray Int Word8] -> Maybe (Either Int Int)
findInBuffers = findInBuffersAcc 0
  where
    findInBuffersAcc acc p pos (buf:bufs) =
	case findInArray p buf pos of
	    Just nlPos -> Just (Right (acc + nlPos - pos))
	    Nothing -> (findInBuffersAcc $! acc + snd (bounds buf) - pos + 1) p 0 bufs 
    findInBuffersAcc 0 _ _ [] = Nothing
    findInBuffersAcc acc _ _ [] = Just (Left acc)

isWhite :: Word8 -> Bool
isWhite c = c == 10 || c == 13 || c == 9 || c == 32

skipWhiteSpace pos (bufs@(b:bs)) cont
    | not (isWhite (b ! pos))	= cont pos bufs
    | pos == snd (bounds b)	= skipWhiteSpace 0 bs cont
    | otherwise			= (skipWhiteSpace $! (pos+1)) bufs cont
skipWhiteSpace pos [] cont = cont pos []

takeArray pos0 bs0 len cont =
    runST (do
	marr <- newArray (0, len-1) 0 :: ST s (STUArray s Int Word8)
	fillArray marr 0 pos0 bs0
    )
  where
    fillArray marr marrPos pos bufs = do
	if marrPos == len
	    then do
		arr <- freeze marr
		return (cont arr pos bufs)
	    else do
		let (b:bs) = bufs
		    remain = len - marrPos
		    inThisArray = snd (bounds b) - pos + 1
		if inThisArray <= remain
		    then do
			copyFromArray b pos marr marrPos inThisArray
			fillArray marr (marrPos + inThisArray) 0 bs
		    else  do
			-- inThisArray > remain
			copyFromArray b pos marr marrPos remain
			fillArray marr (marrPos + remain) (pos + remain) (b:bs)

    copyFromArray src srcPos dst dstPos count 
	| count > 0 = do
	    writeArray dst dstPos (src ! srcPos)
	    ((copyFromArray src $! (srcPos+1)) dst $! (dstPos+1)) $! (count-1)
	| otherwise = do
	    return ()