Hi,<div><br></div><div>I&#39;m working on Concurrent Haskell, especially with the monad STM. I don&#39;t fully understand the way my program is executed. I think the lazy evaluation leads to a loss of performance, if we don&#39;t pay attention to this problem. A short example will be more explicit : </div>
<div><br></div><div>Imagine this scenario : we have a set of threads (the workers) that have (each) a result to compute (purely). When finished, they try to save the result in an shared inbox, using STM. If the inbox is full, the thread waits until the inbox is empty. </div>
<div>A specific thread is looking at the inbox: when it finds a value in the inbox, it prints the value on the screen (for example, it could be any processing based on the value) and then empty the inbox and wait that a remaining thread add a new value).</div>
<div><br></div><div><br></div><div>Let&#39;s a function &quot;do_job&quot;, the function to execute by the threads (the workers) :</div><div><br></div><div><div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace">do_job :: (b -&gt; a) -&gt; b -&gt; Inbox a -&gt; IO ()</font></div>
<div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace">do_job f input inbox = do { value &lt;- return (f input) </font></div><div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace">                          ; atomically ( writeMsg inbox value ) }</font></div>
<div>    </div></div><div>The idea is : (f input) is the function to compute. Once compute, we want to save the result atomically. </div><div>The problem is, because of the lazy evaluation, the &quot;value&quot; is computed in the atomic section, and not before, resulting in a loss of efficiency. Indeed, to be fast, a concurrent program has to keep the atomic sections as &quot;small&quot; as possible, because it limits the parallelism. </div>
<div><br></div><div>To illustrate this, let&#39;s see this source code :</div><div><br></div><div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace"><br></font></div><div><div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace">module Main where</font></div>
<div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace"><br></font></div><div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace">import Control.Concurrent</font></div><div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace">import Control.Concurrent.STM</font></div>
<div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace">import Data.Maybe</font></div><div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace">import System.Random</font></div><div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace">import System.IO</font></div>
<div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace"><br></font></div><div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace">{-- Inbox --}</font></div><div><span class="Apple-style-span" style="font-family: &#39;courier new&#39;, monospace; ">type Inbox a = TVar (Maybe a)</span></div>
<div><span class="Apple-style-span" style="font-family: &#39;courier new&#39;, monospace; "><br></span></div><div><span class="Apple-style-span" style="font-family: &#39;courier new&#39;, monospace; ">createInbox ::  STM (Inbox a)</span></div>
<div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace">createInbox = newTVar Nothing</font></div><div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace"><br></font></div><div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace">readMsg ::  Inbox a -&gt; STM a</font></div>
<div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace">readMsg inbox = do { inboxContent &lt;- readTVar inbox</font></div><div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace">                   ; if (isNothing inboxContent) </font></div>
<div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace">                     then retry </font></div><div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace">                     else do { writeTVar inbox Nothing      </font></div>
<div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace">                             ; return (fromJust inboxContent) } } </font></div><div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace"><br>
</font></div><div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace">writeMsg ::  Inbox a -&gt; a -&gt; STM ()</font></div><div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace">writeMsg inbox value = do { inboxContent &lt;- readTVar inbox</font></div>
<div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace">                          ; if (isNothing inboxContent) </font></div><div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace">                            then writeTVar inbox (Just value) </font></div>
<div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace">                            else retry }</font></div><div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace"><br></font></div>
<div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace">{-- Workers --}</font></div><div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace"><span class="Apple-style-span" style="font-family: arial; "><div>
<font class="Apple-style-span" face="&#39;courier new&#39;, monospace"><b><br class="Apple-interchange-newline">do_job :: (b -&gt; a) -&gt; b -&gt; Inbox a -&gt; IO ()</b></font></div><div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace"><b>do_job f input inbox = do { value &lt;- return (f input) </b></font></div>
<div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace"><b>                          ; atomically ( writeMsg inbox value ) }</b></font></div></span></font></div><div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace"><br>
</font></div><div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace">do_jobs_in_threads ::  [((b-&gt;a),b)] -&gt; Inbox a -&gt; TVar Int -&gt; IO ()</font></div><div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace">do_jobs_in_threads [] _ _ = return ()</font></div>
<div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace">do_jobs_in_threads ((f,input):xs) inbox flag = </font></div><div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace">    do { forkIO_and_notify flag (do_job f input inbox) </font></div>
<div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace">       ; do_jobs_in_threads xs inbox flag }</font></div><div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace"><br></font></div>
<div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace">{-- Caller --}</font></div><div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace"><b><br></b></font></div><div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace"><b>caller ::  Inbox a -&gt; (a -&gt; IO ()) -&gt; Int -&gt; IO ()</b></font></div>
<div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace"><b>caller _ _ 0 = return ()</b></font></div><div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace"><b>caller inbox process n = do { msg &lt;- atomically (readMsg inbox)</b></font></div>
<div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace"><b>                            ; process msg </b></font></div><div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace"><b>                            ; caller inbox process (n-1) }</b></font></div>
<div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace"><br></font></div><div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace">caller_in_thread flag inbox process n = </font></div>
<div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace">    forkIO_and_notify flag (caller inbox process n) </font></div><div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace"><br>
</font></div><div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace">{-- forkIO with notification --}</font></div><div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace"><br></font></div>
<div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace">create_flag = atomically ( newTVar 0 )</font></div><div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace"><br></font></div><div>
<font class="Apple-style-span" face="&#39;courier new&#39;, monospace">forkIO_and_notify :: TVar Int -&gt; IO () -&gt; IO ()</font></div><div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace">forkIO_and_notify tvar action = </font></div>
<div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace">    do { atomically ( do { oldValue &lt;- readTVar tvar </font></div><div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace">                         ; writeTVar tvar (oldValue + 1) } )</font></div>
<div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace">       ; forkIO (do { action</font></div><div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace">                    ; atomically ( do { oldValue &lt;- readTVar tvar </font></div>
<div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace">                                      ; writeTVar tvar (oldValue - 1) } ) } ) </font></div><div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace">       --; putStrLn &quot;Tread lancé&quot; } </font></div>
<div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace">       ; return () }</font></div><div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace">                                   </font></div>
<div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace">waitFlag flag = atomically ( do { valueflag &lt;- readTVar flag </font></div><div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace">                                 ; if valueflag &gt; 0 then retry else return () } )</font></div>
<div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace"><br></font></div><div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace">{-- main --}</font></div><div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace"><br>
</font></div><div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace">main :: IO ()</font></div><div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace">main = do { flag &lt;- create_flag</font></div>
<div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace">          ; inbox &lt;- atomically (createInbox)</font></div><div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace">          ; <b>caller_in_thread flag inbox (\x -&gt; putStrLn (&quot;Caller : &quot;++ (show (x)))) 3</b></font></div>
<div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace"><b>          ; do_jobs_in_threads [(perm,[1..11]),(perm,[1..8]),(perm,[1..3])] inbox flag</b></font></div><div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace">          ; waitFlag flag</font></div>
<div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace">          ;  return () }</font></div></div><div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace">where </font><span class="Apple-style-span" style="font-family: &#39;courier new&#39;, monospace; ">perm (l:ls) = injectett l (perm ls)</span></div>
<div><span class="Apple-style-span" style="font-family: &#39;courier new&#39;, monospace; ">      </span><span class="Apple-style-span" style="font-family: &#39;courier new&#39;, monospace; ">injectett x (l:ls) = injecte x l ++ injectett x ls</span></div>
<div><span class="Apple-style-span" style="font-family: &#39;courier new&#39;, monospace; ">      </span><span class="Apple-style-span" style="font-family: &#39;courier new&#39;, monospace; ">injecte x (l:ls) = [x:l:ls]++map (l:) (injecte x ls)</span></div>
<div><span class="Apple-style-span" style="font-family: &#39;courier new&#39;, monospace; ">      inputs = </span><span class="Apple-style-span" style="font-family: &#39;courier new&#39;, monospace; ">zip (replicate 3 f) [[1..11],[1..8],[1..3]]</span></div>
<meta http-equiv="content-type" content="text/html; charset=utf-8"><meta http-equiv="content-type" content="text/html; charset=utf-8"><meta http-equiv="content-type" content="text/html; charset=utf-8"><meta http-equiv="content-type" content="text/html; charset=utf-8"><div>
<font class="Apple-style-span" face="&#39;courier new&#39;, monospace"><br></font></div><div><font class="Apple-style-span" face="arial, helvetica, sans-serif">As you can see, we ask for 3 threads to compute permutations for [1..11], [1..8] and [1..3]. The &quot;Caller&quot; write a message when a thread finished. What we expect is that the second and third thread finish their work before the first one. But the output of this program is : </font></div>
<div><font class="Apple-style-span" face="arial, helvetica, sans-serif"><div><br></div><div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace"><b>Caller : 39916800</b></font></div><div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace"><b>Caller : 40320</b></font></div>
<div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace"><b>Caller : 6</b></font></div><div><br></div><div>... which means that threads 2 and 3 have to wait the first thread before being able to save (and probably compute) their own result.</div>
<div><br></div><div>If I force to evaluate &quot;value&quot; before the atomic section, by defining :</div><div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace"><font class="Apple-style-span" face="arial, helvetica, sans-serif"><br>
</font></font></div><div><span class="Apple-style-span" style="font-family: arial; "><div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace">do_job :: (b -&gt; a) -&gt; b -&gt; Inbox a -&gt; IO ()</font></div>
<div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace">do_job f input inbox = do { value &lt;- return (f input) </font></div><div><font class="Apple-style-span" face="&#39;courier new&#39;, monospace">                          ; value `seq` atomically ( writeMsg inbox value ) }</font></div>
</span></div></font></div><div><font class="Apple-style-span" face="arial, helvetica, sans-serif"><br></font></div><div><font class="Apple-style-span" face="arial, helvetica, sans-serif">Then I obtain a more efficient program, as the output confirms :</font></div>
<div><font class="Apple-style-span" face="arial, helvetica, sans-serif"><br></font></div><div><font class="Apple-style-span" face="arial, helvetica, sans-serif"><div><b><font class="Apple-style-span" face="&#39;courier new&#39;, monospace">Caller : 6</font></b></div>
<div><b><font class="Apple-style-span" face="&#39;courier new&#39;, monospace">Caller : 40320</font></b></div><div><b><font class="Apple-style-span" face="&#39;courier new&#39;, monospace">Caller : 39916800</font></b></div>
<div><br></div><div>That&#39;s what we want, but what is the explanation of this behavior? STM is designed to be optimistic, not blocking. So, does it means that the &quot;value&quot; is evaluated at &quot;commit-time&quot;?</div>
<div>Do you know some problems that are related or do you know some works that can be useful at this subject?</div><div><br></div><div>Thanks for your help,</div><div><br></div><div>rde</div></font></div><div><font class="Apple-style-span" face="arial, helvetica, sans-serif"><br>
</font></div><div><br></div>