Commit b8560f72 authored by Tobias Leon Hombücher's avatar Tobias Leon Hombücher
Browse files

refactor scheme concerning context sensitivity refactoring

parent 34d54bf1
Pipeline #79349 passed with stages
in 105 minutes and 44 seconds
...@@ -62,7 +62,7 @@ data DebugState = DebugState { ...@@ -62,7 +62,7 @@ data DebugState = DebugState {
newtype DebugT c x y = DebugT (StateT DebugState c x y) newtype DebugT c x y = DebugT (StateT DebugState c x y)
deriving (Profunctor,Category,Arrow,ArrowChoice, deriving (Profunctor,Category,Arrow,ArrowChoice,
ArrowContext ctx, ArrowJoinContext a, ArrowControlFlow a, ArrowContext ctx a', ArrowCallSite lab, ArrowControlFlow a,
ArrowCache a b, ArrowParallelCache a b, ArrowIterateCache a b, ArrowGetCache cache, ArrowCache a b, ArrowParallelCache a b, ArrowIterateCache a b, ArrowGetCache cache,
ArrowStack a,ArrowStackElements a,ArrowStackDepth, ArrowSCC a, ArrowStack a,ArrowStackElements a,ArrowStackDepth, ArrowSCC a,
ArrowMetrics a, ArrowStrict, ArrowPrimitive, ArrowCFG a) ArrowMetrics a, ArrowStrict, ArrowPrimitive, ArrowCFG a)
......
...@@ -44,7 +44,7 @@ import Control.Arrow.Transformer.Abstract.FiniteEnvStore hiding (Env) ...@@ -44,7 +44,7 @@ import Control.Arrow.Transformer.Abstract.FiniteEnvStore hiding (Env)
import Control.Arrow.Transformer.Abstract.LogError import Control.Arrow.Transformer.Abstract.LogError
import Control.Arrow.Transformer.Abstract.Fix import Control.Arrow.Transformer.Abstract.Fix
import Control.Arrow.Transformer.Abstract.Fix.Component as Comp import Control.Arrow.Transformer.Abstract.Fix.Component as Comp
import Control.Arrow.Transformer.Abstract.Fix.Context import Control.Arrow.Transformer.Abstract.Fix.CallSite
import Control.Arrow.Transformer.Abstract.Fix.Stack --as Stack import Control.Arrow.Transformer.Abstract.Fix.Stack --as Stack
import Control.Arrow.Transformer.Abstract.Fix.Cache.Immutable as Cache import Control.Arrow.Transformer.Abstract.Fix.Cache.Immutable as Cache
import Control.Arrow.Transformer.Abstract.Fix.Metrics as Metric import Control.Arrow.Transformer.Abstract.Fix.Metrics as Metric
...@@ -120,7 +120,7 @@ type InterpT c x y = ...@@ -120,7 +120,7 @@ type InterpT c x y =
(ComponentT Comp.Component In (ComponentT Comp.Component In
(StackT Stack In (StackT Stack In
(CacheT Cache.Monotone In Out (CacheT Cache.Monotone In Out
(ContextT Ctx (CallSiteT Label
(ControlFlowT Expr (ControlFlowT Expr
c)))))))))))) x y c)))))))))))) x y
...@@ -258,7 +258,7 @@ evalDebug expr = ...@@ -258,7 +258,7 @@ evalDebug expr =
let ?fixpointAlgorithm = transform $ let ?fixpointAlgorithm = transform $
Fix.fixpointAlgorithm $ Fix.fixpointAlgorithm $
debug . debug .
Ctx.recordCallsite ?sensitivity (\(_,(_,exprs)) -> case exprs of App _ _ l:_ -> Just l; _ -> Nothing) . Fix.filter isApplication (Ctx.recordCallSite ?sensitivity (\(_,(_,exprs)) -> label $ head exprs)) .
recordControlFlowGraph' (\(_,(_,exprs)) -> case exprs of e':_ -> Just e'; _ -> Nothing) . recordControlFlowGraph' (\(_,(_,exprs)) -> case exprs of e':_ -> Just e'; _ -> Nothing) .
Fix.filter' isFunctionBody innermost in Fix.filter' isFunctionBody innermost in
do _ <- Trans.run (Generic.runFixed :: InterpT IO [Expr] Val) (?debugState, (empty, (empty, e0))) do _ <- Trans.run (Generic.runFixed :: InterpT IO [Expr] Val) (?debugState, (empty, (empty, e0)))
......
...@@ -354,4 +354,3 @@ instance HasLabel Expr where ...@@ -354,4 +354,3 @@ instance HasLabel Expr where
instance Hashable Expr where instance Hashable Expr where
hashWithSalt s e = s `hashWithSalt` label e hashWithSalt s e = s `hashWithSalt` label e
...@@ -77,7 +77,7 @@ import GHC.Generics(Generic) ...@@ -77,7 +77,7 @@ import GHC.Generics(Generic)
import Text.Printf import Text.Printf
import Syntax (LExpr,Expr(Apply),Literal(..) ,Op1(..),Op2(..),OpVar(..)) import Syntax (LExpr,Expr(Apply,App),Literal(..) ,Op1(..),Op2(..),OpVar(..))
import GenericInterpreter as Generic import GenericInterpreter as Generic
type Cls = Closure Expr (HashSet Env) type Cls = Closure Expr (HashSet Env)
...@@ -124,16 +124,16 @@ data Number ...@@ -124,16 +124,16 @@ data Number
deriving stock (Eq, Generic) deriving stock (Eq, Generic)
deriving anyclass (NFData) deriving anyclass (NFData)
instance (ArrowContext Ctx c) => ArrowAlloc Addr (ValueT Val c) where instance (ArrowCallSite Label c) => ArrowAlloc Addr (ValueT Val c) where
alloc = proc (var,lab) -> do alloc = proc (var,lab) -> do
ctx <- Ctx.askContext @Ctx -< () ctx <- Ctx.getCallSite -< ()
returnA -< VarA (var,lab,ctx) returnA -< VarA (var,lab,ctx)
{-# INLINE alloc #-} {-# INLINE alloc #-}
{-# SCC alloc #-} {-# SCC alloc #-}
allocLabel :: (ArrowContext Ctx c) => c Label Addr allocLabel :: (ArrowCallSite Label c) => c Label Addr
allocLabel = proc l -> do allocLabel = proc l -> do
ctx <- Ctx.askContext @Ctx -< () ctx <- Ctx.getCallSite -< ()
returnA -< LabelA (l,ctx) returnA -< LabelA (l,ctx)
{-# INLINE allocLabel #-} {-# INLINE allocLabel #-}
{-# SCC allocLabel #-} {-# SCC allocLabel #-}
...@@ -154,7 +154,7 @@ instance (IsString e, ArrowChoice c, ArrowFail e c, ArrowClosure Expr Cls c) ...@@ -154,7 +154,7 @@ instance (IsString e, ArrowChoice c, ArrowFail e c, ArrowClosure Expr Cls c)
{-# SCC closure #-} {-# SCC closure #-}
{-# SCC apply #-} {-# SCC apply #-}
instance (ArrowChoice c, ArrowComplete Val c, ArrowContext Ctx c, ArrowFail e c, ArrowStore Addr Val c, ArrowEnv Text Addr c, instance (ArrowChoice c, ArrowComplete Val c, ArrowCallSite Label c, ArrowFail e c, ArrowStore Addr Val c, ArrowEnv Text Addr c,
Store.Join Val c, Env.Join Addr c,Store.Join Addr c,Fail.Join Val c,IsString e) Store.Join Val c, Env.Join Addr c,Store.Join Addr c,Fail.Join Val c,IsString e)
=> IsVal Val (ValueT Val c) where => IsVal Val (ValueT Val c) where
type Join y (ValueT Val c) = (ArrowComplete y (ValueT Val c),Fail.Join y c) type Join y (ValueT Val c) = (ArrowComplete y (ValueT Val c),Fail.Join y c)
...@@ -659,6 +659,13 @@ isFunctionBody (_,(_,e)) = case e of ...@@ -659,6 +659,13 @@ isFunctionBody (_,(_,e)) = case e of
_ -> False _ -> False
{-# INLINE isFunctionBody #-} {-# INLINE isFunctionBody #-}
isApplication :: In -> Bool
isApplication (_,(_,e)) = case e of
App _ _ _:_ -> True
_ -> False
{-# INLINE isApplication #-}
-- Pretty Printing of inputs and outputs -- Pretty Printing of inputs and outputs
printIn :: In -> Doc ann printIn :: In -> Doc ann
......
...@@ -34,7 +34,7 @@ import Control.Arrow.Transformer.Abstract.FiniteEnvStore ...@@ -34,7 +34,7 @@ import Control.Arrow.Transformer.Abstract.FiniteEnvStore
import Control.Arrow.Transformer.Abstract.LogError import Control.Arrow.Transformer.Abstract.LogError
import Control.Arrow.Transformer.Abstract.Fix import Control.Arrow.Transformer.Abstract.Fix
import Control.Arrow.Transformer.Abstract.Fix.Component as Comp import Control.Arrow.Transformer.Abstract.Fix.Component as Comp
import Control.Arrow.Transformer.Abstract.Fix.Context import Control.Arrow.Transformer.Abstract.Fix.CallSite
import Control.Arrow.Transformer.Abstract.Fix.Stack as Stack import Control.Arrow.Transformer.Abstract.Fix.Stack as Stack
import Control.Arrow.Transformer.Abstract.Fix.Cache.Immutable as Cache import Control.Arrow.Transformer.Abstract.Fix.Cache.Immutable as Cache
import Control.Arrow.Transformer.Abstract.Fix.Metrics as Metric import Control.Arrow.Transformer.Abstract.Fix.Metrics as Metric
...@@ -62,7 +62,7 @@ type InterpT c x y = ...@@ -62,7 +62,7 @@ type InterpT c x y =
(ComponentT Comp.Component In (ComponentT Comp.Component In
(StackT Stack.Stack In (StackT Stack.Stack In
(CacheT Cache.Monotone In Out (CacheT Cache.Monotone In Out
(ContextT Ctx (CallSiteT Label
(ControlFlowT Expr (ControlFlowT Expr
c))))))))))) x y c))))))))))) x y
...@@ -71,7 +71,7 @@ evalChaotic iterationStrat env0 e = ...@@ -71,7 +71,7 @@ evalChaotic iterationStrat env0 e =
let ?fixpointAlgorithm = transform $ let ?fixpointAlgorithm = transform $
Fix.fixpointAlgorithm $ Fix.fixpointAlgorithm $
-- Fix.trace printIn printOut . -- Fix.trace printIn printOut .
Ctx.recordCallsite ?sensitivity (\(_,(_,exprs)) -> case exprs of App _ _ l:_ -> Just l; _ -> Nothing) . Fix.filter isApplication (Ctx.recordCallSite ?sensitivity (\(_,(_,exprs)) -> label $ head exprs)) .
Fix.recordEvaluated . Fix.recordEvaluated .
-- CFlow.recordControlFlowGraph' (\(_,(_,exprs)) -> case exprs of e':_ -> Just e'; _ -> Nothing) . -- CFlow.recordControlFlowGraph' (\(_,(_,exprs)) -> case exprs of e':_ -> Just e'; _ -> Nothing) .
-- Fix.filter' isFunctionBody (Fix.trace printIn printOut . chaotic iterationStrat) -- Fix.filter' isFunctionBody (Fix.trace printIn printOut . chaotic iterationStrat)
......
...@@ -35,7 +35,7 @@ import Control.Arrow.Transformer.Abstract.FiniteEnvStore ...@@ -35,7 +35,7 @@ import Control.Arrow.Transformer.Abstract.FiniteEnvStore
import Control.Arrow.Transformer.Abstract.LogError import Control.Arrow.Transformer.Abstract.LogError
import Control.Arrow.Transformer.Abstract.Terminating import Control.Arrow.Transformer.Abstract.Terminating
import Control.Arrow.Transformer.Abstract.Fix import Control.Arrow.Transformer.Abstract.Fix
import Control.Arrow.Transformer.Abstract.Fix.Context import Control.Arrow.Transformer.Abstract.Fix.CallSite
import Control.Arrow.Transformer.Abstract.Fix.Cache.Immutable as Cache import Control.Arrow.Transformer.Abstract.Fix.Cache.Immutable as Cache
import Control.Arrow.Transformer.Abstract.Fix.Metrics as Metric import Control.Arrow.Transformer.Abstract.Fix.Metrics as Metric
import Control.Arrow.Transformer.Abstract.Fix.ControlFlow import Control.Arrow.Transformer.Abstract.Fix.ControlFlow
...@@ -63,7 +63,7 @@ type Interp x y = ...@@ -63,7 +63,7 @@ type Interp x y =
(FixT (FixT
(MetricsT Metric.Monotone In (MetricsT Metric.Monotone In
(CacheT (Parallel Cache.Monotone) In Out (CacheT (Parallel Cache.Monotone) In Out
(ContextT Ctx (CallSiteT Label
(ControlFlowT Expr (ControlFlowT Expr
(->))))))))) x y (->))))))))) x y
...@@ -75,7 +75,7 @@ eval algo env0 e = ...@@ -75,7 +75,7 @@ eval algo env0 e =
let ?cacheWidening = (storeErrWidening, W.finite) in let ?cacheWidening = (storeErrWidening, W.finite) in
let ?fixpointAlgorithm = transform $ algo $ \update_ -> let ?fixpointAlgorithm = transform $ algo $ \update_ ->
-- Fix.trace printIn printOut . -- Fix.trace printIn printOut .
Ctx.recordCallsite ?sensitivity (\(_,(_,exprs)) -> case exprs of App _ _ l:_ -> Just l; _ -> Nothing) . Fix.filter isApplication (Ctx.recordCallSite ?sensitivity (\(_,(_,exprs)) -> label $ head exprs)) .
Fix.recordEvaluated . Fix.recordEvaluated .
Fix.filter' isFunctionBody update_ in Fix.filter' isFunctionBody update_ in
second snd $ Trans.run (extend' (Generic.runFixed :: Interp [Expr] Val)) (empty,(empty,(env0,e0))) second snd $ Trans.run (extend' (Generic.runFixed :: Interp [Expr] Val)) (empty,(empty,(env0,e0)))
......
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