Commit 20d72c90 authored by Sven Keidel's avatar Sven Keidel

clean up code and add documentation

parent 09e55de0
Pipeline #15248 failed with stages
in 17 minutes and 36 seconds
......@@ -8,16 +8,24 @@ import Control.Arrow
import Data.Profunctor
import Data.Abstract.Widening (Stable)
class (Arrow c, Profunctor c) => ArrowRecurse a b c | c -> a, c -> b where
-- | Decides whether to return a cached result or to recompute.
recurse :: c (a,Cached b) y -> c a y
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
-- | Looks up if there is an entry in the cache.
lookup :: c a (Maybe (Stable,b))
-- | Write a new entry to the cache.
write :: c (a,b,Stable) ()
-- | Update an existing entry in the cache.
update :: c (a,b) (Stable,b)
-- | Set a given entry to stable or unstable.
setStable :: c (Stable,a) ()
type ArrowCacheRecurse a b c = (ArrowCache a b c, ArrowRecurse a b c)
......@@ -37,78 +37,77 @@ newtype ChaoticT a b c x y = ChaoticT (WriterT (Component a) c x y)
deriving (Profunctor,Category,Arrow,ArrowChoice)
type instance Fix (ChaoticT _ _ c) x y = ChaoticT x y c
instance (Identifiable a, ArrowCacheReuse a b c, ArrowChoice c) => ArrowFix (ChaoticT a b c a b) where
fix f = iterateOuter (f (fix f))
instance (Identifiable a, ArrowCacheRecurse a b c, ArrowChoice c) => ArrowFix (ChaoticT a b c a b) where
fix f = iterateInner (f (fix f))
{-# INLINABLE fix #-}
-- | 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)
-- If the cache contains an unstable entry, remember to iterate on this entry.
Cached (Instable,b) -> returnA -< (Component {head = H.singleton a, body = H.empty},b)
-- If we did not encounter the entry, register the entry and keep recursing.
Compute -> iterate -< a
where
iterate = proc a -> do
(component,b) <- unlift f -< a
case () of
-- The call did not depend on any unstable calls. This means
-- we are done and don't need to iterate.
() | H.null (head component) -> do
Cache.write -< (a,b,Stable)
returnA -< (mempty,b)
-- We are at the head of a fixpoint component. This means, we
-- have to iterate until the head stabilized.
| head component == H.singleton a -> do
(stable,bNew) <- Cache.update -< (a,b)
case stable of
-- If the head of a fixpoint component is stable, set
-- all elements in the body of the component as stable
-- too and return.
Stable -> do
map Cache.setStable -< H.toList $ H.map (Stable,) (body component)
returnA -< (mempty,bNew)
-- If the head of a fixpoint component is not stable, keep iterating.
Instable ->
iterate -< a
-- We are inside an fixpoint component, but its head has not stabilized.
| otherwise -> do
Cache.write -< (a,b,Instable)
returnA -< (Component { head = H.delete a (head component),
body = H.insert a (body component) }, b)
-- | Iterate on the innermost fixpoint component.
iterateInner :: (Identifiable a, ArrowCacheReuse a b c, ArrowChoice c) => IterationStrategy (ChaoticT a b c) a b
iterateInner :: (Identifiable a, ArrowCacheRecurse 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
iterateInner f = lift $ recurse $ 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
-- | Iterate on the outermost fixpoint component.
iterateOuter :: (Identifiable a, ArrowCacheRecurse a b c, ArrowChoice c) => IterationStrategy (ChaoticT a b c) a b
{-# INLINE iterateOuter #-}
iterateOuter f = lift $ recurse $ proc (a,r) -> case r of
-- If the cache contains a stable entry, just return it.
Cached (Stable,b) -> returnA -< (mempty,b)
-- If the cache contains an unstable entry, remember to iterate on this entry.
Cached (Instable,b) -> returnA -< (Component {head = H.singleton a, body = H.empty},b)
-- If we did not encounter the entry, register the entry and keep recursing.
Compute -> iterate -< a
where
iterate = proc a -> do
(component,b) <- unlift f -< a
case () of
-- The call did not depend on any unstable calls. This means
-- we are done and don't need to iterate.
() | H.null (head component) -> do
Cache.write -< (a,b,Stable)
returnA -< (mempty,b)
-- We are at the head of a fixpoint component. This means, we
-- have to iterate until the head stabilized.
| head component == H.singleton a -> do
(stable,bNew) <- Cache.update -< (a,b)
case stable of
-- If the head of a fixpoint component is stable, set
-- all elements in the body of the component as stable
-- too and return.
Stable -> do
map Cache.setStable -< H.toList $ H.map (Stable,) (body component)
returnA -< (mempty,bNew)
-- If the head of a fixpoint component is not stable, keep iterating.
Instable ->
iterate -< a
-- We are inside an fixpoint component, but its head has not stabilized.
| otherwise -> do
Cache.write -< (a,b,Instable)
returnA -< (Component { head = H.delete a (head component),
body = H.insert a (body component) }, b)
runChaoticT :: Profunctor c => ChaoticT a b c x y -> c x y
runChaoticT (ChaoticT f) = rmap snd (runWriterT f)
......
......@@ -11,7 +11,7 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Control.Arrow.Transformer.Abstract.Fix.ContextSensitive.Cache where
import Prelude hiding (pred,lookup,map,head,iterate,(.),truncate)
import Prelude hiding (pred,lookup,map,head,iterate,(.),truncate,elem)
import Control.Category
import Control.Arrow
......@@ -38,32 +38,55 @@ import Data.HashSet(HashSet)
import qualified Data.HashSet as H
import Data.HashMap.Lazy(HashMap)
import qualified Data.HashMap.Lazy as M
import Data.Maybe(fromMaybe)
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)
newtype CacheT ctx lab a b c x y = CacheT
(ConstT (Widening a, Widening b)
(ReaderT (Stack 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)) deriving (Show)
instance IsEmpty (Cache ctx a b) where
empty = Cache M.empty
{-# INLINE empty #-}
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 -< ()
=> ArrowRecurse (ctx,(lab,a)) b (CacheT ctx lab a b c) where
recurse (CacheT f) = CacheT $ askConst $ \(widen,_) -> proc (ctx,(lab,a)) -> do
Cache cache <- get -< ()
(a',b) <- case M.lookup ctx cache of
-- If there exists a stable cached entry and the actual input is
-- smaller than the cached input, recurse the cached result.
Just (a',b,Stable) | a a' -> do
returnA -< (a,Cached (Stable,b))
Just (a',b,_) -> do
-- If there exists an unstable cached entry or the actual input is
-- not smaller than the cached input, widen the input and recompute.
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)
-- If the stack already contains the call, return the instable
-- cached result to avoid divergence.
stack <- ask -< ()
returnA -< if elem lab a'' stack
then (a'',Cached (Instable,b))
else (a'',Compute)
Nothing -> do
put -< Cache (M.insert ctx (a,bottom,Instable) cache)
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 #-}
stack <- ask -< ()
returnA -< if elem lab a stack
then (a,Cached (Instable,bottom))
else (a,Compute)
-- Finally, push the new call on the stack.
stack <- ask -< ()
local f -< (push lab a' stack,((ctx,(lab,a')),b))
{-# INLINE recurse #-}
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
......@@ -94,6 +117,22 @@ instance (Identifiable ctx, PreOrd a, Eq a, LowerBounded b, ArrowChoice c, Profu
{-# INLINE write #-}
{-# INLINE setStable #-}
newtype Stack lab a = Stack (HashMap lab (HashSet a))
instance IsEmpty (Stack lab a) where
empty = Stack M.empty
{-# INLINE empty #-}
push :: (Identifiable lab, Identifiable a) => lab -> a -> Stack lab a -> Stack lab a
push lab a (Stack s) = Stack (M.insertWith (\_ old -> H.insert a old) lab (H.singleton a) s)
{-# INLINE push #-}
elem :: (Identifiable lab, Identifiable a) => lab -> a -> Stack lab a -> Bool
elem lab a (Stack s) = fromMaybe False $ do
as <- M.lookup lab s
return (H.member a as)
{-# INLINE elem #-}
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 #-}
......
......@@ -30,10 +30,11 @@ 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 (Identifiable lab, KnownNat k, ArrowRecurse (CallString k lab,(lab,a)) b c) => ArrowRecurse (lab,a) b (CallSiteT k lab c) where
-- | Pushes the label on the call string and truncate the call string to 'k'.
recurse f = lift $ proc (callString,(lab,a)) -> do
recurse (lmap assoc2 (unlift f)) -< (push lab callString,(lab,a))
{-# INLINE recurse #-}
instance ArrowCache (CallString k lab,(lab,a)) b c => ArrowCache (lab,a) b (CallSiteT k lab c) where
lookup = lift $ lookup
......@@ -45,20 +46,20 @@ instance ArrowCache (CallString k lab,(lab,a)) b c => ArrowCache (lab,a) b (Call
{-# 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 ArrowTrans (CallSiteT k lab c) where
type Underlying (CallSiteT k lab c) x y = c (CallString k lab,x) y
instance ArrowEffectCommutative c => ArrowEffectCommutative (CallSiteT k lab c)
instance (Profunctor c,ArrowApply c) => ArrowApply (CallSiteT k lab c) where
app = CallSiteT (app .# first coerce)
{-# INLINE app #-}
......@@ -49,8 +49,8 @@ instance IsEmpty (Cache a b) where
empty = Cache M.empty
{-# INLINE empty #-}
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
instance (LowerBounded b, ArrowChoice c, ArrowCache a b c) => ArrowRecurse a b (StackT stack a c) where
recurse (StackT f) = StackT $ askConst $ \widen -> proc a -> do
m <- lookup' -< a
case m of
Just (Stable,b) -> f -< (a,Cached (Stable,b))
......@@ -61,8 +61,8 @@ instance (LowerBounded b, ArrowChoice c, ArrowCache a b c) => ArrowReuse a b (St
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))
NoLoop -> local f -< (stack',(a',Compute))
Loop -> f -< (a',Cached (fromMaybe (Instable,bottom) b))
where lookup' = lift' (lift' lookup)
instance (ArrowCache a b c, ArrowChoice c, Profunctor c) => ArrowCache a b (StackT stack a c) where
......
......@@ -28,9 +28,9 @@ import Text.Printf
newtype TraceT c x y = TraceT (c x y)
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowTrans,ArrowComplete z,ArrowJoin,ArrowEffectCommutative)
instance (Show a, Show b, ArrowReuse a b c) => ArrowReuse a b (TraceT c) where
reuse (TraceT f) = TraceT $ reuse $ proc (a,b) -> do
f -< Debug.trace (printf "REUSE\n\tx: %s\n\ty: %s\n\n" (show a) (show b)) (a,b)
instance (Show a, Show b, ArrowRecurse a b c) => ArrowRecurse a b (TraceT c) where
recurse (TraceT f) = TraceT $ recurse $ proc (a,b) -> do
f -< Debug.trace (printf "RECURSE\n\tx: %s\n\ty: %s\n\n" (show a) (show b)) (a,b)
instance (Show a, Show b, ArrowCache a b c) => ArrowCache a b (TraceT c) where
lookup = TraceT $ proc a -> do
......
......@@ -5,7 +5,7 @@
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Data.Abstract.CallString where
module Data.Abstract.CallString(CallString) where
import Prelude hiding (truncate)
......
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