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

Add memo table library.

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

ghc/lib/misc/Makefile

-# $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

ghc/lib/misc/Memo.lhs

+% $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}