11 files changed, 1034 insertions, 0 deletions

diff --git a/testsuite/tests/concurrent/prog001/Arithmetic.hs b/testsuite/tests/concurrent/prog001/Arithmetic.hs
new file mode 100644
index 0000000000..c1c18c549b
--- /dev/null
+++ b/testsuite/tests/concurrent/prog001/Arithmetic.hs
@@ -0,0 +1,235 @@
+module Arithmetic where
+
+import Control.Concurrent
+import Control.Concurrent.MVar
+import System.IO.Unsafe
+import Utilities
+import Converter
+import Stream
+import Data.Ratio
+import Trit
+
+
+-- Negate a stream of Gray code
+negateGray :: Gray -> Gray
+negateGray = fl
+
+
+-- Multiply a Gray code stream by 2
+-- The stream must represent a real number in (-1/2, 1/2) only
+mul2 :: Gray -> Gray
+mul2 (x:1:xs) = (x:fl xs)
+
+
+-- Division by 2, the result is to be in (-1/2, 1/2)
+div2 :: Gray -> Gray
+div2 (x:xs) = x:1:(fl xs)
+
+
+-- Addition by 1, the input must be in (-1,0)
+plusOne :: Gray -> Gray
+plusOne (0:xs) = 1:fl xs
+
+
+
+-- Substraction by 1, the input must be in (0,1)
+minusOne :: Gray -> Gray
+minusOne (1:xs) = 0:fl xs
+
+
+
+
+threadTesting :: Gray -> Gray -> IO Int
+threadTesting xs ys = do
+		    m <- newEmptyMVar
+		    c1 <- forkIO (t1 m xs ys)
+		    c2 <- forkIO (t2 m xs ys)
+		    c3 <- forkIO (t3 m xs ys)
+		    c4 <- forkIO (t4 m xs ys)
+		    c5 <- forkIO (t5 m xs ys)
+		    c6 <- forkIO (t6 m xs ys)
+		    c <- takeMVar m
+		    killThread c1
+		    killThread c2
+		    killThread c3
+		    killThread c4
+		    killThread c5
+		    killThread c6
+		    return c
+
+
+
+
+addition :: Gray -> Gray -> IO Gray
+addition xs ys = do
+		     			c <- threadTesting xs ys
+		     			case c of
+		     			   1 -> do
+					           let tx = tail xs
+						   let ty = tail ys
+				  		   t <- unsafeInterleaveIO (addition  tx ty)
+						   return (0:t)
+					   2 ->	 do
+						   let tx = tail xs
+						   let ty = tail ys
+					   	   t <- unsafeInterleaveIO (addition tx ty)
+						   return (1:t)
+					   3 ->  do	
+						   let tx = tail xs
+						   let ty = tail ys					   
+					   	   cs <- unsafeInterleaveIO (addition tx (fl ty))
+						   let c1 = cs !! 0
+						   let c2 = tail cs
+						   return (c1:1:fl c2)
+					   4 ->  do
+						   let tx = tail xs
+						   let ty = tail ys
+					   	   (cs) <- unsafeInterleaveIO (addition (fl tx) ty)
+		               			   let c1 = cs !! 0
+						   let c2 = tail cs
+						   return (c1:1:(fl c2))
+					   5 ->  do
+						   let x1 = xs!!0
+						   let y1 = ys!!0
+						   let tx = (drop 2) xs
+						   let ty = (drop 2) ys
+					   	   cs <- unsafeInterleaveIO (addition (x1:(fl tx)) (y1:(fl ty)))
+						   let c1 = cs !! 0
+						   let c2 = tail cs
+						   return (c1:(1:(fl c2)))
+					   6 ->  do						   
+						   let x1 = xs !! 0
+						   let tx = drop 3 xs
+						   let ty = drop 2 ys
+					   	   t <- unsafeInterleaveIO (addition (x1:1:tx) (1:fl ty))
+						   return (0:t)
+					   7 ->  do
+						   let x1 = xs !! 0
+						   let tx = drop 3 xs
+						   let ty = drop 2 ys
+					   	   t <- unsafeInterleaveIO (addition (fl (x1:1:tx)) (1:(fl ty)))
+						   return (1:t)
+					   8 ->  do
+						   let x1 = xs !! 0
+						   let y2 = ys !! 1
+						   let tx = drop 3 xs
+						   let ty = drop 3 ys
+					   	   t <- unsafeInterleaveIO (addition (fl (x1:fl tx)) (fl (y2:fl ty)))
+						   return (0:1:t)
+					   9 ->  do
+						   let x1 = xs !! 0
+						   let y2 = ys !! 1
+						   let tx = drop 3 xs
+						   let ty = drop 3 ys
+					   	   t <- unsafeInterleaveIO (addition (x1:fl tx) (fl (y2:fl ty)))
+						   return (1:1:t)
+					   10 ->  do
+						   let y1 = ys !! 0
+						   let ty = drop 3 ys
+						   let tx = drop 2 xs
+					  	   t <- unsafeInterleaveIO (addition (1:fl tx) (y1:1:ty))
+						   return (0:t)
+					   11 ->  do
+						   let y1 = ys !! 0
+						   let ty = drop 3 ys
+						   let tx = drop 2 xs
+					   	   t <- unsafeInterleaveIO (addition (1:fl tx) (fl (y1:1:ty)))
+						   return (1:t)
+				 	   12 ->  do
+						   let y1 = ys !! 0
+						   let x2 = xs !! 1
+						   let tx = drop 3 xs
+						   let ty = drop 3 ys
+					   	   t <- unsafeInterleaveIO (addition (fl (x2:fl tx)) (fl (y1:fl ty)))
+						   return (0:1:t)
+					   13 ->  do
+						   let y1 = ys !! 0
+						   let x2 = xs !! 1
+						   let tx = drop 3 xs
+						   let ty = drop 3 ys
+					   	   t <- unsafeInterleaveIO (addition (fl (x2:fl tx)) (y1:fl ty))
+						   return (1:1:t)
+
+
+
+
+
+
+
+
+
+
+
+
+
+-- Compute (a-b)/2
+substraction :: Gray -> Gray -> IO Gray
+substraction xs ys = addition xs (negateGray ys)
+
+
+
+
+
+t1 :: MVar Int -> Stream -> Stream -> IO()
+t1 m (0:as) (0:bs) = putMVar m 1
+t1 m (1:as) (1:bs) = putMVar m 2
+t1 m (0:as) (1:bs) = putMVar m 3
+t1 m (1:as) (0:bs) = putMVar m 4
+
+
+t2 :: MVar Int -> Stream -> Stream -> IO()
+t2 m (a:1:x) (b:1:y) = putMVar m 5
+t2 m x y = yield
+			
+			
+t3 m (a:1:0:x) (0:0:y) = putMVar m 6
+t3 m (a:1:0:x) (1:0:y) = putMVar m 7
+t3 m x y = yield
+	
+
+t4 m (a:1:0:x) (0:b:1:y) = putMVar m 8
+t4 m (a:1:0:x) (1:b:1:y) = putMVar m 9
+t4 m x y = yield			
+			
+								
+t5 m (0:0:x) (b:1:0:y) = putMVar m 10
+t5 m (1:0:x) (b:1:0:y) = putMVar m 11
+t5 m x y = yield
+
+			
+t6 m (0:a:1:x) (b:1:0:y) = putMVar m 12
+t6 m (1:a:1:x) (b:1:0:y) = putMVar m 13
+t6 m x y = yield
+			
+			
+
+
+
+multiplyIO :: Gray -> Gray -> IO Gray
+multiplyIO xs ys = do
+		    s1 <- unsafeInterleaveIO (grayToSignIO xs)
+		    s2 <- unsafeInterleaveIO (grayToSignIO ys)
+		    let s = Trit.multiply s1 s2
+	            let g = signToGray s
+                    return g
+
+						
+
+start :: IO()
+start = do
+	   c <- unsafeInterleaveIO(multiplyIO z1 z1)
+	   putStrLn (show c)
+
+
+startA :: IO()
+startA = do
+	   c <- unsafeInterleaveIO(addition (1:1:z0) (1:1:z0))
+	   putStrLn (show (take 30 c))
+
+z0 = (0:z0)
+z1 = (1:z1)
+
+zl = 0:loop:z0
+
+loop = loop
+loop01 = 0:1:loop01
diff --git a/testsuite/tests/concurrent/prog001/Converter.hs b/testsuite/tests/concurrent/prog001/Converter.hs
new file mode 100644
index 0000000000..d3dfe2a34f
--- /dev/null
+++ b/testsuite/tests/concurrent/prog001/Converter.hs
@@ -0,0 +1,130 @@
+
+module Converter (rationalToGray, grayToSignIO, signToGray, Gray, startF, startC) where
+
+import Stream
+import Data.Ratio
+import Control.Concurrent
+import Control.Concurrent.MVar
+import System.IO.Unsafe
+
+
+type Gray = [Integer]
+type State = (Integer, Integer)
+
+
+-- Convert a rational number (in (-1,1)) to its Gray representation
+rationalToGray :: Rational -> Gray
+rationalToGray x
+		|x<0		= f (negate' (rationalToStream (-x))) (0,0)
+		|otherwise	= f (rationalToStream x) (0,0)
+		
+	
+-- Function to implement the two heads Turing machine that convert a
+-- signed-digit stream to the corresponding Gray-code representation		
+f :: Stream -> State -> Stream
+f (x:xs) (0,0)
+	    |x==(-1)	= 0:f xs (0,0)
+	    |x==0	= c:1:ds
+	    |x==1	= 1:f xs (1,0)
+	    where c:ds = f xs (0,1)
+	    
+f (x:xs) (0,1)
+	    |x==(-1)	= 0:f xs (1,0)
+	    |x==0	= c:0:ds
+	    |x==1	= 1:f xs (0,0)
+	    where c:ds = f xs (0,1)
+	    
+f (x:xs) (1,0)
+	    |x==(-1)	= 1:f xs (0,0)
+	    |x==0	= c:1:ds
+	    |x==1	= 0:f xs (1,0)
+	    where c:ds = f xs (1,1)
+	    
+f (x:xs) (1,1)
+	    |x==(-1)	= 1:f xs (1,0)
+	    |x==0	= c:0:ds
+	    |x==1	= 0:f xs (0,0)
+	    where c:ds = f xs (1,1)
+	  
+	  
+	  
+
+-- Anotherway to convert from a rational to Gray code representation
+-- Behave exactly the same like above	  
+rationalToGray' :: Rational -> Gray
+rationalToGray' x
+		|x<0		= signToGray (negate' (rationalToStream (-x)))	  
+	  	|otherwise	= signToGray (rationalToStream x) 
+		
+
+-- Function to convert a signed-digit stream to Gray representation
+-- Is much shorter than above		
+signToGray :: Stream -> Stream
+signToGray (1:xs) 	= 1:f'(signToGray xs)
+signToGray ((-1):xs) 	= 0:signToGray xs
+signToGray (0:xs) 	= c:1:(f' ds)
+    		  	where c:ds = signToGray xs
+	    
+
+
+-- Convert a Gray-code stream to the corresponding signed-digit representation
+-- Make use of threads 	    
+grayToSignIO :: Stream -> IO Stream
+grayToSignIO (x1:x2:xs) = do
+			c <- threadTesting(x1:x2:xs)
+			if (c==1)
+			   then (do  co <- unsafeInterleaveIO (grayToSignIO (f'(x2:xs)))
+			             return (1:co))
+			   else if (c==2) 
+			   	   then (do co <- unsafeInterleaveIO (grayToSignIO (x2:xs))
+				            return ((-1):co))
+                                   else (do co <- unsafeInterleaveIO (grayToSignIO (x1:f' xs))
+				            return (0:co))
+
+-- Flip the first bit of an infinite stream
+f' (x:xs) = (f'' x):xs
+	    where f'' 1 = 0
+	    	  f'' 0 = 1
+
+
+-- Launch two threads which run concurrently, test for the first digit of the stream (1, 0 or bottom)
+-- As soon as one thread terminate, grab that result and proceed
+threadTesting :: Stream -> IO Int
+threadTesting xs = do   m <- newEmptyMVar
+	    		c1 <- forkIO (f1 m xs)
+		    	c2 <- forkIO (f2 m xs)
+	    		c <- takeMVar m
+	    		killThread c1
+	    		killThread c2
+	    		return c
+	    
+-- Test case 1, when the first bit is either 1 or 0. 
+-- In case of bottom, f1 will never terminate, then f2 will definitely terminate	    
+f1 :: MVar Int -> Stream -> IO() 
+f1 m (0:xs) = putMVar m 2
+f1 m (1:xs) = putMVar m 1
+
+-- Test case 2, when the first bit is completely ignored, esp in case it was a bottom
+-- If the second bit is 1, then we can output, don't care value of the first bit
+-- If the second bit is 0, then loop forever, give chances to f1 to terminate
+f2 :: MVar Int -> Stream -> IO()
+f2 m (c1:c2:xs) 
+		|c2==1		= putMVar m 3
+		|otherwise	= yield
+
+
+
+
+-- Testing
+startC :: IO()
+startC = do
+	    c<- unsafeInterleaveIO (grayToSignIO (1:1:z0))
+	    putStrLn (show (take 100 c))
+
+
+startF = signToGray ((-1):1:z0)
+
+
+z0 = 0:z0
+loop' = loop'
+z1' = (1:z1')
diff --git a/testsuite/tests/concurrent/prog001/Main.hs b/testsuite/tests/concurrent/prog001/Main.hs
new file mode 100644
index 0000000000..b90fe11c5d
--- /dev/null
+++ b/testsuite/tests/concurrent/prog001/Main.hs
@@ -0,0 +1,3 @@
+import Mutiply
+
+main = startM1
diff --git a/testsuite/tests/concurrent/prog001/Makefile b/testsuite/tests/concurrent/prog001/Makefile
new file mode 100644
index 0000000000..9101fbd40a
--- /dev/null
+++ b/testsuite/tests/concurrent/prog001/Makefile
@@ -0,0 +1,3 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
diff --git a/testsuite/tests/concurrent/prog001/Mult.hs b/testsuite/tests/concurrent/prog001/Mult.hs
new file mode 100644
index 0000000000..e387244f68
--- /dev/null
+++ b/testsuite/tests/concurrent/prog001/Mult.hs
@@ -0,0 +1,237 @@
+
+module Main where
+
+import Arithmetic
+import Trit
+import Converter
+import System.IO.Unsafe
+import Data.Ratio
+import Utilities
+import Thread
+
+main = startM1						  
+
+startM1 :: IO()
+startM1 = do
+	  c <- unsafeInterleaveIO (mult (rationalToGray (1%3)) (rationalToGray (0%1)))
+	  putStrLn (show  (take 100 (drop 1 c)))
+
+
+
+
+mult :: Gray -> Gray -> IO Gray
+mult xs ys = do
+		     			c <- threadTesting1 xs ys
+		     			case c of
+
+					   101 -> do
+						   --putStrLn ("In case 101")
+						   let tx = drop 2 xs
+						   let ty = drop 2 ys
+						   t1 <- unsafeInterleaveIO (addition tx ty)
+						   t2 <- unsafeInterleaveIO (addition (fl t1) (1:t1))
+						   t3 <- unsafeInterleaveIO (mult tx ty)
+						   c' <- unsafeInterleaveIO (addition t2 (1:0:0:(fl t3)))
+						   return c'
+
+					   102 -> do
+						   --putStrLn ("In case 102")
+						   let tx = drop 2 xs
+						   let ty = drop 2 ys
+						   t1 <- unsafeInterleaveIO (addition (fl tx) ty)
+					           t2 <- unsafeInterleaveIO (addition tx ty)
+						   t0 <- unsafeInterleaveIO (addition t1 (1:fl t2))
+						   t3 <- unsafeInterleaveIO (mult tx ty)
+						   c' <- unsafeInterleaveIO (addition t0 (1:1:0:fl t3))
+						   return c'
+
+					   103 -> do
+						   --putStrLn ("In case 103")
+						   let tx = drop 2 xs
+						   let ty = drop 2 ys
+						   t <- unsafeInterleaveIO (mult (0:0:tx) (0:0:ty))
+						   return (fl t)
+
+					   104 -> do
+						   --putStrLn ("In case 104")
+						   let tx = drop 2 xs
+						   let ty = drop 2 ys
+						   t <- unsafeInterleaveIO (mult (0:0:tx) (0:1:ty))
+						   return (fl t)
+
+					   201 -> do
+						   c' <- unsafeInterleaveIO (mult ys xs)
+						   return c'
+						   
+					   202 -> do
+						   --putStrLn ("In case 202")
+						   let tx = drop 2 xs
+						   let ty = drop 2 ys
+						   t1 <- unsafeInterleaveIO (addition tx ty)
+						   t2 <- unsafeInterleaveIO (addition t1 (0:fl t1))
+						   t3 <- unsafeInterleaveIO (mult tx ty)
+						   c' <- unsafeInterleaveIO (addition t2 (1:1:1:fl t3))
+						   return c'
+						   
+					   203 -> do
+						   --putStrLn ("In case 203")
+						   let tx = drop 2 xs
+						   let ty = drop 2 ys
+						   t <- unsafeInterleaveIO (mult (0:1:tx) (0:0:ty))
+						   return (fl t)
+
+					   204 -> do
+						   --putStrLn ("In case 204")
+						   let tx = drop 2 xs
+						   let ty = drop 2 ys
+						   t <- unsafeInterleaveIO (mult (0:1:tx) (0:1:ty))
+						   return (fl t)
+
+					   30 ->  do
+						   --putStrLn ("In case 30")
+						   let y1 = ys !! 0
+						   let tx = drop 2 xs
+						   let ty = drop 3 ys
+					           t1 <- unsafeInterleaveIO (addition ((f0' y1):1:ty) ((f0' y1):1:0:ty))
+						   t0 <- unsafeInterleaveIO (mult tx (y1: fl ty))
+						   let c4 = head t0
+						   let d4 = fl (tail t0)
+						   c' <- unsafeInterleaveIO (addition t1 (c4:1:0:0:d4))
+						   return c'
+						   
+					   31 -> do
+					   	  --putStrLn ("In case 31")
+					   	  let tx = drop 2 xs
+						  c' <- unsafeInterleaveIO (mult (0:0:tx) ys)
+						  return (fl c')
+						  
+					   40 ->  do
+					   	   --putStrLn ("In case 40")
+						   let tx = drop 2 xs
+						   let y2 = ys !! 1
+						   let ty = drop 3 ys
+						   t1 <- unsafeInterleaveIO (addition (y2:fl ty) tx)
+						   t2 <- unsafeInterleaveIO (addition (fl t1) (1:y2:1:ty))
+						   t0 <- unsafeInterleaveIO (mult tx (y2:fl ty))
+						   let c2 = f0' (head t0)
+						   let d2 = fl (tail t0)
+						   c' <- unsafeInterleaveIO (addition t2 (1:c2:1:0:d2))
+						   return c'
+						   				   
+					   41 ->  do
+					   	   --putStrLn ("In case 41")
+					   	   let tx = drop 2 xs
+						   let y2 = ys !! 1
+						   let ty = drop 3 ys
+						   c' <- unsafeInterleaveIO (mult (0:0:tx) (0:y2:1:ty))
+						   return (fl c')
+						   
+					   50 ->  do
+					           --putStrLn ("In case 50")
+					   	   let tx = drop 2 xs
+						   let y2 = ys !! 1
+						   let ty = drop 3 ys
+						   t1 <- unsafeInterleaveIO (addition tx (fl (y2:fl ty)))
+						   t2 <- unsafeInterleaveIO (addition t1 (0:y2:1:ty))
+						   t0 <- unsafeInterleaveIO (mult (fl tx) (y2:fl ty))
+						   let c1 = f0' (head t0)
+						   let d1 = fl (tail t0)
+						   c' <- unsafeInterleaveIO (addition t2 (1:c1:1:0:d1))
+						   return c'
+						   
+					   51 ->  do
+					           --putStrLn ("In case 51")
+					   	   let tx = drop 2 xs
+						   let y2 = ys !! 1
+						   let ty = drop 3 ys
+						   c' <- unsafeInterleaveIO (mult (0:1:tx) (0:y2:1:ty))
+						   return (fl c')
+						   
+						   
+					   60 ->  do
+					           --putStrLn ("In case 60")
+					   	   let tx = drop 2 xs
+						   let y1 = ys !! 0
+						   let ty = drop 3 ys
+						   t1 <- unsafeInterleaveIO (addition ((f0' y1):1:ty) (y1:1:0:ty))
+						   t0 <- unsafeInterleaveIO (mult (fl tx) (y1:fl ty))
+						   let c1 = head t0
+						   let d1 = fl (tail t0)
+						   c' <- unsafeInterleaveIO (addition t1 (c1:1:0:0:d1))
+						   return c'
+						   
+					   61 ->  do
+					           --putStrLn ("In case 61")
+					   	   let tx = drop 2 xs
+						   let y1 = ys !! 0
+						   let ty = drop 3 ys
+						   c' <- unsafeInterleaveIO (mult (0:1:tx) (y1:1:0:ty))
+						   return (fl c')
+						   
+						   
+					   70 ->  do
+					           --putStrLn ("In case 70")
+					   	   c' <- unsafeInterleaveIO (mult ys xs)
+						   return c'
+						   
+					   80 ->  do
+					           --putStrLn ("In case 80")
+						   let x2 = xs !! 1
+						   let y2 = ys !! 1
+						   let tx = drop 3 xs
+						   let ty = drop 3 ys
+						   t1 <- unsafeInterleaveIO (addition (x2:fl tx) (y2:fl ty))
+						   t0 <- unsafeInterleaveIO (mult (x2:fl tx) (y2:fl ty))
+						   let c1 = head (fl t1)
+						   let d1 = tail (fl t1)
+						   let c2 = f0' (head t0)
+						   let d2 = fl (tail t0)
+						   c' <- unsafeInterleaveIO (addition (c1:1:(fl d1)) (1:c2:1:0:d2))
+						   return c'
+						   
+					   81 ->  do
+					           --putStrLn ("In case 81")
+					   	   let x2 = xs !! 1
+						   let y2 = ys !! 1
+						   let tx = drop 3 xs
+						   let ty = drop 3 ys
+						   c' <- unsafeInterleaveIO (mult (0:x2:1:tx) (0:y2:1:ty))
+						   return (fl c')
+						   
+					   90 ->  do
+					   	   --putStrLn ("In case 90")
+						   let x2 = xs!!1
+						   let y1 = ys!!0
+						   let tx = drop 3 xs
+						   let ty = drop 3 ys
+						   t0 <- unsafeInterleaveIO (mult (x2:fl tx) (y1:fl ty))
+						   let c1 = head t0
+						   let d1 = fl (tail t0)
+						   c' <- unsafeInterleaveIO (addition ((f0' y1):1:0:ty) (c1:1:0:0:d1))
+						   return c'
+						   
+					   91 ->  do
+					   	   --putStrLn ("In case 91")
+					   	   let x2 = xs!!1
+						   let y1 = ys!!0
+						   let tx = drop 3 xs
+						   let ty = drop 3 ys
+						   c' <- unsafeInterleaveIO (mult (0:x2:1:tx) (y1:1:0:ty))
+						   return (fl c')
+						   
+					   100 -> do
+					   	  --putStrLn ("In case 100")
+					          let x1 = head xs
+						  let y1 = head ys
+						  let tx = drop 3 xs
+						  let ty = drop 3 ys
+						  t0 <- unsafeInterleaveIO (mult (x1:fl tx) (y1:fl ty))
+						  let c4 = head t0
+						  let d4 = fl (tail t0)
+						  return (c4:1:0:0:0:d4)
+						  
+						   
+				
+f0' 0 = 1
+f0' 1 = 0						   
+						   
diff --git a/testsuite/tests/concurrent/prog001/Stream.hs b/testsuite/tests/concurrent/prog001/Stream.hs
new file mode 100644
index 0000000000..349af32962
--- /dev/null
+++ b/testsuite/tests/concurrent/prog001/Stream.hs
@@ -0,0 +1,156 @@
+module Stream (Stream, carry, addStream, rationalToStream, 
+		streamToFloat, addFiniteStream, negate', average) where
+
+import Data.Ratio
+
+
+type Digit = Integer
+type Stream = [Integer]
+
+
+
+-- Convert from a Rational fraction to its stream representation
+rationalToStream :: Rational -> Stream
+rationalToStream x
+	|t<1		= 0:rationalToStream t
+	|otherwise	= 1:rationalToStream (t-1)
+	where t = 2*x
+	
+	
+
+	
+-- Convert from a stream to the Float value
+streamToFloat :: Stream -> Float
+streamToFloat x =  f x (1)
+
+f :: Stream -> Integer -> Float
+f [] n = 0
+f (y:ys) n = (fromIntegral)y/(fromIntegral(2^n)) + f ys (n+1)	
+
+
+
+
+
+-- Add two stream 
+addStream :: Stream -> Stream -> Stream
+addStream (x1:x2:x3:xs) (y1:y2:y3:ys) = (u+c):(addStream (x2:x3:xs) (y2:y3:ys))
+				where u = interim x1 x2 y1 y2
+				      c = carry x2 x3 y2 y3
+				      
+				      
+				      
+-- Compute carry, the C(i) value, given x(i) and y(i)
+carry :: Digit -> Digit -> Digit -> Digit -> Digit
+carry x1 x2 y1 y2 
+	|t>1			=  1
+	|t<(-1)			= -1
+	|t==1 && (minus1 x2 y2)	=  0
+	|t==1 && not (minus1 x2 y2) = 1
+	|t==(-1) && (minus1 x2 y2) = -1
+	|t==(-1) && not (minus1 x2 y2) = 0
+	|t==0				= 0
+	where t = x1+y1
+	
+	
+	
+-- Computer the interim sum, the U(i) value, given x(i), y(i) and c(i)
+interim :: Digit -> Digit -> Digit -> Digit -> Digit
+interim x1 x2 y1 y2
+		|t>1			=  0
+		|t<(-1)			= 0
+		|t==1 && (minus1 x2 y2)	=  1
+		|t==1 && not (minus1 x2 y2) = -1
+		|t==(-1) && (minus1 x2 y2) = 1
+		|t==(-1) && not (minus1 x2 y2) = -1
+		|t==0				= 0
+		where t = x1+y1
+
+
+
+-- Check if at least one of 2 digits is -1
+minus1 :: Digit -> Digit -> Bool
+minus1 x y = (x==(-1))|| (y==(-1))
+
+
+
+
+
+
+-- Algin two stream so that they have the same length
+align :: Stream -> Stream -> (Stream, Stream)
+align xs ys 
+	|x>y 		= (xs, (copy 0 (x-y)) ++ys)
+	|otherwise      = ((copy 0 (y-x)) ++ xs, ys)
+	where x = toInteger(length xs)
+	      y = toInteger(length ys)
+	      
+	      
+	      
+-- Generate a list of x
+copy :: Integer -> Integer -> [Integer]
+copy x n = [x| i<- [1..n]]
+
+
+
+
+
+
+
+-- Add two finite stream (to add the integral part)
+addFiniteStream :: Stream -> Stream -> Stream
+addFiniteStream xs ys = add' u v
+			where (u,v) = align xs ys
+			
+			
+			
+-- Utility function for addFinitieStream			
+add' :: Stream -> Stream -> Stream
+add' u v = normalise (f u v)
+       where f [] [] = []
+             f (x:xs) (y:ys) = (x+y):f xs ys
+	     
+	     
+-- Normalise the sum
+normalise :: Stream -> Stream
+normalise = foldr f [0]
+            where f x (y:ys) = (u:v:ys)
+	                      where u = (x+y) `div` 2
+			            v = (x+y) `mod` 2
+
+
+-- Negate a stream
+negate' :: Stream -> Stream
+negate' = map (*(-1))
+
+
+
+-- Compute average of two stream
+-- Using [-2,-1,0,1,2] to add, and then divide by 2
+average :: Stream -> Stream -> Stream
+average xs ys = div2 (add xs ys)
+
+
+-- Addition of two streams, using [-2,-1,0,1,2]
+add :: Stream -> Stream -> Stream
+add (x:xs) (y:ys) = (x+y):(add xs ys)
+
+
+-- Then divided by 2, [-2,-1,0,1,2] -> [-1,0,1]
+div2 :: Stream -> Stream
+div2 (2:xs)          	= 1:div2 xs 		       
+div2 ((-2):xs)		= (-1):div2 xs
+div2 (0:xs)		= 0:div2 xs
+div2 (1:(-2):xs)	= div2 (0:0:xs)
+div2 (1:(-1):xs)	= div2 (0:1:xs)
+div2 (1:0:xs)		= div2 (0:2:xs)
+div2 (1:1:xs)		= div2 (2:(-1):xs)
+div2 (1:2:xs)		= div2 (2:0:xs)
+div2 ((-1):(-2):xs)	= div2 ((-2):0:xs)
+div2 ((-1):(-1):xs)	= div2 ((-2):1:xs)
+div2 ((-1):0:xs)	= div2 (0:(-2):xs)
+div2 ((-1):1:xs)	= div2 (0:(-1):xs)
+div2 ((-1):2:xs)	= div2 (0:0:xs)
+    		
+ 
+
+test = take 100 (average (rationalToStream (1%2)) (rationalToStream (1%3)))
diff --git a/testsuite/tests/concurrent/prog001/Thread.hs b/testsuite/tests/concurrent/prog001/Thread.hs
new file mode 100644
index 0000000000..62bb7dd3c3
--- /dev/null
+++ b/testsuite/tests/concurrent/prog001/Thread.hs
@@ -0,0 +1,114 @@
+
+module Thread (threadTesting1) where
+
+import Control.Concurrent
+import Control.Concurrent.MVar
+import Stream
+import Converter
+
+threadTesting1 :: Gray -> Gray -> IO Int
+threadTesting1 xs ys = do
+		    m <- newEmptyMVar
+		    c1 <- forkIO (t1 m xs ys)
+		    c2 <- forkIO (t2 m xs ys)
+		    c3 <- forkIO (t3 m xs ys)
+		    c4 <- forkIO (t4 m xs ys)
+		    c5 <- forkIO (t5 m xs ys)
+		    c6 <- forkIO (t6 m xs ys)
+		    c7 <- forkIO (t7 m xs ys)
+		    c8 <- forkIO (t8 m xs ys)
+		    c9 <- forkIO (t9 m xs ys)
+		    c <- takeMVar m
+		    killThread c1
+		    killThread c2
+		    killThread c3
+		    killThread c4
+		    killThread c5
+		    killThread c6
+		    killThread c7
+		    killThread c8
+		    killThread c9
+		    return c
+
+
+
+
+
+
+
+
+t1 :: MVar Int -> Stream -> Stream -> IO()
+t1 m (0:0:x) (0:0:y) = putMVar m 101
+t1 m (0:0:x) (0:1:y) = putMVar m 102
+t1 m (0:0:x) (1:0:y) = putMVar m 103
+t1 m (0:0:x) (1:1:y) = putMVar m 104
+
+t1 m (0:1:x) (0:0:y) = putMVar m 201
+t1 m (0:1:x) (0:1:y) = putMVar m 202
+t1 m (0:1:x) (1:0:y) = putMVar m 203
+t1 m (0:1:x) (1:1:y) = putMVar m 204
+
+t1 m (1:0:x) (0:0:y) = putMVar m 103
+t1 m (1:0:x) (0:1:y) = putMVar m 104
+t1 m (1:0:x) (1:0:y) = putMVar m 101
+t1 m (1:0:x) (1:1:y) = putMVar m 102
+
+
+t1 m (1:1:x) (0:0:y) = putMVar m 203
+t1 m (1:1:x) (0:1:y) = putMVar m 204
+t1 m (1:1:x) (1:0:y) = putMVar m 201
+t1 m (1:1:x) (1:1:y) = putMVar m 202
+
+			
+t2 :: MVar Int -> Stream -> Stream -> IO()
+t2 m (0:0:x) (b:1:0:y) = putMVar m 30
+t2 m (1:0:x) (b:1:0:y) = putMVar m 31						
+t2 m (0:1:x) (b:1:0:y) = putMVar m 60
+t2 m (1:1:x) (b:1:0:y) = putMVar m 61
+t2 m x y = yield
+
+
+t3 m (0:0:x) (0:b:1:y) = putMVar m 40
+t3 m (1:0:x) (1:b:1:y) = putMVar m 40
+t3 m (0:0:x) (1:b:1:y) = putMVar m 41
+t3 m (1:0:x) (0:b:1:y) = putMVar m 41
+
+t3 m (0:1:x) (0:b:1:y) = putMVar m 50
+t3 m (1:1:x) (1:b:1:y) = putMVar m 50
+t3 m (0:1:x) (1:b:1:y) = putMVar m 51
+t3 m (1:1:x) (0:b:1:y) = putMVar m 51
+t3 m x y = yield
+
+t4 m (0:a:1:y) (0:0:x) = putMVar m 70
+t4 m (1:a:1:y) (1:0:x) = putMVar m 70
+t4 m (1:a:1:y) (0:0:x) = putMVar m 70
+t4 m (0:a:1:y) (1:0:x) = putMVar m 70
+t4 m (0:a:1:y) (0:1:x) = putMVar m 70
+t4 m (1:a:1:y) (1:1:x) = putMVar m 70
+t4 m (1:a:1:y) (0:1:x) = putMVar m 70
+t4 m (0:a:1:y) (1:1:x) = putMVar m 70
+t4 m x y = yield
+
+
+t5 m (a:1:0:y) (0:0:x) = putMVar m 70
+t5 m (a:1:0:y) (1:0:x) = putMVar m 70
+t5 m (a:1:0:y) (0:1:x) = putMVar m 70
+t5 m (a:1:0:y) (1:1:x) = putMVar m 70
+t5 m x y = yield
+
+t6 m (0:a:1:x) (0:b:1:y) = putMVar m 80
+t6 m (1:a:1:x) (1:b:1:y) = putMVar m 80
+t6 m (0:a:1:x) (1:b:1:y) = putMVar m 81
+t6 m (1:a:1:x) (0:b:1:y) = putMVar m 81
+t6 m x y = yield
+
+t7 m (0:a:1:x) (b:1:0:y) = putMVar m 90
+t7 m (1:a:1:x) (b:1:0:y) = putMVar m 91
+t7 m x y = yield
+
+t8 m (a:1:0:x) (b:1:0:y) = putMVar m 100
+t8 m x y = yield
+
+t9 m (a:1:0:x) (0:b:1:y) = putMVar m 70
+t9 m (a:1:0:x) (1:b:1:y) = putMVar m 70
+t9 m x y = yield
diff --git a/testsuite/tests/concurrent/prog001/Trit.hs b/testsuite/tests/concurrent/prog001/Trit.hs
new file mode 100644
index 0000000000..bb6d03c9e2
--- /dev/null
+++ b/testsuite/tests/concurrent/prog001/Trit.hs
@@ -0,0 +1,112 @@
+module Trit (Trit, rationalToTrit, getIntegral, getFraction, getFraction',
+		neg, addTrits, subTrits, shiftLeft, shiftRight, multiply
+		) where
+
+import Stream
+import Utilities
+import Data.Ratio
+
+type Mantissa = Stream
+type Fraction = Stream
+type Trit     = (Mantissa, Fraction)
+
+
+-- Convert from a Rational number to its Trit representation (Integral, Fraction)
+rationalToTrit :: Rational -> Trit
+rationalToTrit x
+		|x<1		= ([0], rationalToStream x)
+		|otherwise	= (u', rationalToStream v)
+		where   u = n `div` d
+			u' = toBinary u
+	      		v = x - (toRational u)
+			n = numerator x
+	      		d = denominator x
+			
+			
+-- Get the integral part of Trit
+getIntegral :: Trit -> Mantissa
+getIntegral = fst
+
+
+
+-- Get the fraction part of Trit, with n digit of the stream
+getFraction :: Int -> Trit -> Stream
+getFraction n = take n. snd
+
+
+-- Get the fraction part of Trit
+getFraction' :: Trit -> Stream
+getFraction' = snd
+
+
+
+-- Negate a Trit
+neg :: Trit -> Trit
+neg (a, b) = (negate' a, negate' b)
+
+
+
+-- Add two Trits
+addTrits :: Trit -> Trit -> Trit
+addTrits (m1, (x1:x2:xs)) (m2, (y1:y2:ys)) = (u,addStream (x1:x2:xs) (y1:y2:ys))
+					   where u' = addFiniteStream m1 m2
+					         c = [carry x1 x2 y1 y2]
+						 u = addFiniteStream u' c
+
+
+
+-- Substraction of 2 Trits
+subTrits :: Trit -> Trit -> Trit
+subTrits x y = addTrits x (neg y)
+
+
+
+-- Shift left = *2 opertaion with Trit
+shiftLeft :: Trit -> Trit
+shiftLeft (x, (y:ys)) = (x++ [y], ys)
+
+
+-- Shift right = /2 operation with Trit
+shiftRight :: Trit -> Integer -> Trit
+shiftRight (x, xs) 1 = (init x, (u:xs))
+		    where u = last x
+shiftRight (x, xs) n = shiftRight (init x, (u:xs)) (n-1)
+ 		    where u = last x		    
+		  
+		  
+
+-- Multiply a Trit stream by 1,0 or -1, simply return the stream
+mulOneDigit :: Integer -> Stream -> Stream
+mulOneDigit x xs
+              |x==1      = xs
+	      |x==0      = zero'
+	      |otherwise = negate' xs
+	      where zero' = (0:zero')
+
+
+
+
+
+
+-- Multiplication of two streams
+multiply :: Stream -> Stream -> Stream
+multiply (a0:a1:x) (b0:b1:y) = average p q
+			       where p = average (a1*b0: (average (mulOneDigit b1 x)
+							         (mulOneDigit a1 y)))
+					         (average (mulOneDigit b0 x)
+						          (mulOneDigit a0 y))
+				     q = (a0*b0:a0*b1:a1*b1:(multiply x y))
+
+
+
+
+start0 = take 30 (multiply (rationalToStream (1%2)) zo)
+
+zo :: Stream
+zo = 1:(-1):zero
+     where zero = 0:zero
+
+start1 = take 30 (average (rationalToStream (1%2)) (negate' (rationalToStream (1%4))))
+
+	 
+	 
diff --git a/testsuite/tests/concurrent/prog001/Utilities.hs b/testsuite/tests/concurrent/prog001/Utilities.hs
new file mode 100644
index 0000000000..9e8a39187d
--- /dev/null
+++ b/testsuite/tests/concurrent/prog001/Utilities.hs
@@ -0,0 +1,17 @@
+module Utilities (toBinary, fl) where
+
+import Stream
+import Data.Ratio
+
+-- Convert from an Integer to its signed-digit representation
+toBinary :: Integer -> Stream
+toBinary 0 = [0]
+toBinary x = toBinary t ++ [x `mod` 2]
+	     where t = x `div` 2
+	     
+
+
+fl :: Stream -> Stream
+fl (x:xs) = (f x):xs
+	  where f 0 = 1
+	  	f 1 = 0
diff --git a/testsuite/tests/concurrent/prog001/all.T b/testsuite/tests/concurrent/prog001/all.T
new file mode 100644
index 0000000000..70f38dca4f
--- /dev/null
+++ b/testsuite/tests/concurrent/prog001/all.T
@@ -0,0 +1,26 @@
+# Test for bug #1285326, results in "internal error: scavenge_one:
+# strange object 47" with GHC 6.4, fixed in 6.4.1.
+
+# Also tests for bug #1466.
+
+# NB. This is a VERY IMPORTANT test!  It is the only good test we have
+# for throwTo.  It has shown up several bugs that were not caught by the 
+# other concurrency tests.
+
+# The program appears to be sensitive to scheduling, and can diverge
+# in some cases.  I find that it only reliably completes when given
+# multiple cores, which is why it is only running the 'threaded2' way
+# right now. --SDM 1/4/2010
+
+test('concprog001',
+     [skip_if_fast,
+      only_ways(['threaded2']),
+      extra_clean(['Arithmetic.hi', 'Arithmetic.o',
+                   'Converter.hi',  'Converter.o',
+                   'Mult.hi',       'Mult.o',
+                   'Stream.hi',     'Stream.o',
+                   'Thread.hi',     'Thread.o',
+                   'Trit.hi',       'Trit.o',
+                   'Utilities.hi',  'Utilities.o'])],
+     multimod_compile_and_run,
+     ['Mult',''])
diff --git a/testsuite/tests/concurrent/prog001/concprog001.stdout b/testsuite/tests/concurrent/prog001/concprog001.stdout
new file mode 100644
index 0000000000..fb69b5b792
--- /dev/null
+++ b/testsuite/tests/concurrent/prog001/concprog001.stdout
@@ -0,0 +1 @@
+[1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0]