0votos

Flujo sincrónico dentro de un árbol de procesos concurrentes no deterministas en Haskell

por josejuan hace 5 años

Usando una mónada.

Si un proceso inicia procesos concurrentes no deterministas y éstos a su vez inician otros, podemos "dibujar" el árbol de procesos generado y el orden en el que ésto ocurre. Se pide programar un entorno (¿API?) que permita recuperar de forma sincrónica cierto producto (ej. un log) de los procesos concurrentes.

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
-- Para más detalles de la estrategia implementada en la mónada: 
-- http://www.genbetadev.com/cnet/secuencia-sincronica-en-un-proceso-no-determinista 
 
 
-- fibonacci.hs (usando el API) ---------------------- 
 
import SyncAsync 
import Control.Concurrent (threadDelay) 
 
fibonacci :: Int -> SyncAsyncIO Int 
fibonacci n = do 
 
  lift $ threadDelay 200000 
  syncAction $ putStrLn $ "> " ++ show n 
   
  if n < 2 
    then endTree 1 
    else forkTree (fibonacci (n-1)) (fibonacci (n-2)) (+) 
 
 
test = runSyncAsyncTree $ fibonacci 4 
 
 
 
-- SyncAsync.hs (el API) ------------------- 
 
module SyncAsync (lift, SyncAsyncIO, syncAction, endTree, forkTree, runSyncAsyncTree) where 
import Control.Monad.Trans (lift) 
import Control.Monad.Trans.State 
import Control.Concurrent.Async 
import qualified Semaphore as S 
 
data SyncAsyncST = SyncAsyncST S.Semaphore S.Semaphore 
type SyncAsyncIO = StateT SyncAsyncST IO 
 
syncAction :: IO a -> SyncAsyncIO () 
syncAction f = do        wi' <- lift $ S.new 
                         SyncAsyncST wi wo <- get 
                         lift $ async $ S.wait wi >> f >> S.free wi' 
                         put $ SyncAsyncST wi' wo 
 
endTree :: b -> SyncAsyncIO b 
endTree a = do           SyncAsyncST wi wo <- get 
                         lift $ async $ S.wait wi >> S.free wo 
                         return a 
 
forkTree :: SyncAsyncIO a -> SyncAsyncIO b -> (a -> b -> c) -> SyncAsyncIO c 
forkTree fa fb g = do    SyncAsyncST wi wo <- get 
                         wi' <- lift $ S.new 
                         ra <- lift $ async $ runStateT fa (SyncAsyncST wi wi') 
                         rb <- lift $ async $ runStateT fb (SyncAsyncST wi' wo) 
                         (a, _) <- lift $ wait ra 
                         (b, _) <- lift $ wait rb 
                         return $! g a b 
 
runSyncAsyncTree :: SyncAsyncIO b -> IO b 
runSyncAsyncTree f = do  wi <- S.new 
                         S.free wi 
                         wo <- S.new 
                         (a, _) <- runStateT f (SyncAsyncST wi wo) 
                         S.wait wo 
                         return a 
 
 
 
-- Semaphore.hs (un semáforo como otro cualquiera) -------------- 
 
module Semaphore (Semaphore, new, wait, free) where 
 
import Control.Concurrent.Async (Async(..), async, waitCatch, cancel) 
import Control.Concurrent (threadDelay) 
 
type Semaphore = Async () 
    -- Es un bug, si corre por más de 3160 años no funciona :P 
new  = async $ threadDelay 99999999999999999 
wait = waitCatch 
free = cancel 

Comenta la solución

Tienes que identificarte para poder publicar tu comentario.