Verified Commit b975af58 authored by Sven Keidel's avatar Sven Keidel
Browse files

add interface to query the CFG.

parent c995774b
Pipeline #65988 failed with stages
in 83 minutes and 38 seconds
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
......@@ -22,6 +23,14 @@ class (Arrow c, Profunctor c) => ArrowControlFlow stmt c | c -> stmt where
-- For example, @(nextStatement -< e1; nextStatement -< e2)@ adds an CFG edge between @e1@ and @e2@.
nextStatement :: c x y -> c (Maybe stmt, x) y
class (Arrow c, Profunctor c) => ArrowCFG graph c | c -> graph where
-- | Get the current control flow graph of the program.
getCFG :: c () graph
default getCFG :: (c ~ t c', ArrowTrans t, ArrowCFG graph c') => c () graph
getCFG = lift' getCFG
{-# INLINE getCFG #-}
-- | 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 -> nextStatement f -< (Just (getStatement a),a)
......@@ -53,3 +62,6 @@ instance (Applicative f, ArrowControlFlow stmt c) => ArrowControlFlow stmt (Stat
instance (Monoid w, ArrowControlFlow stmt c) => ArrowControlFlow stmt (WriterT w c) where
nextStatement f = lift (nextStatement (unlift f))
{-# INLINE nextStatement #-}
instance ArrowCFG graph c => ArrowCFG graph (ConstT r c)
instance ArrowCFG graph c => ArrowCFG graph (ReaderT r c)
......@@ -48,7 +48,7 @@ class (Arrow c, Profunctor c) => ArrowStackDepth c where
{-# INLINE depth #-}
class (Arrow c, Profunctor c) => ArrowStackElements a c where
class (Arrow c, Profunctor c) => ArrowStackElements a c | c -> a where
elems :: c () [a]
peek :: c () (Maybe a)
......
......@@ -186,6 +186,7 @@ parseSExpr val = case val of
LT.List (Atom "string-append": args) -> opvar_ StringAppend (map parseSExpr args)
LT.List (Atom "list": args) -> list (map parseSExpr args)
LT.List [Atom "error", LT.String err] -> error_ err
LT.List [Atom "breakpoint", e] -> breakpoint (parseSExpr e)
LT.List (Atom x: args) -> app (var_ (pack x)) (map parseSExpr args)
LT.List (fun: args) -> app (parseSExpr fun) (map parseSExpr args)
......
......@@ -126,6 +126,7 @@ data Expr
| Op2 Op2 Expr Expr Label
| OpVar OpVar [Expr] Label
| Error String Label
| Breakpoint Expr -- breakpoint z
deriving (Generic,NFData)
instance Eq Expr where
......@@ -172,6 +173,8 @@ opvar_ :: OpVar -> [LExpr] -> LExpr
opvar_ operation es = OpVar operation <$> sequence es <*> fresh
error_ :: String -> LExpr
error_ err = Error err <$> fresh
breakpoint :: LExpr -> LExpr
breakpoint e = Breakpoint <$> e
instance Show Literal where show = show . pretty
......
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