packages feed

stable-memo 0.1.3 → 0.2.0

raw patch · 4 files changed

+77/−34 lines, 4 filesdep +ghc-prim

Dependencies added: ghc-prim

Files

Data/StableMemo.hs view
@@ -1,26 +1,24 @@ {-# LANGUAGE BangPatterns #-}-module Data.StableMemo (memo, memo2, memo3) where+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE TypeOperators #-}+module Data.StableMemo (memo, memo2, memo3, (-->) (), memoPoly) where +import Control.Applicative import Data.Proxy -import System.Mem.Weak (Weak)- import qualified Data.StableMemo.Internal as Internal-import qualified System.Mem.Weak as Weak -data Strong a = Strong a !(Weak a)+import Data.StableMemo.Internal ((-->) ()) -instance Internal.Ref Strong where-  mkRef _ y final = do-    weak <- Weak.mkWeakPtr y $ Just final-    return $ Strong y weak-  deRef (Strong x _) = return $ Just x-  finalize (Strong _ weak) = Weak.finalize weak+-- | Memoize a function with support for a certain form of polymorphic+-- recursion.+memoPoly :: (f --> g) -> (f --> g)+{-# NOINLINE memoPoly #-}+memoPoly = Internal.memo (Proxy :: Proxy Internal.Strong)  -- | Memoize a unary function. memo :: (a -> b) -> (a -> b)-{-# NOINLINE memo #-}-memo = Internal.memo (Proxy :: Proxy Strong)+memo f = getConst . memoPoly (Const . f . getConst) . Const  -- | Curried memoization to share partial evaluation memo2 :: (a -> b -> c) -> (a -> b -> c)
Data/StableMemo/Internal.hs view
@@ -1,20 +1,29 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE KindSignatures #-}-module Data.StableMemo.Internal (Ref (..), memo) where+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE TypeOperators #-}+module Data.StableMemo.Internal (Ref (..), Strong (..), (-->) (), memo) where  import Data.Proxy import System.Mem.StableName  import Data.HashTable.IO (BasicHashTable)+import GHC.Prim (Any) import System.IO.Unsafe (unsafePerformIO) import System.Mem.Weak (Weak)+import Unsafe.Coerce (unsafeCoerce)  import qualified Data.HashTable.IO as HashTable import qualified System.Mem.Weak as Weak -type SNMap a b = BasicHashTable (StableName a) b-type MemoTable ref a b = SNMap a (ref b)+newtype (f <<< g) a = O { unO :: f (g a) } +-- Invariant: The type parameters for a key and its corresponding+-- value are the same.+type SNMap f g = BasicHashTable (StableName (f Any)) (g Any)++type MemoTable ref f g = SNMap f (ref <<< g)+ class Ref ref where   mkRef    :: a -> b -> IO () -> IO (ref b)   deRef    :: ref a -> IO (Maybe a)@@ -25,34 +34,54 @@   deRef = Weak.deRefWeak   finalize = Weak.finalize -finalizer :: StableName a -> Weak (MemoTable ref a b) -> IO ()+data Strong a = Strong a !(Weak a)++instance Ref Strong where+  mkRef _ y final = do+    weak <- Weak.mkWeakPtr y $ Just final+    return $ Strong y weak+  deRef (Strong x _) = return $ Just x+  finalize (Strong _ weak) = Weak.finalize weak++finalizer :: StableName (f Any) -> Weak (MemoTable ref f g) -> IO () finalizer sn weakTbl = do   r <- Weak.deRefWeak weakTbl   case r of     Nothing -> return ()     Just tbl -> HashTable.delete tbl sn -memo' :: Ref ref => Proxy ref -> (a -> b) -> MemoTable ref a b -> Weak (MemoTable ref a b) -> (a -> b)+unsafeToAny :: f a -> f Any+unsafeToAny = unsafeCoerce++unsafeFromAny :: f Any -> f a+unsafeFromAny = unsafeCoerce++-- | Polymorphic memoizable function+type f --> g = forall a. f a -> g a++memo' :: Ref ref =>+         Proxy ref -> (f --> g) -> MemoTable ref f g ->+         Weak (MemoTable ref f g) -> (f --> g) memo' _ f tbl weakTbl !x = unsafePerformIO $ do-  sn <- makeStableName x+  sn <- makeStableName $ unsafeToAny x   lkp <- HashTable.lookup tbl sn   case lkp of     Nothing -> notFound sn-    Just w -> do+    Just (O w) -> do       maybeVal <- deRef w       case maybeVal of         Nothing -> notFound sn-        Just val -> return val+        Just val -> return $ unsafeFromAny val   where notFound sn = do           let y = f x-          weak <- mkRef x y $ finalizer sn weakTbl-          HashTable.insert tbl sn weak+          weak <- mkRef x (unsafeToAny y) $ finalizer sn weakTbl+          HashTable.insert tbl sn $ O weak           return y -tableFinalizer :: Ref ref => MemoTable ref a b -> IO ()-tableFinalizer = HashTable.mapM_ $ finalize . snd+tableFinalizer :: Ref ref => MemoTable ref f g -> IO ()+tableFinalizer = HashTable.mapM_ $ finalize . unO . snd -memo :: Ref ref => Proxy (ref :: * -> *) -> (a -> b) -> (a -> b)+memo :: Ref ref => Proxy (ref :: * -> *) -> (f --> g) -> (f --> g) memo p f =   let (tbl, weak) = unsafePerformIO $ do         tbl' <- HashTable.new
Data/StableMemo/Weak.hs view
@@ -10,18 +10,28 @@ -}  {-# LANGUAGE BangPatterns #-}-module Data.StableMemo.Weak (memo, memo2, memo3) where+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE TypeOperators #-}+module Data.StableMemo.Weak (memo, memo2, memo3, (-->) (), memoPoly) where +import Control.Applicative import Data.Proxy  import System.Mem.Weak (Weak)  import qualified Data.StableMemo.Internal as Internal +import Data.StableMemo.Internal ((-->) ())++-- | Memoize a function with support for a certain form of polymorphic+-- recursion.+memoPoly :: (f --> g) -> (f --> g)+{-# NOINLINE memoPoly #-}+memoPoly = Internal.memo (Proxy :: Proxy Weak)+ -- | Memoize a unary function. memo :: (a -> b) -> (a -> b)-{-# NOINLINE memo #-}-memo = Internal.memo (Proxy :: Proxy Weak)+memo f = getConst . memoPoly (Const . f . getConst) . Const  -- | Curried memoization to share partial evaluation memo2 :: (a -> b -> c) -> (a -> b -> c)
stable-memo.cabal view
@@ -1,5 +1,5 @@ name:                stable-memo-version:             0.1.3+version:             0.2.0 synopsis:            Memoization based on argument identity license:             MIT license-file:        LICENSE@@ -41,7 +41,7 @@   stable-memo will not work for arguments which happen to have the   same value but are not the same heap object. This rules out many   candidates for memoization, such as the most common example, the-  naive Fibonacci implementation whose domain is strict Ints; it can+  naive Fibonacci implementation whose domain is machine Ints; it can   still be made to work for some domains, though, such as the lazy   naturals. @@ -79,10 +79,16 @@   (<http://community.haskell.org/~simonmar/papers/weak.pdf>).  library-  build-depends:       base >=4.6 && <5, hashtables ==1.0.*, tagged ==0.4.*+  build-depends:       base >=4.6 && <5,+                       hashtables ==1.0.*,+                       tagged ==0.4.*,+                       ghc-prim >=0.3 && < 0.4   default-language:    Haskell2010   exposed-modules:     Data.StableMemo, Data.StableMemo.Weak-  other-extensions:    BangPatterns+  other-extensions:    BangPatterns,+                       KindSignatures,+                       Rank2Types,+                       TypeOperators   other-modules:       Data.StableMemo.Internal  source-repository head@@ -92,4 +98,4 @@ source-repository this   type:     darcs   location: http://patch-tag.com/r/jmcarthur/stable-memo-  tag:      v0.1.3+  tag:      v0.2.0