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