Personal tools

Concurrency demos/Haskell-Javascript concurrency

From HaskellWiki

< Concurrency demos(Difference between revisions)
Jump to: navigation, search
(Uploaded test source)
 
(Updated the program source and screenshot per transition back to plain CPS)
 
(10 intermediate revisions by one user not shown)
Line 1: Line 1:
  +
__TOC__
  +
==Introduction==
  +
  +
This piece of code is intended for compilation to Javascript via [[Yhc/Javascript|Yhc Javascript Backend]] and loading into a web browser.
  +
  +
The program is written based on the [[Continuation|plain CPS notation]].
  +
  +
When started, the <hask>main</hask> function forks out three pseudo-threads, and exits. Each thread outputs some lines of text and terminates. Each line printed contains absolute timestamp obtined via Javascript function <code>newDate.getTime()</code>. Explicit delays are used to yield control to other threads. This test also demonstrates the use of message boxes that may be used for Javascript threads to interact with each other.
  +
  +
==Program==
 
<haskell>
 
<haskell>
-- Test of Control.Monad.Cont in Javascript
+
-- Test of plain CPS based concurrency in Javascript
   
 
module ContTest where
 
module ContTest where
   
  +
import CPS
 
import UnsafeJS
 
import UnsafeJS
import Control.Monad
+
import Data.JSRef
import Control.Monad.Cont
+
import Control.Concurrent.JSThreads
 
import CDOM.Level2.DomUtils
 
import CDOM.Level2.DomUtils
 
import DOM.Level2.Dom
 
import DOM.Level2.Dom
Line 14: Line 25:
 
import Debug.Profiling
 
import Debug.Profiling
   
putLineTm = putLine True
+
putLineTm = putLine0 True
   
putLine tmf cls txt doc par = do
+
putLine = putLine0 False
tm <- getTimeStamp 0
+
t <- mkText doc $ (if tmf then (show tm ++ ": ") else "") ++ txt
+
putLine0 tmf cls txt doc par =
d <- mkDiv doc >>= set'className cls
+
getTimeStamp $ \tm ->
addChild t d
+
mkText doc ((if tmf then (show tm ++ ": ") else "") ++ txt) $ \t ->
  +
mkDiv doc (set'className cls) $ \d ->
  +
addChild t d $ \_ ->
 
addChild d par
 
addChild d par
   
main = (`runCont` id) $ do
+
main = getHTMLDocument $ \doc ->
doc <- getHTMLDocument
+
documentBody doc $ \body ->
body <- documentBody doc
+
putLine "title" "Simple Concurrency Test with Plain CPS" doc body $ \_ ->
putLine False "title" "Simple Concurrency Test with Control.Monad.Cont" doc body
+
forkThread (step1 doc body) $
forkCont $ step0 doc body
+
forkThread (step3 doc body) $
forkCont $ step1 doc body
+
msgBox $ \mb ->
forkCont $ step3 doc body
+
forkThread (thr1 doc body mb) $
return True
+
forkThread (thr2 doc body mb) $
  +
True
   
delimit f r = Cont $ \c -> runCont (return 0) $ \a -> f (runCont (return a) c) r
 
   
forkCont x = delimit (forkAfter 0) (runCont x id)
+
step1 doc body =
  +
putLineTm "" "Line 1-5" doc body |>>|
  +
putLineTm "" "Line 1-6" doc body |>>|
  +
getTimeStamp $ \t1 ->
  +
yieldMs 1000 $
  +
getTimeDiff t1 $ \tmm ->
  +
putLineTm "" ("Actual timeout was " ++ show tmm ++ "ms") doc body |>>|
  +
putLineTm "" "Line 1-7" doc body |>>|
  +
putLineTm "" "Line 1-8" doc body |>>|
  +
True
   
yield n = delimit (forkAfter n) True
+
step3 doc body =
  +
putLineTm "" "Line 3-9" doc body |>>|
  +
putLineTm "" "Line 3-A" doc body |>>|
  +
yieldMs 500 $
  +
putLineTm "" "Line 3-B" doc body |>>|
  +
putLineTm "" "Line 3-C" doc body |>>|
  +
True
   
step0 doc body = do
 
putLineTm "" "Line 0-1" doc body
 
tmm <- callCC $ \tdiff -> do
 
putLineTm "" "Line 0-2" doc body
 
t1 <- getTimeStamp 0
 
yield 1000
 
t2 <- getTimeStamp t1
 
putLineTm "" "Line 0-3" doc body
 
tdiff t2
 
putLineTm "" "Line 0-4" doc body
 
putLineTm "" ("Actual timeout was " ++ show tmm ++ "ms") doc body
 
return True
 
   
step1 doc body = do
 
putLineTm "" "Line 1-5" doc body
 
putLineTm "" "Line 1-6" doc body
 
yield 1000
 
putLineTm "" "Line 1-7" doc body
 
putLineTm "" "Line 1-8" doc body
 
return True
 
   
step3 doc body = do
+
showresp r doc body = case r of
putLineTm "" "Line 3-9" doc body
+
Nothing -> putLine "" "Failed" doc body
putLineTm "" "Line 3-A" doc body
+
Just m -> putLine "" ("Success") doc body
yield 500
+
putLineTm "" "Line 3-B" doc body
+
showmsg t m doc body =
putLineTm "" "Line 3-C" doc body
+
case m of
return True
+
Nothing -> putLine "" (t ++ " " ++ "No message") doc body
  +
Just m' -> putLine "" (t ++ " " ++ "Message: " ++ show m') doc body
  +
  +
thr1 doc body mb =
  +
putLine "" "Thread 1 started" doc body |>>|
  +
putLine "" "Thread 1 waiting" doc body |>>|
  +
recvMsg mb $ \m ->
  +
showmsg "T1:" m doc body |>>|
  +
putLine "" "Thread 1 resumed" doc body |>>|
  +
putLine "" "Thread 1 sending" doc body |>>|
  +
sendMsg mb "123" $ \x ->
  +
showresp x doc body |>>|
  +
putLine "" "Thread 1 finishing" doc body |>>|
  +
True
  +
  +
thr2 doc body mb =
  +
putLine "" "Thread 2 started" doc body |>>|
  +
putLine "" "Thread 2 sending" doc body |>>|
  +
sendMsg mb "abc" $ \x ->
  +
showresp x doc body |>>|
  +
putLine "" "Thread 2 has sent message" doc body |>>|
  +
putLine "" "Thread 2 waiting" doc body |>>|
  +
recvMsg mb $ \m ->
  +
showmsg "T2:" m doc body |>>|
  +
putLine "" "Thread 2 finishing" doc body |>>|
  +
True
 
</haskell>
 
</haskell>
  +
  +
==Output==
  +
  +
The figure below shows contents of the web browser window after running the test program above. Actual timeout value is of course different in each run of the program.
  +
  +
  +
<center>
  +
[[Image:ContTest.jpg]]
  +
  +
<small>'''Fig. 1:''' Web browser window showing output of the test program</small>
  +
</center>
  +
  +
==Try it out==
  +
  +
The compiled HTML page of this demo program is accessible at:
  +
  +
http://darcs.haskell.org/yhc/web/jsdemos/ContTest.html

Latest revision as of 15:05, 1 December 2007

Contents

[edit] 1 Introduction

This piece of code is intended for compilation to Javascript via Yhc Javascript Backend and loading into a web browser.

The program is written based on the plain CPS notation.

When started, the
main
function forks out three pseudo-threads, and exits. Each thread outputs some lines of text and terminates. Each line printed contains absolute timestamp obtined via Javascript function newDate.getTime(). Explicit delays are used to yield control to other threads. This test also demonstrates the use of message boxes that may be used for Javascript threads to interact with each other.

[edit] 2 Program

-- Test of plain CPS based concurrency in Javascript
 
module ContTest where
 
import CPS
import UnsafeJS
import Data.JSRef
import Control.Concurrent.JSThreads
import CDOM.Level2.DomUtils
import DOM.Level2.Dom
import DOM.Level2.Html2
import DOM.Level2.HTMLElement
import DOM.Level2.HTMLDivElement
import Debug.Profiling
 
putLineTm = putLine0 True
 
putLine = putLine0 False
 
putLine0 tmf cls txt doc par =
  getTimeStamp $ \tm ->
  mkText doc ((if tmf then (show tm ++ ": ") else "") ++ txt) $ \t ->
  mkDiv doc (set'className cls) $ \d ->
  addChild t d $ \_ ->
  addChild d par
 
main = getHTMLDocument $ \doc ->
       documentBody doc $ \body ->
       putLine "title" "Simple Concurrency Test with Plain CPS" doc body $ \_ ->
       forkThread (step1 doc body) $
       forkThread (step3 doc body) $
       msgBox $ \mb ->
       forkThread (thr1 doc body mb) $
       forkThread (thr2 doc body mb) $
       True
 
 
step1 doc body =
  putLineTm "" "Line 1-5" doc body |>>|
  putLineTm "" "Line 1-6" doc body |>>|
  getTimeStamp $ \t1 ->
  yieldMs 1000 $
  getTimeDiff t1 $ \tmm ->
  putLineTm "" ("Actual timeout was " ++ show tmm ++ "ms") doc body |>>|
  putLineTm "" "Line 1-7" doc body |>>|
  putLineTm "" "Line 1-8" doc body |>>|
  True
 
step3 doc body =
  putLineTm "" "Line 3-9" doc body |>>|
  putLineTm "" "Line 3-A" doc body |>>|
  yieldMs 500 $
  putLineTm "" "Line 3-B" doc body |>>|
  putLineTm "" "Line 3-C" doc body |>>|
  True
 
 
 
showresp r doc body =  case r of
    Nothing -> putLine "" "Failed" doc body
    Just m -> putLine "" ("Success") doc body
 
showmsg t m doc body =
  case m of
    Nothing -> putLine "" (t ++ " " ++ "No message") doc body
    Just m' -> putLine "" (t ++ " " ++ "Message: " ++ show m') doc body
 
thr1 doc body mb =
  putLine "" "Thread 1 started" doc body |>>|
  putLine "" "Thread 1 waiting" doc body |>>|
  recvMsg mb $ \m ->
  showmsg "T1:" m doc body |>>|
  putLine "" "Thread 1 resumed" doc body |>>|
  putLine "" "Thread 1 sending" doc body |>>|
  sendMsg mb "123" $ \x ->
  showresp x doc body |>>|
  putLine "" "Thread 1 finishing" doc body |>>|
  True
 
thr2 doc body mb =
  putLine "" "Thread 2 started" doc body |>>|
  putLine "" "Thread 2 sending" doc body |>>|
  sendMsg mb "abc" $ \x ->
  showresp x doc body |>>|
  putLine "" "Thread 2 has sent message" doc body |>>|
  putLine "" "Thread 2 waiting" doc body |>>|
  recvMsg mb $ \m ->
  showmsg "T2:" m doc body |>>|
  putLine "" "Thread 2 finishing" doc body |>>|
  True

[edit] 3 Output

The figure below shows contents of the web browser window after running the test program above. Actual timeout value is of course different in each run of the program.


ContTest.jpg

Fig. 1: Web browser window showing output of the test program

[edit] 4 Try it out

The compiled HTML page of this demo program is accessible at:

http://darcs.haskell.org/yhc/web/jsdemos/ContTest.html