ghc/interpreter/test/unused/ptrEq.hs

   1 foo :: Float -> Float
   2 foo = cache sin
   3
   4 -- A lazy cache.
   5 -- Uses pointer equality (which is not referentially transparent)
   6 -- in a referentially transparent way to allow the test to be:
   7 -- 1) Fully polymorphic (no Eq context)
   8 -- 2) Safe (no assumption that Eq is correct)
   9 -- 3) Lazy -- no need to evaluate the entire argument.
  10 -- Unlike John Hughes' lazy memo functions, there's no assistance
  11 -- from the garbage collector to delete entries which can never be
  12 -- used in the future.
  13
  14 cache :: (a -> b) -> (a -> b)
  15 cache f = \x -> unsafePerformIO (f' x)
  16  where
  17   ref  = unsafePerformIO (newRef (error "cache", error "cache"))
  18   f' x = derefRef ref >>= \ (x',a) ->
  19          if x `primPtrEq` x' then
  20            hit >>
  21            return a
  22          else
  23            miss                 >>
  24            let a = f x in
  25            assignRef ref (x, a) >>
  26            return a
  27
  28 primitive primPtrEq "primPtrEq" :: a -> a -> Bool
  29
  30
  31 -- Hooks for recording cache hits and misses
  32 {-
  33 hit  = return ()
  34 miss = return ()
  35 -}
  36
  37 hit  = putStrLn "hit"
  38 miss = putStrLn "miss"
  39
  40 {-
  41 hitRef, missRef :: Ref Int
  42 hitRef  = unsafePerformIO (newRef 0)
  43 missRef = unsafePerformIO (newRef 0)
  44 hit  = derefRef hitRef  >>= \ x -> assignRef hitRef (x+1)
  45 miss = derefRef missRef >>= \ x -> assignRef missRef (x+1)
  46
  47 report =
  48   derefRef hitRef  >>= \ hits ->
  49   derefRef missRef >>= \ misses ->
  50   putStrLn ("Cache hits: " ++ show hits ++ "; cache misses: " ++ show misses)
  51 -}
  52
  53