Commit 9b11f5e0 authored by Sven Keidel's avatar Sven Keidel

implement k-CFA analysis for PCF

parent 93fb1147
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
module Control.Arrow.Class.Alloc where
import Control.Arrow
import Data.Store (Store)
import Data.Environment(Env)
class Arrow c => ArrowAlloc var addr val c where
alloc :: c (var,Env var addr,Store addr val) addr
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE RecordWildCards #-}
module Control.Arrow.Class.Contour(ArrowContour(..),Contour,empty,push,toList,size,maxSize) where
import Data.Sequence (Seq,(|>))
import qualified Data.Sequence as S
import qualified Data.Foldable as F
data Contour l = Contour {
contour :: (Seq l),
size :: Int,
maxSize :: Int
}
empty :: Int -> Contour l
empty m = Contour S.empty 0 m
push :: l -> Contour l -> Contour l
push l (Contour {..}) = resize (Contour (contour |> l) (size + 1) maxSize)
resize :: Contour l -> Contour l
resize cont@(Contour {..})
| size > maxSize = Contour (S.drop (size - maxSize) contour) maxSize maxSize
| otherwise = cont
toList :: Contour l -> [l]
toList = F.toList . contour
class ArrowContour l c | c -> l where
askContour :: c () (Contour l)
module Control.Arrow.Contour(
module Control.Arrow.Class.Contour,
module Control.Arrow.Transformer.Contour
) where
import Control.Arrow.Class.Contour
import Control.Arrow.Transformer.Contour
......@@ -3,13 +3,16 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
module Control.Arrow.Transformer.BoundedEnvironment(BoundedEnv,runBoundedEnv,liftBoundedEnv,Alloc) where
{-# LANGUAGE ConstraintKinds #-}
module Control.Arrow.Transformer.BoundedEnvironment(BoundedEnv,runBoundedEnv,liftBoundedEnv,ArrowAlloc(..)) where
import Prelude hiding ((.))
import Control.Category
import Control.Arrow
import Control.Arrow.Class.Alloc
import Control.Arrow.Class.Environment
import Control.Arrow.Class.Reader
import Control.Arrow.Class.State
......@@ -17,46 +20,48 @@ import Control.Arrow.Class.Fail
import Control.Arrow.Class.Fix
import Control.Arrow.Transformer.Reader
import Control.Arrow.Transformer.State
import Control.Arrow.Utils
import Data.HashMap.Lazy (HashMap)
import qualified Data.HashMap.Lazy as H
import Data.Hashable
import Data.Order
import Data.Environment (Env)
import qualified Data.Environment as E
import Data.Store (Store)
import qualified Data.Store as S
type Alloc var addr val c = BoundedEnv var addr val c var addr
newtype BoundedEnv var addr val c x y = BoundedEnv ( ReaderArrow (Alloc var addr val c, HashMap var addr) (StateArrow (Store addr val) c) x y )
-- The galois connection for environment store pairs ensures that if
-- an variable is bound to an address in the environment, then the
-- address has an binding in the store.
newtype BoundedEnv var addr val c x y =
BoundedEnv ( ReaderArrow (Env var addr) (StateArrow (Store addr val) c) x y )
deriving (Category,Arrow,ArrowChoice)
runBoundedEnv :: (Eq var, Hashable var, Eq addr, Hashable addr, Complete val, ArrowChoice c, ArrowApply c)
=> BoundedEnv var addr val c x y -> c (Alloc var addr val c,HashMap var val,x) y
runBoundedEnv :: (Eq var, Hashable var, Eq addr, Hashable addr, Complete val, ArrowChoice c, ArrowAlloc var addr val c)
=> BoundedEnv var addr val c x y -> c ([(var,val)],x) y
runBoundedEnv f =
let BoundedEnv (ReaderArrow (StateArrow f')) = proc (bs,x) -> do
env <- getEnv -< ()
env' <- bindings -< (bs,env)
localEnv f -< (env',x)
in (\(al,env,x) -> (S.empty,((al,H.empty),(H.toList env,x)))) ^>> f' >>^ snd
in (\(env,x) -> (S.empty,(E.empty,(env,x)))) ^>> f' >>^ snd
liftBoundedEnv :: Arrow c => c x y -> BoundedEnv var addr vaal c x y
liftBoundedEnv :: Arrow c => c x y -> BoundedEnv var addr val c x y
liftBoundedEnv f = BoundedEnv (liftReader (liftState f))
instance (Eq var, Hashable var, Eq addr, Hashable addr, Complete val, ArrowApply c) =>
ArrowEnv var val (HashMap var addr) (BoundedEnv var addr val c) where
instance (Eq var, Hashable var, Eq addr, Hashable addr, Complete val, ArrowAlloc var addr val c) =>
ArrowEnv var val (Env var addr) (BoundedEnv var addr val c) where
lookup = proc x -> do
env <- getEnv -< ()
store <- getStore -< ()
returnA -< do
addr <- H.lookup x env
addr <- E.lookup x env
S.lookup addr store
getEnv = BoundedEnv (pi2 <<< askA)
getEnv = BoundedEnv askA
extendEnv = proc (x,y,env) -> do
addr <- localEnv alloc -< (env,x)
store <- getStore -< ()
addr <- liftBoundedEnv alloc -< (x,env,store)
putStore -< S.insertWith () addr y store
returnA -< H.insert x addr env
localEnv (BoundedEnv (ReaderArrow f)) = BoundedEnv (ReaderArrow ((\((al,_),(env,a)) -> ((al,env),a)) ^>> f))
returnA -< E.insert x addr env
localEnv (BoundedEnv (ReaderArrow f)) = BoundedEnv (ReaderArrow ((\(_,(env,a)) -> (env,a)) ^>> f))
instance ArrowReader r c => ArrowReader r (BoundedEnv var addr val c) where
askA = liftBoundedEnv askA
......@@ -81,25 +86,17 @@ putStore :: Arrow c => BoundedEnv var addr val c (Store addr val) ()
putStore = BoundedEnv putA
{-# INLINE putStore #-}
alloc :: ArrowApply c => BoundedEnv var addr val c var addr
alloc = proc v -> do
(a,_) <- BoundedEnv askA -< ()
a -<< v
{-# INLINE alloc #-}
instance (ArrowApply c, ArrowFix (HashMap var addr,Store addr val,x) (Store addr val,y) c) => ArrowFix x y (BoundedEnv var addr val c) where
fixA f = BoundedEnv $ ReaderArrow $ StateArrow $ proc (s,((a,e),x)) -> do
fixA (unlift a . f . lift) -<< (e,s,x)
instance (ArrowFix (Env var addr,Store addr val,x) (Store addr val,y) c) => ArrowFix x y (BoundedEnv var addr val c) where
fixA f = BoundedEnv $ ReaderArrow $ StateArrow $ proc (s,(e,x)) -> fixA (unlift . f . lift) -< (e,s,x)
where
lift :: Arrow c => c (HashMap var addr,Store addr val,x) (Store addr val,y) -> BoundedEnv var addr val c x y
lift g = BoundedEnv (ReaderArrow (StateArrow ((\(s,((_,e),x)) -> (e,s,x)) ^>> g)))
unlift :: Arrow c => Alloc var addr val c -> BoundedEnv var addr val c x y -> c (HashMap var addr,Store addr val,x) (Store addr val,y)
unlift a (BoundedEnv (ReaderArrow (StateArrow g))) = (\(s,e,x) -> (e,((a,s),x))) ^>> g
lift :: Arrow c => c (Env var addr,Store addr val,x) (Store addr val,y) -> BoundedEnv var addr val c x y
lift g = BoundedEnv (ReaderArrow (StateArrow ((\(s,(e,x)) -> (e,s,x)) ^>> g)))
unlift :: Arrow c => BoundedEnv var addr val c x y -> c (Env var addr,Store addr val,x) (Store addr val,y)
unlift (BoundedEnv (ReaderArrow (StateArrow g))) = (\(s,e,x) -> (e,(s,x))) ^>> g
deriving instance PreOrd (c (Store addr val,((Alloc var addr val c,HashMap var addr),x)) (Store addr val,y)) => PreOrd (BoundedEnv var addr val c x y)
deriving instance Complete (c (Store addr val,((Alloc var addr val c,HashMap var addr),x)) (Store addr val,y)) => Complete (BoundedEnv var addr val c x y)
deriving instance CoComplete (c (Store addr val,((Alloc var addr val c,HashMap var addr),x)) (Store addr val,y)) => CoComplete (BoundedEnv var addr val c x y)
deriving instance LowerBounded (c (Store addr val,((Alloc var addr val c,HashMap var addr),x)) (Store addr val,y)) => LowerBounded (BoundedEnv var addr val c x y)
deriving instance UpperBounded (c (Store addr val,((Alloc var addr val c,HashMap var addr),x)) (Store addr val,y)) => UpperBounded (BoundedEnv var addr val c x y)
deriving instance PreOrd (c (Store addr val,(Env var addr,x)) (Store addr val,y)) => PreOrd (BoundedEnv var addr val c x y)
deriving instance Complete (c (Store addr val,(Env var addr,x)) (Store addr val,y)) => Complete (BoundedEnv var addr val c x y)
deriving instance CoComplete (c (Store addr val,(Env var addr,x)) (Store addr val,y)) => CoComplete (BoundedEnv var addr val c x y)
deriving instance LowerBounded (c (Store addr val,(Env var addr,x)) (Store addr val,y)) => LowerBounded (BoundedEnv var addr val c x y)
deriving instance UpperBounded (c (Store addr val,(Env var addr,x)) (Store addr val,y)) => UpperBounded (BoundedEnv var addr val c x y)
{-# LANGUAGE Arrows #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE Arrows #-}
module Control.Arrow.Transformer.Contour where
module Control.Arrow.Transformer.Contour(Contour,empty,push,toList,size,maxSize,ContourArrow,runContourArrow,liftContour) where
import Prelude hiding (id,(.),lookup)
import Control.Arrow
import Control.Arrow.Class.Contour
import Control.Arrow.Class.Alloc
import Control.Arrow.Class.Reader
import Control.Arrow.Class.State
import Control.Arrow.Class.Fail
import Control.Arrow.Class.Environment
import Control.Arrow.Class.Fix
import Control.Arrow.Transformer.Reader
import Control.Category
newtype ContourArrow l c a b = ContourArrow (ReaderArrow (Contour l) c a b)
import qualified Data.Foldable as F
import Data.Label
import Data.Order
import Data.Hashable
import Data.Sequence (Seq,(|>))
import qualified Data.Sequence as S
data Contour l = Contour {
contour :: Seq (Hashed l),
size :: Int,
maxSize :: Int
}
instance Show l => Show (Contour l) where
show = show . toList
instance Eq l => Eq (Contour l) where
c1 == c2 = contour c1 == contour c2
instance Hashable (Contour l) where
hashWithSalt s = hashWithSalt s . F.toList . contour
empty :: Int -> Contour l
empty m = Contour S.empty 0 m
liftContour :: Arrow c => c a b -> ContourArrow l c a b
liftContour f = ContourArrow (liftReader f)
push :: Hashable l => l -> Contour l -> Contour l
push l (Contour {..}) = resize (Contour (contour |> hashed l) (size + 1) maxSize)
runContourArrow :: Arrow c => ContourArrow l c a b -> c (Int,a) b
runContourArrow (ContourArrow (ReaderArrow f)) = first empty ^>> f
resize :: Contour l -> Contour l
resize cont@(Contour {..})
| size > maxSize = Contour (S.drop (size - maxSize) contour) maxSize maxSize
| otherwise = cont
toList :: Contour l -> [l]
toList = map unhashed . F.toList . contour
newtype ContourArrow l c a b = ContourArrow (Contour l -> c a b)
liftContour :: c a b -> ContourArrow l c a b
liftContour f = ContourArrow (const f)
runContourArrow :: Int -> ContourArrow l c a b -> c a b
runContourArrow n (ContourArrow f) = f (empty n)
instance Arrow c => Category (ContourArrow l c) where
id = liftContour id
ContourArrow f . ContourArrow g = ContourArrow (f . g)
ContourArrow f . ContourArrow g = ContourArrow $ \l -> (f l . g l)
instance Arrow c => Arrow (ContourArrow l c) where
arr f = liftContour (arr f)
first (ContourArrow f) = ContourArrow (first f)
second (ContourArrow f) = ContourArrow (second f)
first (ContourArrow f) = ContourArrow (first . f)
second (ContourArrow f) = ContourArrow (second . f)
instance ArrowChoice c => ArrowChoice (ContourArrow l c) where
left (ContourArrow f) = ContourArrow (left f)
right (ContourArrow f) = ContourArrow (right f)
left (ContourArrow f) = ContourArrow (left . f)
right (ContourArrow f) = ContourArrow (right . f)
instance ArrowApply c => ArrowApply (ContourArrow l c) where
app = ContourArrow $ (\(ContourArrow f,x) -> (f,x)) ^>> app
app = ContourArrow $ \l -> (\(ContourArrow f,x) -> (f l,x)) ^>> app
instance ArrowReader r c => ArrowReader r (ContourArrow l c) where
askA = liftContour askA
localA (ContourArrow (ReaderArrow f)) = ContourArrow $ ReaderArrow $ (\(cont,(r,x)) -> (r,(cont,x))) ^>> localA f
localA (ContourArrow f) = ContourArrow $ \l -> (\(r,x) -> (r,x)) ^>> localA (f l)
instance ArrowState s c => ArrowState s (ContourArrow l c) where
getA = liftContour getA
......@@ -56,17 +94,25 @@ instance ArrowEnv x y env c => ArrowEnv x y env (ContourArrow l c) where
lookup = liftContour lookup
getEnv = liftContour getEnv
extendEnv = liftContour extendEnv
localEnv (ContourArrow (ReaderArrow f)) = ContourArrow $ ReaderArrow $ (\(cont,(r,x)) -> (r,(cont,x))) ^>> localEnv f
localEnv (ContourArrow f) = ContourArrow $ \l -> (\(r,x) -> (r,x)) ^>> localEnv (f l)
instance (ArrowFix x y c, ArrowApply c) => ArrowFix x y (ContourArrow x c) where
-- Pushes the last argument on the contour.
fixA f = ContourArrow $ ReaderArrow $ proc (cont,x) -> fixA (unlift . f . lift (push x cont)) -<< x
instance (ArrowFix x y c, ArrowApply c, Label x l, Hashable l) => ArrowFix x y (ContourArrow l c) where
-- Pushes the label of the last argument on the contour.
fixA f = ContourArrow $ \l -> proc x -> fixA (unlift l . f . lift) -<< x
where
lift :: Arrow c => Contour x -> c x y -> ContourArrow x c x y
lift c f' = proc x -> localContour (liftContour f') -< (c,x)
localContour :: Arrow c => ContourArrow l c x y -> ContourArrow l c (Contour l, x) y
localContour (ContourArrow (ReaderArrow f')) = ContourArrow $ ReaderArrow $ snd ^>> f'
unlift :: Arrow c => ContourArrow x c x y -> c x y
unlift f' = (const 0 &&& id) ^>> runContourArrow f'
lift :: c x y -> ContourArrow l c x y
lift = liftContour
unlift :: (Hashable l, Label x l, ArrowApply c) => Contour l -> ContourArrow l c x y -> c x y
unlift cont (ContourArrow f') = proc x -> do
y <- f' (push (getLabel x) cont) -<< x
returnA -< y
instance Arrow c => ArrowAlloc var (var,Contour l) val (ContourArrow l c) where
alloc = ContourArrow $ \l -> proc (x,_,_) -> returnA -< (x,l)
deriving instance PreOrd (Contour l -> c x y) => PreOrd (ContourArrow l c x y)
deriving instance LowerBounded (Contour l -> c x y) => LowerBounded (ContourArrow l c x y)
deriving instance Complete (Contour l -> c x y) => Complete (ContourArrow l c x y)
deriving instance CoComplete (Contour l -> c x y) => CoComplete (ContourArrow l c x y)
deriving instance UpperBounded (Contour l -> c x y) => UpperBounded (ContourArrow l c x y)
......@@ -9,7 +9,6 @@ module Control.Arrow.Transformer.Either(EitherArrow(..),liftEither) where
import Prelude hiding (id,lookup)
import Control.Arrow
import Control.Arrow.Class.Environment
import Control.Arrow.Class.Fail
import Control.Arrow.Class.Reader
import Control.Arrow.Class.State
......@@ -79,11 +78,11 @@ instance (ArrowChoice c, ArrowReader r c) => ArrowReader r (EitherArrow e c) whe
askA = liftEither askA
localA (EitherArrow f) = EitherArrow (localA f)
instance (ArrowChoice c, ArrowEnv x y env c) => ArrowEnv x y env (EitherArrow e c) where
lookup = liftEither lookup
getEnv = liftEither getEnv
extendEnv = liftEither extendEnv
localEnv (EitherArrow f) = EitherArrow (localEnv f)
-- instance (ArrowChoice c, ArrowEnv x y env c) => ArrowEnv x y env (EitherArrow e c) where
-- lookup = liftEither lookup
-- getEnv = liftEither getEnv
-- extendEnv = liftEither extendEnv
-- localEnv (EitherArrow f) = EitherArrow (localEnv f)
instance ArrowChoice c => ArrowTry x y z (EitherArrow e c) where
tryA (EitherArrow f) (EitherArrow g) (EitherArrow h) = EitherArrow $ proc x -> do
......
......@@ -9,10 +9,10 @@ module Control.Arrow.Transformer.Environment where
import Prelude hiding ((.))
import Data.HashMap.Lazy (HashMap)
import qualified Data.HashMap.Lazy as H
import Data.Hashable
import Data.Order
import Data.Environment (Env)
import qualified Data.Environment as E
import Control.Category
import Control.Arrow
......@@ -23,42 +23,45 @@ import Control.Arrow.Class.Fail
import Control.Arrow.Class.Environment
import Control.Arrow.Class.Fix
newtype Environment a b c x y = Environment (ReaderArrow (HashMap a b) c x y)
newtype Environment var val c x y = Environment (ReaderArrow (Env var val) c x y)
deriving (Category,Arrow,ArrowChoice)
runEnvironment :: Environment a b c x y -> c (HashMap a b,x) y
runEnvironment (Environment (ReaderArrow f)) = f
runEnvironment :: (Arrow c, Eq var, Hashable var) => Environment var val c x y -> c ([(var,val)],x) y
runEnvironment (Environment (ReaderArrow f)) = first E.fromList ^>> f
liftEnv :: Arrow c => c x y -> Environment a b c x y
liftEnv :: Arrow c => c x y -> Environment var val c x y
liftEnv f = Environment (liftReader f)
instance ArrowApply c => ArrowApply (Environment a b c) where
instance ArrowApply c => ArrowApply (Environment var val c) where
app = Environment $ (\(Environment f,x) -> (f,x)) ^>> app
instance ArrowReader r c => ArrowReader r (Environment a b c) where
instance ArrowReader r c => ArrowReader r (Environment var val c) where
askA = liftEnv askA
localA (Environment (ReaderArrow f)) = Environment (ReaderArrow ((\(env,(r,x)) -> (r,(env,x))) ^>> localA f))
instance ArrowState s c => ArrowState s (Environment a b c) where
instance ArrowState s c => ArrowState s (Environment var val c) where
getA = liftEnv getA
putA = liftEnv putA
instance ArrowFail e c => ArrowFail e (Environment a b c) where
instance ArrowFail e c => ArrowFail e (Environment var val c) where
failA = liftEnv failA
instance (Eq a, Hashable a, Arrow c) => ArrowEnv a b (HashMap a b) (Environment a b c) where
instance (Eq var, Hashable var, ArrowChoice c) => ArrowEnv var val (Env var val) (Environment var val c) where
lookup = proc x -> do
env <- getEnv -< ()
returnA -< H.lookup x env
returnA -< E.lookup x env
getEnv = Environment askA
extendEnv = arr $ \(x,y,env) -> H.insert x y env
extendEnv = arr $ \(x,y,env) -> E.insert x y env
localEnv (Environment f) = Environment (localA f)
instance (ArrowFix (HashMap a b,x) y c) => ArrowFix x y (Environment a b c) where
fixA f = Environment (ReaderArrow (fixA (runEnvironment . f . Environment . ReaderArrow)))
instance (ArrowFix (Env var val,x) y c) => ArrowFix x y (Environment var val c) where
fixA f = Environment (ReaderArrow (fixA (unlift . f . lift)))
where
lift = Environment . ReaderArrow
unlift (Environment (ReaderArrow f')) = f'
deriving instance PreOrd (c (HashMap a b,x) y) => PreOrd (Environment a b c x y)
deriving instance Complete (c (HashMap a b,x) y) => Complete (Environment a b c x y)
deriving instance CoComplete (c (HashMap a b,x) y) => CoComplete (Environment a b c x y)
deriving instance LowerBounded (c (HashMap a b,x) y) => LowerBounded (Environment a b c x y)
deriving instance UpperBounded (c (HashMap a b,x) y) => UpperBounded (Environment a b c x y)
deriving instance PreOrd (c (Env var val,x) y) => PreOrd (Environment var val c x y)
deriving instance Complete (c (Env var val,x) y) => Complete (Environment var val c x y)
deriving instance CoComplete (c (Env var val,x) y) => CoComplete (Environment var val c x y)
deriving instance LowerBounded (c (Env var val,x) y) => LowerBounded (Environment var val c x y)
deriving instance UpperBounded (c (Env var val,x) y) => UpperBounded (Environment var val c x y)
......@@ -3,18 +3,18 @@
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE Arrows #-}
module Control.Arrow.Transformer.Fail(ErrorArrow(..),liftError) where
import Prelude hiding (id,(.),lookup)
import Control.Category
import Control.Arrow
import Control.Arrow.Class.Environment
import Control.Arrow.Class.Fail
import Control.Arrow.Class.Fix
import Control.Arrow.Class.Reader
import Control.Arrow.Class.State
import Control.Arrow.Class.Environment
import Control.Arrow.Class.Fix
import Control.Monad (join)
import Data.Error
import Data.Order
......@@ -27,7 +27,12 @@ liftError f = ErrorArrow (f >>> arr Success)
instance ArrowChoice c => Category (ErrorArrow r c) where
id = liftError id
ErrorArrow f . ErrorArrow g = ErrorArrow $ g >>> toEither ^>> right f >>^ (fromEither >>> join)
ErrorArrow f . ErrorArrow g = ErrorArrow $ proc x -> do
ey <- g -< x
case ey of
Bot -> returnA -< Bot
Error e -> returnA -< Error e
Success y -> f -< y
instance ArrowChoice c => Arrow (ErrorArrow r c) where
arr f = liftError (arr f)
......@@ -36,12 +41,14 @@ instance ArrowChoice c => Arrow (ErrorArrow r c) where
injectRight :: (Error e a,x) -> Error e (a,x)
injectRight (er,x) = case er of
Bot -> Bot
Error e -> Error e
Success a -> Success (a,x)
{-# INLINE injectRight #-}
injectLeft :: (x, Error e a) -> Error e (x,a)
injectLeft (x,er) = case er of
Bot -> Bot
Error e -> Error e
Success a -> Success (x,a)
{-# INLINE injectLeft #-}
......@@ -52,6 +59,7 @@ instance ArrowChoice c => ArrowChoice (ErrorArrow r c) where
commuteLeft :: Either (Error e x) y -> Error e (Either x y)
commuteLeft e0 = case e0 of
Left Bot -> Bot
Left (Error e) -> Error e
Left (Success x) -> Success (Left x)
Right y -> Success (Right y)
......@@ -60,6 +68,7 @@ commuteLeft e0 = case e0 of
commuteRight :: Either x (Error e y) -> Error e (Either x y)
commuteRight e0 = case e0 of
Left x -> Success (Left x)
Right Bot -> Bot
Right (Error e) -> Error e
Right (Success x) -> Success (Right x)
{-# INLINE commuteRight #-}
......
......@@ -8,7 +8,7 @@
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE CPP #-}
-- {-# OPTIONS_GHC -DTRACE #-}
{-# OPTIONS_GHC -DTRACE #-}
module Control.Arrow.Transformer.FixCache(CacheArrow,runCacheArrow,runCacheArrow',liftCache) where
import Prelude hiding (id,(.),lookup)
......@@ -31,6 +31,8 @@ import Debug.Trace
import Text.Printf
#endif
-- The main idea of this fixpoint caching algorithm is due to David Darais et. al., Abstract Definitional Interpreters (Functional Pearl), ICFP' 17
-- We made some changes to the algorithm to simplify it.
newtype CacheArrow a b x y = CacheArrow (((Store a b,Store a b),x) -> (Store a b,y))
runCacheArrow :: CacheArrow a b x y -> (x -> y)
......@@ -61,32 +63,33 @@ instance ArrowApply (CacheArrow i o) where
app = CacheArrow $ (\(io,(CacheArrow f,x)) -> (f,(io,x))) ^>> app
#ifdef TRACE
instance (Show x, Show y, Eq x, Hashable x, LowerBounded y, Complete y)
instance (Show x, Show y, Eq x, Hashable x, LowerBounded y, Widening y)
=> ArrowFix x y (CacheArrow x y) where
fixA f = trace (printf "fixA fact") $ proc x -> do
fixA f = trace (printf "fixA f") $ proc x -> do
old <- getOutCache -< ()
setOutCache -< bottom
y <- localInCache (trace (printf "\tfix (memoize . fact)") $ fix (memoize . f)) -< (old,x)
y <- localInCache (fix (memoize . f)) -< (old,x)
new <- getOutCache -< ()
if new old -- We are in the reductive set of `f` and have overshot the fixpoint
then returnA -< y
else fixA f -< x
memoize :: (Show x, Show y, Eq x, Hashable x, LowerBounded y, Complete y) => CacheArrow x y x y -> CacheArrow x y x y
memoize :: (Show x, Show y, Eq x, Hashable x, LowerBounded y, Widening y) => CacheArrow x y x y -> CacheArrow x y x y
memoize f = proc x -> do
m <- lookupOutCache -< trace (printf "\t\tmemoize -< %s" (show x)) x
m <- lookupOutCache -< trace (printf "\tmemoize -< %s" (show x)) x
case m of
Just y -> do
returnA -< trace (printf "\t\t%s <- memoize -< %s" (show y) (show x)) y
returnA -< trace (printf "\t%s <- memoize -< %s" (show y) (show x)) y
Nothing -> do
yOld <- lookupInCache -< x
writeOutCache -< trace (printf "\t\tout(%s) := %s" (show x) (show (fromMaybe bottom yOld))) (x, fromMaybe bottom yOld)
y <- f -< trace (printf "\t\tfact -< %s" (show x)) x
writeOutCache -< trace (printf "\tout(%s) := %s" (show x) (show (fromMaybe bottom yOld))) (x, fromMaybe bottom yOld)
y <- f -< trace (printf "\tf -< %s" (show x)) x
yCached <- lookupOutCache -< x
updateOutCache -< trace (printf "\t\tout(%s) := %s ⊔ %s = %s" (show x) (show (fromJust yCached)) (show y) (show (fromJust yCached y)))
(trace (printf "\t\t%s <- fact -< %s" (show y) (show x))
(x, y))
returnA -< trace (printf "\t\t%s <- memoize -< %s" (show y) (show x)) y
updateOutCache -< (x, y)
yNew <- lookupOutCache -< x
returnA -< trace (printf "\t%s <- f -< %s\n" (show y) (show x) ++
printf "\tout(%s) := %s ▽ %s = %s\n" (show x) (show (fromJust yCached)) (show y) (show yNew) ++
printf "\t%s <- memoize -< %s" (show y) (show x)) y
#else
instance (Eq x, Hashable x, LowerBounded y, Widening y)
......
{-# LANGUAGE DeriveGeneric #-}
module Data.Bounded where
import Prelude hiding (Bounded)
......@@ -7,18 +6,17 @@ import Data.Order
import Data.Widening
import Data.Hashable
import GHC.Generics
-- |Bounded invokes the least upper bound operator until the element reaches a given limit.
data Bounded a = Bounded a a deriving (Generic)
data Bounded a = Bounded a a
instance Eq a => Eq (Bounded a) where
Bounded _ x == Bounded _ y = x == y