├── .gitignore ├── Setup.hs ├── cabal.project ├── .gitmodules ├── README.md ├── stack.yaml ├── src ├── Abstract │ ├── Set.hs │ ├── Type.hs │ ├── Eval.hs │ ├── Interpreter.hs │ ├── Term.hs │ ├── Environment.hs │ ├── Interpreter │ │ ├── Collecting.hs │ │ ├── Dead.hs │ │ ├── Tracing.hs │ │ ├── Symbolic.hs │ │ └── Caching.hs │ ├── Configuration.hs │ ├── Value.hs │ ├── Primitive.hs │ ├── Store.hs │ └── Syntax.hs ├── Data │ └── Functor │ │ └── Classes │ │ ├── Eq │ │ └── Generic.hs │ │ ├── Ord │ │ └── Generic.hs │ │ └── Show │ │ └── Generic.hs └── Control │ └── Effect.hs ├── LICENSE └── abstract-interpretation.cabal /.gitignore: -------------------------------------------------------------------------------- 1 | .ghc.environment.x86_64-darwin-8.2.1 2 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: ./ 2 | optional-packages: vendor/*/ 3 | 4 | jobs: $ncpus 5 | -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- 1 | [submodule "vendor/effects"] 2 | path = vendor/effects 3 | url = https://github.com/joshvera/effects.git 4 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # abstract-interpretation 2 | 3 | Experiments in abstracting definitional interpreters à la https://plum-umd.github.io/abstracting-definitional-interpreters/ 4 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: nightly-2017-09-20 2 | packages: 3 | - . 4 | - location: vendor/effects 5 | extra-dep: true 6 | extra-deps: [] 7 | flags: {} 8 | extra-package-dbs: [] 9 | -------------------------------------------------------------------------------- /src/Abstract/Set.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | module Abstract.Set where 3 | 4 | import Data.Bifunctor (second) 5 | import Data.Function (on) 6 | import Data.Functor.Classes 7 | import Data.Pointed 8 | import Data.Semigroup 9 | import qualified Data.Set as Set 10 | 11 | newtype Set a = Set { unSet :: Set.Set a } 12 | deriving (Eq, Eq1, Foldable, Monoid, Ord, Ord1, Pointed, Semigroup, Show, Show1) 13 | 14 | member :: Ord a => a -> Set a -> Bool 15 | member = (. unSet) . Set.member 16 | 17 | insert :: Ord a => a -> Set a -> Set a 18 | insert a = Set . Set.insert a . unSet 19 | 20 | delete :: Ord a => a -> Set a -> Set a 21 | delete a = Set . Set.delete a . unSet 22 | 23 | split :: Ord a => Set a -> Maybe (a, Set a) 24 | split = fmap (second Set) . Set.minView . unSet 25 | 26 | difference :: Ord a => Set a -> Set a -> Set a 27 | difference = (Set .) . (Set.difference `on` unSet) 28 | -------------------------------------------------------------------------------- /src/Abstract/Type.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts, FlexibleInstances, GADTs, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-} 2 | module Abstract.Type where 3 | 4 | import Control.Effect 5 | import Control.Monad.Effect.Internal 6 | import Control.Monad.Fail 7 | import Prelude hiding (fail) 8 | 9 | type TName = Int 10 | 11 | data Type = Int | Bool | Type :-> Type | Type :* Type | TVar TName 12 | deriving (Eq, Ord, Show) 13 | 14 | 15 | unify :: MonadFail m => Type -> Type -> m Type 16 | unify Int Int = pure Int 17 | unify Bool Bool = pure Bool 18 | unify (a1 :-> b1) (a2 :-> b2) = (:->) <$> unify a1 a2 <*> unify b1 b2 19 | unify (a1 :* b1) (a2 :* b2) = (:*) <$> unify a1 a2 <*> unify b1 b2 20 | unify (TVar _) b = pure b 21 | unify a (TVar _) = pure a 22 | unify t1 t2 = fail ("cannot unify " ++ show t1 ++ " with " ++ show t2) 23 | 24 | 25 | data Fresh a where 26 | Reset :: Int -> Fresh () 27 | Fresh :: Fresh Int 28 | 29 | class Monad m => MonadFresh m where 30 | fresh :: m TName 31 | reset :: TName -> m () 32 | 33 | instance (Fresh :< fs) => MonadFresh (Eff fs) where 34 | fresh = send Fresh 35 | reset = send . Reset 36 | 37 | 38 | instance RunEffect Fresh a where 39 | runEffect = relayState (0 :: TName) (const pure) (\ s action k -> case action of 40 | Fresh -> k (succ s) s 41 | Reset s' -> k s' ()) 42 | -------------------------------------------------------------------------------- /src/Abstract/Eval.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeApplications, AllowAmbiguousTypes, DefaultSignatures, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, UndecidableInstances, ScopedTypeVariables #-} 2 | module Abstract.Eval where 3 | 4 | import Abstract.Term 5 | import Abstract.Store 6 | 7 | import Data.Proxy 8 | import Data.Union 9 | 10 | 11 | -- Standard evaluator/interpreter 12 | class Monad m => Eval v m syntax constr where 13 | evaluate :: (Term syntax -> m v) -> constr (Term syntax) -> m v 14 | 15 | 16 | instance ( Monad m 17 | , Apply (Eval v m s) fs 18 | ) 19 | => Eval v m s (Union fs) where 20 | evaluate ev = apply (Proxy :: Proxy (Eval v m s)) (evaluate ev) 21 | 22 | 23 | 24 | class Monad m => MonadGC l a m where 25 | askRoots :: m (Set (Address l a)) 26 | 27 | extraRoots :: Set (Address l a) -> m b -> m b 28 | 29 | 30 | -- Collecting evaluator 31 | class Monad m => EvalCollect l v m syntax constr where 32 | evalCollect :: (Term syntax -> m v) 33 | -> constr (Term syntax) 34 | -> m v 35 | default evalCollect :: (Eval v m syntax constr) => (Term syntax -> m v) 36 | -> constr (Term syntax) 37 | -> m v 38 | evalCollect = evaluate 39 | 40 | instance ( Monad m 41 | , Apply (EvalCollect l v m s) fs 42 | ) 43 | => EvalCollect l v m s (Union fs) where 44 | evalCollect ev = apply (Proxy :: Proxy (EvalCollect l v m s)) (evalCollect @l ev) 45 | -------------------------------------------------------------------------------- /src/Abstract/Interpreter.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances, AllowAmbiguousTypes, ConstraintKinds, DataKinds, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables, TypeApplications, TypeOperators #-} 2 | module Abstract.Interpreter where 3 | 4 | import Abstract.Environment 5 | import Abstract.Primitive 6 | import Abstract.Store 7 | import Abstract.Term 8 | import Abstract.Type 9 | import Abstract.Eval 10 | 11 | import Control.Effect 12 | import Control.Monad.Effect hiding (run) 13 | import Control.Monad.Effect.Fail 14 | import Control.Monad.Effect.NonDetEff 15 | import Control.Monad.Effect.Reader 16 | import Control.Monad.Effect.State 17 | import Data.Function (fix) 18 | import Data.Semigroup 19 | import Prelude hiding (fail) 20 | 21 | 22 | type Interpreter l v = '[Fresh, Fail, NonDetEff, State (Store l v), Reader (Environment l v)] 23 | 24 | type MonadInterpreter l v m = (MonadEnv l v m, MonadStore l v m, MonadFail m) 25 | 26 | type EvalResult l v = Final (Interpreter l v) v 27 | 28 | type Eval' t m = t -> m 29 | 30 | -- Evaluate an expression. 31 | -- Example: 32 | -- eval @Precise @(Value Syntax Precise) @Syntax (makeLam "x" (var "x") # true) 33 | eval :: forall l v s 34 | . ( Ord v 35 | , Eval v (Eff (Interpreter l v)) s s 36 | , MonadAddress l (Eff (Interpreter l v)) 37 | , MonadPrim v (Eff (Interpreter l v)) 38 | , Semigroup (Cell l v)) 39 | => Term s 40 | -> EvalResult l v 41 | eval = run @(Interpreter l v) . fix ev 42 | 43 | ev :: (Eval v m syntax syntax) => (Term syntax -> m v) -> Term syntax -> m v 44 | ev ev = evaluate ev . out 45 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2017, Rob Rix 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Rob Rix nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /src/Abstract/Term.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DefaultSignatures, TypeOperators, FlexibleContexts, UndecidableInstances, MultiParamTypeClasses, FlexibleInstances, TypeFamilies #-} 2 | 3 | module Abstract.Term where 4 | 5 | import Abstract.Set 6 | 7 | import Data.Function 8 | import Data.Functor.Classes 9 | import Data.Functor.Foldable 10 | import Data.Proxy 11 | import Data.Union 12 | 13 | type Name = String 14 | 15 | newtype Term syntax = In { out :: syntax (Term syntax) } 16 | 17 | type instance Base (Term syntax) = syntax 18 | 19 | instance (Functor syntax) => Recursive (Term syntax) where 20 | project = out 21 | 22 | 23 | class FreeVariables1 syntax where 24 | liftFreeVariables :: (a -> Set Name) -> syntax a -> Set Name 25 | default liftFreeVariables :: (Foldable syntax) => (a -> Set Name) -> syntax a -> Set Name 26 | liftFreeVariables = foldMap 27 | 28 | class FreeVariables term where 29 | freeVariables :: term -> Set Name 30 | 31 | instance (FreeVariables1 syntax, Functor syntax) => FreeVariables (Term syntax) where 32 | freeVariables = cata (liftFreeVariables id) 33 | 34 | instance (Apply FreeVariables1 fs) => FreeVariables1 (Union fs) where 35 | liftFreeVariables f = apply (Proxy :: Proxy FreeVariables1) (liftFreeVariables f) 36 | 37 | 38 | -- Smart constructor helper for Term 39 | inject :: (g :< fs) => g (Term (Union fs)) -> Term (Union fs) 40 | inject = In . inj 41 | 42 | -- Instances 43 | 44 | instance Eq1 syntax => Eq (Term syntax) where 45 | (==) = liftEq (==) `on` out 46 | 47 | instance Ord1 syntax => Ord (Term syntax) where 48 | compare (In a) (In b) = liftCompare compare a b 49 | 50 | instance Show1 syntax => Show (Term syntax) where 51 | showsPrec p = liftShowsPrec showsPrec showList p . out 52 | -------------------------------------------------------------------------------- /src/Data/Functor/Classes/Eq/Generic.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators, FlexibleInstances, FlexibleContexts#-} 2 | module Data.Functor.Classes.Eq.Generic 3 | ( Eq1(..) 4 | , genericLiftEq 5 | ) where 6 | 7 | import Data.Functor.Classes 8 | import GHC.Generics 9 | 10 | -- | Generically-derivable lifting of the 'Eq' class to unary type constructors. 11 | class GEq1 f where 12 | -- | Lift an equality test through the type constructor. 13 | -- 14 | -- The function will usually be applied to an equality function, but the more general type ensures that the implementation uses it to compare elements of the first container with elements of the second. 15 | gliftEq :: (a -> b -> Bool) -> f a -> f b -> Bool 16 | 17 | -- | A suitable implementation of Eq1’s liftEq for Generic1 types. 18 | genericLiftEq :: (Generic1 f, GEq1 (Rep1 f)) => (a -> b -> Bool) -> f a -> f b -> Bool 19 | genericLiftEq f a b = gliftEq f (from1 a) (from1 b) 20 | 21 | 22 | -- Generics 23 | 24 | instance GEq1 U1 where 25 | gliftEq _ _ _ = True 26 | 27 | instance GEq1 Par1 where 28 | gliftEq f (Par1 a) (Par1 b) = f a b 29 | 30 | instance Eq c => GEq1 (K1 i c) where 31 | gliftEq _ (K1 a) (K1 b) = a == b 32 | 33 | instance Eq1 f => GEq1 (Rec1 f) where 34 | gliftEq f (Rec1 a) (Rec1 b) = liftEq f a b 35 | 36 | instance GEq1 f => GEq1 (M1 i c f) where 37 | gliftEq f (M1 a) (M1 b) = gliftEq f a b 38 | 39 | instance (GEq1 f, GEq1 g) => GEq1 (f :+: g) where 40 | gliftEq f a b = case (a, b) of 41 | (L1 a, L1 b) -> gliftEq f a b 42 | (R1 a, R1 b) -> gliftEq f a b 43 | _ -> False 44 | 45 | instance (GEq1 f, GEq1 g) => GEq1 (f :*: g) where 46 | gliftEq f (a1 :*: b1) (a2 :*: b2) = gliftEq f a1 a2 && gliftEq f b1 b2 47 | 48 | instance (Eq1 f, GEq1 g) => GEq1 (f :.: g) where 49 | gliftEq f (Comp1 a) (Comp1 b) = liftEq (gliftEq f) a b 50 | -------------------------------------------------------------------------------- /src/Control/Effect.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, TypeFamilies, TypeOperators, UndecidableInstances #-} 2 | module Control.Effect where 3 | 4 | import Abstract.Set 5 | import qualified Control.Monad.Effect as Effect 6 | import Control.Monad.Effect.Fail 7 | import Control.Monad.Effect.Internal hiding (run) 8 | import Control.Monad.Effect.NonDetEff 9 | import Control.Monad.Effect.Reader 10 | import Control.Monad.Effect.State 11 | import Control.Monad.Effect.Writer 12 | import Data.Pointed 13 | 14 | run :: RunEffects fs a => Eff fs a -> Final fs a 15 | run = Effect.run . runEffects 16 | 17 | class RunEffects fs a where 18 | type Final fs a 19 | runEffects :: Eff fs a -> Eff '[] (Final fs a) 20 | 21 | instance (RunEffect f1 a, RunEffects (f2 ': fs) (Result f1 a)) => RunEffects (f1 ': f2 ': fs) a where 22 | type Final (f1 ': f2 ': fs) a = Final (f2 ': fs) (Result f1 a) 23 | runEffects = runEffects . runEffect 24 | 25 | instance RunEffect f a => RunEffects '[f] a where 26 | type Final '[f] a = Result f a 27 | runEffects = runEffect 28 | 29 | 30 | class RunEffect f a where 31 | type Result f a 32 | type instance Result f a = a 33 | runEffect :: Eff (f ': fs) a -> Eff fs (Result f a) 34 | 35 | instance Monoid b => RunEffect (State b) a where 36 | type Result (State b) a = (a, b) 37 | runEffect = flip runState mempty 38 | 39 | instance Monoid b => RunEffect (Reader b) a where 40 | runEffect = flip runReader mempty 41 | 42 | instance RunEffect Fail a where 43 | type Result Fail a = Either String a 44 | runEffect = runFail 45 | 46 | instance Monoid w => RunEffect (Writer w) a where 47 | type Result (Writer w) a = (a, w) 48 | runEffect = runWriter 49 | 50 | instance Ord a => RunEffect NonDetEff a where 51 | type Result NonDetEff a = Set a 52 | runEffect = relay (pure . point) (\ m k -> case m of 53 | MZero -> pure mempty 54 | MPlus -> mappend <$> k True <*> k False) 55 | -------------------------------------------------------------------------------- /src/Data/Functor/Classes/Ord/Generic.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators, FlexibleInstances, FlexibleContexts #-} 2 | module Data.Functor.Classes.Ord.Generic 3 | ( Ord1(..) 4 | , genericLiftCompare 5 | ) where 6 | 7 | import Data.Functor.Classes 8 | import Data.Semigroup 9 | import GHC.Generics 10 | 11 | -- | Generically-derivable lifting of the 'Ord' class to unary type constructors. 12 | class GOrd1 f where 13 | -- | Lift a comparison function through the type constructor. 14 | -- 15 | -- The function will usually be applied to a comparison function, but the more general type ensures that the implementation uses it to compare elements of the first container with elements of the second. 16 | gliftCompare :: (a -> b -> Ordering) -> f a -> f b -> Ordering 17 | 18 | -- | A suitable implementation of Ord1’s liftCompare for Generic1 types. 19 | genericLiftCompare :: (Generic1 f, GOrd1 (Rep1 f)) => (a -> b -> Ordering) -> f a -> f b -> Ordering 20 | genericLiftCompare f a b = gliftCompare f (from1 a) (from1 b) 21 | 22 | 23 | -- Generics 24 | 25 | instance GOrd1 U1 where 26 | gliftCompare _ _ _ = EQ 27 | 28 | instance GOrd1 Par1 where 29 | gliftCompare f (Par1 a) (Par1 b) = f a b 30 | 31 | instance Ord c => GOrd1 (K1 i c) where 32 | gliftCompare _ (K1 a) (K1 b) = compare a b 33 | 34 | instance Ord1 f => GOrd1 (Rec1 f) where 35 | gliftCompare f (Rec1 a) (Rec1 b) = liftCompare f a b 36 | 37 | instance GOrd1 f => GOrd1 (M1 i c f) where 38 | gliftCompare f (M1 a) (M1 b) = gliftCompare f a b 39 | 40 | instance (GOrd1 f, GOrd1 g) => GOrd1 (f :+: g) where 41 | gliftCompare f a b = case (a, b) of 42 | (L1 a, L1 b) -> gliftCompare f a b 43 | (R1 a, R1 b) -> gliftCompare f a b 44 | (L1 _, R1 _) -> LT 45 | (R1 _, L1 _) -> GT 46 | 47 | instance (GOrd1 f, GOrd1 g) => GOrd1 (f :*: g) where 48 | gliftCompare f (a1 :*: b1) (a2 :*: b2) = gliftCompare f a1 a2 <> gliftCompare f b1 b2 49 | 50 | instance (Ord1 f, GOrd1 g) => GOrd1 (f :.: g) where 51 | gliftCompare f (Comp1 a) (Comp1 b) = liftCompare (gliftCompare f) a b 52 | -------------------------------------------------------------------------------- /src/Abstract/Environment.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, UndecidableInstances, DeriveFoldable, DeriveFunctor, DeriveTraversable, DeriveGeneric, GeneralizedNewtypeDeriving #-} 2 | module Abstract.Environment where 3 | 4 | import Abstract.Store 5 | import Abstract.Term 6 | 7 | import Control.Monad.Effect 8 | import Control.Monad.Effect.Reader 9 | import Data.Functor.Classes 10 | import Data.Functor.Classes.Show.Generic 11 | import Data.Pointed 12 | import Data.Semigroup 13 | import GHC.Generics 14 | import qualified Data.Map as Map 15 | 16 | newtype Environment l a = Environment { unEnvironment :: Map.Map Name (Address l a) } 17 | deriving (Eq, Foldable, Functor, Monoid, Ord, Semigroup, Show, Traversable, Generic1) 18 | 19 | envLookup :: Name -> Environment l a -> Maybe (Address l a) 20 | envLookup = (. unEnvironment) . Map.lookup 21 | 22 | envInsert :: Name -> Address l a -> Environment l a -> Environment l a 23 | envInsert name value (Environment m) = Environment (Map.insert name value m) 24 | 25 | envRoots :: (Foldable t, Ord l) => Environment l a -> t Name -> Set (Address l a) 26 | envRoots env = foldr ((<>) . maybe mempty point . flip envLookup env) mempty 27 | 28 | 29 | class Monad m => MonadEnv l a m where 30 | askEnv :: m (Environment l a) 31 | localEnv :: (Environment l a -> Environment l a) -> m b -> m b 32 | 33 | instance Reader (Environment l a) :< fs => MonadEnv l a (Eff fs) where 34 | askEnv = ask 35 | localEnv = local 36 | 37 | 38 | -- Instances 39 | 40 | instance Eq2 Environment where liftEq2 eqL eqA (Environment m1) (Environment m2) = liftEq (liftEq2 eqL eqA) m1 m2 41 | instance Eq l => Eq1 (Environment l) where liftEq = liftEq2 (==) 42 | instance Ord2 Environment where liftCompare2 compareL compareA (Environment m1) (Environment m2) = liftCompare (liftCompare2 compareL compareA) m1 m2 43 | instance Ord l => Ord1 (Environment l) where liftCompare = liftCompare2 compare 44 | instance Show l => Show1 (Environment l) where liftShowsPrec = genericLiftShowsPrec 45 | -------------------------------------------------------------------------------- /abstract-interpretation.cabal: -------------------------------------------------------------------------------- 1 | name: abstract-interpretation 2 | version: 0.0.0.1 3 | synopsis: Experiments in abstracting definitional interpreters 4 | description: Experiments in abstracting definitional interpreters à la https://plum-umd.github.io/abstracting-definitional-interpreters/ 5 | homepage: https://github.com/robrix/abstract-interpretation 6 | license: BSD3 7 | license-file: LICENSE 8 | author: Rob Rix 9 | maintainer: rob.rix@me.com 10 | copyright: 2017 Rob Rix 11 | category: Development 12 | build-type: Simple 13 | cabal-version: >=1.10 14 | 15 | library 16 | exposed-modules: Abstract.Configuration 17 | , Abstract.Environment 18 | , Abstract.Eval 19 | , Abstract.Interpreter 20 | , Abstract.Interpreter.Caching 21 | , Abstract.Interpreter.Collecting 22 | , Abstract.Interpreter.Dead 23 | , Abstract.Interpreter.Symbolic 24 | , Abstract.Interpreter.Tracing 25 | , Abstract.Primitive 26 | , Abstract.Set 27 | , Abstract.Store 28 | , Abstract.Syntax 29 | , Abstract.Term 30 | , Abstract.Type 31 | , Abstract.Value 32 | , Control.Effect 33 | other-modules: Data.Functor.Classes.Eq.Generic 34 | , Data.Functor.Classes.Show.Generic 35 | , Data.Functor.Classes.Ord.Generic 36 | build-depends: base >=4.10 && <4.11 37 | , containers 38 | , effects 39 | , pointed 40 | , recursion-schemes 41 | , pretty-show 42 | , hscolour 43 | hs-source-dirs: src 44 | default-language: Haskell2010 45 | ghc-options: -Wall -fno-warn-name-shadowing 46 | -------------------------------------------------------------------------------- /src/Abstract/Interpreter/Collecting.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables, TypeApplications, TypeOperators, UndecidableInstances #-} 2 | module Abstract.Interpreter.Collecting where 3 | 4 | import Abstract.Environment 5 | import Abstract.Interpreter 6 | import Abstract.Primitive 7 | import Abstract.Set 8 | import Abstract.Store 9 | import Abstract.Term 10 | import Abstract.Value 11 | import Abstract.Eval 12 | 13 | import Control.Monad.Effect 14 | import Control.Monad.Effect.Reader 15 | import Data.Semigroup 16 | 17 | 18 | instance (Ord l, Reader (Set (Address l a)) :< fs) => MonadGC l a (Eff fs) where 19 | askRoots = ask :: Eff fs (Set (Address l a)) 20 | 21 | extraRoots roots' = local (<> roots') 22 | 23 | gc :: (Ord l, Foldable (Cell l), AbstractValue l a) => Set (Address l a) -> Store l a -> Store l a 24 | gc roots store = storeRestrict store (reachable roots store) 25 | 26 | reachable :: (Ord l, Foldable (Cell l), AbstractValue l a) => Set (Address l a) -> Store l a -> Set (Address l a) 27 | reachable roots store = go roots mempty 28 | where go set seen = case split set of 29 | Nothing -> seen 30 | Just (a, as) 31 | | Just values <- storeLookupAll a store -> go (difference (foldr ((<>) . valueRoots) mempty values <> as) seen) (insert a seen) 32 | | otherwise -> go seen (insert a seen) 33 | 34 | 35 | evCollect :: forall l t v m 36 | . ( Ord l 37 | , Foldable (Cell l) 38 | , MonadStore l v m 39 | , MonadGC l v m 40 | , AbstractValue l v 41 | ) 42 | => (Eval' t (m v) -> Eval' t (m v)) 43 | -> Eval' t (m v) 44 | -> Eval' t (m v) 45 | evCollect ev0 ev e = do 46 | roots <- askRoots :: m (Set (Address l v)) 47 | v <- ev0 ev e 48 | modifyStore (gc (roots <> valueRoots v)) 49 | return v 50 | 51 | evRoots :: forall l v m s 52 | . ( Ord l 53 | , MonadEnv l v m 54 | , MonadGC l v m 55 | , MonadPrim v m 56 | , AbstractValue l v 57 | , EvalCollect l v m s s 58 | ) 59 | => Eval' (Term s) (m v) 60 | -> Eval' (Term s) (m v) 61 | evRoots ev = evalCollect @l ev . out 62 | -------------------------------------------------------------------------------- /src/Abstract/Configuration.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFoldable, FlexibleContexts, StandaloneDeriving, UndecidableInstances #-} 2 | module Abstract.Configuration where 3 | 4 | import Abstract.Set 5 | import Abstract.Store 6 | import Abstract.Environment 7 | 8 | import Data.List (intersperse) 9 | import Data.Functor.Classes 10 | import Data.Monoid 11 | 12 | data Configuration l t v 13 | = Configuration 14 | { configurationTerm :: t 15 | , configurationRoots :: Set (Address l v) 16 | , configurationEnvironment :: Environment l v 17 | , configurationStore :: Store l v 18 | } 19 | 20 | deriving instance (Eq l, Eq t, Eq v, Eq1 (Cell l)) => Eq (Configuration l t v) 21 | deriving instance (Ord l, Ord t, Ord v, Ord1 (Cell l)) => Ord (Configuration l t v) 22 | deriving instance (Show l, Show t, Show v, Show1 (Cell l)) => Show (Configuration l t v) 23 | deriving instance (Ord l, Foldable (Cell l)) => Foldable (Configuration l t) 24 | 25 | 26 | instance (Eq l, Eq1 (Cell l)) => Eq2 (Configuration l) where 27 | liftEq2 eqT eqV (Configuration t1 r1 e1 s1) (Configuration t2 r2 e2 s2) = eqT t1 t2 && liftEq (liftEq eqV) r1 r2 && liftEq eqV e1 e2 && liftEq eqV s1 s2 28 | 29 | instance (Eq l, Eq t, Eq1 (Cell l)) => Eq1 (Configuration l t) where 30 | liftEq = liftEq2 (==) 31 | 32 | instance (Ord l, Ord1 (Cell l)) => Ord2 (Configuration l) where 33 | liftCompare2 compareT compareV (Configuration t1 r1 e1 s1) (Configuration t2 r2 e2 s2) = compareT t1 t2 <> liftCompare (liftCompare compareV) r1 r2 <> liftCompare compareV e1 e2 <> liftCompare compareV s1 s2 34 | 35 | instance (Ord l, Ord t, Ord1 (Cell l)) => Ord1 (Configuration l t) where 36 | liftCompare = liftCompare2 compare 37 | 38 | showsConstructor :: String -> Int -> [Int -> ShowS] -> ShowS 39 | showsConstructor name d fields = showParen (d > 10) $ showString name . showChar ' ' . foldr (.) id (intersperse (showChar ' ') ([($ 11)] <*> fields)) 40 | 41 | 42 | instance (Show l, Show1 (Cell l)) => Show2 (Configuration l) where 43 | liftShowsPrec2 spT _ spV slV d (Configuration t r e s) = showsConstructor "Configuration" d [ flip spT t, flip (liftShowsPrec (liftShowsPrec spV slV) (liftShowList spV slV)) r, flip (liftShowsPrec spV slV) e, flip (liftShowsPrec spV slV) s ] 44 | 45 | instance (Show l, Show t, Show1 (Cell l)) => Show1 (Configuration l t) where 46 | liftShowsPrec = liftShowsPrec2 showsPrec showList 47 | -------------------------------------------------------------------------------- /src/Abstract/Interpreter/Dead.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes, DataKinds, DeriveFoldable, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-} 2 | module Abstract.Interpreter.Dead where 3 | 4 | import Abstract.Interpreter 5 | import Abstract.Primitive 6 | import Abstract.Set 7 | import Abstract.Store 8 | import Abstract.Term 9 | import Abstract.Eval 10 | 11 | import Control.Effect 12 | import Control.Monad.Effect hiding (run) 13 | import Control.Monad.Effect.State 14 | import Data.Function (fix) 15 | import Data.Functor.Foldable 16 | import Data.Functor.Classes 17 | import Data.Pointed 18 | import Data.Semigroup 19 | 20 | 21 | type DeadCodeInterpreter l t v = State (Dead t) ': Interpreter l v 22 | 23 | type DeadCodeResult l t v = Final (DeadCodeInterpreter l t v) v 24 | 25 | 26 | newtype Dead a = Dead { unDead :: Set a } 27 | deriving (Eq, Foldable, Semigroup, Monoid, Ord, Show) 28 | 29 | 30 | class Monad m => MonadDead t m where 31 | killAll :: Dead t -> m () 32 | revive :: Ord t => t -> m () 33 | 34 | instance (State (Dead t) :< fs) => MonadDead t (Eff fs) where 35 | killAll = put 36 | revive = modify . (Dead .) . (. unDead) . delete 37 | 38 | 39 | subterms :: (Ord a, Recursive a, Foldable (Base a)) => a -> Set a 40 | subterms term = para (foldMap (uncurry ((<>) . point))) term <> point term 41 | 42 | 43 | -- Dead code analysis 44 | -- Example: 45 | -- evalDead @Precise @(Value Syntax Precise) @Syntax (if' true (Abstract.Syntax.int 1) (Abstract.Syntax.int 2)) 46 | evalDead :: forall l v s 47 | . ( Ord v 48 | , Ord1 s 49 | , Recursive (Term s) 50 | , Foldable (Base (Term s)) 51 | , Eval v (Eff (DeadCodeInterpreter l (Term s) v)) s s 52 | , MonadAddress l (Eff (DeadCodeInterpreter l (Term s) v)) 53 | , MonadPrim v (Eff (DeadCodeInterpreter l (Term s) v)) 54 | , Semigroup (Cell l v) 55 | ) 56 | => Term s 57 | -> DeadCodeResult l (Term s) v 58 | evalDead e0 = run @(DeadCodeInterpreter l (Term s) v) $ do 59 | killAll (Dead (subterms e0)) 60 | fix (evDead ev) e0 61 | 62 | evDead :: (Ord t, MonadDead t m) 63 | => (Eval' t (m v) -> Eval' t (m v)) 64 | -> Eval' t (m v) 65 | -> Eval' t (m v) 66 | evDead ev0 ev e = do 67 | revive e 68 | ev0 ev e 69 | -------------------------------------------------------------------------------- /src/Data/Functor/Classes/Show/Generic.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators, FlexibleInstances, FlexibleContexts #-} 2 | module Data.Functor.Classes.Show.Generic 3 | ( Show1(..) 4 | , genericLiftShowsPrec 5 | , genericLiftShowList 6 | ) where 7 | 8 | import Data.Functor.Classes 9 | import GHC.Generics 10 | import Text.Show 11 | 12 | -- | Generically-derivable lifting of the 'Show' class to unary type constructors. 13 | class GShow1 f where 14 | -- | showsPrec function for an application of the type constructor based on showsPrec and showList functions for the argument type. 15 | gliftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS 16 | 17 | -- | showList function for an application of the type constructor based on showsPrec and showList functions for the argument type. The default implementation using standard list syntax is correct for most types. 18 | gliftShowList :: GShow1 f => (Int -> a -> ShowS) -> ([a] -> ShowS) -> [f a] -> ShowS 19 | gliftShowList sp sl = showListWith (gliftShowsPrec sp sl 0) 20 | 21 | -- | A suitable implementation of Show1’s liftShowsPrec for Generic1 types. 22 | genericLiftShowsPrec :: (Generic1 f, GShow1 (Rep1 f)) => (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS 23 | genericLiftShowsPrec sp sl d = gliftShowsPrec sp sl d . from1 24 | 25 | -- | A suitable implementation of Show1’s liftShowsPrec for Generic1 types. 26 | genericLiftShowList :: (Generic1 f, GShow1 (Rep1 f)) => (Int -> a -> ShowS) -> ([a] -> ShowS) -> [f a] -> ShowS 27 | genericLiftShowList sp sl = gliftShowList sp sl . map from1 28 | 29 | 30 | -- Generics 31 | 32 | instance GShow1 U1 where 33 | gliftShowsPrec _ _ _ _ = id 34 | 35 | instance GShow1 Par1 where 36 | gliftShowsPrec sp _ d (Par1 a) = sp d a 37 | 38 | instance Show c => GShow1 (K1 i c) where 39 | gliftShowsPrec _ _ d (K1 a) = showsPrec d a 40 | 41 | instance Show1 f => GShow1 (Rec1 f) where 42 | gliftShowsPrec sp sl d (Rec1 a) = liftShowsPrec sp sl d a 43 | 44 | instance GShow1 f => GShow1 (M1 D c f) where 45 | gliftShowsPrec sp sl d (M1 a) = gliftShowsPrec sp sl d a 46 | 47 | instance (Constructor c, GShow1 f) => GShow1 (M1 C c f) where 48 | gliftShowsPrec sp sl d m = showsUnaryWith (gliftShowsPrec sp sl) (conName m) d (unM1 m) 49 | 50 | instance GShow1 f => GShow1 (M1 S c f) where 51 | gliftShowsPrec sp sl d (M1 a) = gliftShowsPrec sp sl d a 52 | 53 | instance (GShow1 f, GShow1 g) => GShow1 (f :+: g) where 54 | gliftShowsPrec sp sl d (L1 l) = gliftShowsPrec sp sl d l 55 | gliftShowsPrec sp sl d (R1 r) = gliftShowsPrec sp sl d r 56 | 57 | instance (GShow1 f, GShow1 g) => GShow1 (f :*: g) where 58 | gliftShowsPrec sp sl d (a :*: b) = gliftShowsPrec sp sl d a . showChar ' ' . gliftShowsPrec sp sl d b 59 | 60 | instance (Show1 f, GShow1 g) => GShow1 (f :.: g) where 61 | gliftShowsPrec sp sl d (Comp1 a) = liftShowsPrec (gliftShowsPrec sp sl) (gliftShowList sp sl) d a 62 | -------------------------------------------------------------------------------- /src/Abstract/Value.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds, FunctionalDependencies, AllowAmbiguousTypes, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables, TypeOperators, UndecidableInstances #-} 2 | module Abstract.Value where 3 | 4 | import Abstract.Environment 5 | import Abstract.Primitive 6 | import Abstract.Term 7 | import Abstract.Set 8 | import Abstract.Store 9 | import Abstract.Type 10 | 11 | import Control.Monad hiding (fail) 12 | import Control.Monad.Fail 13 | import Data.Functor.Classes 14 | import Data.Semigroup 15 | import Prelude hiding (fail) 16 | 17 | 18 | data Value syntax l 19 | = I Prim 20 | | Closure Name (Term syntax) (Environment l (Value syntax l)) 21 | deriving (Eq, Ord, Show) 22 | 23 | 24 | -- Instances 25 | 26 | instance Eq1 syntax => Eq1 (Value syntax) where 27 | liftEq eqL = go 28 | where go v1 v2 = case (v1, v2) of 29 | (I a, I b) -> a == b 30 | (Closure s1 t1 e1, Closure s2 t2 e2) -> s1 == s2 && t1 == t2 && liftEq2 eqL go e1 e2 31 | _ -> False 32 | 33 | instance Ord1 syntax => Ord1 (Value syntax) where 34 | liftCompare compareL = go 35 | where go v1 v2 = case (v1, v2) of 36 | (I a, I b) -> compare a b 37 | (Closure s1 t1 e1, Closure s2 t2 e2) -> compare s1 s2 <> compare t1 t2 <> liftCompare2 compareL go e1 e2 38 | (I _, _) -> LT 39 | _ -> GT 40 | 41 | instance MonadFail m => MonadPrim (Value s l) m where 42 | delta1 o (I a) = fmap I (delta1 o a) 43 | delta1 Not _ = nonBoolean 44 | delta1 _ _ = nonNumeric 45 | 46 | delta2 o (I a) (I b) = fmap I (delta2 o a b) 47 | delta2 And _ _ = nonBoolean 48 | delta2 Or _ _ = nonBoolean 49 | delta2 Eq Closure{} Closure{} = undefinedComparison 50 | delta2 Eq _ _ = disjointComparison 51 | delta2 Lt Closure{} Closure{} = undefinedComparison 52 | delta2 Lt _ _ = disjointComparison 53 | delta2 LtE Closure{} Closure{} = undefinedComparison 54 | delta2 LtE _ _ = disjointComparison 55 | delta2 Gt Closure{} Closure{} = undefinedComparison 56 | delta2 Gt _ _ = disjointComparison 57 | delta2 GtE Closure{} Closure{} = undefinedComparison 58 | delta2 GtE _ _ = disjointComparison 59 | delta2 _ _ _ = nonNumeric 60 | 61 | truthy (I a) = truthy a 62 | truthy _ = nonBoolean 63 | 64 | 65 | 66 | class AbstractValue l v | v -> l where 67 | literal :: Prim -> v 68 | valueRoots :: v -> Set (Address l v) 69 | 70 | instance (FreeVariables1 syntax, Functor syntax, Ord l) => AbstractValue l (Value syntax l) where 71 | valueRoots (I _) = mempty 72 | valueRoots (Closure name body env) = envRoots env (delete name (freeVariables body)) 73 | 74 | literal = I 75 | 76 | instance AbstractValue Monovariant Type where 77 | valueRoots _ = mempty 78 | 79 | literal (PInt _) = Int 80 | literal (PBool _) = Bool 81 | -------------------------------------------------------------------------------- /src/Abstract/Interpreter/Tracing.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes, DataKinds, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-} 2 | module Abstract.Interpreter.Tracing where 3 | 4 | import Abstract.Configuration 5 | import Abstract.Environment 6 | import Abstract.Eval 7 | import Abstract.Interpreter 8 | import Abstract.Primitive 9 | import Abstract.Set 10 | import Abstract.Store 11 | import Abstract.Term 12 | 13 | import Control.Effect 14 | import Control.Monad.Effect hiding (run) 15 | import Control.Monad.Effect.Reader 16 | import Control.Monad.Effect.Writer 17 | import Data.Function (fix) 18 | import Data.Functor.Classes (Ord1) 19 | import Data.Semigroup 20 | import GHC.Exts (IsList(..)) 21 | import qualified Data.Set as Set 22 | 23 | type TracingInterpreter l t v g = Reader (Set (Address l v)) ': Writer (g (Configuration l t v)) ': Interpreter l v 24 | 25 | type TraceInterpreter l t v = TracingInterpreter l t v [] 26 | type ReachableStateInterpreter l t v = TracingInterpreter l t v Set.Set 27 | 28 | type TraceResult l t v f = Final (TracingInterpreter l t v f) v 29 | 30 | 31 | class Monad m => MonadTrace l t v g m where 32 | trace :: g (Configuration l t v) -> m () 33 | 34 | instance (Writer (g (Configuration l t v)) :< fs) => MonadTrace l t v g (Eff fs) where 35 | trace = tell 36 | 37 | 38 | -- Tracing and reachable state analyses 39 | -- 40 | -- Examples 41 | -- evalTrace @Precise @(Value Syntax Precise) @Syntax (makeLam "x" (var "x") # true) 42 | -- evalReach @Precise @(Value Syntax Precise) @Syntax (makeLam "x" (var "x") # true) 43 | 44 | evalTrace :: forall l v s 45 | . ( Ord v, Ord1 s, Ord1 (Cell l) 46 | , MonadAddress l (Eff (TraceInterpreter l (Term s) v)) 47 | , MonadPrim v (Eff (TraceInterpreter l (Term s) v)) 48 | , MonadGC l v (Eff (TraceInterpreter l (Term s) v)) 49 | , Semigroup (Cell l v) 50 | , Eval v (Eff (TraceInterpreter l (Term s) v)) s s 51 | ) 52 | => Eval' (Term s) (TraceResult l (Term s) v []) 53 | evalTrace = run @(TraceInterpreter l (Term s) v) . fix (evTell @l @(Term s) @v @[] ev) 54 | 55 | evalReach :: forall l v s 56 | . ( Ord v, Ord l, Ord1 (Cell l), Ord1 s 57 | , MonadAddress l (Eff (ReachableStateInterpreter l (Term s) v)) 58 | , MonadPrim v (Eff (ReachableStateInterpreter l (Term s) v)) 59 | , MonadGC l v (Eff (ReachableStateInterpreter l (Term s) v)) 60 | , Semigroup (Cell l v) 61 | , Eval v (Eff (ReachableStateInterpreter l (Term s) v)) s s 62 | ) 63 | => Eval' (Term s) (TraceResult l (Term s) v Set.Set) 64 | evalReach = run @(ReachableStateInterpreter l (Term s) v) . fix (evTell @l @(Term s) @v @Set.Set ev) 65 | 66 | 67 | evTell :: forall l t v g m 68 | . ( Ord l 69 | , IsList (g (Configuration l t v)) 70 | , Item (g (Configuration l t v)) ~ Configuration l t v 71 | , MonadTrace l t v g m 72 | , MonadEnv l v m 73 | , MonadStore l v m 74 | , MonadGC l v m 75 | ) 76 | => (Eval' t (m v) -> Eval' t (m v)) 77 | -> Eval' t (m v) 78 | -> Eval' t (m v) 79 | evTell ev0 ev e = do 80 | env <- askEnv 81 | store <- getStore 82 | roots <- askRoots 83 | trace (fromList [Configuration e roots env store] :: g (Configuration l t v)) 84 | ev0 ev e 85 | -------------------------------------------------------------------------------- /src/Abstract/Interpreter/Symbolic.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, RankNTypes, TypeOperators, UndecidableInstances #-} 2 | module Abstract.Interpreter.Symbolic where 3 | 4 | import Abstract.Interpreter 5 | import Abstract.Primitive 6 | import Abstract.Term 7 | import Abstract.Syntax 8 | 9 | import Control.Applicative 10 | import Control.Monad 11 | import Control.Monad.Effect 12 | import Control.Monad.Effect.State 13 | import Control.Monad.Fail 14 | import Data.Functor.Classes 15 | import qualified Data.Set as Set 16 | import Data.Union 17 | 18 | data Sym t a = Sym t | V a 19 | deriving (Eq, Ord, Show) 20 | 21 | sym :: (Num a, Num t) => (forall n . Num n => n -> n) -> Sym t a -> Sym t a 22 | sym f (Sym t) = Sym (f t) 23 | sym f (V a) = V (f a) 24 | 25 | sym2 :: Applicative f => (a -> a -> f a) -> (a -> t) -> (t -> t -> t) -> Sym t a -> Sym t a -> f (Sym t a) 26 | sym2 f _ _ (V a) (V b) = V <$> f a b 27 | sym2 _ _ g (Sym a) (Sym b) = pure (Sym (g a b)) 28 | sym2 f num g a (V b) = sym2 f num g a (Sym (num b)) 29 | sym2 f num g (V a) b = sym2 f num g (Sym (num a)) b 30 | 31 | 32 | evSymbolic :: (Eval' t (Eff fs (v (Sym t a))) -> Eval' t (Eff fs (v (Sym t a)))) 33 | -> Eval' t (Eff fs (v (Sym t a))) 34 | -> Eval' t (Eff fs (v (Sym t a))) 35 | evSymbolic ev0 ev e = ev0 ev e 36 | 37 | 38 | data PathExpression t = E t | NotE t 39 | deriving (Eq, Ord, Show) 40 | 41 | newtype PathCondition t = PathCondition { unPathCondition :: Set.Set (PathExpression t) } 42 | deriving (Eq, Ord, Show) 43 | 44 | 45 | refine :: (Ord t, MonadPathCondition t m) => PathExpression t -> m () 46 | refine = modifyPathCondition . pathConditionInsert 47 | 48 | pathConditionMember :: Ord t => PathExpression t -> PathCondition t -> Bool 49 | pathConditionMember = (. unPathCondition) . Set.member 50 | 51 | pathConditionInsert :: Ord t => PathExpression t -> PathCondition t -> PathCondition t 52 | pathConditionInsert = ((PathCondition .) . (. unPathCondition)) . Set.insert 53 | 54 | 55 | class Monad m => MonadPathCondition t m where 56 | getPathCondition :: m (PathCondition t) 57 | putPathCondition :: PathCondition t -> m () 58 | 59 | instance (State (PathCondition t) :< fs) => MonadPathCondition t (Eff fs) where 60 | getPathCondition = get 61 | putPathCondition = put 62 | 63 | modifyPathCondition :: MonadPathCondition t m => (PathCondition t -> PathCondition t) -> m () 64 | modifyPathCondition f = getPathCondition >>= putPathCondition . f 65 | 66 | instance ( Alternative m 67 | , MonadFail m 68 | , MonadPrim Prim m 69 | , MonadPathCondition (Term (Union fs)) m 70 | , Apply Eq1 fs 71 | , Apply Ord1 fs 72 | , Binary :< fs 73 | , Unary :< fs 74 | , Primitive :< fs 75 | ) => MonadPrim (Sym (Term (Union fs)) Prim) m where 76 | delta1 o a = case o of 77 | Negate -> pure (negate a) 78 | Abs -> pure (abs a) 79 | Signum -> pure (signum a) 80 | Not -> case a of 81 | Sym t -> pure (Sym (not' t)) 82 | V a -> V <$> delta1 Not a 83 | 84 | delta2 o a b = case o of 85 | Plus -> pure (a + b) 86 | Minus -> pure (a - b) 87 | Times -> pure (a * b) 88 | DividedBy -> isZero b >>= flip when divisionByZero >> sym2 (delta2 DividedBy) prim div' a b 89 | Quotient -> isZero b >>= flip when divisionByZero >> sym2 (delta2 Quotient) prim quot' a b 90 | Remainder -> isZero b >>= flip when divisionByZero >> sym2 (delta2 Remainder) prim rem' a b 91 | Modulus -> isZero b >>= flip when divisionByZero >> sym2 (delta2 Modulus) prim mod' a b 92 | And -> sym2 (delta2 And) prim and' a b 93 | Or -> sym2 (delta2 Or) prim or' a b 94 | Eq -> sym2 (delta2 Eq) prim eq a b 95 | Lt -> sym2 (delta2 Lt) prim lt a b 96 | LtE -> sym2 (delta2 LtE) prim lte a b 97 | Gt -> sym2 (delta2 Gt) prim gt a b 98 | GtE -> sym2 (delta2 GtE) prim gte a b 99 | 100 | truthy (V a) = truthy a 101 | truthy (Sym e) = do 102 | phi <- getPathCondition 103 | if E e `pathConditionMember` phi then 104 | return True 105 | else if NotE e `pathConditionMember` phi then 106 | return False 107 | else 108 | (refine (E e) >> return True) 109 | <|> (refine (NotE e) >> return False) 110 | 111 | instance (Binary :< fs, Unary :< fs, Primitive :< fs) => Num (Sym (Term (Union fs)) Prim) where 112 | fromInteger = V . fromInteger 113 | 114 | signum (V a) = V (signum a) 115 | signum (Sym t) = Sym (signum t) 116 | abs (V a) = V (abs a) 117 | abs (Sym t) = Sym (abs t) 118 | negate (V a) = V (negate a) 119 | negate (Sym t) = Sym (negate t) 120 | V a + V b = V ( a + b) 121 | Sym a + V b = Sym ( a + prim b) 122 | V a + Sym b = Sym (prim a + b) 123 | Sym a + Sym b = Sym ( a + b) 124 | V a - V b = V ( a - b) 125 | Sym a - V b = Sym ( a - prim b) 126 | V a - Sym b = Sym (prim a - b) 127 | Sym a - Sym b = Sym ( a - b) 128 | V a * V b = V ( a * b) 129 | Sym a * V b = Sym ( a * prim b) 130 | V a * Sym b = Sym (prim a * b) 131 | Sym a * Sym b = Sym ( a * b) 132 | -------------------------------------------------------------------------------- /src/Abstract/Primitive.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-} 2 | module Abstract.Primitive where 3 | 4 | import Abstract.Type 5 | import Control.Applicative 6 | import Control.Monad hiding (fail) 7 | import Control.Monad.Fail 8 | import Prelude hiding (fail) 9 | 10 | data Op1 = Negate | Abs | Signum | Not 11 | deriving (Eq, Ord, Show) 12 | 13 | data Op2 = Plus | Minus | Times | DividedBy | Quotient | Remainder | Modulus | And | Or | Eq | Lt | LtE | Gt | GtE 14 | deriving (Eq, Ord, Show) 15 | 16 | arithmeticOperators :: [Op2] 17 | arithmeticOperators = [Plus, Minus, Times, DividedBy, Quotient, Remainder, Modulus] 18 | 19 | booleanOperators :: [Op2] 20 | booleanOperators = [And, Or] 21 | 22 | relationOperators :: [Op2] 23 | relationOperators = [Eq, Lt, LtE, Gt, GtE] 24 | 25 | 26 | data Prim 27 | = PInt {-# UNPACK #-} !Int 28 | | PBool !Bool 29 | deriving (Eq, Ord, Show) 30 | 31 | class Monad m => MonadPrim a m where 32 | delta1 :: Op1 -> a -> m a 33 | delta2 :: Op2 -> a -> a -> m a 34 | truthy :: a -> m Bool 35 | 36 | 37 | divisionByZero :: MonadFail m => m a 38 | divisionByZero = fail "division by zero" 39 | 40 | nonNumeric :: MonadFail m => m a 41 | nonNumeric = fail "numeric operation on non-numeric value" 42 | 43 | nonBoolean :: MonadFail m => m a 44 | nonBoolean = fail "boolean operation on non-boolean value" 45 | 46 | disjointComparison :: MonadFail m => m a 47 | disjointComparison = fail "comparison of disjoint values" 48 | 49 | undefinedComparison :: MonadFail m => m a 50 | undefinedComparison = fail "undefined comparison" 51 | 52 | 53 | isZero :: (Num a, MonadPrim a m) => a -> m Bool 54 | isZero = truthy <=< delta2 Eq 0 55 | 56 | instance MonadFail m => MonadPrim Prim m where 57 | delta1 o a = case (o, a) of 58 | (Negate, PInt a) -> pure (PInt (negate a)) 59 | (Abs, PInt a) -> pure (PInt (abs a)) 60 | (Signum, PInt a) -> pure (PInt (signum a)) 61 | (Not, PBool a) -> pure (PBool (not a)) 62 | (Not, _) -> nonBoolean 63 | _ -> nonNumeric 64 | 65 | delta2 o (PInt a) (PInt b) = case o of 66 | Plus -> pure (PInt (a + b)) 67 | Minus -> pure (PInt (a - b)) 68 | Times -> pure (PInt (a * b)) 69 | DividedBy -> isZero (PInt b) >>= flip when divisionByZero >> pure (PInt (a `div` b)) 70 | Quotient -> isZero (PInt b) >>= flip when divisionByZero >> pure (PInt (a `quot` b)) 71 | Remainder -> isZero (PInt b) >>= flip when divisionByZero >> pure (PInt (a `rem` b)) 72 | Modulus -> isZero (PInt b) >>= flip when divisionByZero >> pure (PInt (a `mod` b)) 73 | Eq -> pure (PBool (a == b)) 74 | Lt -> pure (PBool (a < b)) 75 | LtE -> pure (PBool (a <= b)) 76 | Gt -> pure (PBool (a > b)) 77 | GtE -> pure (PBool (a >= b)) 78 | _ -> nonBoolean 79 | delta2 o (PBool a) (PBool b) = case o of 80 | And -> pure (PBool (a && b)) 81 | Or -> pure (PBool (a || b)) 82 | Eq -> pure (PBool (a == b)) 83 | Lt -> pure (PBool (a < b)) 84 | LtE -> pure (PBool (a <= b)) 85 | Gt -> pure (PBool (a > b)) 86 | GtE -> pure (PBool (a >= b)) 87 | _ -> nonNumeric 88 | delta2 _ _ _ = disjointComparison 89 | 90 | truthy (PBool a) = pure a 91 | truthy _ = nonBoolean 92 | 93 | instance (MonadFail m, Alternative m) => MonadPrim Type m where 94 | delta1 Not Bool = pure Bool 95 | delta1 Not _ = nonBoolean 96 | delta1 _ Int = pure Int 97 | delta1 _ _ = nonNumeric 98 | 99 | delta2 o a b 100 | | o `elem` booleanOperators = case (a, b) of 101 | (Bool, Bool) -> pure Bool 102 | (TVar _, Bool) -> pure Bool 103 | (Bool, TVar _) -> pure Bool 104 | (TVar _, TVar _) -> pure Bool 105 | _ -> nonBoolean 106 | | o `elem` relationOperators = case (a, b) of 107 | _ | a == b -> pure Bool 108 | (TVar _, _) -> pure Bool 109 | (_, TVar _) -> pure Bool 110 | _ -> disjointComparison 111 | | o `elem` arithmeticOperators = case (a, b) of 112 | (Int, Int) -> pure Int 113 | (TVar _, Int) -> pure Int 114 | (Int, TVar _) -> pure Int 115 | (TVar _, TVar _) -> pure Int 116 | _ -> nonNumeric 117 | delta2 DividedBy Int Int = pure Int <|> divisionByZero 118 | delta2 Quotient Int Int = pure Int <|> divisionByZero 119 | delta2 Remainder Int Int = pure Int <|> divisionByZero 120 | delta2 Modulus Int Int = pure Int <|> divisionByZero 121 | delta2 _ _ _ = nonNumeric 122 | 123 | truthy Bool = pure True <|> pure False 124 | truthy (TVar _) = pure True <|> pure False 125 | truthy _ = nonBoolean 126 | 127 | 128 | instance Num Prim where 129 | fromInteger = PInt . fromInteger 130 | 131 | negate (PInt a) = PInt (negate a) 132 | negate _ = error "negate of non-integer" 133 | abs (PInt a) = PInt (abs a) 134 | abs _ = error "abs of non-integer" 135 | signum (PInt a) = PInt (signum a) 136 | signum _ = error "signum of non-integer" 137 | 138 | PInt a + PInt b = PInt (a + b) 139 | _ + _ = error "(+) of non-integer" 140 | PInt a * PInt b = PInt (a * b) 141 | _ * _ = error "(*) of non-integer" 142 | -------------------------------------------------------------------------------- /src/Abstract/Store.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes, DataKinds, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-} 2 | module Abstract.Store 3 | ( Precise(..) 4 | , Monovariant(..) 5 | , MonadAddress(alloc, Cell) 6 | , Store(..) 7 | , storeLookup 8 | , storeLookupAll 9 | , storeRestrict 10 | , Address(..) 11 | , Set(..) 12 | , deref 13 | , assign 14 | , MonadStore(..) 15 | , modifyStore 16 | ) where 17 | 18 | import Abstract.Set 19 | import Abstract.Term 20 | import Control.Applicative 21 | import Control.Monad ((<=<)) 22 | import Control.Monad.Effect 23 | import Control.Monad.Effect.State 24 | import Control.Monad.Fail 25 | import Data.Foldable (asum, toList) 26 | import Data.Functor.Classes 27 | import qualified Data.Map as Map 28 | import Data.Pointed 29 | import Data.Semigroup 30 | import Prelude hiding (fail) 31 | 32 | newtype Store l a = Store { unStore :: Map.Map (Address l a) (Cell l a) } 33 | deriving (Semigroup, Monoid) 34 | 35 | newtype Address l a = Address { unAddress :: l } 36 | deriving (Eq, Ord, Show) 37 | 38 | storeLookup :: Ord l => Address l a -> Store l a -> Maybe (Cell l a) 39 | storeLookup = (. unStore) . Map.lookup 40 | 41 | storeLookupAll :: (Ord l, Foldable (Cell l)) => Address l a -> Store l a -> Maybe [a] 42 | storeLookupAll address = fmap toList . storeLookup address 43 | 44 | storeInsert :: (Ord l, Semigroup (Cell l a), Pointed (Cell l)) => Address l a -> a -> Store l a -> Store l a 45 | storeInsert = (((Store .) . (. unStore)) .) . (. point) . Map.insertWith (<>) 46 | 47 | storeSize :: Store l a -> Int 48 | storeSize = Map.size . unStore 49 | 50 | storeRestrict :: Ord l => Store l a -> Set (Address l a) -> Store l a 51 | storeRestrict (Store m) roots = Store (Map.filterWithKey (\ address _ -> address `member` roots) m) 52 | 53 | 54 | assign :: (Ord l, Semigroup (Cell l a), Pointed (Cell l), MonadStore l a m) => Address l a -> a -> m () 55 | assign = (modifyStore .) . storeInsert 56 | 57 | 58 | class Monad m => MonadStore l a m where 59 | getStore :: m (Store l a) 60 | putStore :: Store l a -> m () 61 | 62 | instance (State (Store l a) :< fs) => MonadStore l a (Eff fs) where 63 | getStore = get 64 | putStore = put 65 | 66 | modifyStore :: MonadStore l a m => (Store l a -> Store l a) -> m () 67 | modifyStore f = getStore >>= putStore . f 68 | 69 | 70 | class (Ord l, Pointed (Cell l), Monad m) => MonadAddress l m where 71 | type Cell l :: * -> * 72 | 73 | deref :: (MonadStore l a m, MonadFail m) => Address l a -> m a 74 | 75 | alloc :: MonadStore l a m => Name -> m (Address l a) 76 | 77 | 78 | newtype Precise = Precise { unPrecise :: Int } 79 | deriving (Eq, Ord, Show) 80 | 81 | allocPrecise :: Store Precise a -> Address Precise a 82 | allocPrecise = Address . Precise . storeSize 83 | 84 | newtype I a = I { unI :: a } 85 | deriving (Eq, Ord, Show) 86 | 87 | instance Monad m => MonadAddress Precise m where 88 | type Cell Precise = I 89 | 90 | deref = maybe uninitializedAddress (pure . unI) <=< flip fmap getStore . storeLookup 91 | 92 | alloc _ = fmap allocPrecise getStore 93 | 94 | 95 | newtype Monovariant = Monovariant { unMonovariant :: Name } 96 | deriving (Eq, Ord, Show) 97 | 98 | instance (Alternative m, Monad m) => MonadAddress Monovariant m where 99 | type Cell Monovariant = Set 100 | 101 | deref = asum . maybe [] (map pure . toList) <=< flip fmap getStore . storeLookup 102 | 103 | alloc = pure . Address . Monovariant 104 | 105 | 106 | uninitializedAddress :: MonadFail m => m a 107 | uninitializedAddress = fail "uninitialized address" 108 | 109 | 110 | instance Semigroup (I a) where 111 | (<>) = const 112 | 113 | instance Foldable I where 114 | foldMap f = f . unI 115 | 116 | instance Functor I where 117 | fmap f = I . f . unI 118 | 119 | instance Traversable I where 120 | traverse f = fmap I . f . unI 121 | 122 | instance Pointed I where 123 | point = I 124 | 125 | instance Eq1 I where 126 | liftEq eq (I a) (I b) = eq a b 127 | 128 | instance Ord1 I where 129 | liftCompare comp (I a) (I b) = comp a b 130 | 131 | instance Show1 I where 132 | liftShowsPrec sp _ d (I a) = sp d a 133 | 134 | instance Foldable (Address l) where 135 | foldMap _ = mempty 136 | 137 | instance Functor (Address l) where 138 | fmap _ = Address . unAddress 139 | 140 | instance Traversable (Address l) where 141 | traverse _ = fmap Address . pure . unAddress 142 | 143 | 144 | instance Foldable (Cell l) => Foldable (Store l) where 145 | foldMap = (. unStore) . foldMap . foldMap 146 | 147 | instance (Ord l, Functor (Cell l)) => Functor (Store l) where 148 | fmap f = Store . Map.mapKeys (Address . unAddress) . fmap (fmap f) . unStore 149 | 150 | instance (Ord l, Traversable (Cell l)) => Traversable (Store l) where 151 | traverse f = fmap (Store . Map.mapKeys (Address . unAddress)) . traverse (traverse f) . unStore 152 | 153 | 154 | instance (Eq l, Eq1 (Cell l)) => Eq1 (Store l) where 155 | liftEq eq (Store m1) (Store m2) = liftEq2 (liftEq eq) (liftEq eq) m1 m2 156 | 157 | instance (Eq a, Eq l, Eq1 (Cell l)) => Eq (Store l a) where 158 | (==) = eq1 159 | 160 | instance Eq2 Address where 161 | liftEq2 eqL _ (Address a) (Address b) = eqL a b 162 | 163 | instance Eq l => Eq1 (Address l) where 164 | liftEq = liftEq2 (==) 165 | 166 | instance (Ord l, Ord1 (Cell l)) => Ord1 (Store l) where 167 | liftCompare compareA (Store m1) (Store m2) = liftCompare2 (liftCompare compareA) (liftCompare compareA) m1 m2 168 | 169 | instance (Ord a, Ord l, Ord1 (Cell l)) => Ord (Store l a) where 170 | compare = compare1 171 | 172 | instance Ord2 Address where 173 | liftCompare2 compareL _ (Address a) (Address b) = compareL a b 174 | 175 | instance Ord l => Ord1 (Address l) where 176 | liftCompare = liftCompare2 compare 177 | 178 | instance (Show l, Show1 (Cell l)) => Show1 (Store l) where 179 | liftShowsPrec sp sl d (Store m) = showsUnaryWith (liftShowsPrec (liftShowsPrec sp sl) (liftShowList sp sl)) "Store" d m 180 | 181 | instance (Show a, Show l, Show1 (Cell l)) => Show (Store l a) where 182 | showsPrec = showsPrec1 183 | 184 | instance Show2 Address where 185 | liftShowsPrec2 spL _ _ _ d = showsUnaryWith spL "Address" d . unAddress 186 | 187 | instance Show l => Show1 (Address l) where 188 | liftShowsPrec = liftShowsPrec2 showsPrec showList 189 | -------------------------------------------------------------------------------- /src/Abstract/Interpreter/Caching.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes, ConstraintKinds, DataKinds, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-} 2 | module Abstract.Interpreter.Caching where 3 | 4 | import Abstract.Configuration 5 | import Abstract.Environment 6 | import Abstract.Eval 7 | import Abstract.Interpreter 8 | import Abstract.Interpreter.Collecting 9 | import Abstract.Primitive 10 | import Abstract.Set 11 | import Abstract.Store 12 | import Abstract.Term 13 | import Abstract.Type 14 | import Abstract.Value 15 | 16 | import Control.Applicative 17 | import Control.Effect 18 | import Control.Monad.Effect.Fail 19 | import Control.Monad.Effect.Internal hiding (run) 20 | import Control.Monad.Effect.NonDetEff 21 | import Control.Monad.Effect.Reader 22 | import Control.Monad.Effect.State 23 | import Data.Foldable 24 | import Data.Function (fix) 25 | import Data.Functor.Classes 26 | import Data.Maybe 27 | import Data.Pointed 28 | import Data.Semigroup 29 | import qualified Data.Map as Map 30 | 31 | newtype Cache l t v = Cache { unCache :: Map.Map (Configuration l t v) (Set (v, Store l v)) } 32 | 33 | deriving instance (Ord l, Ord t, Ord v, Ord1 (Cell l)) => Monoid (Cache l t v) 34 | 35 | cacheLookup :: (Ord l, Ord t, Ord v, Ord1 (Cell l)) => Configuration l t v -> Cache l t v -> Maybe (Set (v, Store l v)) 36 | cacheLookup key = Map.lookup key . unCache 37 | 38 | cacheSet :: (Ord l, Ord t, Ord v, Ord1 (Cell l)) => Configuration l t v -> Set (v, Store l v) -> Cache l t v -> Cache l t v 39 | cacheSet = (((Cache .) . (. unCache)) .) . Map.insert 40 | 41 | cacheInsert :: (Ord l, Ord t, Ord v, Ord1 (Cell l)) => Configuration l t v -> (v, Store l v) -> Cache l t v -> Cache l t v 42 | cacheInsert = (((Cache .) . (. unCache)) .) . (. point) . Map.insertWith (<>) 43 | 44 | 45 | type CachingInterpreter l t v = '[Fresh, Reader (Set (Address l v)), Reader (Environment l v), Fail, NonDetEff, State (Store l v), Reader (Cache l t v), State (Cache l t v)] 46 | 47 | type CachingResult l t v = Final (CachingInterpreter l t v) v 48 | 49 | type MonadCachingInterpreter l t v m = (MonadEnv l v m, MonadStore l v m, MonadCacheIn l t v m, MonadCacheOut l t v m, MonadGC l v m, Alternative m) 50 | 51 | 52 | 53 | class Monad m => MonadCacheIn l t v m where 54 | askCache :: m (Cache l t v) 55 | localCache :: (Cache l t v -> Cache l t v) -> m a -> m a 56 | 57 | instance (Reader (Cache l t v) :< fs) => MonadCacheIn l t v (Eff fs) where 58 | askCache = ask 59 | localCache = local 60 | 61 | 62 | class Monad m => MonadCacheOut l t v m where 63 | getCache :: m (Cache l t v) 64 | putCache :: Cache l t v -> m () 65 | 66 | instance (State (Cache l t v) :< fs) => MonadCacheOut l t v (Eff fs) where 67 | getCache = get 68 | putCache = put 69 | 70 | modifyCache :: MonadCacheOut l t v m => (Cache l t v -> Cache l t v) -> m () 71 | modifyCache f = fmap f getCache >>= putCache 72 | 73 | 74 | class (Alternative m, Monad m) => MonadNonDet m where 75 | collect :: Monoid b => (a -> b) -> m a -> m b 76 | 77 | instance (NonDetEff :< fs) => MonadNonDet (Eff fs) where 78 | collect f = interpose (pure . f) (\ m k -> case m of 79 | MZero -> pure mempty 80 | MPlus -> mappend <$> k True <*> k False) 81 | 82 | 83 | -- Coinductively-cached evaluation 84 | -- 85 | -- Examples: 86 | -- evalCache @Monovariant @Type @Syntax (makeLam "x" (var "x") # true) 87 | -- evalCache @Precise @(Value Syntax Precise) @Syntax (makeLam "x" (var "x") # true) 88 | 89 | evalCache :: forall l v s 90 | . ( Ord v, Ord l 91 | , Ord1 (Cell l), Ord1 s 92 | , Foldable (Cell l) 93 | , MonadAddress l (Eff (CachingInterpreter l (Term s) v)) 94 | , MonadPrim v (Eff (CachingInterpreter l (Term s) v)) 95 | , Semigroup (Cell l v) 96 | , AbstractValue l v 97 | , EvalCollect l v (Eff (CachingInterpreter l (Term s) v)) s s 98 | ) 99 | => Term s 100 | -> CachingResult l (Term s) v 101 | evalCache e = run @(CachingInterpreter l (Term s) v) (fixCache @l (fix (evCache @l (evCollect @l (evRoots @l)))) e) 102 | 103 | 104 | evCache :: forall l t v m 105 | . ( Ord l, Ord t, Ord v 106 | , Ord1 (Cell l) 107 | , MonadCachingInterpreter l t v m 108 | ) 109 | => (Eval' t (m v) -> Eval' t (m v)) 110 | -> Eval' t (m v) 111 | -> Eval' t (m v) 112 | evCache ev0 ev e = do 113 | env <- askEnv 114 | store <- getStore 115 | roots <- askRoots 116 | let c = Configuration e roots env store :: Configuration l t v 117 | out <- getCache 118 | case cacheLookup c out of 119 | Just pairs -> asum . flip map (toList pairs) $ \ (value, store') -> do 120 | putStore store' 121 | return value 122 | Nothing -> do 123 | in' <- askCache 124 | let pairs = fromMaybe mempty (cacheLookup c in') 125 | putCache (cacheSet c pairs out) 126 | v <- ev0 ev e 127 | store' <- getStore 128 | modifyCache (cacheInsert c (v, store')) 129 | return v 130 | 131 | fixCache :: forall l t v m 132 | . ( Ord l, Ord t, Ord v 133 | , Ord1 (Cell l) 134 | , MonadCachingInterpreter l t v m 135 | , MonadNonDet m 136 | , MonadFresh m 137 | ) 138 | => Eval' t (m v) 139 | -> Eval' t (m v) 140 | fixCache eval e = do 141 | env <- askEnv 142 | store <- getStore 143 | roots <- askRoots 144 | let c = Configuration e roots env store :: Configuration l t v 145 | pairs <- mlfp mempty (\ dollar -> do 146 | putCache (mempty :: Cache l t v) 147 | putStore store 148 | reset 0 149 | _ <- localCache (const dollar) (collect point (eval e) :: m (Set v)) 150 | getCache) 151 | asum . flip map (maybe [] toList (cacheLookup c pairs)) $ \ (value, store') -> do 152 | putStore store' 153 | return value 154 | 155 | 156 | mlfp :: (Eq a, Monad m) => a -> (a -> m a) -> m a 157 | mlfp a f = loop a 158 | where loop x = do 159 | x' <- f x 160 | if x' == x then 161 | return x 162 | else 163 | loop x' 164 | 165 | 166 | instance (Eq l, Eq1 (Cell l)) => Eq2 (Cache l) where 167 | liftEq2 eqT eqV (Cache a) (Cache b) = liftEq2 (liftEq2 eqT eqV) (liftEq (liftEq2 eqV (liftEq eqV))) a b 168 | 169 | instance (Eq l, Eq t, Eq1 (Cell l)) => Eq1 (Cache l t) where 170 | liftEq = liftEq2 (==) 171 | 172 | instance (Eq l, Eq t, Eq v, Eq1 (Cell l)) => Eq (Cache l t v) where 173 | (==) = eq1 174 | 175 | 176 | instance (Ord l, Ord1 (Cell l)) => Ord2 (Cache l) where 177 | liftCompare2 compareT compareV (Cache a) (Cache b) = liftCompare2 (liftCompare2 compareT compareV) (liftCompare (liftCompare2 compareV (liftCompare compareV))) a b 178 | 179 | instance (Ord l, Ord t, Ord1 (Cell l)) => Ord1 (Cache l t) where 180 | liftCompare = liftCompare2 compare 181 | 182 | instance (Ord l, Ord t, Ord v, Ord1 (Cell l)) => Ord (Cache l t v) where 183 | compare = compare1 184 | 185 | 186 | instance (Show l, Show1 (Cell l)) => Show2 (Cache l) where 187 | liftShowsPrec2 spT slT spV slV d = showsUnaryWith (liftShowsPrec2 spKey slKey (liftShowsPrec spPair slPair) (liftShowList spPair slPair)) "Cache" d . unCache 188 | where spKey = liftShowsPrec2 spT slT spV slV 189 | slKey = liftShowList2 spT slT spV slV 190 | spPair = liftShowsPrec2 spV slV spStore slStore 191 | slPair = liftShowList2 spV slV spStore slStore 192 | spStore = liftShowsPrec spV slV 193 | slStore = liftShowList spV slV 194 | 195 | instance (Show l, Show t, Show1 (Cell l)) => Show1 (Cache l t) where 196 | liftShowsPrec = liftShowsPrec2 showsPrec showList 197 | 198 | instance (Show l, Show t, Show v, Show1 (Cell l)) => Show (Cache l t v) where 199 | showsPrec = showsPrec1 200 | -------------------------------------------------------------------------------- /src/Abstract/Syntax.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeApplications, DataKinds, TypeFamilies, ConstraintKinds, AllowAmbiguousTypes, DeriveAnyClass, DeriveFunctor, DeriveFoldable, DeriveGeneric, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables, TypeOperators, UndecidableInstances #-} 2 | module Abstract.Syntax where 3 | 4 | import Abstract.Environment 5 | import Abstract.Eval 6 | import Abstract.Primitive 7 | import Abstract.Set 8 | import Abstract.Store 9 | import Abstract.Term 10 | import Abstract.Type 11 | import Abstract.Value 12 | 13 | import Control.Applicative 14 | import Control.Monad hiding (fail) 15 | import Control.Monad.Effect 16 | import Control.Monad.Fail 17 | import Data.Functor.Classes 18 | import Data.Functor.Classes.Eq.Generic 19 | import Data.Functor.Classes.Show.Generic 20 | import Data.Functor.Classes.Ord.Generic 21 | import Data.Pointed 22 | import Data.Semigroup 23 | import Data.Union 24 | import GHC.Generics 25 | import Prelude hiding (fail) 26 | 27 | -- The Syntax of our language, defined as an open Union of type constructors. 28 | type Syntax = Union 29 | '[ Variable 30 | , Primitive 31 | , Lambda 32 | , Application 33 | , Rec 34 | , Unary 35 | , Binary 36 | , If 37 | ] 38 | 39 | 40 | 41 | -- Variables 42 | newtype Variable a = Variable String deriving (Eq, Ord, Show, Functor, Foldable, Generic1) 43 | instance Show1 Variable where liftShowsPrec = genericLiftShowsPrec 44 | instance Eq1 Variable where liftEq = genericLiftEq 45 | instance Ord1 Variable where liftCompare = genericLiftCompare 46 | 47 | instance (Monad m, MonadFail m, MonadAddress l m, MonadStore l (Value s l) m, MonadEnv l (Value s l) m) => Eval (Value s l) m s Variable where 48 | evaluate _ (Variable x) = do 49 | env <- askEnv 50 | maybe (fail ("free variable: " ++ x)) deref (envLookup x (env :: Environment l (Value s l))) 51 | 52 | instance (Alternative m, MonadFail m, MonadStore Monovariant Type m, MonadEnv Monovariant Type m) => Eval Type m s Variable where 53 | evaluate _ (Variable x) = do 54 | env <- askEnv 55 | maybe (fail ("free type: " ++ x)) deref (envLookup x (env :: Environment Monovariant Type)) 56 | 57 | instance FreeVariables1 Variable where 58 | liftFreeVariables _ (Variable name) = point name 59 | 60 | instance (Monad m, Eval v m s Variable) => EvalCollect l v m s Variable 61 | 62 | 63 | -- Primitives 64 | newtype Primitive a = Primitive Prim deriving (Eq, Ord, Show, Functor, Foldable, Generic1, FreeVariables1) 65 | instance Show1 Primitive where liftShowsPrec = genericLiftShowsPrec 66 | instance Eq1 Primitive where liftEq = genericLiftEq 67 | instance Ord1 Primitive where liftCompare = genericLiftCompare 68 | 69 | instance Monad m => Eval (Value s l) m s Primitive where 70 | evaluate _ (Primitive x) = return (I x) 71 | 72 | instance Monad m => Eval Type m s Primitive where 73 | evaluate _ (Primitive (PInt _)) = return Int 74 | evaluate _ (Primitive (PBool _)) = return Bool 75 | 76 | instance (Monad m, Eval v m s Primitive) => EvalCollect l v m s Primitive 77 | 78 | -- Lambdas 79 | data Lambda a = Lambda Name a deriving (Eq, Ord, Show, Functor, Foldable, Generic1) 80 | instance Show1 Lambda where liftShowsPrec = genericLiftShowsPrec 81 | instance Eq1 Lambda where liftEq = genericLiftEq 82 | instance Ord1 Lambda where liftCompare = genericLiftCompare 83 | 84 | instance (Monad m, MonadEnv l (Value s l) m) => Eval (Value s l) m s Lambda where 85 | evaluate _ (Lambda name body) = do 86 | env <- askEnv 87 | return (Closure name body (env :: Environment l (Value s l))) 88 | 89 | instance (MonadStore Monovariant Type m, MonadEnv Monovariant Type m, MonadFail m, Semigroup (Cell Monovariant Type), MonadFresh m, Alternative m) => Eval Type m s Lambda where 90 | evaluate ev (Lambda name body) = do 91 | a <- alloc name 92 | tvar <- fresh 93 | assign a (TVar tvar) 94 | outTy <- localEnv (envInsert name (a :: Address Monovariant Type)) (ev body) 95 | return (TVar tvar :-> outTy) 96 | 97 | instance FreeVariables1 Lambda where 98 | liftFreeVariables f (Lambda name body) = delete name (f body) 99 | 100 | instance (Monad m, Eval v m s Lambda) => EvalCollect l v m s Lambda 101 | 102 | -- Recursive binder (e.g. letrec) 103 | data Rec a = Rec Name a deriving (Eq, Ord, Show, Functor, Foldable, Generic1) 104 | instance Show1 Rec where liftShowsPrec = genericLiftShowsPrec 105 | instance Eq1 Rec where liftEq = genericLiftEq 106 | instance Ord1 Rec where liftCompare = genericLiftCompare 107 | 108 | instance (Monad m, MonadAddress l m, MonadStore l (Value s l) m, MonadEnv l (Value s l) m, Semigroup (Cell l (Value s l))) => Eval (Value s l) m s Rec where 109 | evaluate ev (Rec name body) = do 110 | a <- alloc name 111 | v <- localEnv (envInsert name (a :: Address l (Value s l))) (ev body) 112 | assign a v 113 | return v 114 | 115 | instance (MonadStore Monovariant Type m, MonadEnv Monovariant Type m, MonadFail m, Semigroup (Cell Monovariant Type), MonadFresh m, Alternative m) => Eval Type m s Rec where 116 | evaluate ev (Rec name body) = do 117 | a <- alloc name 118 | tvar <- fresh 119 | assign a (TVar tvar) 120 | localEnv (envInsert name (a :: Address Monovariant Type)) (ev body) 121 | 122 | instance FreeVariables1 Rec where 123 | liftFreeVariables f (Rec name body) = delete name (f body) 124 | 125 | instance (Monad m, Eval v m s Rec) => EvalCollect l v m s Rec 126 | 127 | 128 | -- Application 129 | data Application a = Application a a deriving (Eq, Ord, Show, Functor, Foldable, Generic1, FreeVariables1) 130 | instance Show1 Application where liftShowsPrec = genericLiftShowsPrec 131 | instance Eq1 Application where liftEq = genericLiftEq 132 | instance Ord1 Application where liftCompare = genericLiftCompare 133 | 134 | instance ( Monad m 135 | , MonadFail m 136 | , MonadAddress l m 137 | , MonadStore l (Value s l) m 138 | , MonadEnv l (Value s l) m 139 | , Semigroup (Cell l (Value s l)) 140 | ) 141 | => Eval (Value s l) m s Application where 142 | evaluate ev (Application e1 e2) = do 143 | Closure name body env <- ev e1 144 | value <- ev e2 145 | a <- alloc name 146 | assign a value 147 | localEnv (const (envInsert name a env)) (ev body) 148 | 149 | instance ( Monad m 150 | , MonadFail m 151 | , MonadFresh m 152 | ) 153 | => Eval Type m s Application where 154 | evaluate ev (Application e1 e2) = do 155 | opTy <- ev e1 156 | inTy <- ev e2 157 | tvar <- fresh 158 | _ :-> outTy <- opTy `unify` (inTy :-> TVar tvar) 159 | return outTy 160 | 161 | instance ( Ord l 162 | , Monad m 163 | , MonadGC l (Value s l) m 164 | , MonadAddress l m 165 | , MonadStore l (Value s l) m 166 | , MonadEnv l (Value s l) m 167 | , Semigroup (Cell l (Value s l)) 168 | , FreeVariables1 Application 169 | , Functor s 170 | , FreeVariables1 s 171 | ) 172 | => EvalCollect l (Value s l) m s Application where 173 | evalCollect ev (Application e1 e2) = do 174 | env <- askEnv @l @(Value s l) 175 | v1@(Closure name body env') <- extraRoots (envRoots env (freeVariables e2)) (ev e1) 176 | v2 <- extraRoots (valueRoots @l v1) (ev e2) 177 | a <- alloc name 178 | assign a v2 179 | localEnv (const (envInsert name a env')) (ev body) 180 | 181 | instance ( Ord l 182 | , Monad m 183 | , MonadFail m 184 | , MonadFresh m 185 | , MonadGC l Type m 186 | , MonadEnv l Type m 187 | , AbstractValue l Type 188 | , Functor s 189 | , FreeVariables1 s 190 | ) 191 | => EvalCollect l Type m s Application where 192 | evalCollect ev (Application e1 e2) = do 193 | env <- askEnv @l @Type 194 | opTy <- extraRoots (envRoots env (freeVariables e2)) (ev e1) 195 | inTy <- extraRoots (valueRoots @l opTy) (ev e2) 196 | tvar <- fresh 197 | _ :-> outTy <- opTy `unify` (inTy :-> TVar tvar) 198 | return outTy 199 | 200 | 201 | -- Unary operations 202 | data Unary a = Unary Op1 a deriving (Eq, Ord, Show, Functor, Foldable, Generic1, FreeVariables1) 203 | instance Show1 Unary where liftShowsPrec = genericLiftShowsPrec 204 | instance Eq1 Unary where liftEq = genericLiftEq 205 | instance Ord1 Unary where liftCompare = genericLiftCompare 206 | 207 | instance (Monad m, MonadPrim v m) => Eval v m s Unary where 208 | evaluate ev (Unary op e) = do 209 | v <- ev e 210 | delta1 op v 211 | 212 | instance (Monad m, MonadPrim v m) => EvalCollect l v m s Unary 213 | 214 | -- Binary operations 215 | data Binary a = Binary Op2 a a deriving (Eq, Ord, Show, Functor, Foldable, Generic1, FreeVariables1) 216 | instance Show1 Binary where liftShowsPrec = genericLiftShowsPrec 217 | instance Eq1 Binary where liftEq = genericLiftEq 218 | instance Ord1 Binary where liftCompare = genericLiftCompare 219 | 220 | instance (Monad m, MonadPrim v m) => Eval v m s Binary where 221 | evaluate ev (Binary op e0 e1) = do 222 | v1 <- ev e0 223 | v2 <- ev e1 224 | delta2 op v1 v2 225 | 226 | instance ( Ord l 227 | , Monad m 228 | , MonadGC l v m 229 | , MonadEnv l v m 230 | , MonadPrim v m 231 | , Functor s 232 | , FreeVariables1 s 233 | , AbstractValue l v 234 | ) 235 | => EvalCollect l v m s Binary where 236 | evalCollect ev (Binary op e0 e1) = do 237 | env <- askEnv @l @v 238 | v0 <- extraRoots (envRoots env (freeVariables e1)) (ev e0) 239 | v1 <- extraRoots (valueRoots @l v0) (ev e1) 240 | delta2 op v0 v1 241 | 242 | 243 | -- If statements 244 | data If a = If a a a deriving (Eq, Ord, Show, Functor, Foldable, Generic1, FreeVariables1) 245 | instance Show1 If where liftShowsPrec = genericLiftShowsPrec 246 | instance Eq1 If where liftEq = genericLiftEq 247 | instance Ord1 If where liftCompare = genericLiftCompare 248 | 249 | instance (Monad m, MonadPrim v m) => Eval v m s If where 250 | evaluate ev (If c t e) = do 251 | v <- ev c 252 | c' <- truthy v 253 | ev (if c' then t else e) 254 | 255 | instance ( Ord l 256 | , Monad m 257 | , MonadGC l v m 258 | , MonadEnv l v m 259 | , MonadPrim v m 260 | , Functor s 261 | , FreeVariables1 s 262 | ) 263 | => EvalCollect l v m s If where 264 | evalCollect ev (If c t e) = do 265 | env <- askEnv @l @v 266 | v <- extraRoots (envRoots env (freeVariables t <> freeVariables e)) (ev c) 267 | b <- truthy v 268 | ev (if b then t else e) 269 | 270 | 271 | -- Smart constructors for various Terms. 272 | 273 | prim :: (Primitive :< fs) => Prim -> Term (Union fs) 274 | prim = inject . Primitive 275 | 276 | int :: (Primitive :< fs) => Int -> Term (Union fs) 277 | int = prim . PInt 278 | 279 | true :: (Primitive :< fs) => Term (Union fs) 280 | true = prim (PBool True) 281 | 282 | false :: (Primitive :< fs) => Term (Union fs) 283 | false = prim (PBool False) 284 | 285 | var :: (Variable :< fs) => Name -> Term (Union fs) 286 | var = inject . Variable 287 | 288 | infixl 9 # 289 | (#) :: (Application :< fs) => Term (Union fs) -> Term (Union fs) -> Term (Union fs) 290 | (#) a b = inject (Application a b) 291 | 292 | makeLam :: (Lambda :< fs) => Name -> Term (Union fs) -> Term (Union fs) 293 | makeLam name body = inject (Lambda name body) 294 | 295 | let' :: (Lambda :< fs, Application :< fs, Variable :< fs) => Name -> Term (Union fs) -> (Term (Union fs) -> Term (Union fs)) -> Term (Union fs) 296 | let' name val body = lam name body # val 297 | where lam s f = makeLam s (f (var s)) 298 | 299 | makeRec :: (Rec :< fs) => Name -> Term (Union fs) -> Term (Union fs) 300 | makeRec name body = inject (Rec name body) 301 | 302 | mu :: (Rec :< fs, Variable :< fs) => Name -> (Term (Union fs) -> Term (Union fs)) -> Term (Union fs) 303 | mu f b = makeRec f (b (var f)) 304 | 305 | if' :: (If :< fs) => Term (Union fs) -> Term (Union fs) -> Term (Union fs) -> Term (Union fs) 306 | if' c t e = inject (If c t e) 307 | 308 | eq :: (Binary :< fs) => Term (Union fs) -> Term (Union fs) -> Term (Union fs) 309 | eq = (inject .) . Binary Eq 310 | 311 | lt :: (Binary :< fs) => Term (Union fs) -> Term (Union fs) -> Term (Union fs) 312 | lt = (inject .) . Binary Lt 313 | 314 | lte :: (Binary :< fs) => Term (Union fs) -> Term (Union fs) -> Term (Union fs) 315 | lte = (inject .) . Binary LtE 316 | 317 | gt :: (Binary :< fs) => Term (Union fs) -> Term (Union fs) -> Term (Union fs) 318 | gt = (inject .) . Binary Gt 319 | 320 | gte :: (Binary :< fs) => Term (Union fs) -> Term (Union fs) -> Term (Union fs) 321 | gte = (inject .) . Binary GtE 322 | 323 | and' :: (Binary :< fs) => Term (Union fs) -> Term (Union fs) -> Term (Union fs) 324 | and' = (inject .) . Binary And 325 | 326 | or' :: (Binary :< fs) => Term (Union fs) -> Term (Union fs) -> Term (Union fs) 327 | or' = (inject .) . Binary Or 328 | 329 | div' :: (Binary :< fs) => Term (Union fs) -> Term (Union fs) -> Term (Union fs) 330 | div' = (inject .) . Binary DividedBy 331 | 332 | quot' :: (Binary :< fs) => Term (Union fs) -> Term (Union fs) -> Term (Union fs) 333 | quot' = (inject .) . Binary Quotient 334 | 335 | rem' :: (Binary :< fs) => Term (Union fs) -> Term (Union fs) -> Term (Union fs) 336 | rem' = (inject .) . Binary Remainder 337 | 338 | mod' :: (Binary :< fs) => Term (Union fs) -> Term (Union fs) -> Term (Union fs) 339 | mod' = (inject .) . Binary Modulus 340 | 341 | not' :: (Unary :< fs) => Term (Union fs) -> Term (Union fs) 342 | not' = inject . Unary Not 343 | 344 | 345 | instance (Binary :< fs, Unary :< fs, Primitive :< fs) => Num (Term (Union fs)) where 346 | fromInteger = int . fromInteger 347 | 348 | signum = inject . Unary Signum 349 | abs = inject . Unary Abs 350 | negate = inject . Unary Negate 351 | (+) = (inject .) . Binary Plus 352 | (-) = (inject .) . Binary Minus 353 | (*) = (inject .) . Binary Times 354 | --------------------------------------------------------------------------------