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
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 ()
_______________________________________________
Glasgow-haskell-bugs mailing list
[EMAIL PROTECTED]
http://www.haskell.org/mailman/listinfo/glasgow-haskell-bugs
