Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Glasgow Haskell Compiler
GHC
Commits
9ae84316
Commit
9ae84316
authored
Sep 13, 2005
by
simonmar
Browse files
[project @ 2005-09-13 10:06:59 by simonmar]
add test for bug #1285326
parent
0a4224d6
Changes
10
Hide whitespace changes
Inline
Side-by-side
testsuite/tests/ghc-regress/concurrent/prog001/Arithmetic.hs
0 → 100644
View file @
9ae84316
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
0 → 100644
View file @
9ae84316
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
0 → 100644
View file @
9ae84316
import
Mutiply
main
=
startM1
testsuite/tests/ghc-regress/concurrent/prog001/Makefile
0 → 100644
View file @
9ae84316
TOP
=
../../../..
include
$(TOP)/mk/boilerplate.mk
include
$(TOP)/mk/test.mk
testsuite/tests/ghc-regress/concurrent/prog001/Mult.hs
0 → 100644
View file @
9ae84316
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'
)