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 {
newtype DebugT c x y = DebugT (StateT DebugState c x y)
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,
ArrowStack a,ArrowStackElements a,ArrowStackDepth, ArrowSCC a,
ArrowMetrics a, ArrowStrict, ArrowPrimitive, ArrowCFG a)
......
......@@ -44,7 +44,7 @@ import Control.Arrow.Transformer.Abstract.FiniteEnvStore hiding (Env)
import Control.Arrow.Transformer.Abstract.LogError
import Control.Arrow.Transformer.Abstract.Fix
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.Cache.Immutable as Cache
import Control.Arrow.Transformer.Abstract.Fix.Metrics as Metric
......@@ -120,7 +120,7 @@ type InterpT c x y =
(ComponentT Comp.Component In
(StackT Stack In
(CacheT Cache.Monotone In Out
(ContextT Ctx
(CallSiteT Label
(ControlFlowT Expr
c)))))))))))) x y
......@@ -258,7 +258,7 @@ evalDebug expr =
let ?fixpointAlgorithm = transform $
Fix.fixpointAlgorithm $
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) .
Fix.filter' isFunctionBody innermost in
do _ <- Trans.run (Generic.runFixed :: InterpT IO [Expr] Val) (?debugState, (empty, (empty, e0)))
......
......@@ -353,5 +353,4 @@ instance HasLabel Expr where
Error _ l -> l
instance Hashable Expr where
hashWithSalt s e = s `hashWithSalt` label e
hashWithSalt s e = s `hashWithSalt` label e
\ No newline at end of file
......@@ -77,7 +77,7 @@ import GHC.Generics(Generic)
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
type Cls = Closure Expr (HashSet Env)
......@@ -124,16 +124,16 @@ data Number
deriving stock (Eq, Generic)
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
ctx <- Ctx.askContext @Ctx -< ()
ctx <- Ctx.getCallSite -< ()
returnA -< VarA (var,lab,ctx)
{-# INLINE alloc #-}
{-# SCC alloc #-}
allocLabel :: (ArrowContext Ctx c) => c Label Addr
allocLabel :: (ArrowCallSite Label c) => c Label Addr
allocLabel = proc l -> do
ctx <- Ctx.askContext @Ctx -< ()
ctx <- Ctx.getCallSite -< ()
returnA -< LabelA (l,ctx)
{-# INLINE allocLabel #-}
{-# SCC allocLabel #-}
......@@ -154,7 +154,7 @@ instance (IsString e, ArrowChoice c, ArrowFail e c, ArrowClosure Expr Cls c)
{-# SCC closure #-}
{-# 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)
=> IsVal Val (ValueT Val c) where
type Join y (ValueT Val c) = (ArrowComplete y (ValueT Val c),Fail.Join y c)
......@@ -659,6 +659,13 @@ isFunctionBody (_,(_,e)) = case e of
_ -> False
{-# INLINE isFunctionBody #-}
isApplication :: In -> Bool
isApplication (_,(_,e)) = case e of
App _ _ _:_ -> True
_ -> False
{-# INLINE isApplication #-}
-- Pretty Printing of inputs and outputs
printIn :: In -> Doc ann
......
......@@ -34,7 +34,7 @@ import Control.Arrow.Transformer.Abstract.FiniteEnvStore
import Control.Arrow.Transformer.Abstract.LogError
import Control.Arrow.Transformer.Abstract.Fix
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.Cache.Immutable as Cache
import Control.Arrow.Transformer.Abstract.Fix.Metrics as Metric
......@@ -62,7 +62,7 @@ type InterpT c x y =
(ComponentT Comp.Component In
(StackT Stack.Stack In
(CacheT Cache.Monotone In Out
(ContextT Ctx
(CallSiteT Label
(ControlFlowT Expr
c))))))))))) x y
......@@ -71,7 +71,7 @@ evalChaotic iterationStrat env0 e =
let ?fixpointAlgorithm = transform $
Fix.fixpointAlgorithm $
-- 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 .
-- CFlow.recordControlFlowGraph' (\(_,(_,exprs)) -> case exprs of e':_ -> Just e'; _ -> Nothing) .
-- Fix.filter' isFunctionBody (Fix.trace printIn printOut . chaotic iterationStrat)
......
......@@ -35,7 +35,7 @@ import Control.Arrow.Transformer.Abstract.FiniteEnvStore
import Control.Arrow.Transformer.Abstract.LogError
import Control.Arrow.Transformer.Abstract.Terminating
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.Metrics as Metric
import Control.Arrow.Transformer.Abstract.Fix.ControlFlow
......@@ -63,7 +63,7 @@ type Interp x y =
(FixT
(MetricsT Metric.Monotone In
(CacheT (Parallel Cache.Monotone) In Out
(ContextT Ctx
(CallSiteT Label
(ControlFlowT Expr
(->))))))))) x y
......@@ -75,7 +75,7 @@ eval algo env0 e =
let ?cacheWidening = (storeErrWidening, W.finite) in
let ?fixpointAlgorithm = transform $ algo $ \update_ ->
-- 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.filter' isFunctionBody update_ in
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