Commit a9fa512b authored by Sven Keidel's avatar Sven Keidel

refactor PCF to use context-sensitivity

parent 3d17cf95
Pipeline #15183 failed with stages
in 9 minutes and 46 seconds
{-# LANGUAGE Arrows #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
module Control.Arrow.Cache where
import Control.Arrow
......@@ -11,8 +11,13 @@ import Data.Abstract.Widening (Stable)
data Cached b = Compute | Cached (Stable,b)
deriving (Show,Eq)
type ArrowCacheReuse a b c = (ArrowCache a b c, ArrowReuse a b c)
class (Arrow c, Profunctor c) => ArrowReuse a b c | c -> a, c -> b where
reuse :: c (a,Cached b) y -> c a y
class (Arrow c, Profunctor c) => ArrowCache a b c | c -> a, c -> b where
memoize :: c (a,Cached b) y -> c a y
lookup :: c a (Maybe (Stable,b))
write :: c (a,b,Stable) ()
update :: c (a,b) (Stable,b)
setStable :: c (Stable,a) ()
......@@ -8,7 +8,7 @@
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
module Control.Arrow.Fix(Fix,ArrowFix(..),IterationStrategy,filter,trace) where
module Control.Arrow.Fix(Fix,Fix',ArrowFix(..),IterationStrategy,filter,trace) where
import Prelude hiding (filter,pred)
......@@ -23,6 +23,7 @@ import Text.Printf
-- | Type family that computes the type of the fixpoint.
type family Fix (c :: * -> * -> *) x y :: * -> * -> *
type Fix' c x y = Fix c x y x y
-- | Interface for describing fixpoint computations.
class ArrowFix c where
......
{-# LANGUAGE Arrows #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE RankNTypes #-}
{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
module Control.Arrow.Transformer.Abstract.Fix(FixT,runFixT) where
import Prelude hiding (id,(.),const,head,iterate,lookup)
import Control.Category
import Control.Arrow hiding (loop)
import Control.Arrow.Fix
import Control.Arrow.Trans
import Control.Arrow.Order
import Control.Arrow.Transformer.Const
import Control.Arrow.Transformer.Static
import Data.Profunctor
import Data.Profunctor.Unsafe((.#))
import Data.Coerce
newtype FixT a b c x y = FixT { unFixT :: ConstT (IterationStrategy c a b) c x y }
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowComplete z, ArrowJoin)
runFixT :: IterationStrategy c a b -> FixT a b c x y -> c x y
runFixT iterationStrat (FixT f) = runConstT iterationStrat f
{-# INLINE runFixT #-}
instance ArrowRun c => ArrowRun (FixT a b c) where
type Run (FixT a b c) x y = IterationStrategy c a b -> Run c x y
run (FixT f) iterationStrat = run (runConstT iterationStrat f)
{-# INLINE run #-}
type instance Fix (FixT _ _ c) x y = FixT x y c
instance (Profunctor c,ArrowChoice c) => ArrowFix (FixT a b c a b) where
fix f = iterationStrategy (f (fix f))
instance (Profunctor c,ArrowApply c) => ArrowApply (FixT a b c) where
app = FixT (app .# first coerce)
{-# INLINE app #-}
instance ArrowLift (FixT a b) where
lift' = FixT . lift'
{-# INLINE lift' #-}
instance ArrowEffectCommutative c => ArrowEffectCommutative (FixT a b c)
----- Helper functions -----
iterationStrategy :: FixT a b c a b -> FixT a b c a b
iterationStrategy (FixT (ConstT (StaticT f))) = FixT $ ConstT $ StaticT $ \strat -> strat (f strat)
{-# INLINE iterationStrategy #-}
......@@ -9,7 +9,7 @@
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
module Control.Arrow.Transformer.Abstract.Fix.Chaotic(ChaoticT,runChaoticT,chaotic) where
module Control.Arrow.Transformer.Abstract.Fix.Chaotic(ChaoticT,runChaoticT,iterateOuter,iterateInner) where
import Prelude hiding (pred,lookup,map,head,iterate,(.),elem)
......@@ -22,8 +22,6 @@ import Control.Arrow.Order(ArrowComplete(..),ArrowJoin(..),ArrowEffect
import Control.Arrow.Utils
import Control.Arrow.Transformer.Writer
import Control.Arrow.Transformer.Const
import Control.Arrow.Transformer.Static
import Data.Profunctor
import Data.Order
......@@ -35,21 +33,18 @@ import Data.Coerce
import Data.Abstract.Widening(Stable(..))
import Text.Printf
newtype ChaoticT a b c x y = ChaoticT (ConstT (IterationStrategy c a (Component a,b)) (WriterT (Component a) c) x y)
newtype ChaoticT a b c x y = ChaoticT (WriterT (Component a) c x y)
deriving (Profunctor,Category,Arrow,ArrowChoice)
runChaoticT :: Profunctor c => IterationStrategy c a (Component a,b) -> ChaoticT a b c x y -> c x y
runChaoticT strat (ChaoticT f) = rmap snd (runWriterT (runConstT strat f))
{-# INLINE runChaoticT #-}
type instance Fix (ChaoticT _ _ c) x y = ChaoticT x y c
instance (Identifiable a, ArrowCache a b c, ArrowChoice c) => ArrowFix (ChaoticT a b c a b) where
fix f = lift $ \strat -> strat (chaotic (unlift (f (fix f)) strat))
instance (Identifiable a, ArrowCacheReuse a b c, ArrowChoice c) => ArrowFix (ChaoticT a b c a b) where
fix f = iterateOuter (f (fix f))
{-# INLINABLE fix #-}
{-# INLINE chaotic #-}
chaotic :: (Identifiable a, ArrowCache a b c, ArrowChoice c) => IterationStrategy c a (Component a,b)
chaotic f = Cache.memoize $ proc (a,r) -> do
-- | Iterate on the outermost fixpoint component.
iterateOuter :: (Identifiable a, ArrowCacheReuse a b c, ArrowChoice c) => IterationStrategy (ChaoticT a b c) a b
{-# INLINE iterateOuter #-}
iterateOuter f = lift $ Cache.reuse $ proc (a,r) -> do
case r of
-- If the cache contains a stable entry, just return it.
Cached (Stable,b) -> returnA -< (mempty,b)
......@@ -62,7 +57,7 @@ chaotic f = Cache.memoize $ proc (a,r) -> do
where
iterate = proc a -> do
(component,b) <- f -< a
(component,b) <- unlift f -< a
case () of
-- The call did not depend on any unstable calls. This means
......@@ -94,14 +89,39 @@ chaotic f = Cache.memoize $ proc (a,r) -> do
returnA -< (Component { head = H.delete a (head component),
body = H.insert a (body component) }, b)
instance ArrowTrans (ChaoticT a b c) where
type Underlying (ChaoticT a b c) x y = IterationStrategy c a (Component a,b) -> c x (Component a,y)
-- | Iterate on the innermost fixpoint component.
iterateInner :: (Identifiable a, ArrowCacheReuse a b c, ArrowChoice c) => IterationStrategy (ChaoticT a b c) a b
{-# INLINE iterateInner #-}
iterateInner f = lift $ Cache.reuse $ proc (a,r) -> do
case r of
Cached (Stable,b) -> returnA -< (mempty,b)
Cached (Instable,b) -> returnA -< (Component {head = H.singleton a, body = H.empty},b)
Compute -> iterate -< a
where
iterate = proc a -> do
(component,b) <- unlift f -< a
if H.null (head component)
then do
Cache.write -< (a,b,Stable)
returnA -< (mempty,b)
else do
(stable,bNew) <- Cache.update -< (a,b)
case stable of
Stable -> returnA -< (component { head = H.delete a (head component) },bNew)
Instable -> iterate -< a
runChaoticT :: Profunctor c => ChaoticT a b c x y -> c x y
runChaoticT (ChaoticT f) = rmap snd (runWriterT f)
{-# INLINE runChaoticT #-}
instance (Identifiable a, ArrowRun c) => ArrowRun (ChaoticT a b c) where
type Run (ChaoticT a b c) x y = IterationStrategy c a (Component a,b) -> Run c x y
run f strat = run (runChaoticT strat f)
type Run (ChaoticT a b c) x y = Run c x y
run f = run (runChaoticT f)
{-# INLINE run #-}
instance ArrowTrans (ChaoticT a b c) where
type Underlying (ChaoticT a b c) x y = c x (Component a,y)
instance (Identifiable a, Profunctor c,ArrowApply c) => ArrowApply (ChaoticT a b c) where
app = ChaoticT (lmap (first coerce) app)
{-# INLINE app #-}
......
......@@ -9,7 +9,7 @@
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Control.Arrow.Transformer.Abstract.Fix.Context where
module Control.Arrow.Transformer.Abstract.Fix.ContextSensitive.Cache where
import Prelude hiding (pred,lookup,map,head,iterate,(.),truncate)
......@@ -26,38 +26,54 @@ import Control.Arrow.Transformer.Const
import Control.Arrow.Transformer.Reader
import Control.Arrow.Transformer.State
import Data.Profunctor(Profunctor(..))
import Data.Identifiable
import Data.Profunctor.Unsafe
import Data.Empty
import Data.Order
import Data.Coerce
import Data.Abstract.Context
import Data.Abstract.Widening(Widening,Stable(..))
import Data.HashMap.Lazy(HashMap)
import Data.HashSet(HashSet)
import qualified Data.HashSet as H
import Data.HashMap.Lazy(HashMap)
import qualified Data.HashMap.Lazy as M
newtype ContextT ctx lab a b c x y = ContextT (ConstT (Widening a, Widening b) (ReaderT ctx (StateT (Cache ctx a b) c)) x y)
newtype CacheT ctx lab a b c x y = CacheT (ConstT (Widening a, Widening b) (ReaderT (HashSet (lab,a)) (StateT (Cache ctx a b) c)) x y)
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowTrans)
newtype Cache ctx a b = Cache (HashMap ctx (a,b,Stable))
newtype Cache ctx a b = Cache (HashMap ctx (a,b,Stable)) deriving (Show)
instance IsEmpty (Cache ctx a b) where
empty = Cache M.empty
{-# INLINE empty #-}
instance (IsContext ctx lab, PreOrd a, Eq a, LowerBounded b, ArrowChoice c, Profunctor c) => ArrowCache (lab,a) b (ContextT ctx lab a b c) where
memoize (ContextT f) = ContextT $ askConst $ \(widen,_) -> pushCtx $ proc (ctx,(lab,a)) -> do
instance (Identifiable ctx, Identifiable lab, Identifiable a, PreOrd a, LowerBounded b, ArrowChoice c, Profunctor c)
=> ArrowReuse (ctx,(lab,a)) b (CacheT ctx lab a b c) where
reuse (CacheT f) = CacheT $ askConst $ \(widen,_) -> proc (ctx,(lab,a)) -> do
stack <- ask -< ()
Cache cache <- get -< ()
case M.lookup ctx cache of
Just (a',b,s)
| a a' -> f -< ((lab,a),Cached (s,b))
| otherwise -> do
let (s',a'') = widen a' a
put -< Cache (M.insert ctx (a'',b,s s') cache)
f -< ((lab,a''),Compute)
(a',b) <- case M.lookup ctx cache of
Just (a',b,Stable) | a a' -> do
returnA -< (a,Cached (Stable,b))
Just (a',b,_) -> do
let (_,a'') = widen a' a
put -< Cache (M.insert ctx (a'',b,Instable) cache)
returnA -< (a'',if H.member (lab,a'') stack then Cached (Instable,b) else Compute)
Nothing -> do
put -< Cache (M.insert ctx (a,bottom,Instable) cache)
f -< ((lab,a),Compute)
update = ContextT $ askConst $ \(_,widen) -> proc ((_,a),b) -> do
ctx <- ask -< ()
returnA -< (a,if H.member (lab,a) stack then Cached (Instable,bottom) else Compute)
local f -< (H.insert (lab,a') stack,((ctx,(lab,a')),b))
{-# INLINE reuse #-}
instance (Identifiable ctx, PreOrd a, Eq a, LowerBounded b, ArrowChoice c, Profunctor c) => ArrowCache (ctx,(lab,a)) b (CacheT ctx lab a b c) where
lookup = CacheT $ proc (ctx,(_,a)) -> do
Cache cache <- get -< ()
case M.lookup ctx cache of
Just (a',b,s)
| a a' -> returnA -< Just (s,b)
| otherwise -> returnA -< Just (Instable,b)
Nothing -> returnA -< Nothing
update = CacheT $ askConst $ \(_,widen) -> proc ((ctx,(_,a)),b) -> do
Cache cache <- get -< ()
case M.lookup ctx cache of
Just (a',b',_) -> do
......@@ -70,38 +86,33 @@ instance (IsContext ctx lab, PreOrd a, Eq a, LowerBounded b, ArrowChoice c, Prof
write = proc (a,b,s) -> do
update -< (a,b)
setStable -< (s,a)
setStable = proc _ -> returnA -< ()
-- ContextT $ proc (s,_) -> do
-- ctx <- ask -< ()
-- Cache cache <- get -< ()
-- put -< Cache (M.adjust (\(a',b',s') -> (a',b',s ⊔ s')) ctx cache)
{-# INLINE memoize #-}
setStable = CacheT $ proc (s,(ctx,(_,a))) -> do
Cache cache <- get -< ()
put -< Cache (M.adjust (\(a',b',s') -> (a',b',if a == a' then s else s')) ctx cache)
{-# INLINE lookup #-}
{-# INLINE update #-}
{-# INLINE write #-}
{-# INLINE setStable #-}
pushCtx :: (IsContext ctx lab, ArrowReader ctx c) => c (ctx,(lab,a)) y -> c (lab,a) y
pushCtx f = proc (lab,a) -> do
ctx <- ask -< ()
let ctx' = push lab ctx
local f -< (ctx',(ctx',(lab,a)))
{-# INLINE pushCtx #-}
runCacheT :: Profunctor c => Widening a -> Widening b -> CacheT ctx lab a b c x y -> c x (Cache ctx a b,y)
runCacheT wa wb (CacheT f) = lmap (\x -> (empty,(empty,x))) (runStateT (runReaderT (runConstT (wa,wb) f)))
{-# INLINE runCacheT #-}
runContextT :: (IsEmpty ctx,Profunctor c) => Widening a -> Widening b -> ContextT ctx lab a b c x y -> c x (Cache ctx a b,y)
runContextT wa wb (ContextT f) = lmap (\x -> (empty,(empty,x))) (runStateT (runReaderT (runConstT (wa,wb) f)))
{-# INLINE runContextT #-}
instance (IsEmpty ctx,ArrowRun c) => ArrowRun (ContextT ctx lab a b c) where
type Run (ContextT ctx lab a b c) x y = Widening a -> Widening b -> Run c x (Cache ctx a b,y)
run f wa wb = run (runContextT wa wb f)
instance ArrowRun c => ArrowRun (CacheT ctx lab a b c) where
type Run (CacheT ctx lab a b c) x y = Widening a -> Widening b -> Run c x (Cache ctx a b,y)
run f wa wb = run (runCacheT wa wb f)
{-# INLINE run #-}
instance (Complete y, ArrowEffectCommutative c) => ArrowComplete y (ContextT ctx lab a b c) where
ContextT f <> ContextT g = ContextT $ rmap (uncurry ()) (f &&& g)
instance (Complete y, ArrowEffectCommutative c) => ArrowComplete y (CacheT ctx lab a b c) where
CacheT f <> CacheT g = CacheT $ rmap (uncurry ()) (f &&& g)
{-# INLINE (<⊔>) #-}
instance (Arrow c, Profunctor c) => ArrowJoin (ContextT ctx lab a b c) where
joinSecond (ContextT f) = ContextT (second f)
instance (Arrow c, Profunctor c) => ArrowJoin (CacheT ctx lab a b c) where
joinSecond (CacheT f) = CacheT (second f)
{-# INLINE joinSecond #-}
instance ArrowEffectCommutative c => ArrowEffectCommutative (ContextT ctx lab a b c)
instance (Profunctor c,ArrowApply c) => ArrowApply (CacheT ctx lab a b c) where
app = CacheT (app .# first coerce)
{-# INLINE app #-}
instance ArrowEffectCommutative c => ArrowEffectCommutative (CacheT ctx lab a b c)
{-# LANGUAGE Arrows #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Control.Arrow.Transformer.Abstract.Fix.ContextSensitive.CallSite where
import Prelude hiding (lookup)
import Control.Category
import Control.Arrow
import Control.Arrow.Cache
import Control.Arrow.Trans
import Control.Arrow.Order
import Control.Arrow.Transformer.Reader
import Data.Profunctor.Unsafe
import Data.Coerce
import Data.Empty
import Data.Identifiable
import Data.Abstract.CallString
import Data.Abstract.Context
import Data.Monoidal
import GHC.TypeLits
newtype CallSiteT k lab c x y = CallSiteT (ReaderT (CallString k lab) c x y)
deriving (Category,Arrow,ArrowChoice,Profunctor)
instance (Identifiable lab, KnownNat k, ArrowReuse (CallString k lab,(lab,a)) b c) => ArrowReuse (lab,a) b (CallSiteT k lab c) where
reuse f = lift $ proc (contour,(lab,a)) -> do
reuse (lmap assoc2 (unlift f)) -< (push lab contour,(lab,a))
{-# INLINE reuse #-}
instance ArrowCache (CallString k lab,(lab,a)) b c => ArrowCache (lab,a) b (CallSiteT k lab c) where
lookup = lift $ lookup
write = lift $ lmap (\(cont,((l,a),b,s)) -> ((cont,(l,a)),b,s)) write
update = lift $ lmap (\(cont,((l,a),b)) -> ((cont,(l,a)),b)) update
setStable = lift $ lmap (\(cont,(s,(l,a))) -> (s,(cont,(l,a)))) setStable
{-# INLINE lookup #-}
{-# INLINE write #-}
{-# INLINE update #-}
{-# INLINE setStable #-}
instance ArrowTrans (CallSiteT k lab c) where
type Underlying (CallSiteT k lab c) x y = c (CallString k lab,x) y
runCallSiteT :: (Profunctor c) => CallSiteT k lab c x y -> c x y
runCallSiteT (CallSiteT f) = lmap (\x -> (empty,x)) (runReaderT f)
{-# INLINE runCallSiteT #-}
instance ArrowEffectCommutative c => ArrowEffectCommutative (CallSiteT k lab c)
instance (ArrowRun c) => ArrowRun (CallSiteT k lab c) where
type Run (CallSiteT k lab c) x y = Run c x y
run f = run (runCallSiteT f)
{-# INLINE run #-}
instance (Profunctor c,ArrowApply c) => ArrowApply (CallSiteT k lab c) where
app = CallSiteT (app .# first coerce)
{-# INLINE app #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
module Control.Arrow.Transformer.Abstract.Fix.Finite where
import Prelude hiding ((.))
import Data.Coerce
import Data.Empty
import Data.HashMap.Lazy (HashMap)
import qualified Data.HashMap.Lazy as M
import Data.Identifiable
import Data.Order
import Data.Profunctor
import Data.Profunctor.Unsafe
import Control.Category
import Control.Arrow
import Control.Arrow.Order
import Control.Arrow.Fix
import Control.Arrow.Trans
import Control.Arrow.State
import Control.Arrow.Transformer.State
newtype FiniteT a b c x y = FiniteT (StateT (HashMap a b) c x y)
deriving (Category,Arrow,ArrowChoice,ArrowTrans,Profunctor)
runFiniteT :: Profunctor c => FiniteT a b c x y -> c x (HashMap a b,y)
runFiniteT (FiniteT f) = lmap (\x -> (empty,x)) (runStateT f)
instance (Identifiable a, Arrow c, Profunctor c) => ArrowFix (FiniteT a b c a b) where
fix f = FiniteT $ proc a -> do
b <- coerce (f (fix f)) -< a
modify' (\((a,b),m) -> (b,M.insert a b m)) -< (a,b)
instance ArrowRun c => ArrowRun (FiniteT a b c) where
type Run (FiniteT a b c) x y = Run c x (HashMap a b,y)
run = run . runFiniteT
{-# INLINE run #-}
instance (Profunctor c, Arrow c, Complete y) => ArrowComplete y (FiniteT a b c) where
FiniteT f <> FiniteT g = FiniteT $ dimap (\x -> (x,x)) (\(y1,y2) -> y1 y2) (f *** g)
{-# INLINE (<⊔>) #-}
instance (Profunctor c, ArrowApply c) => ArrowApply (FiniteT a b c) where
app = FiniteT (app .# first coerce)
{-# INLINE app #-}
......@@ -16,6 +16,7 @@ module Control.Arrow.Transformer.Abstract.Fix.Parallel where
-- import Control.Arrow.State
-- import Control.Arrow.Reader
-- import Control.Arrow.Trans
-- import Control.Arrow.Cache
-- import Control.Arrow.Order(ArrowComplete(..),ArrowJoin(..),ArrowEffectCommutative)
-- import Control.Arrow.Transformer.Reader
-- import Control.Arrow.Transformer.State
......@@ -26,30 +27,23 @@ module Control.Arrow.Transformer.Abstract.Fix.Parallel where
-- import Data.Identifiable
-- import Data.Empty
-- import Data.Coerce
-- import Data.HashMap.Lazy(HashMap)
-- import qualified Data.HashMap.Lazy as M
-- import Data.Abstract.Cache(IsCache)
-- import qualified Data.Abstract.Cache as Cache
-- import Data.Abstract.StackWidening(Stack(..))
-- import Data.Abstract.Widening(Stable(..))
-- import qualified Data.Abstract.Widening as W
-- data Iteration cache a b = Iteration { old :: cache a b, new :: cache a b, stable :: Stable }
-- newtype ParallelT cache a b c x y = ParallelT (ReaderT (Stack a) (StateT (Iteration cache a b) c) x y)
-- data Iteration a b = Iteration { old :: HashMap a b, new :: HashMap a b, stable :: Stable }
-- newtype ParallelT a b c x y = ParallelT (StateT (Iteration a b) c x y)
-- deriving (Profunctor,Category,Arrow,ArrowChoice)
-- runParallelT :: (IsCache cache a b, Profunctor c) => ParallelT cache a b c x y -> c x (cache a b,y)
-- runParallelT (ParallelT f) = dimap (\a -> (empty,(empty,a))) (first new) (runStateT (runReaderT f))
-- runParallelT :: (Profunctor c) => ParallelT cache a b c x y -> c x (HashMap a b,y)
-- runParallelT (ParallelT f) = dimap (\a -> (empty,a)) (first new) (runStateT f)
-- execParallelT :: (IsCache cache a b, Profunctor c) => ParallelT cache a b c x y -> c x (cache a b)
-- execParallelT f = rmap fst (runParallelT f)
-- evalParallelT :: (IsCache cache a b, Profunctor c) => ParallelT cache a b c x y -> c x y
-- evalParallelT f = rmap snd (runParallelT f)
-- parallel :: (Identifiable a, IsCache cache a b, Profunctor c, ArrowChoice c) => Cache.Widening (Iteration cache) a b -> IterationStrategy (ParallelT cache a b c) a b
-- parallel widen (ParallelT f) = ParallelT $ push $ proc (xs,a) -> do
-- cache <- get -< ()
-- case Cache.lookup a cache of
-- parallel :: (Identifiable a, Profunctor c, ArrowChoice c) => W.Widening b -> IterationStrategy (ParallelT a b c) a b
-- parallel widen (ParallelT f) = ParallelT $ push $ memoize $ proc (r,a) -> do
-- case r of
-- Just (_,b) | H.member a xs -> returnA -< b
-- _ -> iterate -< (xs,a)
-- where
......@@ -69,17 +63,17 @@ module Control.Arrow.Transformer.Abstract.Fix.Parallel where
-- Stack xs <- ask -< ()
-- local g -< (Stack (H.insert a xs),(xs,a))
-- instance IsCache cache a b => IsCache (Iteration cache) a b where
-- type Widening (Iteration cache) a b = Cache.Widening cache a b
-- initialize a cache =
-- case (Cache.lookup a (old cache), Cache.lookup a (new cache)) of
-- (Just (st,b), Nothing) ->
-- let new' = Cache.insert a b st (new cache)
-- in cache { new = new', stable = stable cache ⊔ st }
-- (Nothing, Nothing) ->
-- let new' = Cache.initialize a (new cache)
-- in cache { new = new', stable = Instable }
-- (_,_) -> cache
-- initialize a cache =
-- case (M.lookup a (old cache), M.lookup a (new cache)) of
-- (Just b, Nothing) ->
-- let new' = M.insert a b (new cache)
-- in cache { new = new', stable = stable cache ⊔ st }
-- (Nothing, Nothing) ->
-- let new' = M.insert a bottom (new cache)
-- in cache { new = new', stable = Instable }
-- (_,_) -> cache
-- instance ArrowCache Iteration a b where
-- insert a b st cache = cache { new = Cache.insert a b st (new cache)
-- , stable = stable cache ⊔ st }
-- setStable a cache = cache { new = Cache.setStable a (new cache)}
......
......@@ -6,7 +6,7 @@
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Control.Arrow.Transformer.Abstract.Fix.Stack where
module Control.Arrow.Transformer.Abstract.Fix.StackWidening where
import Prelude hiding (pred,lookup,map,head,iterate,(.))
......@@ -15,33 +15,30 @@ import Control.Arrow
import Control.Arrow.Cache
import Control.Arrow.Const
import Control.Arrow.Reader
import Control.Arrow.State
import Control.Arrow.Trans
import Control.Arrow.Order(ArrowJoin(..),ArrowComplete(..),ArrowEffectCommutative)
import Control.Arrow.Transformer.Const
import Control.Arrow.Transformer.Reader
import Control.Arrow.Transformer.State
import Data.Profunctor
import Data.Profunctor.Unsafe((.#))
import Data.Coerce
import Data.Empty
import Data.Order
import Data.Identifiable
import Data.Abstract.StackWidening
import Data.Abstract.Widening(Widening,Stable(..))
import Data.Abstract.Widening(Stable(..))
import Data.Maybe(fromMaybe)
import Data.HashMap.Lazy(HashMap)
import qualified Data.HashMap.Lazy as M
newtype StackT stack a b c x y = StackT (ConstT (StackWidening stack a, Widening b) (ReaderT (stack a) (StateT (Cache a b) c)) x y)
newtype StackT stack a c x y = StackT (ConstT (StackWidening stack a) (ReaderT (stack a) c) x y)
deriving (Profunctor,Category,Arrow,ArrowChoice)
runStackT :: (IsEmpty (stack a), Profunctor c)
=> StackWidening stack a -> Widening b -> StackT stack a b c x y -> c x (Cache a b, y)
runStackT stackWiden widen (StackT f) = lmap (\x -> (empty,(empty,x))) (runStateT (runReaderT (runConstT (stackWiden,widen) f)))
=> StackWidening stack a -> StackT stack a c x y -> c x y
runStackT stackWiden (StackT f) = lmap (\x -> (empty,x)) (runReaderT (runConstT stackWiden f))
{-# INLINE runStackT #-}
newtype Cache a b = Cache (HashMap a (Stable,b))
......@@ -52,45 +49,51 @@ instance IsEmpty (Cache a b) where
empty = Cache M.empty
{-# INLINE empty #-}
instance (Identifiable a, LowerBounded b, ArrowChoice c, Profunctor c) => ArrowCache a b (StackT stack a b c) where
memoize (StackT f) = StackT $ askConst $ \(widen,_) -> proc a -> do
Cache cache <- get -< ()
case M.lookup a cache of
instance (LowerBounded b, ArrowChoice c, ArrowCache a b c) => ArrowReuse a b (StackT stack a c) where
reuse (StackT f) = StackT $ askConst $ \widen -> proc a -> do
m <- lookup' -< a
case m of
Just (Stable,b) -> f -< (a,Cached (Stable,b))
_ -> do
stack <- ask -< ()
let ((a',l),stack') = widen a stack
case M.lookup a' cache of
m' <- lookup' -< a'
case m' of
Just (Stable,b) -> f -< (a',Cached (Stable,b))
b -> case l of
NoLoop -> local f -< (stack',(a',Compute))
Loop -> f -< (a',Cached (fromMaybe (Instable,bottom) b))
write = StackT $ modify' (\((a,b,s),Cache cache) -> ((),Cache (M.insert a (s,b) cache)))
update = StackT $ askConst $ \(_,widen) -> modify' (\((a,b),Cache cache) ->
let (_,bOld) = fromMaybe (Instable,bottom) (M.lookup a cache)