1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
|
{-# LANGUAGE MagicHash, UnboxedTuples #-}
-- This test is adapted from setnumcapabilities001.
import GHC.Conc hiding (threadWaitRead, threadWaitWrite)
import GHC.Exts
import GHC.IO.Encoding
import System.Environment
import System.IO
import Control.Monad
import Text.Printf
import Data.Time.Clock
import Control.DeepSeq
import System.Posix.IO
import System.Posix.Types
import Control.Concurrent
import Control.Exception
passTheParcel :: Int -> IO (IO ())
passTheParcel n = do
pipes@(p1 : rest) <- forM [0..n-1] $ \_ -> createPipe
rs@((_,tid1) : _) <- forM (pipes `zip` (rest ++ [p1])) $ \((readfd, _), (_, writefd)) -> do
let
read = fdRead readfd $ fromIntegral 1
write = fdWrite writefd
mv <- newEmptyMVar
tid <- forkIO $ let
loop = flip catch (\(x :: IOException) -> pure ()) $ forever $ do
threadWaitRead readfd
(s, _) <- read
threadWaitWrite writefd
write s
cleanup = do
closeFdWith closeFd readfd
closeFdWith closeFd writefd
putMVar mv ()
in loop `finally` cleanup
pure (mv, tid)
let
cleanup = do
killThread tid1
forM_ rs $ \(mv, _) -> takeMVar mv
fdWrite (snd p1) "a"
pure cleanup
main = do
setLocaleEncoding latin1 -- fdRead and fdWrite depend on the current locale
[n,q,t,z] <- fmap (fmap read) getArgs
cleanup_ptp <- passTheParcel z
t <- forkIO $ do
forM_ (cycle ([n,n-1..1] ++ [2..n-1])) $ \m -> do
setNumCapabilities m
threadDelay t
printf "%d\n" (nqueens q)
cleanup_ptp
killThread t
-- If we don't kill the child thread, it might be about to
-- call setNumCapabilities() in C when the main thread exits,
-- and chaos can ensue. See #12038
nqueens :: Int -> Int
nqueens nq = length (pargen 0 [])
where
safe :: Int -> Int -> [Int] -> Bool
safe x d [] = True
safe x d (q:l) = x /= q && x /= q+d && x /= q-d && safe x (d+1) l
gen :: [[Int]] -> [[Int]]
gen bs = [ (q:b) | b <- bs, q <- [1..nq], safe q 1 b ]
pargen :: Int -> [Int] -> [[Int]]
pargen n b
| n >= threshold = iterate gen [b] !! (nq - n)
| otherwise = concat bs
where bs = map (pargen (n+1)) (gen [b]) `using` parList rdeepseq
threshold = 3
using :: a -> Strategy a -> a
x `using` strat = runEval (strat x)
type Strategy a = a -> Eval a
newtype Eval a = Eval (State# RealWorld -> (# State# RealWorld, a #))
runEval :: Eval a -> a
runEval (Eval x) = case x realWorld# of (# _, a #) -> a
instance Functor Eval where
fmap = liftM
instance Applicative Eval where
pure x = Eval $ \s -> (# s, x #)
(<*>) = ap
instance Monad Eval where
return = pure
Eval x >>= k = Eval $ \s -> case x s of
(# s', a #) -> case k a of
Eval f -> f s'
parList :: Strategy a -> Strategy [a]
parList strat = traverse (rparWith strat)
rpar :: Strategy a
rpar x = Eval $ \s -> spark# x s
rseq :: Strategy a
rseq x = Eval $ \s -> seq# x s
rparWith :: Strategy a -> Strategy a
rparWith s a = do l <- rpar r; return (case l of Lift x -> x)
where r = case s a of
Eval f -> case f realWorld# of
(# _, a' #) -> Lift a'
data Lift a = Lift a
rdeepseq :: NFData a => Strategy a
rdeepseq x = do rseq (rnf x); return x
|
