ghc/lib/misc/Memo.lhs

   1 % $Id: Memo.lhs,v 1.1 1999/02/03 16:54:02 simonm Exp $
   2 %
   3 % (c) The GHC Team, 1999
   4 %
   5 % Hashing memo tables.
   6
   7 \begin{code}
   8 {-# OPTIONS -fglasgow-exts #-}
   9
  10 module Memo
  11         ( memo          -- :: (a -> b) -> a -> b
  12         , memo_sized    -- :: Int -> (a -> b) -> a -> b
  13         ) where
  14
  15 import Stable
  16 import Weak
  17 import IO
  18 import IOExts
  19 import Concurrent
  20 \end{code}
  21
  22 -----------------------------------------------------------------------------
  23 Memo table representation.
  24
  25 The representation is this: a fixed-size hash table where each bucket
  26 is a list of table entries, of the form (key,value).
  27
  28 The key in this case is (StableName key), and we use hashStableName to
  29 hash it.
  30
  31 It's important that we can garbage collect old entries in the table
  32 when the key is no longer reachable in the heap.  Hence the value part
  33 of each table entry is (Weak val), where the weak pointer "key" is the
  34 key for our memo table, and 'val' is the value of this memo table
  35 entry.  When the key becomes unreachable, a finaliser will fire and
  36 remove this entry from the hash bucket, and further attempts to
  37 dereference the weak pointer will return Nothing.  References from
  38 'val' to the key are ignored (see the semantics of weak pointers in
  39 the documentation).
  40
  41 \begin{code}
  42 type MemoTable key val
  43         = MVar (
  44             Int,        -- current table size
  45             IOArray Int [(StableName key, Weak val)]   -- hash table
  46            )
  47 \end{code}
  48
  49 We use an MVar to the hash table, so that several threads may safely
  50 access it concurrently.  This includes the finalisation threads that
  51 remove entries from the table.
  52
  53 ToDo: make the finalisers refer to the memo table only through a weak
  54 pointer, because otherwise the memo table will keep itself alive
  55 (i.e. even after the function is dead, the weak pointers in the memo
  56 table stay alive because their keys are alive, and hence the values
  57 and finalisers are alive, therefore the table itself stays alive.
  58 Bad).
  59
  60 \begin{code}
  61 memo :: (a -> b) -> a -> b
  62 memo f = memo_sized default_table_size f
  63
  64 default_table_size = 1001
  65
  66 memo_sized :: Int -> (a -> b) -> a -> b
  67 memo_sized size f =
  68    let table = unsafePerformIO (do
  69                   tbl <- newIOArray (0,1001) [];
  70                   newMVar (size,tbl))
  71    in  memo' f table
  72
  73 memo' :: (a -> b) -> MemoTable a b -> a -> b
  74 memo' f ref = \x -> unsafePerformIO $ do
  75    stable_key <- makeStableName x
  76    (size, table) <- takeMVar ref
  77    let hash_key = hashStableName stable_key `mod` size
  78    bucket <- readIOArray table hash_key
  79    lkp <- lookupSN stable_key bucket
  80
  81    case lkp of
  82         Just result -> do
  83                 putMVar ref (size,table)
  84                 return result
  85         Nothing -> do
  86                 let result = f x
  87                 weak <- mkWeak x result finaliser
  88                 writeIOArray table hash_key ((stable_key,weak):bucket)
  89                 putMVar ref (size,table)
  90                 return result
  91
  92             where finaliser = do
  93                         (size,table) <- takeMVar ref
  94                         bucket <- readIOArray table hash_key
  95                         let new_bucket = [ (sn,weak)
  96                                          | (sn,weak) <- bucket,
  97                                            sn /= stable_key ]
  98                         writeIOArray table hash_key new_bucket
  99                         putMVar ref (size,table)
 100
 101 lookupSN :: StableName key -> [(StableName key, Weak val)] -> IO (Maybe val)
 102 lookupSN sn [] = return Nothing
 103 lookupSN sn ((sn',weak) : xs)
 104    | sn == sn'  = do maybe_item <- deRefWeak weak
 105                      case maybe_item of
 106                         Nothing -> error ("dead weak pair: " ++
 107                                                 show (hashStableName sn))
 108                         Just v  -> return (Just v)
 109    | otherwise  = lookupSN sn xs
 110 \end{code}