T3307 and environment001 just fail on MSYS
[packages/base.git] / tests / Memo2.lhs
1 % $Id: Memo.lhs,v 1.1 2005/12/16 10:46:05 simonmar Exp $
2 %
3 % (c) The GHC Team, 1999
4 %
5 % Hashing memo tables.
6
7 \begin{code}
8 {-# LANGUAGE CPP #-}
9
10 module Memo2
11         {-# DEPRECATED "This module is unmaintained, and will disappear soon" #-}
12 #ifndef __PARALLEL_HASKELL__
13         ( memo          -- :: (a -> b) -> a -> b
14         , memoSized     -- :: Int -> (a -> b) -> a -> b
15         ) 
16 #endif
17         where
18
19 #ifndef __PARALLEL_HASKELL__
20
21 import System.Mem.StableName    ( StableName, makeStableName, hashStableName )
22 import System.Mem.Weak          ( Weak, mkWeakPtr, mkWeak, deRefWeak, finalize )
23 import Data.Array.IO            ( IOArray, newArray, readArray, writeArray )
24 import System.IO.Unsafe         ( unsafePerformIO )
25 import Control.Concurrent.MVar  ( MVar, newMVar, putMVar, takeMVar )
26 \end{code}
27
28 -----------------------------------------------------------------------------
29 Memo table representation.
30
31 The representation is this: a fixed-size hash table where each bucket
32 is a list of table entries, of the form (key,value).
33
34 The key in this case is (StableName key), and we use hashStableName to
35 hash it.
36
37 It's important that we can garbage collect old entries in the table
38 when the key is no longer reachable in the heap.  Hence the value part
39 of each table entry is (Weak val), where the weak pointer "key" is the
40 key for our memo table, and 'val' is the value of this memo table
41 entry.  When the key becomes unreachable, a finalizer will fire and
42 remove this entry from the hash bucket, and further attempts to
43 dereference the weak pointer will return Nothing.  References from
44 'val' to the key are ignored (see the semantics of weak pointers in
45 the documentation).
46
47 \begin{code}
48 type MemoTable key val
49         = MVar (
50             Int,        -- current table size
51             IOArray Int [MemoEntry key val]   -- hash table
52            )
53
54 -- a memo table entry: compile with -funbox-strict-fields to eliminate
55 -- the boxes around the StableName and Weak fields.
56 data MemoEntry key val = MemoEntry !(StableName key) !(Weak val)
57 \end{code}
58
59 We use an MVar to the hash table, so that several threads may safely
60 access it concurrently.  This includes the finalization threads that
61 remove entries from the table.
62
63 ToDo: Can efficiency be improved at all?
64
65 \begin{code}
66 memo :: (a -> b) -> a -> b
67 memo f = memoSized default_table_size f
68
69 default_table_size = 1001
70
71 -- Our memo functions are *strict*.  Lazy memo functions tend to be
72 -- less useful because it is less likely you'll get a memo table hit
73 -- for a thunk.  This change was made to match Hugs's Memo
74 -- implementation, and as the result of feedback from Conal Elliot
75 -- <conal@microsoft.com>.
76
77 memoSized :: Int -> (a -> b) -> a -> b
78 memoSized size f = strict (lazyMemoSized size f)
79
80 strict = ($!)
81
82 lazyMemoSized :: Int -> (a -> b) -> a -> b
83 lazyMemoSized size f =
84    let (table,weak) = unsafePerformIO (
85                 do { tbl <- newArray (0,size) []
86                    ; mvar <- newMVar (size,tbl)
87                    ; weak <- mkWeakPtr mvar (Just (table_finalizer tbl size))
88                    ; return (mvar,weak)
89                    })
90    in  memo' f table weak
91
92 table_finalizer :: IOArray Int [MemoEntry key val] -> Int -> IO ()
93 table_finalizer table size = 
94    sequence_ [ finalizeBucket i | i <- [0..size] ]
95  where
96    finalizeBucket i = do
97       bucket <- readArray table i 
98       sequence_ [ finalize w | MemoEntry _ w <- bucket ]
99
100 memo' :: (a -> b) -> MemoTable a b -> Weak (MemoTable a b) -> a -> b
101 memo' f ref weak_ref = \k -> unsafePerformIO $ do
102    stable_key <- makeStableName k
103    (size, table) <- takeMVar ref
104    let hash_key = hashStableName stable_key `mod` size
105    bucket <- readArray table hash_key
106    lkp <- lookupSN stable_key bucket
107
108    case lkp of
109      Just result -> do
110         putMVar ref (size,table)
111         return result
112      Nothing -> do
113         let result = f k
114         weak <- mkWeak k result (Just (finalizer hash_key stable_key weak_ref))
115         writeArray table hash_key (MemoEntry stable_key weak : bucket)
116         putMVar ref (size,table)
117         return result
118
119 finalizer :: Int -> StableName a -> Weak (MemoTable a b) -> IO ()
120 finalizer hash_key stable_key weak_ref = 
121   do r <- deRefWeak weak_ref 
122      case r of
123         Nothing -> return ()
124         Just mvar -> do
125                 (size,table) <- takeMVar mvar
126                 bucket <- readArray table hash_key
127                 let new_bucket = [ e | e@(MemoEntry sn weak) <- bucket, 
128                                        sn /= stable_key ]
129                 writeArray table hash_key new_bucket
130                 putMVar mvar (size,table)
131
132 lookupSN :: StableName key -> [MemoEntry key val] -> IO (Maybe val)
133 lookupSN sn [] = sn `seq` return Nothing -- make it strict in sn
134 lookupSN sn (MemoEntry sn' weak : xs)
135    | sn == sn'  = do maybe_item <- deRefWeak weak
136                      case maybe_item of
137                         Nothing -> error ("dead weak pair: " ++ 
138                                                 show (hashStableName sn))
139                         Just v  -> return (Just v)
140    | otherwise  = lookupSN sn xs
141 #endif
142 \end{code}