Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Alex D
GHC
Commits
5b03dc69
Commit
5b03dc69
authored
Jun 18, 2016
by
Thomas Miedema
Browse files
Testsuite: tabs > spaces [skip ci]
parent
915e07c3
Changes
64
Expand all
Hide whitespace changes
Inline
Sidebyside
libraries/base/tests/Memo1.lhs
View file @
5b03dc69
...
...
@@ 7,16 +7,16 @@
\begin{code}
module Memo1
( memo
 :: (a > b) > a > b
, memoSized
 :: Int > (a > b) > a > b
)
where
import System.Mem.StableName
( StableName, makeStableName, hashStableName )
import System.Mem.Weak
( Weak, mkWeakPtr, mkWeak, deRefWeak, finalize )
import Data.Array.IO
( IOArray, newArray, readArray, writeArray )
import System.IO.Unsafe
( unsafePerformIO )
import Control.Concurrent.MVar
( MVar, newMVar, putMVar, takeMVar )
( memo
 :: (a > b) > a > b
, memoSized
 :: Int > (a > b) > a > b
)
where
import System.Mem.StableName
( StableName, makeStableName, hashStableName )
import System.Mem.Weak
( Weak, mkWeakPtr, mkWeak, deRefWeak, finalize )
import Data.Array.IO
( IOArray, newArray, readArray, writeArray )
import System.IO.Unsafe
( unsafePerformIO )
import Control.Concurrent.MVar
( MVar, newMVar, putMVar, takeMVar )
\end{code}

...
...
@@ 40,10 +40,10 @@ the documentation).
\begin{code}
type MemoTable key val
= MVar (
Int,
 current table size
IOArray Int [MemoEntry key val]  hash table
)
= MVar (
Int,
 current table size
IOArray Int [MemoEntry key val]  hash table
)
 a memo table entry: compile with funboxstrictfields to eliminate
 the boxes around the StableName and Weak fields.
...
...
@@ 76,19 +76,19 @@ strict = ($!)
lazyMemoSized :: Int > (a > b) > a > b
lazyMemoSized size f =
let (table,weak) = unsafePerformIO (
do { tbl < newArray (0,size) []
; mvar < newMVar (size,tbl)
; weak < mkWeakPtr mvar (Just (table_finalizer tbl size))
; return (mvar,weak)
})
do { tbl < newArray (0,size) []
; mvar < newMVar (size,tbl)
; weak < mkWeakPtr mvar (Just (table_finalizer tbl size))
; return (mvar,weak)
})
in memo' f table weak
table_finalizer :: IOArray Int [MemoEntry key val] > Int > IO ()
table_finalizer table size =
table_finalizer table size =
sequence_ [ finalizeBucket i  i < [0..size] ]
where
finalizeBucket i = do
bucket < readArray table i
bucket < readArray table i
sequence_ [ finalize w  MemoEntry _ w < bucket ]
memo' :: (a > b) > MemoTable a b > Weak (MemoTable a b) > a > b
...
...
@@ 101,35 +101,35 @@ memo' f ref weak_ref = \k > unsafePerformIO $ do
case lkp of
Just result > do
putMVar ref (size,table)
return result
putMVar ref (size,table)
return result
Nothing > do
let result = f k
weak < mkWeak k result (Just (finalizer hash_key stable_key weak_ref))
writeArray table hash_key (MemoEntry stable_key weak : bucket)
putMVar ref (size,table)
return result
let result = f k
weak < mkWeak k result (Just (finalizer hash_key stable_key weak_ref))
writeArray table hash_key (MemoEntry stable_key weak : bucket)
putMVar ref (size,table)
return result
finalizer :: Int > StableName a > Weak (MemoTable a b) > IO ()
finalizer hash_key stable_key weak_ref =
do r < deRefWeak weak_ref
finalizer hash_key stable_key weak_ref =
do r < deRefWeak weak_ref
case r of
Nothing > return ()
Just mvar > do
(size,table) < takeMVar mvar
bucket < readArray table hash_key
let new_bucket = [ e  e@(MemoEntry sn weak) < bucket,
sn /= stable_key ]
writeArray table hash_key new_bucket
putMVar mvar (size,table)
Nothing > return ()
Just mvar > do
(size,table) < takeMVar mvar
bucket < readArray table hash_key
let new_bucket = [ e  e@(MemoEntry sn weak) < bucket,
sn /= stable_key ]
writeArray table hash_key new_bucket
putMVar mvar (size,table)
lookupSN :: StableName key > [MemoEntry key val] > IO (Maybe val)
lookupSN sn [] = sn `seq` return Nothing  make it strict in sn
lookupSN sn (MemoEntry sn' weak : xs)
 sn == sn' = do maybe_item < deRefWeak weak
case maybe_item of
Nothing > error ("dead weak pair: " ++
show (hashStableName sn))
Just v > return (Just v)
case maybe_item of
Nothing > error ("dead weak pair: " ++
show (hashStableName sn))
Just v > return (Just v)
 otherwise = lookupSN sn xs
\end{code}
libraries/base/tests/Memo2.lhs
View file @
5b03dc69
...
...
@@ 7,16 +7,16 @@
\begin{code}
module Memo2
( memo
 :: (a > b) > a > b
, memoSized
 :: Int > (a > b) > a > b
)
where
import System.Mem.StableName
( StableName, makeStableName, hashStableName )
import System.Mem.Weak
( Weak, mkWeakPtr, mkWeak, deRefWeak, finalize )
import Data.Array.IO
( IOArray, newArray, readArray, writeArray )
import System.IO.Unsafe
( unsafePerformIO )
import Control.Concurrent.MVar
( MVar, newMVar, putMVar, takeMVar )
( memo
 :: (a > b) > a > b
, memoSized
 :: Int > (a > b) > a > b
)
where
import System.Mem.StableName
( StableName, makeStableName, hashStableName )
import System.Mem.Weak
( Weak, mkWeakPtr, mkWeak, deRefWeak, finalize )
import Data.Array.IO
( IOArray, newArray, readArray, writeArray )
import System.IO.Unsafe
( unsafePerformIO )
import Control.Concurrent.MVar
( MVar, newMVar, putMVar, takeMVar )
\end{code}

...
...
@@ 40,10 +40,10 @@ the documentation).
\begin{code}
type MemoTable key val
= MVar (
Int,
 current table size
IOArray Int [MemoEntry key val]  hash table
)
= MVar (
Int,
 current table size
IOArray Int [MemoEntry key val]  hash table
)
 a memo table entry: compile with funboxstrictfields to eliminate
 the boxes around the StableName and Weak fields.
...
...
@@ 76,19 +76,19 @@ strict = ($!)
lazyMemoSized :: Int > (a > b) > a > b
lazyMemoSized size f =
let (table,weak) = unsafePerformIO (
do { tbl < newArray (0,size) []
; mvar < newMVar (size,tbl)
; weak < mkWeakPtr mvar (Just (table_finalizer tbl size))
; return (mvar,weak)
})
do { tbl < newArray (0,size) []
; mvar < newMVar (size,tbl)
; weak < mkWeakPtr mvar (Just (table_finalizer tbl size))
; return (mvar,weak)
})
in memo' f table weak
table_finalizer :: IOArray Int [MemoEntry key val] > Int > IO ()
table_finalizer table size =
table_finalizer table size =
sequence_ [ finalizeBucket i  i < [0..size] ]
where
finalizeBucket i = do
bucket < readArray table i
bucket < readArray table i
sequence_ [ finalize w  MemoEntry _ w < bucket ]
memo' :: (a > b) > MemoTable a b > Weak (MemoTable a b) > a > b
...
...
@@ 101,35 +101,35 @@ memo' f ref weak_ref = \k > unsafePerformIO $ do
case lkp of
Just result > do
putMVar ref (size,table)
return result
putMVar ref (size,table)
return result
Nothing > do
let result = f k
weak < mkWeak k result (Just (finalizer hash_key stable_key weak_ref))
writeArray table hash_key (MemoEntry stable_key weak : bucket)
putMVar ref (size,table)
return result
let result = f k
weak < mkWeak k result (Just (finalizer hash_key stable_key weak_ref))
writeArray table hash_key (MemoEntry stable_key weak : bucket)
putMVar ref (size,table)
return result
finalizer :: Int > StableName a > Weak (MemoTable a b) > IO ()
finalizer hash_key stable_key weak_ref =
do r < deRefWeak weak_ref
finalizer hash_key stable_key weak_ref =
do r < deRefWeak weak_ref
case r of
Nothing > return ()
Just mvar > do
(size,table) < takeMVar mvar
bucket < readArray table hash_key
let new_bucket = [ e  e@(MemoEntry sn weak) < bucket,
sn /= stable_key ]
writeArray table hash_key new_bucket
putMVar mvar (size,table)
Nothing > return ()
Just mvar > do
(size,table) < takeMVar mvar
bucket < readArray table hash_key
let new_bucket = [ e  e@(MemoEntry sn weak) < bucket,
sn /= stable_key ]
writeArray table hash_key new_bucket
putMVar mvar (size,table)
lookupSN :: StableName key > [MemoEntry key val] > IO (Maybe val)
lookupSN sn [] = sn `seq` return Nothing  make it strict in sn
lookupSN sn (MemoEntry sn' weak : xs)
 sn == sn' = do maybe_item < deRefWeak weak
case maybe_item of
Nothing > error ("dead weak pair: " ++
show (hashStableName sn))
Just v > return (Just v)
case maybe_item of
Nothing > error ("dead weak pair: " ++
show (hashStableName sn))
Just v > return (Just v)
 otherwise = lookupSN sn xs
\end{code}
testsuite/tests/concurrent/prog001/Arithmetic.hs
View file @
5b03dc69
...
...
@@ 41,114 +41,114 @@ 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
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
)
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
)
...
...
@@ 180,51 +180,51 @@ 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
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
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
)
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
))
c
<
unsafeInterleaveIO
(
addition
(
1
:
1
:
z0
)
(
1
:
1
:
z0
))
putStrLn
(
show
(
take
30
c
))
z0
=
(
0
:
z0
)
z1
=
(
1
:
z1
)
...
...
testsuite/tests/concurrent/prog001/Converter.hs
View file @
5b03dc69
...
...
@@ 15,92 +15,92 @@ 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
)

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

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
)

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
)

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
)