Personal tools

Concurrency demos/Haskell-Javascript concurrency

From HaskellWiki

< Concurrency demos(Difference between revisions)
Jump to: navigation, search
(Added TOC)
(Updated the program source and screenshot per transition back to plain CPS)
 
(7 intermediate revisions by one user not shown)
Line 1: Line 1:
=Introduction=
+
__TOC__
  +
==Introduction==
   
 
This piece of code is intended for compilation to Javascript via [[Yhc/Javascript|Yhc Javascript Backend]] and loading into a web browser.
 
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 in monadic style, but it is based on the [[Continuation|Continuation Monad]].
+
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.
+
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=
+
==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 23: Line 24:
 
import Debug.Profiling
 
import Debug.Profiling
   
-- Output a line of text into browser's window.
+
putLineTm = putLine0 True
-- tmf: boolean value instructing to output timestamp when True
 
-- cls: stylesheet class name
 
-- txt: text to output
 
-- doc: reference to the owner document
 
-- par: parent element where text will be output
 
   
putLineTm = putLine True
+
putLine = putLine0 False
   
putLine tmf cls txt doc par = do
+
putLine0 tmf cls txt doc par =
tm <- getTimeStamp 0
+
getTimeStamp $ \tm ->
t <- mkText doc $ (if tmf then (show tm ++ ": ") else "") ++ txt
+
mkText doc ((if tmf then (show tm ++ ": ") else "") ++ txt) $ \t ->
d <- mkDiv doc >>= set'className cls
+
mkDiv doc (set'className cls) $ \d ->
addChild t d
+
addChild t d $ \_ ->
 
addChild d par
 
addChild d par
   
-- Main function. References to the document and document body will be passed
+
main = getHTMLDocument $ \doc ->
-- to every thread for simplicity. All output goes into the document's body.
+
documentBody doc $ \body ->
-- In our example all computations have type Cont Bool x. This makes sense
+
putLine "title" "Simple Concurrency Test with Plain CPS" doc body $ \_ ->
-- because Javascript event handlers are expected to return a boolean value.
+
forkThread (step1 doc body) $
  +
forkThread (step3 doc body) $
  +
msgBox $ \mb ->
  +
forkThread (thr1 doc body mb) $
  +
forkThread (thr2 doc body mb) $
  +
True
   
main = (`runCont` id) $ do
 
doc <- getHTMLDocument
 
body <- documentBody doc
 
putLine False "title" "Simple Concurrency Test with Control.Monad.Cont" doc body
 
   
-- Fork three pseudo-threads.
+
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
   
forkCont $ step0 doc body
+
step3 doc body =
forkCont $ step1 doc body
+
putLineTm "" "Line 3-9" doc body |>>|
forkCont $ step3 doc body
+
putLineTm "" "Line 3-A" doc body |>>|
return True
+
yieldMs 500 $
  +
putLineTm "" "Line 3-B" doc body |>>|
  +
putLineTm "" "Line 3-C" doc body |>>|
  +
True
   
-- Home-grown continiation delimiter function. Passes remainder of the
 
-- whole computation to a given function and forces the whole computation
 
-- to complete by returning a final value. Something similar to returning
 
-- a final value in plain CPS instead of invoking the continuation.
 
-- f: function which the remainder of the program will be passed to.
 
-- Remainder will not be evaluated.
 
-- r: final value of the whole computation that the latter will be
 
-- terminated with.
 
   
delimit f r = Cont $ \c -> runCont (return 0) $ \a -> f (runCont (return a) c) r
 
   
-- A primitive to fork out a thread. See the Yhc/Javascript Programmers Guide
+
showresp r doc body = case r of
-- for the implementation of forkAfter; briefly, it saves the continuation
+
Nothing -> putLine "" "Failed" doc body
-- in a global Javascript object, and calls window.setTimeout to execute
+
Just m -> putLine "" ("Success") doc body
-- the saved continuation after the timeout expires. Thus effects like
 
-- forking parallel thread and cooperative concurrency may be achieved.
 
-- As follows from the function source below, it yields execution to whatever
 
-- given as `x' (which must return a final value of the same type as
 
-- the "parent" thread), while the remained of the parent will be started
 
-- after a minimal timeout. The "child" thread is expected to be courteous
 
-- to its parent and yield execution shortly.
 
   
forkCont x = delimit (forkAfter 0) (runCont x id)
+
showmsg t m doc body =
  +
case m of
  +
Nothing -> putLine "" (t ++ " " ++ "No message") doc body
  +
Just m' -> putLine "" (t ++ " " ++ "Message: " ++ show m') doc body
   
-- A primitive to yield execution for a given interval (in milliseconds).
+
thr1 doc body mb =
-- It just sets the timeout desired (0 is OK, but it of course will be longer)
+
putLine "" "Thread 1 started" doc body |>>|
-- and terminates the whole computation with final value of True.
+
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
   
yield n = delimit (forkAfter n) 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>
   
-- Thread 0. It also features callCC to make sure it is compatible with
+
==Output==
-- our home-grown delimiter. Within callCC's nested computation, actual
 
-- timeout is measured as pair timestamps before and after yield. Output
 
-- continues then, and finally the timeput value is passed back to callCC.
 
-- As output shows, line 0-3 is printed after the thread is resumed, so
 
-- the delimiter works from any depth.
 
   
step0 doc body = do
+
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.
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
 
   
-- Two other threads are nothing spectacular, only they have different
 
-- timeout lengths, so thread 3 will wake up first.
 
   
step1 doc body = do
+
<center>
putLineTm "" "Line 1-5" doc body
+
[[Image:ContTest.jpg]]
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
+
<small>'''Fig. 1:''' Web browser window showing output of the test program</small>
putLineTm "" "Line 3-9" doc body
+
</center>
putLineTm "" "Line 3-A" doc body
+
yield 500
+
==Try it out==
putLineTm "" "Line 3-B" doc body
+
putLineTm "" "Line 3-C" doc body
+
The compiled HTML page of this demo program is accessible at:
return True
+
</haskell>
+
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