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