#3458: Allocation where none should happen
-------------------------------+--------------------------------------------
Reporter: guest | Owner:
Type: bug | Status: new
Priority: normal | Milestone:
Component: Compiler | Version: 6.10.1
Severity: normal | Resolution:
Keywords: | Difficulty: Unknown
Testcase: | Os: Linux
Architecture: x86_64 (amd64) |
-------------------------------+--------------------------------------------
Comment (by guest):
{{{
ll = 60,
next :: Word32 -> Word32
next s = (ia*s + ic) `rem` im
ia = 3877
ic = 29573
im = 139968
}}}
The whole program (changed to use IOUArray everywhere now, but the problem
remains):
{{{
{-# OPTIONS -O2 -funbox-strict-fields -fexcess-precision -fvia-C -optc-O3
-optc-ffast-math -optc-fomit-frame-pointer -optc-march=native -optc-
mfpmath=sse -optc-msse3 #-}
------------------------------------------------------------------------
---
--- The Computer Language Benchmarks Game
---
--- http://shootout.alioth.debian.org
---
--- Fasta Benchmark
---
--- Program by Rohan Lean
---
------------------------------------------------------------------------
import Control.Arrow
import Control.Concurrent
import Data.Array.Base
import Data.Array.IO
import Data.Array.Unboxed
import Data.ByteString.Internal
import Data.Word
import System
import System.IO
------------------------------------------------------------------------
main = do n <- readIO . head =<< getArgs
putStrLn ">ONE Homo sapiens alu"
write_alu (2*n)
putStrLn ">TWO IUB ambiguity codes"
s <- write iub (3*n) 42
putStrLn ">THREE Homo sapiens frequency"
write hom (5*n) s
------------------------------------------------------------------------
ll = 60 -- line length
------------------------------------------------------------------------
write_alu n = loop n =<< newListArray (1,bs) ul where
cc = length alu_string `lcm` ll
bs = cc + quot cc ll
un = \s -> (take ll s) ++ [0x0a] ++ un (drop ll s)
ul = un $ cycle $ map c2w alu_string
loop n b
| cc <= n = do
hPutArray stdout b bs
loop (n-cc) b
| otherwise = do
hPutArray stdout b (n + quot n ll)
if rem n ll /= 0
then putChar '\n'
else return ()
------------------------------------------------------------------------
---
--- Constants for the linear congruential PRNG
---
ia = 3877
ic = 29573
im = 139968
------------------------------------------------------------------------
next :: Word32 -> Word32
next s = (ia*s + ic) `rem` im
skip n s = foldr id s $ replicate n next
------------------------------------------------------------------------
tn = 1 -- number of working threads
lc = 250 -- threads prepare that many lines
cc = lc*ll -- thus many characters
bs = cc+lc -- buffersize
------------------------------------------------------------------------
write d n s = do
go_1 <- newMVar ()
done <- newEmptyMVar
spawn tn (convert d) n s go_1 go_1 done
------------------------------------------------------------------------
spawn 1 d n s go_k go_1 done = do
a <- newArray (1,bs) 0x0a
forkIO $ writer d n a s go_k go_1 done
takeMVar done
spawn t d n s go_k go_1 done = do
go_next <- newEmptyMVar
a <- newArray (1,bs) 0x0a
forkIO $ writer d n a s go_k go_next done
spawn (t-1) d (max (n-cc) 0) (skip cc s) go_next go_1 done
------------------------------------------------------------------------
writer d 0 a s go go_next done = killThread =<< myThreadId
writer d n a s go go_next done = do
(t,br) <- gen d 0 0 cr s a
takeMVar go
hPutArray stdout a br
putMVar go_next ()
if n-cr == 0 then putMVar done t
else return ()
let u = skip (cc*(tn-1)) t
writer d n' a u go go_next done
where
cr = min n cc
n' = max 0 (n-cc*tn)
------------------------------------------------------------------------
gen d r n m s a
| r == ll = gen d 0 (n+1) (m+1) s a
| n == m = do
unsafeWrite a n 0x0a
return (s, if r == 0 then m else m+1)
| otherwise = do
let t = next s
unsafeWrite a n (pick d t)
gen d (r+1) (n+1) m t a
------------------------------------------------------------------------
pick (c,p) r = loop 0 where
loop i = if r < unsafeAt p i
then fromIntegral $ unsafeAt c i :: Word8
else loop (i+1)
------------------------------------------------------------------------
convert :: [(Char, Float)] -> ((UArray Int Word32), (UArray Int Word32))
convert t = (a c, a p)
where
a s = listArray (1, fromIntegral $ length t) s
(c,p) = map fromIntegral *** map (ceiling . (* fromIntegral im))
$ map c2w *** scanl1 (+)
$ unzip t
------------------------------------------------------------------------
alu_string = "GGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGG\
\GAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGA\
\CCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAAT\
\ACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCA\
\GCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGG\
\AGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCC\
\AGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAA"
------------------------------------------------------------------------
iub = [('a',0.27),('c',0.12),('g',0.12),('t',0.27),('B',0.02)
,('D',0.02),('H',0.02),('K',0.02),('M',0.02),('N',0.02)
,('R',0.02),('S',0.02),('V',0.02),('W',0.02),('Y',0.02)]
hom = [('a',0.3029549426680),('c',0.1979883004921)
,('g',0.1975473066391),('t',0.3015094502008)]
}}}
--
Ticket URL: <http://hackage.haskell.org/trac/ghc/ticket/3458#comment:2>
GHC <http://www.haskell.org/ghc/>
The Glasgow Haskell Compiler_______________________________________________
Glasgow-haskell-bugs mailing list
[email protected]
http://www.haskell.org/mailman/listinfo/glasgow-haskell-bugs
