Commit a4f506b1 authored by Sven Keidel's avatar Sven Keidel

Merge branch 'gamma-cfa'

parents 81c717f7 8f284291
Pipeline #26941 passed with stages
in 35 minutes and 45 seconds
......@@ -24,8 +24,9 @@ class (Arrow c, Profunctor c) => ArrowClosure expr cls c | cls -> expr where
closure = lift' closure
{-# INLINE closure #-}
class IsClosure cls env | env -> cls, cls -> env where
class IsClosure cls env where
mapEnvironment :: (env -> env) -> cls -> cls
traverseEnvironment :: Applicative f => (env -> f env) -> cls -> f cls
setEnvironment :: env -> cls -> cls
setEnvironment env = mapEnvironment (const env)
{-# INLINE setEnvironment #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
module Control.Arrow.Fix(Fix,Fix',ArrowFix(..),IterationStrategy,transform,filter) where
module Control.Arrow.Fix(Fix,Fix',ArrowFix(..)) where
import Prelude hiding (filter,pred)
import Control.Arrow
import Control.Arrow.Trans
import Data.Profunctor
import Data.Lens(Iso',from,Prism',getMaybe,get,set)
-- | 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
......@@ -34,16 +28,3 @@ class ArrowFix c where
type instance Fix (->) x y = (->)
instance ArrowFix (x -> y) where
fix f = f (fix f)
type IterationStrategy c a b = c a b -> c a b
transform :: Profunctor c => Iso' a a' -> IterationStrategy c a' b -> IterationStrategy c a b
transform iso strat f = lmap (get iso) (strat (lmap (get (from iso)) f))
{-# INLINE transform #-}
filter :: (Profunctor c, ArrowChoice c, ArrowApply c) => Prism' a a' -> IterationStrategy c a' b -> IterationStrategy c a b
filter pred strat f = proc a -> case getMaybe pred a of
Just a' -> strat (lmap (\x -> set pred x a) f) -<< a'
Nothing -> f -< a
{-# INLINE filter #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FunctionalDependencies #-}
module Control.Arrow.Fix.Cache where
import Prelude hiding (lookup)
import Control.Arrow
import Control.Arrow.Trans
import Data.Profunctor
import Data.Abstract.Stable
class (Arrow c, Profunctor c) => ArrowCache a b c | c -> a, c -> b where
-- | Initializes a cache entry with 'bottom'.
initialize :: c a b
-- | Looks up if there is an entry in the cache.
lookup :: c a (Maybe (Stable,b))
......@@ -17,3 +24,21 @@ class (Arrow c, Profunctor c) => ArrowCache a b c | c -> a, c -> b where
-- | Set a given entry to stable or unstable.
setStable :: c (Stable,a) ()
default initialize :: (c ~ t c', ArrowLift t, ArrowCache a b c') => c a b
default lookup :: (c ~ t c', ArrowLift t, ArrowCache a b c') => c a (Maybe (Stable,b))
default write :: (c ~ t c', ArrowLift t, ArrowCache a b c') => c (a,b,Stable) ()
default update :: (c ~ t c', ArrowLift t, ArrowCache a b c') => c (a,b) (Stable,b)
default setStable :: (c ~ t c', ArrowLift t, ArrowCache a b c') => c (Stable,a) ()
initialize = lift' initialize
lookup = lift' lookup
write = lift' write
update = lift' update
setStable = lift' setStable
{-# INLINE initialize #-}
{-# INLINE lookup #-}
{-# INLINE write #-}
{-# INLINE update #-}
{-# INLINE setStable #-}
......@@ -14,13 +14,10 @@ import Data.Order
import Text.Printf
class (Arrow c, Profunctor c) => ArrowIterate a c where
-- | Remembers to iterate on an unstable result until it stabilized.
class (Arrow c, Profunctor c) => ArrowChaotic a c | c -> a where
iterate :: c (a,b) b
class (Arrow c, Profunctor c) => ArrowComponent a c | c -> a where
setComponent :: c (Component a,y) y
withComponent :: c x y -> (c (x,y,Component a) y) -> c x y
withComponent :: c x y -> c (x,y,Component a) y -> c x y
data Component a = Component { head :: HashSet a, body :: HashSet a } deriving (Eq)
......
This diff is collapsed.
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE TypeFamilies #-}
module Control.Arrow.Fix.Context where
import Prelude hiding ((.))
import Control.Category
import Control.Arrow
import Control.Arrow.Fix
import Control.Arrow.Trans
import Data.Profunctor
class (Arrow c, Profunctor c) => ArrowContext ctx a c | c -> ctx, c -> a where
type Widening c a :: *
class (Arrow c, Profunctor c) => ArrowContext ctx c | c -> ctx where
askContext :: c () ctx
localContext :: c x y -> c (ctx,x) y
joinByContext :: Widening c a -> c a a
joinByContext' :: ArrowContext ctx a c => Widening c a -> IterationStrategy c a b
joinByContext' widen f = f . joinByContext widen
{-# INLINE joinByContext' #-}
default askContext :: (c ~ t c', ArrowLift t, ArrowContext ctx c') => c () ctx
askContext = lift' askContext
{-# INLINE askContext #-}
class (Arrow c, Profunctor c) => ArrowJoinContext a c | c -> a where
joinByContext :: c a a
default joinByContext :: (c ~ t c', ArrowLift t, ArrowJoinContext a c') => c a a
joinByContext = lift' joinByContext
{-# INLINE joinByContext #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
module Control.Arrow.Fix.Reuse
( ArrowReuse(..)
, reuseFirst
, reuseExact
, reuseByMetric
, reuseStableByMetric
)
module Control.Arrow.Fix.Reuse ( ArrowReuse(..))
where
import Prelude hiding (lookup)
import Control.Arrow
import Control.Arrow.Fix
import Control.Arrow.Fix.Cache
import Data.Abstract.Stable
import Data.Order
import Data.Metric
import Data.Profunctor
import Data.Monoid (First(..))
import Text.Printf
class (Arrow c, Profunctor c) => ArrowReuse a b c where
-- | Reuse cached results at the cost of precision.
reuse :: (Monoid m) => Stable -> (a -> a -> Stable -> b -> m -> m) -> c a m
reuseFirst :: (PreOrd a, ArrowChoice c, ArrowReuse a b c) => Stable -> IterationStrategy c a b
reuseFirst s f = proc a -> do
m <- reuse s (\a a' s' b' m -> case m of
First (Just _) -> m
First Nothing
| a a' -> First (Just (a',b',s'))
| otherwise -> m) -< a
case getFirst m of
Just (_,b,Stable) -> returnA -< b
Just (a',_,Unstable) -> f -< a'
Nothing -> f -< a
{-# INLINE reuseFirst #-}
reuseExact :: (ArrowChoice c, ArrowCache a b c) => IterationStrategy c a b
reuseExact f = proc a -> do
m <- lookup -< a
case m of
Just (Stable,b) -> returnA -< b
_ -> f -< a
{-# INLINE reuseExact #-}
reuseByMetric :: (PreOrd a, Ord n, ArrowChoice c, ArrowReuse a b c) => Metric a n -> IterationStrategy c a b
reuseByMetric metric = reuseByMetric_ (\s a a' -> Product s (metric a a')) Unstable
{-# INLINE reuseByMetric #-}
reuseStableByMetric :: (PreOrd a, Ord n, ArrowChoice c, ArrowReuse a b c) => Metric a n -> IterationStrategy c a b
reuseStableByMetric metric = reuseByMetric_ (const metric) Stable
{-# INLINE reuseStableByMetric #-}
reuseByMetric_ :: (PreOrd a, Ord n, ArrowChoice c, ArrowReuse a b c) => (Stable -> Metric a n) -> Stable -> IterationStrategy c a b
reuseByMetric_ metric s f = proc a -> do
m <- reuse s (\a a' s' b' m ->
if a a'
then m <> Just (Measured { input = a', output = b', stable = s', measured = metric s' a a' })
else m) -< a
case m of
Just Measured { stable = Stable, output = b } -> returnA -< b
Just Measured { stable = Unstable, input = a' } -> f -< a'
Nothing -> f -< a
{-# INLINE reuseByMetric_ #-}
data Measured a b n = Measured { input :: a, output :: b, stable :: Stable, measured :: n }
instance (Show a, Show b, Show n) => Show (Measured a b n) where
show m = printf "%s@%s" (show (output m)) (show (measured m))
instance Ord n => Semigroup (Measured a b n) where
m1 <> m2
| measured m1 <= measured m2 = m1
| otherwise = m2
{-# INLINE (<>) #-}
......@@ -36,7 +36,7 @@ import Data.Coerce
newtype ErrorT e c x y = ErrorT (KleisliT (Error e) c x y)
deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowTrans, ArrowLift, ArrowRun,
ArrowCont, ArrowConst r, ArrowState s, ArrowReader r,
ArrowEnv var val, ArrowClosure expr cls, ArrowStore a b,
ArrowEnv var val, ArrowLetRec var val, ArrowClosure expr cls, ArrowStore a b,
ArrowExcept e')
runErrorT :: ErrorT e c x y -> c x (Error e y)
......
......@@ -16,7 +16,6 @@ import qualified Prelude as P
import Control.Category
import Control.Arrow
import Control.Arrow.Fix.Context
import Control.Arrow.Cont
import Control.Arrow.Const
import Control.Arrow.Transformer.Const
......@@ -28,12 +27,14 @@ import Control.Arrow.Store
import Control.Arrow.Fail
import Control.Arrow.Except
import Control.Arrow.Trans
import Control.Arrow.Fix.Context
import Control.Arrow.Environment as Env
import Control.Arrow.Closure
import Control.Arrow.Fix
import Control.Arrow.Order
import Control.Arrow.Utils
import Data.Abstract.Widening (Widening)
import Data.Abstract.Closure (Closure)
import qualified Data.Abstract.Closure as Cls
......@@ -48,50 +49,52 @@ import Data.Profunctor.Unsafe((.#))
import Data.Coerce
type Alloc var addr val c = EnvT var addr val c (var,val) addr
newtype EnvT var addr val c x y = EnvT (ConstT (Alloc var addr val c) (ReaderT (HashMap var addr) (StateT (HashMap addr val) c)) x y)
newtype EnvT var addr val c x y = EnvT (ConstT (Alloc var addr val c, Widening val) (ReaderT (HashMap var addr) (StateT (HashMap addr val) c)) x y)
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowTrans, ArrowLowerBounded,
ArrowFail e, ArrowExcept e, ArrowStore var' val', ArrowRun, ArrowCont)
ArrowFail e, ArrowExcept e, ArrowStore var' val', ArrowRun, ArrowCont,
ArrowContext ctx)
instance (Identifiable var, Identifiable addr, Complete val, ArrowEffectCommutative c, ArrowChoice c, Profunctor c) => ArrowEnv var val (EnvT var addr val c) where
type Join y (EnvT var addr val c) = Env.Join y c
type Join y (EnvT var addr val c) = ()
lookup (EnvT f) (EnvT g) = EnvT $ proc (var,x) -> do
env <- Reader.ask -< ()
store <- State.get -< ()
case do { addr <- Map.lookup var env; Map.lookup addr store } of
P.Just val -> f -< (val,x)
P.Nothing -> g -< x
extend (EnvT f) = EnvT $ askConst $ \(EnvT alloc) -> proc (var,val,x) -> do
extend (EnvT f) = EnvT $ askConst $ \(EnvT alloc,widening) -> proc (var,val,x) -> do
env <- Reader.ask -< ()
store <- State.get -< ()
case Map.lookup var env of
P.Just addr -> do
State.put -< Map.insertWith () addr val store
State.put -< Map.insertWith (\old new -> snd (widening old new)) addr val store
f -< x
P.Nothing -> do
addr <- alloc -< (var,val)
State.put -< Map.insertWith () addr val store
State.put -< Map.insertWith (\old new -> snd (widening old new)) addr val store
Reader.local f -< (Map.insert var addr env, x)
{-# INLINE lookup #-}
{-# INLINE extend #-}
instance (Identifiable var, Identifiable addr, Identifiable expr, ArrowEffectCommutative c, ArrowChoice c, Profunctor c) => ArrowClosure expr (Closure expr (HashSet (HashMap var addr))) (EnvT var addr val c) where
instance (Identifiable var, Identifiable addr, Identifiable expr, ArrowEffectCommutative c, ArrowChoice c, Profunctor c) =>
ArrowClosure expr (Closure expr (HashSet (HashMap var addr))) (EnvT var addr val c) where
type Join y (EnvT var addr val c) = Complete y
closure = EnvT $ proc expr -> do
env <- Reader.ask -< ()
returnA -< Cls.closure expr (Set.singleton env)
apply (EnvT f) = Cls.apply $proc ((expr,envs),x) ->
apply (EnvT f) = Cls.apply $ proc ((expr,envs),x) ->
(| joinList (error "encountered an empty set of environments" -< ())
(\env -> EnvT (Reader.local f) -< (env,(expr,x))) |) (Set.toList envs)
{-# INLINE closure #-}
{-# INLINE apply #-}
instance (Identifiable var, Identifiable addr, Complete val, IsClosure val (HashSet (HashMap var addr)), ArrowEffectCommutative c, ArrowContext addr a c, ArrowChoice c, Profunctor c) => ArrowLetRec var val (EnvT var addr val c) where
letRec (EnvT f) = EnvT $ askConst $ \(EnvT alloc) -> proc (bindings,x) -> do
instance (Identifiable var, Identifiable addr, Complete val, IsClosure val (HashSet (HashMap var addr)), ArrowEffectCommutative c, ArrowChoice c, Profunctor c) => ArrowLetRec var val (EnvT var addr val c) where
letRec (EnvT f) = EnvT $ askConst $ \(EnvT alloc,widening) -> proc (bindings,x) -> do
env <- Reader.ask -< ()
addrs <- map alloc -< bindings
let env' = Map.fromList [ (var,addr) | ((var,_), addr) <- zip bindings addrs ] `Map.union` env
vals = Map.fromList [ (addr, setEnvironment (Set.singleton env') val) | (addr, (_,val)) <- zip addrs bindings ]
State.modify' (\(vals,store) -> ((), vals store)) -< vals
State.modify' (\(vals,store) -> ((), Map.unionWith (\old new -> snd (widening old new)) store vals)) -< vals
Reader.local f -< (env',x)
{-# INLINE letRec #-}
......
{-# LANGUAGE Arrows #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE RankNTypes #-}
......@@ -16,8 +14,10 @@ import Prelude hiding (id,(.),const,head,iterate,lookup)
import Control.Category
import Control.Arrow hiding (loop)
import Control.Arrow.Fix
import Control.Arrow.Fix.Combinator
import Control.Arrow.Fix.Context (ArrowContext)
import Control.Arrow.Order(ArrowEffectCommutative,ArrowComplete,ArrowJoin)
import Control.Arrow.Trans
import Control.Arrow.Order
import Control.Arrow.Transformer.Const
import Control.Arrow.Transformer.Static
......@@ -25,21 +25,21 @@ 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)
newtype FixT a b c x y = FixT { unFixT :: ConstT (FixpointCombinator c a b) c x y }
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowComplete z, ArrowJoin, ArrowContext ctx)
runFixT :: IterationStrategy c a b -> FixT a b c x y -> c x y
runFixT iterationStrat (FixT f) = runConstT iterationStrat f
runFixT :: FixpointCombinator c a b -> FixT a b c x y -> c x y
runFixT comb (FixT f) = runConstT comb 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)
type Run (FixT a b c) x y = FixpointCombinator c a b -> Run c x y
run (FixT f) comb = run (runConstT comb 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, ArrowChoice c) => ArrowFix (FixT a b c a b) where
fix f = combinator (f (fix f))
{-# NOINLINE fix #-}
instance (Profunctor c,ArrowApply c) => ArrowApply (FixT a b c) where
......@@ -53,7 +53,6 @@ instance ArrowLift (FixT a b) where
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 #-}
combinator :: FixT a b c a b -> FixT a b c a b
combinator (FixT (ConstT (StaticT f))) = FixT $ ConstT $ StaticT $ \comb -> comb (f comb)
{-# INLINE combinator #-}
......@@ -5,17 +5,15 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
module Control.Arrow.Transformer.Abstract.Fix.Chaotic(ChaoticT,runChaoticT,iterateOuter,iterateInner) where
module Control.Arrow.Transformer.Abstract.Fix.Chaotic(ChaoticT,runChaoticT) where
import Prelude hiding (id,pred,lookup,map,head,iterate,(.),elem)
import Control.Category
import Control.Arrow hiding (loop)
import Control.Arrow.Fix
import Control.Arrow.Fix.Chaotic
import Control.Arrow.Fix.Reuse
import Control.Arrow.Fix.Cache as Cache
......@@ -23,105 +21,24 @@ import Control.Arrow.Fix.Stack as Stack
import Control.Arrow.Fix.Context as Context
import Control.Arrow.State
import Control.Arrow.Trans
import Control.Arrow.Order(ArrowComplete(..),ArrowJoin(..),ArrowEffectCommutative)
import Control.Arrow.Utils
import Control.Arrow.Order
import Control.Arrow.Transformer.Writer
import Data.Abstract.Stable
import Data.Order
import Data.Profunctor
import qualified Data.HashSet as H
import Data.Identifiable
import Data.Coerce
-- | Iterate on the innermost fixpoint component.
iterateInner :: (Identifiable a, LowerBounded b, ArrowStack a c, ArrowIterate a c, ArrowComponent a c, ArrowCache a b c, ArrowChoice c) => IterationStrategy c a b
{-# INLINE iterateInner #-}
iterateInner = detectLoop . go
where
go f = withComponent f $ proc (a,b,component) ->
-- The call did not depend on any unstable calls. This means
-- we are done and don't need to iterate.
if H.null (head component)
then do
Cache.write -< (a,b,Stable)
returnA -< b
else do
(stable,bNew) <- Cache.update -< (a,b)
case stable of
Stable ->
if head component == H.singleton a
then do
map Cache.setStable -< (Stable,) <$> H.toList (body component)
setComponent -< (mempty, bNew)
else do
setStable -< (Unstable,a)
setComponent -< (component { head = H.delete a (head component)
, body = H.insert a (body component) }, bNew)
Unstable -> go f -< a
-- | Iterate on the outermost fixpoint component.
iterateOuter :: (Identifiable a, LowerBounded b, ArrowStack a c, ArrowIterate a c, ArrowComponent a c, ArrowCache a b c, ArrowChoice c) => IterationStrategy c a b
{-# INLINE iterateOuter #-}
iterateOuter = detectLoop . go
where
go f = withComponent f $ proc (a,b,component) -> 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)
setComponent -< (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)
setComponent -< (mempty, bNew)
-- If the head of a fixpoint component is not stable, keep iterating.
Unstable ->
go f -< a
-- We are inside an fixpoint component, but its head has not stabilized.
| otherwise -> do
Cache.write -< (a,b,Unstable)
setComponent -< (Component { head = H.delete a (head component),
body = H.insert a (body component) }, b)
detectLoop :: (LowerBounded b, ArrowStack a c, ArrowCache a b c, ArrowIterate a c, ArrowChoice c) => IterationStrategy c a b
detectLoop f = proc a -> do
loop <- Stack.elem -< a
if loop
then do
m <- Cache.lookup -< a
case m of
Just (Stable,b) -> returnA -< b
Just (Unstable,b) -> iterate -< (a, b)
Nothing -> iterate -< (a, bottom)
else Stack.push f -< a
{-# INLINE detectLoop #-}
newtype ChaoticT a c x y = ChaoticT (WriterT (Component a) c x y)
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowStack a,ArrowCache a b,ArrowReuse a b,ArrowState s,ArrowContext ctx a)
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowStack a,ArrowCache a b,ArrowReuse a b,ArrowState s,ArrowContext ctx, ArrowJoinContext u)
instance (Identifiable a, Arrow c, Profunctor c) => ArrowIterate a (ChaoticT a c) where
instance (Identifiable a, Arrow c, Profunctor c) => ArrowChaotic a (ChaoticT a c) where
iterate = lift (arr (first singleton))
{-# INLINE iterate #-}
instance (Identifiable a, Arrow c, Profunctor c) => ArrowComponent a (ChaoticT a c) where
setComponent = lift id
withComponent f g = lift $ proc a -> do
(component,b) <- unlift f -< a
unlift g -< (a,b,component)
{-# INLINE iterate #-}
{-# INLINE setComponent #-}
{-# INLINE withComponent #-}
......
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
......@@ -12,96 +12,51 @@ import Prelude hiding (lookup,truncate,(.),id)
import Control.Category
import Control.Arrow
import Control.Arrow.Fix
import Control.Arrow.Fix.Context
import Control.Arrow.Fix.Cache
import Control.Arrow.Trans
import Control.Arrow.Reader
import Control.Arrow.State
import Control.Arrow.Order
import Control.Arrow.Transformer.Reader
import Control.Arrow.Transformer.State
import Data.Abstract.CallString
import qualified Data.Abstract.Widening as W
import Data.HashMap.Lazy (HashMap)
import qualified Data.HashMap.Lazy as M
import Data.Profunctor.Unsafe
import Data.Coerce
import Data.Empty
import Data.Order hiding (lub)
import Data.Identifiable
callsiteSensitive :: forall a lab b c. ArrowContext (CallString lab) a c => Int -> (a -> lab) -> Widening c a -> IterationStrategy c a b
callsiteSensitive k getLabel = callsiteSensitive' k (Just . getLabel)
{-# INLINE callsiteSensitive #-}
callsiteSensitive' :: forall a lab b c. ArrowContext (CallString lab) a c => Int -> (a -> Maybe lab) -> Widening c a -> IterationStrategy c a b
callsiteSensitive' k getLabel widen = recordCallsite k getLabel . joinByContext' widen
{-# INLINE callsiteSensitive' #-}
recordCallsite :: forall a lab b c. ArrowContext (CallString lab) a c => Int -> (a -> Maybe lab) -> IterationStrategy c a b
recordCallsite k getLabel f = proc a -> do
callString <- askContext -< ()
let callString' = case getLabel a of
Just lab -> truncate k (push lab callString)
Nothing -> callString
localContext f -< (callString',a)
{-# INLINE recordCallsite #-}
newtype ContextT ctx c x y = ContextT (ReaderT ctx c x y)
deriving (Category,Arrow,ArrowChoice,Profunctor,ArrowTrans,ArrowCache u b)
newtype ContextT ctx a c x y = ContextT (ReaderT ctx (StateT (HashMap ctx a) c) x y)
deriving (Category,Arrow,ArrowChoice,Profunctor,ArrowTrans,ArrowCache a b)
runContextT :: (IsEmpty ctx, Profunctor c) => ContextT ctx c x y -> c x y
runContextT (ContextT f) = lmap (empty,) (runReaderT f)
{-# INLINE runContextT #-}
instance (Identifiable ctx, PreOrd a, ArrowChoice c, Profunctor c) => ArrowContext ctx a (ContextT ctx a c) where
type Widening (ContextT ctx a c) a = W.Widening a
instance (Arrow c, Profunctor c) => ArrowContext ctx (ContextT ctx c) where
askContext = ContextT ask
localContext (ContextT f) = ContextT (local f)
joinByContext widen = ContextT $ proc a -> do
ctx <- ask -< ()
cache <- get -< ()
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 input.
Just a'
| a a' -> returnA -< a'
| otherwise -> do
-- If there exists the actual input is not smaller than the cached
-- input, widen the input.
let (_,a'') = widen a' a
put -< M.insert ctx a'' cache
returnA -< a''
Nothing -> do
put -< M.insert ctx a cache
returnA -< a
{-# INLINE askContext #-}
{-# INLINE localContext #-}
{-# INLINE joinByContext #-}
runContextT :: (IsEmpty ctx, Profunctor c) => ContextT ctx a c x y -> c x y
runContextT (ContextT f) = dimap (\x -> (empty,(empty,x))) snd (runStateT (runReaderT f))
{-# INLINE runContextT #-}
instance ArrowLift (ContextT ctx a) where
lift' = ContextT . lift' . lift'
instance ArrowLift (ContextT ctx) where
lift' = ContextT . lift'
{-# INLINE lift' #-}
instance (IsEmpty ctx, ArrowRun c) => ArrowRun (ContextT ctx a c) where
type Run (ContextT ctx a c) x y = Run c x y