home *** CD-ROM | disk | FTP | other *** search
/ PSION CD 2 / PsionCDVol2.iso / Programs / 876 / hugs.sis / Memo.hs < prev    next >
Encoding:
Text File  |  2000-09-21  |  4.7 KB  |  154 lines
  1. {-----------------------------------------------------------------------------
  2.  
  3.                    A LIBRARY OF MEMOIZATION COMBINATORS
  4.  
  5.                             15th September 1999
  6.  
  7.                              Byron Cook
  8.                         OGI
  9.  
  10. This Hugs module implements several flavors of memoization functions,
  11. as described in Haskell Workshop 1997.
  12. -----------------------------------------------------------------------------}
  13.  
  14. module Memo(
  15.         memo,  
  16.         memoN,  
  17.         memoFix,
  18.         memoFixN,
  19.         cache, 
  20.         cacheN, 
  21.         cacheFix,
  22.         cacheFixN
  23.         ) where
  24.  
  25. import ST
  26. -- import IOExts (unsafePtrEq, trace)
  27.  
  28. memo      :: (a -> b) -> (a -> b)
  29. memoN     :: Int -> (a -> b) -> (a -> b)
  30. memoFix   :: ((a -> b) -> (a -> b)) -> (a -> b)
  31. memoFixN  :: Int -> ((a -> b) -> (a -> b)) -> (a -> b)
  32. cache     :: (a -> b) -> (a -> b)
  33. cacheN    :: Int -> (a -> b) -> (a -> b)
  34. cacheFix  :: ((a -> b) -> (a -> b)) -> (a -> b)
  35. cacheFixN :: Int -> ((a -> b) -> (a -> b)) -> (a -> b)
  36.  
  37. ----------------------------------------------------------------
  38. -- Memoization Functions (memo-tables are hash-tables)
  39. ----------------------------------------------------------------
  40. memo          = memoN defaultSize 
  41. memoN         = mkMemo eql hash 
  42.  
  43. memoFix       = memoFixN defaultSize 
  44. memoFixN n f  = let g = f h
  45.                     h = memoN n g
  46.                 in g
  47.  
  48. ----------------------------------------------------------------
  49. -- Caching Functions (memo-tables are caches)
  50. ----------------------------------------------------------------
  51. cache          = cacheN defaultSize
  52. cacheN         = mkCache eql hash
  53. cacheFix       = cacheFixN defaultSize
  54. cacheFixN n f  = let g = f h
  55.                      h = cacheN n g
  56.                  in g
  57.  
  58. ----------------------------------------------------------------
  59. -- Type synonyms
  60. ----------------------------------------------------------------
  61. type TaintedEq a   = a -> a -> ST Mem Bool
  62. type HashTable a b = STArray Mem Int [(a,b)]
  63. type Cache a b     = STArray Mem Int (Maybe (a,b))
  64. type HashSize      = Int
  65. type HashFunc a    = a -> ST Mem Int
  66. type Mem           = ()
  67.  
  68.  
  69. ----------------------------------------------------------------
  70. -- Foundation functions
  71. ----------------------------------------------------------------
  72. defaultSize :: HashSize
  73. defaultSize = 40
  74.  
  75. memoize :: ST Mem t -> (t -> a -> b -> ST Mem b) -> 
  76.            (a -> b) -> a -> b
  77. memoize new access f = {-trace "memoize" $-} unsafeST $ do 
  78.   t <- new
  79.   return (\x -> unsafeST $ access t x (f x))
  80.  
  81.  
  82. mkMemo  :: TaintedEq a -> HashFunc a -> Int -> (a -> c) -> (a -> c)
  83. mkCache :: TaintedEq a -> HashFunc a -> Int -> (a -> c) -> (a -> c)
  84.  
  85. mkCache e h sz = memoize (newCache sz) (accessCache e h sz)
  86. mkMemo  e h sz = memoize (newHash sz)  (accessHash e  h sz)
  87.  
  88.  
  89. ----------------------------------------------------------------
  90. -- Hash and Cache Tables
  91. ----------------------------------------------------------------
  92. accessHash  :: TaintedEq a ->  
  93.                HashFunc a -> 
  94.                Int -> 
  95.                HashTable a b -> 
  96.                a -> b -> ST Mem b
  97.  
  98. accessHash equal h sz table x v = do 
  99.   hv' <- h x
  100.   let hv = hv' `mod` sz
  101.   l <- readSTArray table hv
  102.   find l l hv
  103.  where find l [] hv = {-trace "miss " $-} do
  104.          u <- writeSTArray table  hv ((x,v):l) 
  105.          case u of {() -> return v}
  106.        find l ((x',v'):xs) hv = do
  107.          a <- equal x x'
  108.          if a then {-trace "hit "-} (return $ v')
  109.           else find l xs hv
  110.  
  111. newHash :: Int -> ST Mem (HashTable a b)
  112. newHash n = newSTArray (0,n) []
  113.  
  114.  
  115. accessCache  :: TaintedEq a ->
  116.                 HashFunc a ->
  117.                 Int ->
  118.                 Cache a b ->
  119.                 a -> b -> ST Mem b
  120.  
  121. accessCache equal h sz table x v = do 
  122.   hv' <- h x 
  123.   let hv = hv' `mod` sz 
  124.   l <-  readSTArray table hv
  125.   case l of
  126.      Nothing      -> do u <- writeSTArray table hv (Just (x,v))
  127.                         case u of {() -> return v}
  128.      Just (x',y)  -> do e <- equal x' x
  129.                         if e then return y
  130.                          else do u <- writeSTArray table hv (Just (x,v))
  131.                                  case u of {() -> return v}
  132.  
  133. newCache :: Int -> ST Mem (Cache a b)
  134. newCache n = newSTArray (0,n) Nothing
  135.  
  136. ------------------------------------------------------------------
  137. -- These functions are bad --- dont pay attention to them
  138. primitive primUnsafeCoerce "primUnsafeCoerce" :: a -> b  
  139.  
  140. unsafeST :: ST s a -> a
  141. unsafeST m = fst (reifyST m ())
  142.  
  143. reifyST :: ST s a -> (b -> (a,b))
  144. reifyST = primUnsafeCoerce
  145.  
  146. -- lisp style eql --- as described in "Lazy-memo functions"
  147. primitive eql "STEql" :: a -> a -> ST Mem Bool
  148. -- a `eql` b = return (a `unsafePtrEq` b)
  149.  
  150. -- hash based on addresses (or values if the arg is a base type)
  151. primitive hash "STHash" :: a -> ST Mem Int
  152.  
  153. ------------------------------------------------------------------
  154.