Commit 06ec9f0e authored by Sven Keidel's avatar Sven Keidel

add a transformer that records a control-flow graph

parent b097051d
Pipeline #30910 passed with stages
in 42 minutes and 44 seconds
......@@ -19,6 +19,7 @@ dependencies:
- union-find
- deepseq
- profunctors
- fgl
library:
ghc-options:
......
{-# LANGUAGE Arrows #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FunctionalDependencies #-}
module Control.Arrow.Fix.ControlFlow where
import Control.Arrow
import Control.Arrow.Fix
import Control.Arrow.Trans
import Data.Profunctor
class (Arrow c, Profunctor c) => ArrowControlFlow stmt c | c -> stmt where
-- | Adds a control-flow edge between the previously evaluated statement and the next statement.
-- For example, @(nextStatement -< e1; nextStatement -< e2)@ adds an CFG edge between @e1@ and @e2@.
nextStatement :: c stmt ()
default nextStatement :: (c ~ t c', ArrowLift t, ArrowControlFlow stmt c') => c stmt ()
nextStatement = lift' nextStatement
-- | Records the trace of the abstract interpreter as an control-flow graph.
recordControlFlowGraph :: ArrowControlFlow stmt c => (a -> stmt) -> FixpointCombinator c a b
recordControlFlowGraph getStatement f = proc a -> do
nextStatement -< getStatement a
f -< a
{-# INLINE recordControlFlowGraph #-}
......@@ -13,41 +13,42 @@
{-# LANGUAGE ScopedTypeVariables #-}
module Control.Arrow.Transformer.Abstract.Fix.Cache.Immutable where
import Prelude hiding (pred,lookup,map,head,iterate,(.),id,truncate,elem,product,(**))
import Control.Category
import Control.Arrow
import Control.Arrow.Const
import Control.Arrow.Trans
import Control.Arrow.State
import Control.Arrow.Fix.Context as Context
import Control.Arrow.Fix.Cache as Cache
import Control.Arrow.Fix.Parallel as Parallel
import Control.Arrow.Order(ArrowJoin(..),ArrowComplete(..),ArrowEffectCommutative)
import Control.Arrow.Transformer.Const
import Control.Arrow.Transformer.Static
import Control.Arrow.Transformer.State
import Data.Profunctor.Unsafe
import Data.Empty
import Data.Order hiding (lub)
import Data.Coerce
import Data.Identifiable
import Data.HashMap.Lazy(HashMap)
import Prelude hiding (pred,lookup,map,head,iterate,(.),id,truncate,elem,product,(**))
import Control.Category
import Control.Arrow
import Control.Arrow.Const
import Control.Arrow.Trans
import Control.Arrow.State
import Control.Arrow.Fix.ControlFlow as ControlFlow
import Control.Arrow.Fix.Context as Context
import Control.Arrow.Fix.Cache as Cache
import Control.Arrow.Fix.Parallel as Parallel
import Control.Arrow.Order (ArrowJoin(..),ArrowComplete(..),ArrowEffectCommutative)
import Control.Arrow.Transformer.Const
import Control.Arrow.Transformer.Static
import Control.Arrow.Transformer.State
import Data.Profunctor.Unsafe
import Data.Empty
import Data.Order hiding (lub)
import Data.Coerce
import Data.Identifiable
import Data.HashMap.Lazy (HashMap)
import qualified Data.HashMap.Lazy as M
import Data.Monoidal
import Data.Maybe
import Data.Monoidal
import Data.Maybe
import Data.Abstract.Stable
import Data.Abstract.Stable
import qualified Data.Abstract.Widening as W
import GHC.Exts
import GHC.Exts
type family Widening c :: *
newtype CacheT cache a b c x y = CacheT { unCacheT :: ConstT (Widening (cache a b)) (StateT (cache a b) c) x y}
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowState (cache a b))
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowState (cache a b),ArrowControlFlow stmt)
instance ArrowTrans (CacheT cache a b c) where
type Underlying (CacheT cache a b c) x y = Widening (cache a b) -> c (cache a b, x) (cache a b, y)
......
......@@ -16,6 +16,7 @@ import Control.Category
import Control.Arrow hiding (loop)
import Control.Arrow.Fix.Chaotic
import Control.Arrow.Fix.Cache as Cache
import Control.Arrow.Fix.ControlFlow
import Control.Arrow.Fix.Stack as Stack
import Control.Arrow.Fix.Context as Context
import Control.Arrow.State
......@@ -29,7 +30,8 @@ import Data.Identifiable
import Data.Coerce
newtype ChaoticT a c x y = ChaoticT (WriterT (Component a) c x y)
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowStack a,ArrowCache a b,ArrowState s,ArrowContext ctx, ArrowJoinContext u)
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowStack a,ArrowCache a b,
ArrowState s,ArrowContext ctx, ArrowJoinContext u, ArrowControlFlow stmt)
instance (Identifiable a, Arrow c, Profunctor c) => ArrowChaotic a (ChaoticT a c) where
setComponent = lift id
......
......@@ -12,6 +12,7 @@ import Prelude hiding (lookup,truncate,(.),id)
import Control.Category
import Control.Arrow
import Control.Arrow.Fix.ControlFlow
import Control.Arrow.Fix.Context
import Control.Arrow.Fix.Cache
import Control.Arrow.Trans
......@@ -26,7 +27,8 @@ import Data.Empty
import Data.Order hiding (lub)
newtype ContextT ctx c x y = ContextT (ReaderT ctx c x y)
deriving (Category,Arrow,ArrowChoice,Profunctor,ArrowTrans,ArrowCache u b)
deriving (Category,Arrow,ArrowChoice,Profunctor,
ArrowTrans,ArrowCache u b,ArrowControlFlow stmt)
runContextT :: (IsEmpty ctx, Profunctor c) => ContextT ctx c x y -> c x y
runContextT (ContextT f) = lmap (empty,) (runReaderT f)
......
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
module Control.Arrow.Transformer.Abstract.Fix.ControlFlow where
import Control.Arrow
import Control.Arrow.Order
import Control.Arrow.Trans
import Control.Arrow.Transformer.State
import Control.Arrow.Fix.ControlFlow
import Control.Category
import Data.Label
import Data.Coerce
import Data.Empty
import Data.Order
import Data.Profunctor.Unsafe
import Data.Graph.Inductive (Gr)
import qualified Data.Graph.Inductive as G
data CFG stmt = CFG
{ graph :: Gr stmt ()
, predecessor :: Maybe stmt
}
instance IsEmpty (CFG stmt) where
empty = CFG { graph = G.empty
, predecessor = Nothing
}
newtype ControlFlowT stmt c x y = ControlFlowT (StateT (CFG stmt) c x y)
deriving (Profunctor,Category,Arrow,ArrowChoice)
instance (HasLabel stmt, Arrow c, Profunctor c) => ArrowControlFlow stmt (ControlFlowT stmt c) where
nextStatement = lift $ proc (cfg,nextStmt) -> do
let cfg' = cfg { graph = addEdge (predecessor cfg) nextStmt (graph cfg)
, predecessor = Just nextStmt
}
returnA -< (cfg', ())
where
addEdge :: HasLabel stmt => Maybe stmt -> stmt -> Gr stmt () -> Gr stmt ()
addEdge pred next cfg = undefined
-- TODO: Add an control-flow edge from @previousStmt@ to @nextStmt@.
-- Be careful, since you might insert the same nodes and edges multiple
-- times (I don't know if this is a problem for FGL graphs).
--
-- TODO: `pred = Nothing` marks the entry point of the control-flow graph.
-- In this case it should suffice to add a control-flow node for `next`.
--
-- TODO: Use `HasLabel.label` to extract the label from statements and use it as node identifiers in the graph.
instance (ArrowRun c) => ArrowRun (ControlFlowT stmt c) where
type Run (ControlFlowT stmt c) x y = Run c x (Gr stmt (),y)
run f = run (dimap (empty,) (first graph) (unlift f))
{-# INLINE run #-}
instance ArrowTrans (ControlFlowT stmt c) where
type Underlying (ControlFlowT stmt c) x y = c (CFG stmt,x) (CFG stmt,y)
instance (Complete y, ArrowEffectCommutative c) => ArrowComplete y (ControlFlowT stmt c) where
ControlFlowT f <> ControlFlowT g = ControlFlowT $ rmap (uncurry ()) (f &&& g)
{-# INLINE (<⊔>) #-}
instance (Profunctor c,ArrowApply c) => ArrowApply (ControlFlowT stmt c) where
app = ControlFlowT (app .# first coerce)
{-# INLINE app #-}
......@@ -16,6 +16,7 @@ import Control.Arrow
import Control.Arrow.Order
import Control.Arrow.State
import Control.Arrow.Trans
import Control.Arrow.Fix.ControlFlow as CF
import Control.Arrow.Fix.Chaotic as Chaotic
import Control.Arrow.Fix.Cache as Cache
import Control.Arrow.Fix.Stack as Stack
......@@ -35,7 +36,7 @@ import Data.Coerce
import Text.Printf
newtype MetricsT a c x y = MetricsT (StateT (Metrics a) c x y)
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowChaotic a)
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowChaotic a,ArrowControlFlow stmt)
data Metrics a = Metrics Int (HashMap a Metric)
......
......@@ -8,30 +8,31 @@
{-# LANGUAGE UndecidableInstances #-}
module Control.Arrow.Transformer.Abstract.Fix.Stack(StackT,Stack) where
import Prelude hiding (pred,lookup,map,head,iterate,(.))
import Prelude hiding (pred,lookup,map,head,iterate,(.))
import Control.Category
import Control.Arrow hiding (loop)
import Control.Arrow.Fix.Parallel as Parallel
import Control.Arrow.Fix.Cache as Cache
import Control.Arrow.Fix.Stack(ArrowStack)
import Control.Category
import Control.Arrow hiding (loop)
import Control.Arrow.Fix.ControlFlow as ControlFlow
import Control.Arrow.Fix.Parallel as Parallel
import Control.Arrow.Fix.Cache as Cache
import Control.Arrow.Fix.Stack (ArrowStack)
import qualified Control.Arrow.Fix.Stack as Stack
import Control.Arrow.Fix.Context(ArrowContext,ArrowJoinContext)
import Control.Arrow.State
import Control.Arrow.Trans
import Control.Arrow.Order(ArrowJoin(..),ArrowComplete(..),ArrowEffectCommutative)
import Control.Arrow.Fix.Context (ArrowContext,ArrowJoinContext)
import Control.Arrow.State
import Control.Arrow.Trans
import Control.Arrow.Order (ArrowJoin(..),ArrowComplete(..),ArrowEffectCommutative)
import Control.Arrow.Transformer.Reader
import Control.Arrow.Transformer.Reader
import Data.Profunctor
import Data.Profunctor.Unsafe((.#))
import Data.Coerce
import Data.Empty
import Data.Profunctor
import Data.Profunctor.Unsafe ((.#))
import Data.Coerce
import Data.Empty
newtype StackT stack a c x y = StackT (ReaderT (stack a) c x y)
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowJoin,ArrowComplete z,
ArrowCache a b,ArrowState s,ArrowTrans,ArrowContext ctx, ArrowJoinContext u,
ArrowParallel)
ArrowParallel,ArrowControlFlow stmt)
data Stack a = Stack
{ elems :: [a]
......
......@@ -15,6 +15,7 @@ import Control.Category
import Control.Arrow
import Control.Arrow.Fix.Chaotic
import Control.Arrow.Fix.Parallel as Parallel
import Control.Arrow.Fix.ControlFlow as CF
import Control.Arrow.Fix.Cache as Cache
import Control.Arrow.Fix.Stack as Stack
import Control.Arrow.Fix.Context as Context
......@@ -29,7 +30,7 @@ import Text.Printf
newtype TraceT c x y = TraceT (c x y)
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowTrans,ArrowComplete z,ArrowJoin,
ArrowEffectCommutative,ArrowChaotic a,ArrowStack a,ArrowContext ctx,ArrowState s)
ArrowEffectCommutative,ArrowChaotic a,ArrowStack a,ArrowContext ctx,ArrowState s,ArrowControlFlow stmt)
instance ArrowParallel c => ArrowParallel (TraceT c) where
nextIteration = TraceT $ proc () ->
......
......@@ -22,6 +22,7 @@ import Control.Arrow.Closure
import Control.Arrow.Except
import Control.Arrow.Fail
import Control.Arrow.Fix
import Control.Arrow.Fix.ControlFlow
import Control.Arrow.Fix.Cache
import Control.Arrow.Fix.Chaotic
import Control.Arrow.Fix.Context
......@@ -45,7 +46,7 @@ newtype ConstT r c x y = ConstT (StaticT ((->) r) c x y)
ArrowState s,ArrowReader r',ArrowWriter w, ArrowLetRec var val,
ArrowEnv var val, ArrowClosure expr cls, ArrowStore var val,
ArrowFail e, ArrowExcept e,
ArrowContext ctx, ArrowStack a, ArrowCache a b, ArrowChaotic a)
ArrowContext ctx, ArrowStack a, ArrowCache a b, ArrowChaotic a,ArrowControlFlow stmt)
constT :: (r -> c x y) -> ConstT r c x y
constT f = ConstT (StaticT f)
......
......@@ -17,6 +17,7 @@ import Control.Arrow.Closure as Cls
import Control.Arrow.Except as Exc
import Control.Arrow.Fail
import Control.Arrow.Fix
import Control.Arrow.Fix.ControlFlow as CF
import Control.Arrow.Fix.Parallel as Parallel
import Control.Arrow.Fix.Cache as Cache
import Control.Arrow.Fix.Context as Context
......@@ -170,5 +171,6 @@ instance ArrowContext ctx c => ArrowContext ctx (ReaderT r c) where
{-# INLINE localContext #-}
instance ArrowJoinContext a c => ArrowJoinContext a (ReaderT r c)
instance (ArrowCache a b c) => ArrowCache a b (ReaderT r c)
instance (ArrowParallel c) => ArrowParallel (ReaderT r c)
instance ArrowCache a b c => ArrowCache a b (ReaderT r c)
instance ArrowParallel c => ArrowParallel (ReaderT r c)
instance ArrowControlFlow stmt c => ArrowControlFlow stmt (ReaderT r c)
......@@ -18,6 +18,7 @@ import Control.Arrow.Closure as Cls
import Control.Arrow.Except as Exc
import Control.Arrow.Fail as Fail
import Control.Arrow.Fix
import Control.Arrow.Fix.ControlFlow as CF
import Control.Arrow.Fix.Chaotic as Chaotic
import Control.Arrow.Fix.Cache as Cache
import Control.Arrow.Fix.Context as Context
......@@ -198,6 +199,7 @@ instance ArrowWidening y c => ArrowWidening y (StateT s c) where
{-# INLINE widening #-}
instance (ArrowCache a b c) => ArrowCache a b (StateT s c)
instance ArrowControlFlow stmt c => ArrowControlFlow stmt (StateT s c)
instance ArrowChaotic a c => ArrowChaotic a (StateT s c) where
setComponent = lift' setComponent
......
......@@ -10,6 +10,7 @@ import Prelude hiding (id,(.),lookup,read,fail,elem)
import Control.Category
import Control.Arrow
import Control.Arrow.Fix.ControlFlow as CF
import Control.Arrow.Fix.Chaotic as Chaotic
import Control.Arrow.Fix.Cache as Cache
import Control.Arrow.Fix.Context as Ctx
......@@ -193,3 +194,6 @@ instance (Applicative f, ArrowChaotic a c) => ArrowChaotic a (StaticT f c) where
{-# INLINE getComponent #-}
{-# SPECIALIZE instance ArrowChaotic a c => ArrowChaotic a (StaticT ((->) r) c) #-}
instance (Applicative f, ArrowControlFlow stmt c) => ArrowControlFlow stmt (StaticT f c) where
{-# SPECIALIZE instance ArrowControlFlow stmt c => ArrowControlFlow stmt (StaticT ((->) r) c) #-}
......@@ -13,6 +13,7 @@ import Prelude hiding (id,(.),lookup,read,fail)
import Control.Category
import Control.Arrow
import Control.Arrow.Const
import Control.Arrow.Fix.ControlFlow as CF
import Control.Arrow.Fix.Cache as Cache
import Control.Arrow.Fix.Stack as Stack
import Control.Arrow.Fix.Context as Context
......@@ -184,3 +185,5 @@ instance (Monoid w, ArrowContext ctx c) => ArrowContext ctx (WriterT w c) where
instance (Monoid w, ArrowJoinContext a c) => ArrowJoinContext a (WriterT w c)
instance (Monoid w, ArrowCache a b c) => ArrowCache a b (WriterT w c)
instance (Monoid w, ArrowControlFlow stmt c) => ArrowControlFlow stmt (WriterT w c)
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