Song song về thuật toán phân chia và chinh phục

Question

Tôi đang gặp sự cố để làm cho mã của mình chạy song song. Nó là trình tạo Delaunay 3D sử dụng thuật toán phân tách & có tên là DeWall.

Các chức năng chính là:

deWall::[SimplexPointer] -> SetSimplexFace -> Box -> StateT DeWallSets IO ([Simplex], [Edge]) 
deWall p afl box = do 
    ... 
    ... 
    get >>= recursion box1 box2 p1 p2 sigma edges 
    ... 
    ... 

Nó gọi là "đệ quy" chức năng mà có thể gọi hàm dewall lại. Và đây là nơi mà cơ hội parallization xuất hiện. Các mã sau đây cho thấy các giải pháp tuần tự.

recursion::Box -> Box -> [SimplexPointer] -> [SimplexPointer] -> [Simplex] -> [Edge] -> DeWallSets -> StateT DeWallSets IO ([Simplex], [Edge])  
recursion box1 box2 p1 p2 sigma edges deWallSet 
     | null afl1 && null afl2 = return (sigma, edges) 
     | (null) afl1 = do 
      (s, e) <- deWall p2 afl2 box2 
      return (s ++ sigma, e ++ edges) 
     | (null) afl2 = do 
      (s,e) <- deWall p1 afl1 box1 
      return (s ++ sigma, e ++ edges) 
     | otherwise = do 
      x <- get 
      liftIO $ do 
       (s1, e1) <- evalStateT (deWall p1 afl1 box1) x 
       (s2, e2) <- evalStateT (deWall p2 afl2 box2) x 
       return (s1 ++ s2 ++ sigma, e1 ++ e2 ++ edges) 

     where afl1 = aflBox1 deWallSet 
       afl2 = aflBox2 deWallSet 

Các đơn vị trạng thái và IO được sử dụng để dẫn đường trạng thái và tạo UID cho mỗi tứ diện được tìm thấy bằng MVar. Nỗ lực đầu tiên của tôi là thêm một ngã ba nhưng nó không hoạt động. Nó cung cấp cho một đầu ra sai do thiếu kiểm soát trong phần hợp nhất mà không chờ đợi cho cả hai chủ đề để kết thúc. Tôi không biết làm thế nào để làm cho nó chờ đợi cho họ.

  liftIO $ do 
       let 
        s1 = evalStateT (deWall p1 afl1 box1) x 
        s2 = evalStateT (deWall p2 afl2 box2) x 
        concatThread var (a1, b1) = takeMVar var >>= \(a2, b2) -> putMVar var (a1 ++ a2, b1 ++ b2) 
       mv <- newMVar ([],[]) 
       forkIO (s1 >>= concatThread mv) 
       forkIO (s2 >>= concatThread mv) 
       takeMVar mv >>= \(s, e) -> return (s ++ sigma, e ++ edges) 

Vì vậy, nỗ lực tiếp theo của tôi là sử dụng chiến lược song song tốt hơn "par" và "pseq" cho kết quả phù hợp nhưng không thực hiện song song theo threadScope.

 liftIO $ do 
      let 
       s1 = evalStateT (deWall p1 afl1 box1) x 
       s2 = evalStateT (deWall p2 afl2 box2) x 
       conc = liftM2 (\(a1, b1) (a2, b2) -> (a1 ++ a2, b1 ++ b2)) 
      (stotal, etotal) = s1 `par` (s2 `pseq` (s1 `conc` s2)) 
      return (stotal ++ sigma, etotal ++ edges) 

Tôi đang làm gì sai?

CẬP NHẬT: Bằng cách nào đó vấn đề này dường như có liên quan với sự hiện diện của các đơn vị IO. Trong một phiên bản cũ (cũ) không có đơn nguyên IO, chỉ có đơn vị Trạng thái, thực thi song song sẽ chạy với 'par' và 'pseq'. Các GHC -sstderr cho SPARKS: 1160 (69 converted, 1069 pruned).

recursion::Box -> Box -> [SimplexPointer] -> [SimplexPointer] -> [Simplex] -> [Edge] -> DeWallSets -> State DeWallSets ([Simplex], [Edge]) 
recursion p1 p2 sigma deWallSet 
    | null afl1 && null afl2 = return sigma 
    | (null) afl1 = do 
     s <- deWall p2 afl2 box2 
     return (s ++ sigma) 
    | (null) afl2 = do 
     s <- deWall p1 afl1 box1 
     return (s ++ sigma) 
    | otherwise = do 
        x <- get 
        let s1 = evalState (deWall p1 afl1 box1) x 
        let s2 = evalState (deWall p2 afl2 box2) x 
        return $ s1 `par` (s2 `pseq` (s1 ++ s2 ++ sigma)) 
    where afl1 = aflBox1 deWallSet 
      afl2 = aflBox2 deWallSet 

Cloud có người giải thích điều đó?

Answer 1

Cách dễ nhất để làm cho công việc này sẽ được sử dụng một cái gì đó như:

liftIO $ do 
      let 
       s1 = evalStateT (deWall p1 afl1 box1) x 
       s2 = evalStateT (deWall p2 afl2 box2) x 
      mv1 <- newMVar ([],[]) 
      mv2 <- newMVar ([],[]) 
      forkIO (s1 >>= putMVar mv1) 
      forkIO (s2 >>= putMVar mv2) 
      (a1,b1) <- takeMVar mv1 
      (a2,b2) <- takeMVar mv2 
      return (a1++a2++sigma, b1++b2++edges) 

này hoạt động, nhưng có một số chi phí không cần thiết. Một giải pháp tốt hơn là:

liftIO $ do 
      let 
       s1 = evalStateT (deWall p1 afl1 box1) x 
       s2 = evalStateT (deWall p2 afl2 box2) x 
      mv <- newMVar ([],[]) 
      forkIO (s2 >>= putMVar mv2) 
      (a1,b1) <- s1 
      (a2,b2) <- takeMVar mv2 
      return (a1++a2++sigma, b1++b2++edges) 

Hoặc có thể này nếu kết quả không được đánh giá mà bạn muốn họ được:

liftIO $ do 
     let 
      s1 = evalStateT (deWall p1 afl1 box1) x 
      s2 = evalStateT (deWall p2 afl2 box2) x 
     mv <- newMVar ([],[]) 
     forkIO (s2 >>= evaluate >>= putMVar mv2) 
     (a1,b1) <- s1 
     (a2,b2) <- takeMVar mv2 
     return (a1++a2++sigma, b1++b2++edges) 

(đây là những câu trả lời mà ta đã ban cho các poster trong #haskell mà tôi nghĩ cũng hữu ích ở đây)

Chỉnh sửa: xóa các đánh giá không cần thiết.

Answer 2

Sử dụng par và pseq sẽ xảy ra trên "đường dẫn thực hiện", nghĩa là, không nằm trong một địa phương let. Hãy thử điều này (sửa đổi đoạn cuối cùng của bạn)

let s1 = ... 
    s2 = ... 
    conc = ... 
case s1 `par` (s2 `pseq` (s1 `conc` s2)) of 
    (stotal, etotal) -> 
    return (stotal ++ sigma, etotal ++ edges) 

Một case lực lượng đánh giá của đối số của nó để đầu yếu hình thức bình thường (WHNF) trước khi tiếp tục ở một trong những chi nhánh của nó. WHNF có nghĩa là đối số được đánh giá cho đến khi hàm tạo ngoài cùng được hiển thị. Các trường có thể vẫn chưa được đánh giá.

Để bắt buộc đánh giá đầy đủ đối số sử dụng deepseq. Tuy nhiên, hãy cẩn thận với điều đó bởi vì deepseq đôi khi có thể làm mọi việc chậm hơn bằng cách thực hiện quá nhiều công việc.

Một cách tiếp cận nhẹ hơn để thêm tính nghiêm minh là làm cho lĩnh vực nghiêm ngặt:

data Foo = Foo !Int String 

Bây giờ, bất cứ khi nào một giá trị kiểu Foo được đánh giá để WHNF, như vậy là đối số đầu tiên của nó (nhưng không phải là người thứ hai).

Answer 3

Nếu bạn muốn gắn bó với các chủ đề rõ ràng, thay vì pseq, như bạn đã lưu ý, bạn cần một số cách để đợi chuỗi công việc kết thúc. Đó là một trường hợp sử dụng tuyệt vời cho một semaphore số lượng. Sau khi bạn chia công việc phải hoàn thành, có mỗi luồng công nhân, chấm dứt, báo hiệu semaphore với bao nhiêu công việc đã làm.

Sau đó đợi tất cả các đơn vị công việc cần hoàn thành.

http://www.haskell.org/ghc/docs/6.8.3/html/libraries/base/Control-Concurrent-QSemN.html

Chỉnh sửa: một số giả để giúp giải thích các khái niệm

do 
let workchunks :: [(WorkChunk, Size)] 
    workchunks = dividework work 

    let totalsize = sum $ map snd workchunks 

sem <- newQSem 0 

let forkworkThread (workchunk, size) = do 
     executeWorkChunk workchunk 
     signalQSem size 

mapM_ forkWorkThread workchunks 
waitQSem totalsize 

-- now all your work is done.