Commit 319de0e4 authored by Sven Keidel's avatar Sven Keidel

add mutable caches

parent c6894fe5
Pipeline #30175 passed with stages
in 39 minutes and 28 seconds
......@@ -10,8 +10,11 @@ module Control.Arrow.Primitive where
import Control.Arrow
import Control.Arrow.Trans
import Data.Coerce
import Data.Profunctor
import GHC.Exts
import GHC.ST(ST(..))
class (Arrow c, Profunctor c) => ArrowPrimitive c where
type PrimState c :: *
......@@ -21,3 +24,7 @@ class (Arrow c, Profunctor c) => ArrowPrimitive c where
=> ((# State# (PrimState c), x #) -> (# State# (PrimState c), y #)) -> c x y
primitive f = lift' (primitive f)
{-# INLINE primitive #-}
liftST :: ArrowPrimitive c => (x -> ST (PrimState c) y) -> c x y
liftST f = primitive (\(# s,x #) -> coerce f x s)
{-# INLINE liftST #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE UndecidableInstances #-}
module Control.Arrow.Transformer.Abstract.Fix.Cache.Mutable where
import Prelude hiding ((.))
import Prelude hiding ((.))
import Control.Category
import Control.Arrow
import Control.Arrow.Order
import Control.Arrow.Primitive
import Control.Arrow.Trans
import Control.Arrow.Transformer.Const
import Control.Arrow.Transformer.Abstract.Fix.Cache.Immutable (Widening)
import Control.Category
import Control.Arrow
import Control.Arrow.Fix.Cache as Cache
import Control.Arrow.Order hiding (bottom)
import Control.Arrow.Primitive
import Control.Arrow.Trans
import Control.Arrow.Transformer.Const
import Control.Arrow.Transformer.Abstract.Fix.Cache.Immutable (Widening)
import Data.Coerce
import Data.Order
import Data.Profunctor
import Data.Profunctor.Unsafe
import Data.Abstract.Stable
import qualified Data.Abstract.Widening as W
import Data.Coerce
import Data.Identifiable
import Data.Monoidal
import Data.Order
import Data.Profunctor
import Data.Profunctor.Unsafe
import Data.HashTable (HashTable)
import qualified Data.HashTable as Map
newtype CacheT cache a b c x y = CacheT { unCacheT :: ConstT (Widening (cache c a b), cache c a b) c x y}
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowPrimitive)
......@@ -52,4 +63,77 @@ instance (Profunctor c, ArrowApply c) => ArrowApply (CacheT cache a b c) where
instance ArrowEffectCommutative c => ArrowEffectCommutative (CacheT cache a b c)
newtype Cache c a b = Cache (HashMap a (Stable,b))
class NewCache cache a b where
newCache :: ArrowPrimitive c => c () (cache c a b)
----- Basic Cache -----
newtype Cache c a b = Cache (HashTable (PrimState c) a (Stable,b))
type instance Widening (Cache c a b) = W.Widening b
instance NewCache Cache a b where
newCache = rmap Cache Map.new
instance (Identifiable a, LowerBounded b, ArrowChoice c, ArrowPrimitive c)
=> ArrowCache a b (CacheT Cache a b c) where
initialize = lift $ \(_,Cache cache) -> proc a -> do
(_,b) <- Map.initialize -< (a,(Unstable,bottom),cache)
returnA -< b
lookup = lift $ \(_,Cache cache) -> proc a ->
Map.lookup -< (a,cache)
update = lift $ \(widen,Cache cache) -> proc (a,b) -> do
m <- Map.lookup -< (a,cache)
case m of
Just (Stable,b') ->
returnA -< (Stable,b')
Just (Unstable,b') -> do
let b'' = widen b' b
Map.insert -< (a,b'',cache)
returnA -< b''
Nothing -> do
Map.insert -< (a,(Unstable,b),cache)
returnA -< (Unstable,b)
write = lift $ \(_,Cache cache) -> proc (a,b,s) ->
Map.insert -< (a,(s,b),cache)
setStable = lift $ \(_,Cache cache) -> proc (s,a) ->
Map.update (\_ s m -> (fmap (first (const s)) m,())) -< (a,s,cache)
{-# INLINE initialize #-}
{-# INLINE lookup #-}
{-# INLINE write #-}
{-# INLINE update #-}
{-# INLINE setStable #-}
------ Group Cache ------
data Group cache c a b where
Groups :: HashTable (PrimState c) k (cache c a b) -> Group cache c (k,a) b
type instance Widening (Group cache c (k,a) b) = Widening (cache c a b)
instance NewCache (Group cache) (k,a) b where
newCache = rmap Groups Map.new
instance (Identifiable k, NewCache cache a b, ArrowChoice c, ArrowApply c, ArrowCache a b (CacheT cache a b c), ArrowPrimitive c)
=> ArrowCache (k,a) b (CacheT (Group cache) (k,a) b c) where
initialize = withGroup Cache.initialize
lookup = withGroup Cache.lookup
update = lmap assoc2 (withGroup Cache.update)
write = lmap (\((k,a),b,s) -> (k,(a,b,s))) (withGroup Cache.write)
setStable = lmap shuffle1 (withGroup Cache.setStable)
{-# INLINE initialize #-}
{-# INLINE lookup #-}
{-# INLINE write #-}
{-# INLINE update #-}
{-# INLINE setStable #-}
withGroup :: (Identifiable k, NewCache cache a b, ArrowChoice c, ArrowApply c, ArrowPrimitive c)
=> CacheT cache a b c x y -> CacheT (Group cache) (k,a) b c (k,x) y
withGroup f = lift $ \(widen,Groups groups) -> proc (k,a) -> do
m <- Map.lookup -< (k,groups)
cache <- case m of
Just cache -> returnA -< cache
Nothing -> do
cache <- newCache -< ()
Map.insert -< (k,cache,groups)
returnA -< cache
unlift f (widen,cache) -<< a
{-# INLINE withGroup #-}
{-# LANGUAGE LambdaCase #-}
{- | Lifts functions from `Data.HashTable.ST.Basic` with `ArrowPrimitive.primitive` -}
module Data.HashTable(HashTable,new,newSized,lookup,insert,update,initialize) where
import Prelude hiding (lookup)
import Control.Arrow.Primitive
import Data.Identifiable
import Data.HashTable.ST.Basic (HashTable)
import qualified Data.HashTable.ST.Basic as Map
new :: ArrowPrimitive c => c () (HashTable (PrimState c) k v)
new = liftST (const Map.new)
{-# INLINE new #-}
newSized :: ArrowPrimitive c => c Int (HashTable (PrimState c) k v)
newSized = liftST Map.newSized
{-# INLINE newSized #-}
lookup :: (Identifiable k, ArrowPrimitive c) => c (k,HashTable (PrimState c) k v) (Maybe v)
lookup = liftST (\(key,table) -> Map.lookup table key)
{-# INLINE lookup #-}
insert :: (Identifiable k, ArrowPrimitive c) => c (k,v,HashTable (PrimState c) k v) ()
insert = liftST (\(key,val,table) -> Map.insert table key val)
{-# INLINE insert #-}
update :: (Identifiable k, ArrowPrimitive c) => (k -> x -> Maybe v -> (Maybe v,y)) -> c (k,x,HashTable (PrimState c) k v) y
update f = liftST $ \(key,x,table) -> Map.mutate table key $ \m -> f key x m
{-# INLINE update #-}
initialize :: (Identifiable k, ArrowPrimitive c) => c (k,v,HashTable (PrimState c) k v) v
initialize = update $ \_ _new -> \case
Just old -> (Just old,old)
Nothing -> (Just _new,_new)
{-# INLINE initialize #-}
......@@ -32,7 +32,7 @@ import Control.Arrow.Transformer.Abstract.Terminating
import Control.Arrow.Transformer.Abstract.Fix
import Control.Arrow.Transformer.Abstract.Fix.Chaotic
import Control.Arrow.Transformer.Abstract.Fix.Stack
import Control.Arrow.Transformer.Abstract.Fix.Cache hiding (Widening)
import Control.Arrow.Transformer.Abstract.Fix.Cache.Immutable hiding (Widening)
import Control.Arrow.Transformer.Abstract.Fix.Context
import qualified Data.Abstract.Boolean as Abs
......
......@@ -11,7 +11,6 @@ import Control.Category
import Control.Arrow
import Control.Arrow.Fix
import Control.Arrow.Fix.Stack (ArrowStack,widenInput,maxSize,reuseByMetric)
import qualified Control.Arrow.Fix.Stack as Stack
import Control.Arrow.Fix.Cache (ArrowCache)
import Control.Arrow.Fix.Chaotic (ArrowChaotic,chaotic,iterateInner,iterateOuter)
import Control.Arrow.Fix.Parallel (ArrowParallel,parallel)
......@@ -20,7 +19,7 @@ import Control.Arrow.Transformer.Abstract.Terminating
import Control.Arrow.Transformer.Abstract.Fix
import Control.Arrow.Transformer.Abstract.Fix.Metrics
import Control.Arrow.Transformer.Abstract.Fix.Chaotic
import Control.Arrow.Transformer.Abstract.Fix.Cache hiding (Widening)
import Control.Arrow.Transformer.Abstract.Fix.Cache.Immutable hiding (Widening)
import Control.Arrow.Transformer.Abstract.Fix.Stack
-- import Control.Arrow.Transformer.Abstract.Fix.Trace
......
......@@ -37,7 +37,7 @@ import Control.Arrow.Transformer.Abstract.Fix
import Control.Arrow.Transformer.Abstract.Fix.Context
import Control.Arrow.Transformer.Abstract.Fix.Stack
-- import Control.Arrow.Transformer.Abstract.Fix.Trace
import Control.Arrow.Transformer.Abstract.Fix.Cache(CacheT,Cache,Parallel,Monotone,type (**),Group)
import Control.Arrow.Transformer.Abstract.Fix.Cache.Immutable(CacheT,Cache,Parallel,Monotone,type (**),Group)
import Control.Arrow.Transformer.Abstract.Terminating
import Control.Monad.State hiding (lift,fail)
......
......@@ -41,7 +41,7 @@ import Control.Arrow.Transformer.Abstract.Except
import Control.Arrow.Transformer.Abstract.Fix
import Control.Arrow.Transformer.Abstract.Fix.Chaotic
import Control.Arrow.Transformer.Abstract.Fix.Context
import Control.Arrow.Transformer.Abstract.Fix.Cache hiding (Widening)
import Control.Arrow.Transformer.Abstract.Fix.Cache.Immutable hiding (Widening)
import Control.Arrow.Transformer.Abstract.Fix.Stack
import Control.Arrow.Transformer.Abstract.Store
import Control.Arrow.Transformer.Abstract.Terminating
......
......@@ -48,7 +48,7 @@ import Control.Arrow.Transformer.Abstract.Error
import Control.Arrow.Transformer.Abstract.Except
import Control.Arrow.Transformer.Abstract.Fix
import Control.Arrow.Transformer.Abstract.Fix.Chaotic
import Control.Arrow.Transformer.Abstract.Fix.Cache
import Control.Arrow.Transformer.Abstract.Fix.Cache.Immutable
import Control.Arrow.Transformer.Abstract.Fix.Stack
import Control.Arrow.Transformer.Abstract.Store
import Control.Arrow.Transformer.Abstract.Terminating
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment