Ticket #3167: main.hs

File main.hs, 4.5 KB (added by guest, 6 years ago)
Line 
1{-# LANGUAGE TypeOperators #-}
2{-# OPTIONS_GHC -fno-warn-incomplete-patterns -fno-warn-orphans #-}
3{-
4  Compile with: $ghc --make -threaded -O2 main.hs
5  Execute with: $./main +RTS -A128M -s -c -N4 -RTS 5000000 500
6
7  processing x
8  main: internal error: removeThreadFromQueue: not found
9      (GHC version 6.8.2 for i386_unknown_linux)
10      Please report this as a GHC bug:  http://www.haskell.org/ghc/reportabug 
11
12  The value of x is not always the same, and it depends on the values
13  used, including RTS settings.
14
15  Using only 1 thread, it works.
16  Increasing the thread stack size (-k1M), it works.
17
18  I suspect the problem is caused by an uncaught stack overflow.
19-}
20module Main where
21
22import Control.Arrow (first)
23import Control.Monad (liftM)
24import Control.Parallel (pseq)
25import Control.Parallel.Strategies
26import Data.Array.Vector ((:*:)(..), UA, UArr, appendU, foldlU, lengthU, singletonU, snocU, toU)
27import Data.Foldable (foldl')
28import Data.Int (Int8, Int16)
29import Data.IntMap (IntMap, alter, empty, unionsWith, toAscList)
30import Debug.Trace (trace)
31import System.Console.GetOpt
32import System.Environment (getArgs)
33import System.Random (RandomGen, mkStdGen, randomR, randomRs)
34
35
36type A = Int16
37type B = Int8
38
39
40invert :: [(A, UArr B)] -> [(B, UArr A)]
41invert = convert . result . split'
42    where
43      convert :: IntMap (UArr A) -> [(B, UArr A)]
44      convert = map (first fromIntegral) . toAscList
45
46      split' xs = split (length xs `div` 4) xs
47
48      -- XXX unions is not strict
49      result = mapReduce rnf invert' rnf (unionsWith appendU)
50
51invert' :: [(A, UArr B)] -> IntMap (UArr A)
52invert' = foldl' invert'' empty
53    where
54      invert'' :: IntMap (UArr A) -> (A, UArr B) -> IntMap (UArr A)
55      invert'' m (a, bs) = trace msg foldlU accum m bs
56          where
57            msg :: String
58            msg = "processing " ++ show a
59
60            accum :: IntMap (UArr A) -> B -> IntMap (UArr A)
61            accum m' b =
62                a `seq` b `seq` alter append (fromIntegral b) m'
63                where
64                  append Nothing = Just $ singletonU a
65                  append (Just u) = Just $! snocU u a
66
67
68parse :: [String] -> (Int, Int)
69parse argv =
70    case getOpt Permute [] argv of
71      ([], [n, m], []) -> (read n, read m)
72      ([], [], [])     -> (100, 10)
73      (_, _, errs)     -> die errs
74    where
75      header   = "Usage: main [n m]"
76      info     = usageInfo header []
77      die errs = error $ concat errs ++ info
78
79
80main :: IO ()
81main = do
82  (n, m) <- liftM parse getArgs
83
84  let
85      -- Create the input data, using random numbers
86      gen = mkStdGen 777
87
88      stream :: [B]
89      stream = map fromIntegral $ randomRs (0, m) gen
90
91      u :: [UArr B]
92      u = map toU $ randomPartition (take n stream) n m gen
93
94      input :: [(A, UArr B)]
95      input = zip (enumFrom 1) u
96
97  print $ length input
98  print $ length $ invert input
99
100
101--
102-- Support functions and instances
103--
104
105-- |Split a list into a list of lists, each having length @n@.
106--
107-- Code originally written by:
108-- Daniel Peebles (aka pumpkin).
109split :: Int -> [a] -> [[a]]
110split n = takeWhile (not . null) . map (take n) . iterate (drop n)
111
112-- |Given a list, its length, the number of subdivisions and a random
113-- number generator, compute a random partition of the input.
114--
115-- /A subpart may be empty./
116--
117-- Code adapted from:
118-- <http://hpaste.org/fastcgi/hpaste.fcgi/view?id=2485#a249>.
119randomPartition :: RandomGen gen => [a] -> Int -> Int -> gen -> [[a]]
120randomPartition [] 0 m _       = replicate m []
121randomPartition xs _ 1 _       = [xs]
122randomPartition (x : xs) n m g = result where
123    (t, g') = randomR (1, n + m - 1) g
124    result | t < m     = [] : randomPartition (x : xs) n (m - 1) g'
125           | otherwise = mapHead (x :) (randomPartition xs (n - 1) m g')
126    mapHead f (y : ys) = f y : ys
127
128mapReduce :: Strategy b    -- evaluation strategy for mapping
129          -> (a -> b)      -- map function
130          -> Strategy c    -- evaluation strategy for reduction
131          -> ([b] -> c)    -- reduce function
132          -> [a]           -- list to map over
133          -> c
134
135mapReduce mapStrat mapFunc reduceStrat reduceFunc input =
136    mapResult `pseq` reduceResult
137  where mapResult    = parMap mapStrat mapFunc input
138        reduceResult = reduceFunc mapResult `using` reduceStrat
139
140
141-- XXX these are missing from uvector package
142instance (NFData a, NFData b) => NFData (a :*: b) where
143    -- NOTE: (:*:) is already strict
144    rnf (a :*: b) = rnf a `seq` rnf b `seq` ()
145
146instance (NFData a, UA a) => NFData (UArr a) where
147    -- NOTE: UArr is already strict
148    rnf arr = lengthU arr `seq` ()