[project @ 2005-09-13 10:06:59 by simonmar]

add test for bug #1285326

testsuite/tests/ghc-regress/concurrent/prog001/Arithmetic.hs

+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

testsuite/tests/ghc-regress/concurrent/prog001/Converter.hs

+
+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')

testsuite/tests/ghc-regress/concurrent/prog001/Main.hs

+import Mutiply
+
+main = startM1

testsuite/tests/ghc-regress/concurrent/prog001/Makefile

+TOP=../../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk

testsuite/tests/ghc-regress/concurrent/prog001/Mult.hs

+
+module Main where
+
+import Arithmetic
+import Trit
+import Stream
+import Converter
+import Control.Concurrent
+import Control.Concurrent.MVar
+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