Verified Commit 721273b8 authored by Sven Keidel's avatar Sven Keidel
Browse files

refactor chaotic fixpoint algos to match paper

parent 16c7f920
Pipeline #78695 passed with stages
in 104 minutes and 56 seconds
......@@ -14,117 +14,149 @@ import Prelude hiding (head,iterate,map)
import Control.Arrow hiding (loop)
import Control.Arrow.Fix
import Control.Arrow.Fix.Metrics as Metrics
import Control.Arrow.Fix.SCC as SCC
-- import Control.Arrow.Fix.Metrics as Metrics
import Control.Arrow.Fix.Stack as Stack
import Control.Arrow.Fix.Cache as Cache
import Control.Arrow.Trans
import Control.Arrow.Transformer.Const
import Control.Arrow.Transformer.Reader
import Control.Arrow.Transformer.State
import Control.Arrow.Transformer.Static
import Data.Abstract.Stable
import Data.Profunctor
import Data.Monoidal
class (Arrow c, Profunctor c) => ArrowComponent a c where
addToComponent :: c (a,StackPointer) ()
default addToComponent :: (c ~ t c', ArrowTrans t, ArrowComponent a c') => c (a,StackPointer) ()
addToComponent = lift' addToComponent
{-# INLINE addToComponent #-}
data InComponent = Empty | Head Nesting | Body deriving (Show)
data Nesting = Inner | Outermost deriving (Show)
class ArrowComponent a c => ArrowInComponent a c | c -> a where
inComponent :: c x y -> c (a,x) (InComponent,y)
inComponent' :: ArrowInComponent a c => c a b -> c a (InComponent,b)
inComponent' f = lmap (\a -> (a,a)) (inComponent f)
{-# INLINE inComponent' #-}
type IterationStrategy c a b = c a b -> c (Stable,a,b) b -> c a b
innermost :: (ArrowChoice c, ArrowInComponent a c) => IterationStrategy c a b
innermost f iterate = proc a -> do
(inComp,b) <- inComponent' f -< a
case inComp of
Head Outermost -> do
iterate -< (Stable,a,b)
Head Inner -> do
iterate -< (Unstable,a,b)
_ -> returnA -< b
{-# INLINE innermost #-}
{-# SCC innermost #-}
innermost' :: (ArrowChoice c, ArrowMetrics a c, ArrowInComponent a c) => IterationStrategy c a b
innermost' f iterate = innermost f $ proc (st,a,b) -> do
Metrics.iterated -< a
iterate -< (st,a,b)
{-# INLINE innermost' #-}
outermost :: (ArrowChoice c, ArrowInComponent a c) => IterationStrategy c a b
outermost f iterate = proc a -> do
(inComp,b) <- inComponent' f -< a
case inComp of
Head Outermost -> do
iterate -< (Stable,a,b)
Head Inner ->
returnA -< b
_ ->
innermost :: forall c a b.
(?cacheWidening :: Widening c, ArrowChoice c,
ArrowSCC a c, ArrowStack a c, ArrowCache a b c)
=> FixpointCombinator c a b
innermost f = proc call -> do
resultCached <- Cache.lookup -< call
recurrentCall <- Stack.elem -< call
case (resultCached, recurrentCall) of
(Just (Stable,b), _) -> returnA -< b
(Just (Unstable,b), RecurrentCall ptr) -> do
SCC.add -< (call, ptr)
returnA -< b
{-# INLINE outermost #-}
{-# SCC outermost #-}
outermost' :: (ArrowChoice c, ArrowMetrics a c, ArrowInComponent a c) => IterationStrategy c a b
outermost' f iterate = outermost f $ proc (st,a,b) -> do
Metrics.iterated -< a
iterate -< (st,a,b)
{-# INLINE outermost' #-}
-- | Iterate on the innermost fixpoint component.
chaotic :: forall a b c.
(?cacheWidening :: Widening c, ArrowChoice c, ArrowComponent a c, ArrowStack a c, ArrowCache a b c)
=> IterationStrategy c a b -> FixpointCombinator c a b
chaotic iterationStrategy f = proc a -> do
m <- Cache.lookup &&& Stack.elem -< a
case m of
(Nothing, RecurrentCall ptr) -> do
SCC.add -< (call, ptr)
Cache.initialize -< call
(_, NoLoop) -> do
iterate -< call
where
iterate :: c a b
iterate = proc call -> do
resultNew <- Stack.push' f -< call
callInSCC <- SCC.elem -< call
case callInSCC of
InSCC ptr -> do
sccSize <- SCC.size -< ()
let stable = if sccSize == 1 then Stable else Unstable
(resultGrown, callNew, resultWidened) <- Cache.update -< (stable, call, resultNew)
case resultGrown of
Stable -> do
SCC.remove -< (call, ptr)
returnA -< resultWidened
Unstable ->
iterate -< callNew
NotInSCC ->
returnA -< resultNew
{-# INLINABLE innermost #-}
outermost :: forall c a b.
(?cacheWidening :: Widening c, ArrowChoice c,
ArrowSCC a c, ArrowStack a c, ArrowCache a b c)
=> FixpointCombinator c a b
outermost f = proc call -> do
resultCached <- Cache.lookup -< call
recurrentCall <- Stack.elem -< call
case (resultCached, recurrentCall) of
(Just (Stable,b), _) -> returnA -< b
(Just (Unstable,b), RecurrentCall ptr) -> do
addToComponent -< (a,ptr)
SCC.add -< (call, ptr)
returnA -< b
(Nothing, RecurrentCall ptr) -> do
addToComponent -< (a,ptr)
Cache.initialize -< a
SCC.add -< (call, ptr)
Cache.initialize -< call
(_, NoLoop) -> do
iterate -< a
iterate -< call
where
iterate :: c a b
iterate = iterationStrategy (Stack.push' f) $ proc (stable,a,b) -> do
(stable',aNew,bNew) <- Cache.update -< (stable,a,b)
case stable' of
Stable -> returnA -< bNew
Unstable -> iterate -< aNew
{-# SCC iterate #-}
{-# INLINABLE iterate #-}
{-# INLINE chaotic #-}
{-# SCC chaotic #-}
------------- Instances --------------
instance ArrowComponent a c => ArrowComponent a (ConstT r c)
instance ArrowComponent a c => ArrowComponent a (ReaderT r c)
instance ArrowInComponent a c => ArrowInComponent a (ReaderT r c) where
inComponent f = lift $ lmap shuffle1 (inComponent (unlift f))
{-# INLINE inComponent #-}
instance ArrowComponent a c => ArrowComponent a (StateT s c)
instance ArrowInComponent a c => ArrowInComponent a (StateT s c) where
inComponent f = lift $ dimap shuffle1 shuffle1 (inComponent (unlift f))
{-# INLINE inComponent #-}
iterate = proc call -> do
resultNew <- Stack.push' f -< call
callInSCC <- SCC.elem -< call
sccSize <- SCC.size -< ()
case callInSCC of
InSCC ptr | sccSize == 1 -> do
(resultGrown, callNew, resultWidened) <- Cache.update -< (Stable, call, resultNew)
case resultGrown of
Stable -> do
SCC.remove -< (call, ptr)
returnA -< resultWidened
Unstable ->
iterate -< callNew
_ -> returnA -< resultNew
{-# INLINABLE outermost #-}
-- type IterationStrategy c a b = c a b -> c (Stable,a,b) b -> c a b
-- innermost :: (ArrowChoice c, ArrowInComponent a c) => IterationStrategy c a b
-- innermost f iterate = proc a -> do
-- (inComp,b) <- inComponent' f -< a
-- case inComp of
-- Head Outermost -> do
-- iterate -< (Stable,a,b)
-- Head Inner -> do
-- iterate -< (Unstable,a,b)
-- _ -> returnA -< b
-- {-# INLINE innermost #-}
-- {-# SCC innermost #-}
-- innermost' :: (ArrowChoice c, ArrowMetrics a c, ArrowInComponent a c) => IterationStrategy c a b
-- innermost' f iterate = innermost f $ proc (st,a,b) -> do
-- Metrics.iterated -< a
-- iterate -< (st,a,b)
-- {-# INLINE innermost' #-}
-- outermost :: (ArrowChoice c, ArrowInComponent a c) => IterationStrategy c a b
-- outermost f iterate = proc a -> do
-- (inComp,b) <- inComponent' f -< a
-- case inComp of
-- Head Outermost -> do
-- iterate -< (Stable,a,b)
-- Head Inner ->
-- returnA -< b
-- _ ->
-- returnA -< b
-- {-# INLINE outermost #-}
-- {-# SCC outermost #-}
-- outermost' :: (ArrowChoice c, ArrowMetrics a c, ArrowInComponent a c) => IterationStrategy c a b
-- outermost' f iterate = outermost f $ proc (st,a,b) -> do
-- Metrics.iterated -< a
-- iterate -< (st,a,b)
-- {-# INLINE outermost' #-}
-- -- | Iterate on the innermost fixpoint component.
-- chaotic :: forall a b c.
-- (?cacheWidening :: Widening c, ArrowChoice c, ArrowSCC a c, ArrowStack a c, ArrowCache a b c)
-- => IterationStrategy c a b -> FixpointCombinator c a b
-- chaotic iterationStrategy f = proc a -> do
-- m <- Cache.lookup &&& Stack.elem -< a
-- case m of
-- (Just (Stable,b), _) -> returnA -< b
-- (Just (Unstable,b), RecurrentCall ptr) -> do
-- SCC.add -< (a,ptr)
-- returnA -< b
-- (Nothing, RecurrentCall ptr) -> do
-- SCC.add -< (a,ptr)
-- Cache.initialize -< a
-- (_, NoLoop) -> do
-- iterate -< a
-- where
-- iterate :: c a b
-- iterate = iterationStrategy (Stack.push' f) $ proc (stable,a,b) -> do
-- (resultGrown,aNew,bNew) <- Cache.update -< (stable,a,b)
-- case resultGrown of
-- Stable -> returnA -< bNew
-- Unstable -> iterate -< aNew
-- {-# SCC iterate #-}
-- {-# INLINABLE iterate #-}
-- {-# INLINE chaotic #-}
-- {-# SCC chaotic #-}
instance (Applicative f, ArrowComponent a c) => ArrowComponent a (StaticT f c) where
{-# SPECIALIZE instance ArrowComponent a c => ArrowComponent a (StaticT ((->) r) c) #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Control.Arrow.Fix.SCC where
import Prelude hiding (head,iterate,map,elem)
import Control.Arrow hiding (loop)
import Control.Arrow.Fix.Stack (StackPointer)
import Control.Arrow.Trans
import Control.Arrow.Transformer.Const
import Control.Arrow.Transformer.Reader
import Control.Arrow.Transformer.State
import Control.Arrow.Transformer.Static
import Data.Profunctor
class (Arrow c, Profunctor c) => ArrowSCC a c | c -> a where
-- | Adds an element to the strongly-connected component. The stack pointer
-- indicates where the element occurs on the stack. This allows to implement
-- SCCs more efficiently with bit sets.
add :: c (a,StackPointer) ()
-- | Removes an element from the strongly-connected component. The stack pointer
-- indicates where the element occurs on the stack. This allows to implement
-- SCCs more efficiently with bit sets.
remove :: c (a,StackPointer) ()
-- | Checks if a the current call is in the SCC.
elem :: c a ElementSCC
-- | Returns the size of the current SCC.
size :: c () Int
default add :: (c ~ t c', ArrowTrans t, ArrowSCC a c') => c (a,StackPointer) ()
default remove :: (c ~ t c', ArrowTrans t, ArrowSCC a c') => c (a,StackPointer) ()
default elem :: (c ~ t c', ArrowTrans t, ArrowSCC a c') => c a ElementSCC
default size :: (c ~ t c', ArrowTrans t, ArrowSCC a c') => c () Int
add = lift' add
remove = lift' remove
elem = lift' elem
size = lift' size
{-# INLINE add #-}
{-# INLINE remove #-}
{-# INLINE elem #-}
{-# INLINE size #-}
data ElementSCC = InSCC StackPointer | NotInSCC
------------- Instances --------------
instance ArrowSCC a c => ArrowSCC a (ConstT r c)
instance ArrowSCC a c => ArrowSCC a (ReaderT r c)
instance ArrowSCC a c => ArrowSCC a (StateT s c)
instance (Applicative f, ArrowSCC a c) => ArrowSCC a (StaticT f c) where
......@@ -19,7 +19,7 @@ import Control.Arrow.Primitive
import Control.Arrow.Strict
import Control.Arrow.Fix
import Control.Arrow.Fix.Cache
import Control.Arrow.Fix.Chaotic
import Control.Arrow.Fix.SCC
import Control.Arrow.Fix.ControlFlow
import Control.Arrow.Fix.Context
import Control.Arrow.Fix.Metrics
......@@ -38,8 +38,7 @@ newtype FixT c x y = FixT (c x y)
deriving (Profunctor,Category,Arrow,ArrowChoice,
ArrowContext ctx, ArrowJoinContext a, ArrowControlFlow a,
ArrowCache a b, ArrowParallelCache a b, ArrowIterateCache a b, ArrowGetCache cache,
ArrowStack a,ArrowStackElements a,ArrowStackDepth,
ArrowComponent a, ArrowInComponent a,
ArrowStack a,ArrowStackElements a,ArrowStackDepth, ArrowSCC a,
ArrowMetrics a, ArrowStrict, ArrowPrimitive, ArrowCFG a)
runFixT :: FixT c x y -> c x y
......
......@@ -18,7 +18,7 @@ import Control.Category
import Control.Arrow hiding (loop)
import Control.Arrow.Primitive
import Control.Arrow.Strict
import Control.Arrow.Fix.Chaotic
import Control.Arrow.Fix.SCC
import Control.Arrow.Fix.Cache as Cache
import Control.Arrow.Fix.ControlFlow
import Control.Arrow.Fix.Stack as Stack
......@@ -86,12 +86,21 @@ instance Monoid (Component a) where
mempty = Component 0
mappend = (<>)
instance (Arrow c, Profunctor c) => ArrowComponent a (ComponentT Component a c) where
addToComponent = lift $ arr $ \(Component comp,(_,pointer)) ->
instance (Arrow c, Profunctor c) => ArrowSCC a (ComponentT Component a c) where
add = lift $ proc (Component comp,(_,pointer)) -> do
let comp' = (shiftL (1 :: Integer) pointer .|. comp)
in (Component comp', ())
{-# INLINE addToComponent #-}
{-# SCC addToComponent #-}
returnA -< (Component comp', ())
{-# INLINE add #-}
remove = lift $ proc (Component comp, (_, pointer)) -> do
let comp' = (complement (shiftL (1 :: Integer) pointer) .&. comp)
returnA -< (Component comp', ())
elem = lift $ proc (Component comp, _) -> do
returnA -< (Component comp, if testBit comp 0 then InSCC 0 else NotInSCC)
size = lift $ proc (Component comp, _) -> do
returnA -< (Component comp, popCount comp)
instance (Identifiable a, ArrowStack a c) => ArrowStack a (ComponentT Component a c) where
push f = lift $ proc (comp,(a,x)) -> do
......@@ -100,18 +109,17 @@ instance (Identifiable a, ArrowStack a c) => ArrowStack a (ComponentT Component
where
pop (Component comp) = Component (shiftR comp 1)
{-# INLINE push #-}
{-# SCC push #-}
instance (Arrow c, Profunctor c) => ArrowInComponent a (ComponentT Component a c) where
inComponent f = lift $ dimap (second snd) (\(comp, y) -> (comp,(isInComponent comp,y))) (unlift f)
where
isInComponent (Component comp)
| comp == 0 = Empty
| comp == 1 = Head Outermost
| testBit comp 0 = Head Inner
| otherwise = Body
{-# INLINE inComponent #-}
{-# SCC inComponent #-}
-- instance (Arrow c, Profunctor c) => ArrowInComponent a (ComponentT Component a c) where
-- inComponent f = lift $ dimap (second snd) (\(comp, y) -> (comp,(isInComponent comp,y))) (unlift f)
-- where
-- isInComponent (Component comp)
-- | comp == 0 = Empty
-- | comp == 1 = Head Outermost
-- | testBit comp 0 = Head Inner
-- | otherwise = Body
-- {-# INLINE inComponent #-}
-- {-# SCC inComponent #-}
......
......@@ -15,7 +15,7 @@ import Control.Arrow.Primitive
import Control.Arrow.Trans
import Control.Arrow.Transformer.State
import Control.Arrow.Transformer.Reader
import Control.Arrow.Fix.Chaotic as Chaotic
import Control.Arrow.Fix.SCC as SCC
import Control.Arrow.Fix.Cache as Cache
import Control.Arrow.Fix.Context (ArrowContext,ArrowJoinContext)
import Control.Arrow.Fix.ControlFlow
......@@ -42,7 +42,7 @@ newtype ControlFlowT stmt c x y = ControlFlowT (StateT (CFG stmt) (ReaderT (Mayb
Profunctor, Category, Arrow, ArrowChoice, ArrowContext ctx,
ArrowCache a b, ArrowParallelCache a b, ArrowIterateCache a b,
ArrowJoinContext u, ArrowStackDepth, ArrowStackElements a,
ArrowMetrics a, ArrowComponent a, ArrowInComponent a,
ArrowMetrics a, ArrowSCC a,
ArrowPrimitive
)
......
......@@ -12,7 +12,7 @@
{-# LANGUAGE UndecidableInstances #-}
module Control.Arrow.Transformer.Abstract.Fix.Metrics where
import Prelude hiding (pred,lookup,map,head,iterate,(.),id,truncate,elem,product,(**))
import Prelude hiding (pred,lookup,map,head,iterate,(.),id,truncate,elem,product,(**),elem)
import Control.Category
import Control.Arrow
......@@ -23,7 +23,7 @@ import Control.Arrow.Trans
import Control.Arrow.Fix.Metrics (ArrowMetrics)
import qualified Control.Arrow.Fix.Metrics as F
import Control.Arrow.Fix.ControlFlow as CF
import Control.Arrow.Fix.Chaotic as Chaotic
import Control.Arrow.Fix.SCC as SCC
import Control.Arrow.Fix.Cache as Cache
import Control.Arrow.Fix.Stack as Stack
import Control.Arrow.Fix.Context(ArrowContext)
......@@ -45,7 +45,7 @@ import Data.Abstract.MonotoneStore(Store)
newtype MetricsT metric a c x y = MetricsT (StateT (metric a) c x y)
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowLowerBounded z,
ArrowComponent a,ArrowInComponent a,ArrowControlFlow stmt,
ArrowSCC a, ArrowControlFlow stmt,
ArrowStackDepth,ArrowStackElements a,ArrowContext ctx,ArrowTopLevel,
ArrowGetCache cache, ArrowPrimitive, ArrowCFG graph)
......@@ -131,7 +131,7 @@ instance (Identifiable a, Arrow c,Profunctor c) => ArrowMetrics a (MetricsT Metr
instance (Identifiable a, ArrowStack a c) => ArrowStack a (MetricsT Metrics a c) where
elem = MetricsT $ proc a -> do
modifyMetric incrementStackLookups -< a
lift' elem -< a
lift' Stack.elem -< a
push f = lift $ lmap (\(m, (a, x)) -> (a, (m, x))) (push (unlift f))
{-# INLINE elem #-}
{-# INLINE push #-}
......@@ -225,7 +225,7 @@ instance (Identifiable a', Arrow c,Profunctor c) => ArrowMetrics (a,a') (Metrics
instance (Identifiable b, ArrowStack (a,b) c) => ArrowStack (a,b) (MetricsT Monotone (a,b) c) where
elem = MetricsT $ proc x@(_,b) -> do
modifyMetric' incrementStackLookups -< b
lift' elem -< x
lift' Stack.elem -< x
push f = lift $ lmap (\(m, (a, x)) -> (a, (m, x))) (push (unlift f))
{-# INLINE elem #-}
{-# INLINE push #-}
......
......@@ -14,7 +14,7 @@ import Prelude hiding (pred,lookup,map,head,iterate,(.),truncate,log)
import Control.Category
import Control.Arrow hiding ((<+>))
import Control.Arrow.Fix.Chaotic
import Control.Arrow.Fix.SCC
import Control.Arrow.Fix.ControlFlow as CF
import Control.Arrow.Fix.Cache as Cache
import Control.Arrow.Fix.Stack as Stack
......@@ -32,8 +32,7 @@ import Data.Text.Prettyprint.Doc
newtype TraceT c x y = TraceT (c x y)
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowLift, ArrowLowerBounded b,
ArrowComponent a, ArrowInComponent a,
ArrowContext ctx,ArrowState s,ArrowControlFlow stmt,
ArrowSCC a, ArrowContext ctx,ArrowState s,ArrowControlFlow stmt,
ArrowTopLevel,ArrowStackDepth,ArrowStackElements a, ArrowMetrics a)
log :: Arrow c => c (Doc ann) ()
......
......@@ -64,13 +64,13 @@ spec =
callsiteSpec $ \f a ->
let ?contextWidening = ?widenA
?cacheWidening = T.widening ?widenB in
let ?fixpointAlgorithm = fixpointAlgorithm (callsiteSensitive ?sensitivity fst . chaotic innermost) in
let ?fixpointAlgorithm = fixpointAlgorithm (callsiteSensitive ?sensitivity fst . innermost) in
snd $ Arrow.run (f :: ChaoticT _ _ _) a
describe "outer component" $
callsiteSpec $ \f a ->
let ?contextWidening = ?widenA
?cacheWidening = T.widening ?widenB in
let ?fixpointAlgorithm = fixpointAlgorithm (callsiteSensitive ?sensitivity fst . chaotic outermost) in
let ?fixpointAlgorithm = fixpointAlgorithm (callsiteSensitive ?sensitivity fst . outermost) in
snd $ Arrow.run (f :: ChaoticT _ _ _) a
data Val = Num IV | Unit | Top deriving (Show,Eq,Generic,Hashable)
......
......@@ -15,7 +15,8 @@ import Control.Arrow.Fix.Stack (ArrowStack,ArrowStackDepth,ArrowStackE
import qualified Control.Arrow.Fix.Stack as Stack
import Control.Arrow.Fix.Cache (ArrowCache,ArrowParallelCache)
import qualified Control.Arrow.Fix.Cache as Cache
import Control.Arrow.Fix.Chaotic (ArrowInComponent,chaotic,innermost,outermost)
import Control.Arrow.Fix.SCC (ArrowSCC)
import Control.Arrow.Fix.Chaotic (innermost,outermost)
import Control.Arrow.Fix.Parallel (parallel,adi)
import qualified Control.Arrow.Trans as Arrow
import Control.Arrow.Transformer.Abstract.Terminating
......@@ -53,8 +54,8 @@ spec =
describe "Parallel" $ fixpointSpec "parallel" (runParallel parallel)
describe "ADI" $ fixpointSpec "adi" (runParallel adi)
describe "Chaotic" $ do
describe "innermost component" $ fixpointSpec "innermost" (runChaotic (chaotic innermost))
describe "outermost component" $ fixpointSpec "outermost" (runChaotic (chaotic outermost))
describe "innermost component" $ fixpointSpec "innermost" (runChaotic innermost)
describe "outermost component" $ fixpointSpec "outermost" (runChaotic outermost)
fixpointSpec :: String -> (forall a b. (Pretty a, Pretty b, Identifiable a, Complete b, ?strat :: Strat a b, ?widen :: Widening b) => Arr a b -> a -> (Metrics a,Terminating b)) -> Spec
fixpointSpec algName eval = sharedSpec $ \name f a -> do
......@@ -161,7 +162,7 @@ type ChaoticT a b =
runChaotic :: forall a b.
(forall x y c. (Pretty x, Pretty y, Identifiable x, ArrowChoice c,
ArrowStack x c, ArrowStackDepth c, ArrowStackElements x c,
ArrowInComponent x c, ArrowCache x y c,
ArrowSCC x c, ArrowCache x y c,
?cacheWidening :: Cache.Widening c) =>
FixpointCombinator c x y)
-> ((Pretty a, Pretty b, Identifiable a, Complete b,
......
......@@ -24,7 +24,7 @@ import Control.Arrow hiding ((<+>))
import Control.Arrow.Fail as Fail
import Control.Arrow.Environment(extend')
import Control.Arrow.Fix as Fix
import Control.Arrow.Fix.Chaotic(chaotic,innermost)
import Control.Arrow.Fix.Chaotic(innermost)
import qualified Control.Arrow.Fix.Context as Ctx
import Control.Arrow.Trans
import Control.Arrow.Closure (ArrowClosure,IsClosure(..))
......@@ -91,7 +91,7 @@ data Val = NumVal IV | ClosureVal Cls | TypeError (Pow String) deriving (Eq, Gen
type In = (Store, (Env, Expr))
type Out = (Store, Terminating (Error (Pow String) Val))
type Interp =
type Interp =
(ValueT Val
(ErrorT (Pow String)
(TerminatingT
......@@ -114,7 +114,7 @@ evalInterval env0 e =
-- traceShow .
-- traceCache show .
Ctx.recordCallsite ?sensitivity (\(_,(_,expr)) -> case expr of App _ _ l -> Just l; _ -> Nothing) .
filter isFunctionBody (chaotic innermost)
filter isFunctionBody innermost
in
snd $ run (extend' (Generic.eval :: Interp Expr Val)) (alloc,widenVal) (Map.empty,(Map.empty,(env0,e0)))
where
......
......@@ -23,30 +23,18 @@ import Control.Category
import Control.Arrow hiding (loop)
import Control.Arrow.Primitive
import Control.Arrow.Strict
import Control.Arrow.Fix
import Control.Arrow.Fix.Cache
import Control.Arrow.Fix.Chaotic
import Control.Arrow.Fix.ControlFlow
import Control.Arrow.Fix.Context
import Control.Arrow.Fix.Metrics
import Control.Arrow.Fix.Stack as Stack
import Control.Arrow.Order(ArrowComplete(..),ArrowJoin(..))
import Control.Arrow.Trans
import Control.Arrow.IO
import Data.Profunctor
import Data.Profunctor.Unsafe((.#))
import Data.Coerce
import Data.Order hiding (lub)
import Syntax (LExpr,Expr(App))
import qualified Network.HTTP.Types as Http
import qualified Network.Wai as Wai
import qualified Network.Wai.Handler.Warp as Warp
import qualified Network.Wai.Handler.WebSockets as WS
import qualified Network.WebSockets as WS
import qualified Safe
<