I am learning parallel programming in Haskell using Simon Marlow's book. On chapter about parallelizing Sudoku solver I decided to write my own solver using backtracking algorithm. The problem is that there is almost no performance gain when I try to distribute 6 cases among 6 cores. When I try to do examples with more cases I get more significant performance gains yet still far from theoretical maximum which should be between 5 and 6. I understand that some cases may run far slower but threadscope diagram shows no excuse for such little gain. Can someone explain me what I am doing wrong. Maybe there is something about ST threads which I am not understanding?
Here is the code:
Sudoku.hs
{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
module Sudoku (getSudokus, solve) where
import Data.Vector(Vector, (!), generate, thaw, freeze)
import Data.List ( nub )
import qualified Data.Vector.Mutable as MV
import Text.Trifecta
import Control.Monad ( replicateM, when )
import Control.Applicative ((<|>))
import Control.Monad.ST
import Control.DeepSeq (NFData)
import GHC.Generics (Generic)
data Cell = Given Int
| Filled Int
| Empty
deriving (Generic, NFData)
newtype Sudoku = Sudoku (Vector Cell)
deriving (Generic, NFData)
instance Show Cell where
show Empty = " "
show (Filled x) = " " ++ show x ++ " "
show (Given x) = "[" ++ show x ++ "]"
instance Show Sudoku where
show (Sudoku vc) = "\n" ++
"+ - - - + - - - + - - - +" ++ "\n" ++
"|" ++ i 0 ++ i 1 ++ i 2 ++ "|" ++ i 3 ++ i 4 ++ i 5 ++ "|" ++ i 6 ++ i 7 ++ i 8 ++ "|" ++ "\n" ++
"|" ++ i 9 ++ i 10 ++ i 11 ++ "|" ++ i 12 ++ i 13 ++ i 14 ++ "|" ++ i 15 ++ i 16 ++ i 17 ++ "|" ++ "\n" ++
"|" ++ i 18 ++ i 19 ++ i 20 ++ "|" ++ i 21 ++ i 22 ++ i 23 ++ "|" ++ i 24 ++ i 25 ++ i 26 ++ "|" ++ "\n" ++
"+ - - - + - - - + - - - +" ++ "\n" ++
"|" ++ i 27 ++ i 28 ++ i 29 ++ "|" ++ i 30 ++ i 31 ++ i 32 ++ "|" ++ i 33 ++ i 34 ++ i 35 ++ "|" ++ "\n" ++
"|" ++ i 36 ++ i 37 ++ i 38 ++ "|" ++ i 39 ++ i 40 ++ i 41 ++ "|" ++ i 42 ++ i 43 ++ i 44 ++ "|" ++ "\n" ++
"|" ++ i 45 ++ i 46 ++ i 47 ++ "|" ++ i 48 ++ i 49 ++ i 50 ++ "|" ++ i 51 ++ i 52 ++ i 53 ++ "|" ++ "\n" ++
"+ - - - + - - - + - - - +" ++ "\n" ++
"|" ++ i 54 ++ i 55 ++ i 56 ++ "|" ++ i 57 ++ i 58 ++ i 59 ++ "|" ++ i 60 ++ i 61 ++ i 62 ++ "|" ++ "\n" ++
"|" ++ i 63 ++ i 64 ++ i 65 ++ "|" ++ i 66 ++ i 67 ++ i 68 ++ "|" ++ i 69 ++ i 70 ++ i 71 ++ "|" ++ "\n" ++
"|" ++ i 72 ++ i 73 ++ i 74 ++ "|" ++ i 75 ++ i 76 ++ i 77 ++ "|" ++ i 78 ++ i 79 ++ i 80 ++ "|" ++ "\n" ++
"+ - - - + - - - + - - - +" ++ "\n"
where i x = show (vc ! x)
parseSudoku :: Parser Sudoku
parseSudoku = do
lst <- replicateM 81 field
(newline *> return ()) <|> eof
return $ Sudoku $ generate 81 (lst !!)
where field = (char '.' >> return Empty) <|> (Given . read . return <$> digit)
getSudokus :: String -> Maybe [Sudoku]
getSudokus raw = case parseString (some parseSudoku) mempty raw of
Success ss -> Just ss
Failure _ -> Nothing
data Direction = Back | Forward
solve :: Sudoku -> Maybe Sudoku
solve sudoku@(Sudoku puzzle) = if isValid sudoku then
Just $ runST $ do
puzzle' <- thaw puzzle
go puzzle' 0 Forward
Sudoku <$> freeze puzzle'
else Nothing
where go _ 81 _ = return ()
go vector position direction = do
cell <- MV.read vector position
case (cell, direction) of
(Empty, Back) -> error "Calling back Empty cell, this should not ever occur"
(Empty, Forward) -> MV.write vector position (Filled 1) >> go vector position Forward
(Given _, Back) -> go vector (position-1) Back
(Given _, Forward) -> go vector (position+1) Forward
(Filled 10, Back) -> MV.write vector position Empty >> go vector (position-1) Back
(Filled 10, Forward) -> go vector position Back
(Filled x, Forward) -> do
let (r, c, s) = calculatePositions position
row <- getRowMV r vector
col <- getColumnMV c vector
sqr <- getSquareMV s vector
if isUnique row && isUnique col && isUnique sqr
then go vector (position+1) Forward
else MV.write vector position (Filled (x+1)) >> go vector position Forward
(Filled x, Back) -> MV.write vector position (Filled (x+1)) >> go vector position Forward
calculatePositions :: Int -> (Int, Int, Int)
calculatePositions i = let (row, col) = divMod i 9
sqr = (row `div` 3)*3 + (col `div` 3)
in (row, col, sqr)
isValid :: Sudoku -> Bool
isValid sudoku = go 0
where go 9 = True
go i = isUnique (getRow i sudoku) && isUnique (getColumn i sudoku) && isUnique (getSquare i sudoku) && go (i+1)
getRow :: Int -> Sudoku -> [Cell]
getRow l (Sudoku vector) = go 0
where go 9 = []
go c = vector ! (l*9 + c) : go (c+1)
getRowMV :: MV.PrimMonad m => Int -> MV.MVector (MV.PrimState m) Cell -> m [Cell]
getRowMV l mv = go 0
where go 9 = return []
go c = do
n <- MV.read mv (l*9 + c)
rl <- go (c+1)
return (n:rl)
getColumn :: Int -> Sudoku -> [Cell]
getColumn c (Sudoku vector) = go 0
where go 9 = []
go i = vector ! (c + i*9) : go (i+1)
getColumnMV :: MV.PrimMonad m => Int -> MV.MVector (MV.PrimState m) Cell -> m [Cell]
getColumnMV c mv = go 0
where go 9 = return []
go i = do
n <- MV.read mv (c + i*9)
rl <- go (i+1)
return (n:rl)
getSquare :: Int -> Sudoku -> [Cell]
getSquare q (Sudoku vector) = let (y, x) = quotRem q 3
start = x*3 + y*3*9
in [ vector ! start, vector ! (start + 1), vector ! (start + 2)
, vector ! (start + 9), vector ! (start + 10), vector ! (start + 11)
, vector ! (start + 18), vector ! (start + 19), vector ! (start + 20)]
getSquareMV :: MV.PrimMonad m => Int -> MV.MVector (MV.PrimState m) a -> m [a]
getSquareMV q mv = let (y, x) = quotRem q 3
start = x*3 + y*3*9
in do
a1 <- MV.read mv start
a2 <- MV.read mv (start + 1)
a3 <- MV.read mv (start + 2)
b1 <- MV.read mv (start + 9)
b2 <- MV.read mv (start + 10)
b3 <- MV.read mv (start + 11)
c1 <- MV.read mv (start + 18)
c2 <- MV.read mv (start + 19)
c3 <- MV.read mv (start + 20)
return [a1,a2,a3,b1,b2,b3,c1,c2,c3]
isUnique :: [Cell] -> Bool
isUnique xs = let sv = strip xs
in length sv == length (nub sv)
where strip (Empty:xs) = strip xs
strip ((Given x):xs) = x : strip xs
strip ((Filled x):xs) = x : strip xs
strip [] = []
Main.hs
module Main where
import Control.Parallel.Strategies
import Control.Monad
import Control.DeepSeq ( force )
import Sudoku
import System.Environment (getArgs)
main :: IO ()
main = do
filename <- head <$> getArgs
contents <- readFile filename
case getSudokus contents of
Just sudokus -> print $ runEval $ do
start <- forM sudokus (rpar . force . solve)
forM start rseq
Nothing -> putStrLn "Error during parsing"
I am compiling it with following flags:
ghc-options: -O2 -rtsopts -threaded -eventlog
Execution with following flags
cabal exec sudoku -- sudoku17.6.txt +RTS -N1 -s -l
gives following performance report and threadscope diagram
950,178,477,200 bytes allocated in the heap
181,465,696 bytes copied during GC
121,832 bytes maximum residency (7 sample(s))
30,144 bytes maximum slop
7 MiB total memory in use (0 MB lost due to fragmentation)
Tot time (elapsed) Avg pause Max pause
Gen 0 227776 colls, 0 par 1.454s 1.633s 0.0000s 0.0011s
Gen 1 7 colls, 0 par 0.001s 0.001s 0.0001s 0.0002s
TASKS: 4 (1 bound, 3 peak workers (3 total), using -N1)
SPARKS: 6 (0 converted, 0 overflowed, 0 dud, 0 GC'd, 6 fizzled)
INIT time 0.001s ( 0.001s elapsed)
MUT time 220.452s (220.037s elapsed)
GC time 1.455s ( 1.634s elapsed)
EXIT time 0.000s ( 0.008s elapsed)
Total time 221.908s (221.681s elapsed)
Alloc rate 4,310,140,685 bytes per MUT second
Productivity 99.3% of total user, 99.3% of total elapsed
Execution with parallelization:
cabal exec sudoku -- sudoku17.6.txt +RTS -N6 -s -l
950,178,549,616 bytes allocated in the heap
325,450,104 bytes copied during GC
142,704 bytes maximum residency (7 sample(s))
82,088 bytes maximum slop
32 MiB total memory in use (0 MB lost due to fragmentation)
Tot time (elapsed) Avg pause Max pause
Gen 0 128677 colls, 128677 par 37.697s 30.612s 0.0002s 0.0035s
Gen 1 7 colls, 6 par 0.005s 0.004s 0.0006s 0.0012s
Parallel GC work balance: 11.66% (serial 0%, perfect 100%)
TASKS: 14 (1 bound, 13 peak workers (13 total), using -N6)
SPARKS: 6 (5 converted, 0 overflowed, 0 dud, 0 GC'd, 1 fizzled)
INIT time 0.010s ( 0.009s elapsed)
MUT time 355.227s (184.035s elapsed)
GC time 37.702s ( 30.616s elapsed)
EXIT time 0.001s ( 0.007s elapsed)
Total time 392.940s (214.667s elapsed)
Alloc rate 2,674,847,755 bytes per MUT second
Productivity 90.4% of total user, 85.7% of total elapsed
Here are the contents of sudoku17.6.txt
.......2143.......6........2.15..........637...........68...4.....23........7....
.......241..8.............3...4..5..7.....1......3.......51.6....2....5..3...7...
.......24....1...........8.3.7...1..1..8..5.....2......2.4...6.5...7.3...........
.......23.1..4....5........1.....4.....2...8....8.3.......5.16..4....7....3......
.......21...5...3.4..6.........21...8.......75.....6.....4..8...1..7.....3.......
.......215.3......6...........1.4.6.7.....5.....2........48.3...1..7....2........
parMap rdeepseq solve
here, right?strategies
but I'd sayforM sudokus (rpar . force . solve)
will solve the sudoku and then create and spark with the puzzle already solve, so you are actually solving in a single thread. I would go with @leftaroundabout recommendation and doJust sudokus -> print $ parMap rdeepseq solve sudokus
and see if the threadscope profile improves.