[project @ 1999-02-03 16:54:00 by simonm]

Add memo table library.

diff --git a/ghc/lib/Makefile b/ghc/lib/Makefile
index 24605ce..0dfe5f2 100644 (file)
--- a/ghc/lib/Makefile
+++ b/ghc/lib/Makefile
@@ -15,7 +15,7 @@ include $(TOP)/mk/boilerplate.mk
 ifeq "$(GhcWithHscBuiltViaC)" "YES"
 SUBDIRS = std exts
 else
-SUBDIRS = std exts misc posix concurrent
+SUBDIRS = std exts concurrent misc posix
 endif
 
 include $(TOP)/mk/target.mk

diff --git a/ghc/lib/misc/Makefile b/ghc/lib/misc/Makefile
index 5695860..2483768 100644 (file)
--- a/ghc/lib/misc/Makefile
+++ b/ghc/lib/misc/Makefile
@@ -1,4 +1,4 @@
-# $Id: Makefile,v 1.10 1998/12/02 13:26:38 simonm Exp $
+# $Id: Makefile,v 1.11 1999/02/03 16:54:01 simonm Exp $
 #
 # Makefile for miscellaneous libraries.
 #
@@ -37,7 +37,7 @@ SRC_MKDEPENDHS_OPTS += -optdep--include-prelude
 #-----------------------------------------------------------------------------
 #      Setting the GHC compile options
 
-SRC_HC_OPTS += -recomp -cpp -fglasgow-exts -fvia-C -Rghc-timing $(GhcLibHcOpts)
+SRC_HC_OPTS += -i../concurrent -recomp -cpp -fglasgow-exts -fvia-C -Rghc-timing $(GhcLibHcOpts)
 
 #
 # Profiling options

diff --git a/ghc/lib/misc/Memo.lhs b/ghc/lib/misc/Memo.lhs
new file mode 100644 (file)
index 0000000..272f88c
--- /dev/null
+++ b/ghc/lib/misc/Memo.lhs
@@ -0,0 +1,110 @@
+% $Id: Memo.lhs,v 1.1 1999/02/03 16:54:02 simonm Exp $
+%
+% (c) The GHC Team, 1999
+%
+% Hashing memo tables.
+
+\begin{code}
+{-# OPTIONS -fglasgow-exts #-}
+
+module Memo
+       ( memo          -- :: (a -> b) -> a -> b
+       , memo_sized    -- :: Int -> (a -> b) -> a -> b
+       ) where
+
+import Stable
+import Weak
+import IO
+import IOExts
+import Concurrent
+\end{code}
+
+-----------------------------------------------------------------------------
+Memo table representation.
+
+The representation is this: a fixed-size hash table where each bucket
+is a list of table entries, of the form (key,value).
+
+The key in this case is (StableName key), and we use hashStableName to
+hash it.
+
+It's important that we can garbage collect old entries in the table
+when the key is no longer reachable in the heap.  Hence the value part
+of each table entry is (Weak val), where the weak pointer "key" is the
+key for our memo table, and 'val' is the value of this memo table
+entry.  When the key becomes unreachable, a finaliser will fire and
+remove this entry from the hash bucket, and further attempts to
+dereference the weak pointer will return Nothing.  References from
+'val' to the key are ignored (see the semantics of weak pointers in
+the documentation).
+
+\begin{code}
+type MemoTable key val
+       = MVar (
+           Int,        -- current table size
+           IOArray Int [(StableName key, Weak val)]   -- hash table
+          )
+\end{code}
+
+We use an MVar to the hash table, so that several threads may safely
+access it concurrently.  This includes the finalisation threads that
+remove entries from the table.
+
+ToDo: make the finalisers refer to the memo table only through a weak
+pointer, because otherwise the memo table will keep itself alive
+(i.e. even after the function is dead, the weak pointers in the memo
+table stay alive because their keys are alive, and hence the values
+and finalisers are alive, therefore the table itself stays alive.
+Bad).
+
+\begin{code}
+memo :: (a -> b) -> a -> b
+memo f = memo_sized default_table_size f
+
+default_table_size = 1001
+
+memo_sized :: Int -> (a -> b) -> a -> b
+memo_sized size f =
+   let table = unsafePerformIO (do
+                 tbl <- newIOArray (0,1001) []; 
+                 newMVar (size,tbl))
+   in  memo' f table
+
+memo' :: (a -> b) -> MemoTable a b -> a -> b
+memo' f ref = \x -> unsafePerformIO $ do
+   stable_key <- makeStableName x
+   (size, table) <- takeMVar ref
+   let hash_key = hashStableName stable_key `mod` size
+   bucket <- readIOArray table hash_key
+   lkp <- lookupSN stable_key bucket
+
+   case lkp of
+       Just result -> do
+               putMVar ref (size,table)
+               return result
+       Nothing -> do
+               let result = f x
+               weak <- mkWeak x result finaliser
+               writeIOArray table hash_key ((stable_key,weak):bucket)
+               putMVar ref (size,table)
+               return result
+
+           where finaliser = do
+                       (size,table) <- takeMVar ref
+                       bucket <- readIOArray table hash_key
+                       let new_bucket = [ (sn,weak) 
+                                        | (sn,weak) <- bucket, 
+                                          sn /= stable_key ]
+                       writeIOArray table hash_key new_bucket
+                       putMVar ref (size,table)
+
+lookupSN :: StableName key -> [(StableName key, Weak val)] -> IO (Maybe val)
+lookupSN sn [] = return Nothing
+lookupSN sn ((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)
+   | otherwise  = lookupSN sn xs
+\end{code}