Personal tools

Concurrency demos/Haskell-Javascript concurrency

From HaskellWiki

< Concurrency demos(Difference between revisions)
Jump to: navigation, search
(Uploaded test source)
Current revision (15:05, 1 December 2007) (edit) (undo)
(Updated the program source and screenshot per transition back to plain CPS)
 
(10 intermediate revisions 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

Current revision

Contents

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.

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

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.


Image:ContTest.jpg

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

4 Try it out

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

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

Retrieved from "http://www.haskell.org/haskellwiki/Concurrency_demos/Haskell-Javascript_concurrency"