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

setup criterion benchmarks for stratego

parent 553edc83
......@@ -14,6 +14,7 @@ dependencies:
- random
- text
- unordered-containers
- deepseq
flags:
trace:
......
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
......@@ -6,6 +8,7 @@ module Data.Abstract.Error where
import Control.Arrow
import Control.Monad
import Control.DeepSeq
import Data.Abstract.FreeCompletion
import Data.Abstract.Widening
......@@ -14,6 +17,8 @@ import Data.Hashable
import Data.Order
import Data.Traversable
import GHC.Generics (Generic, Generic1)
-- | Abstrat domain for exceptions. This abstract domain approximates
-- error more precisely because 'Success ⋢ Fail'. Use this type for
-- analysis in languages that can handle exceptions.
......@@ -21,7 +26,7 @@ data Error e x
= Success x
| Fail e
| SuccessOrFail e x
deriving (Eq, Show)
deriving (Eq, Show, Generic, Generic1, NFData, NFData1)
instance (Hashable e, Hashable x) => Hashable (Error e x) where
hashWithSalt s (Success x) = s `hashWithSalt` (0::Int) `hashWithSalt` x
......
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
......@@ -15,10 +17,13 @@ import Data.Order
import Data.Monoidal
import GHC.Generics (Generic, Generic1)
import Control.DeepSeq
-- | Failure is an Either-like type with the special ordering Failure ⊑ Success.
-- Left and Right of the regular Either type, on the other hand are incomparable.
data Failure e a = Fail e | Success a
deriving (Eq, Functor)
deriving (Eq, Functor, Generic, Generic1, NFData, NFData1)
instance (Show e,Show a) => Show (Failure e a) where
show (Fail e) = "Failure " ++ show e
......
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
......@@ -23,9 +24,10 @@ import Data.Abstract.Widening
import GHC.Exts
import Text.Printf
import Control.DeepSeq
-- | Abstract hashmap
newtype Map a b = Map (HashMap a (There,b)) deriving (Eq,Functor,Foldable,Traversable,Hashable)
newtype Map a b = Map (HashMap a (There,b)) deriving (Eq,Functor,Foldable,Traversable,Hashable,NFData)
instance (Show a,Show b) => Show (Map a b) where
show (Map h)
......
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveAnyClass #-}
module Data.Abstract.There where
import Data.Order
import Data.Hashable
import Control.DeepSeq
import GHC.Generics (Generic)
-- | Datatype that indicates if a value in the map must be there or may not be there.
data There = Must | May deriving (Eq)
data There = Must | May deriving (Eq, Generic, NFData)
instance Show There where
show Must = ""
......
......@@ -9,4 +9,4 @@ packages:
- 'stratego'
# - 'lambda-adt'
# - 'jimple'
# - 'tutorial'
# - 'tutorial'
\ No newline at end of file
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ImplicitParams #-}
module Main where
import SortSemantics -- hiding (sortContext)
import Syntax hiding (Fail)
import SortContext(Context,Sort(..))
import qualified SortContext as Ctx
import qualified Data.Abstract.Map as S
import qualified Data.HashMap.Lazy as M
import Data.Abstract.Failure(Failure)
import Data.Abstract.Error(Error)
import Data.Abstract.FreeCompletion(fromCompletion)
import Data.Abstract.Terminating(fromTerminating)
import Criterion
import Criterion.Main
main :: IO ()
main = defaultMain [
bench "build" $
let ?ctx = Ctx.empty
in nf (seval 0 (Build (StringLiteral "foo"))) bottom
]
where
term :: (?ctx :: Context) => Sort -> Term
term s = Term s ?ctx
termEnv :: [(TermVar, Term)] -> TermEnv
termEnv = S.fromList
emptyEnv :: TermEnv
emptyEnv = S.empty
seval :: Int -> Strat -> Term -> Failure String (Error () (TermEnv,Term))
seval i s = seval'' i 10 s M.empty emptyEnv
seval' :: Int -> Strat -> TermEnv -> Term -> Failure String (Error () (TermEnv,Term))
seval' i s = seval'' i 10 s M.empty
seval'' :: Int -> Int -> Strat -> StratEnv -> TermEnv -> Term -> Failure String (Error () (TermEnv,Term))
seval'' i j s senv tenv t = fromCompletion (error "top element")
(fromTerminating (error "sort semantics does not terminate")
(eval i j s senv (context t) tenv t))
bottom :: (?ctx :: Context) => Term
bottom = term Bottom
......@@ -35,6 +35,16 @@ executables:
- vector
- criterion
benchmarks:
sort-semantics:
source-dirs:
- bench
main: SortSemanticsBench.hs
dependencies:
- sturdy-stratego
- criterion
tests:
spec:
main: Spec.hs
......
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Sort where
import Utils
import Control.DeepSeq
import Data.Text(Text, unpack)
import Data.String(IsString(..))
import Data.Hashable(Hashable(..))
import Data.List(intercalate)
import Data.Abstract.Widening(Widening)
import GHC.Generics(Generic)
newtype SortId = SortId Text deriving (Show,Eq,Ord,Hashable,IsString,Generic)
instance NFData SortId
newtype SortId = SortId Text deriving (Show,Eq,Ord,Hashable,IsString)
data Sort = Bottom | Top | Numerical | Lexical | List Sort | Option Sort | Tuple [Sort] | Sort SortId deriving (Eq)
data Sort = Bottom | Top | Numerical | Lexical | List Sort | Option Sort | Tuple [Sort] | Sort SortId deriving (Eq,Generic)
instance NFData Sort
instance IsString Sort where
fromString = Sort . fromString
......
......@@ -40,6 +40,7 @@ import Control.Arrow.Transformer.Reader
import Control.Arrow.Transformer.State
import Control.Category
import Control.Monad (zipWithM)
import Control.DeepSeq
import Data.Abstract.FreeCompletion hiding (Top)
import qualified Data.Abstract.FreeCompletion as Free
......@@ -64,7 +65,9 @@ import Data.Order
import Test.QuickCheck hiding (Success)
import Text.Printf
data Term = Term {sort :: Sort , context :: Context}
data Term = Term { sort :: Sort, context :: Context }
instance NFData Term where
rnf = rnf . sort
type TermEnv = Map TermVar Term
......
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
......@@ -7,6 +8,7 @@ import SortContext (Context,Sort,Signature)
import qualified SortContext as I
import Control.Monad.Except
import Control.DeepSeq
import Data.ATerm
import Data.Constructor
......@@ -20,6 +22,8 @@ import Data.String (IsString(..))
import Data.Text (Text,pack,unpack)
import qualified Data.Text as T
import GHC.Generics(Generic)
import Text.Read (readMaybe)
import Test.QuickCheck (Arbitrary(..),Gen)
import qualified Test.QuickCheck as Q
......@@ -39,7 +43,8 @@ data Strat
| Let [(StratVar,Strategy)] Strat
| Call StratVar [Strat] [TermVar]
| Prim StratVar [Strat] [TermVar]
deriving (Eq)
deriving (Eq,Generic)
instance NFData Strat
-- | Pattern to match and build terms.
data TermPattern
......@@ -49,7 +54,8 @@ data TermPattern
| Var TermVar
| StringLiteral Text
| NumberLiteral Int
deriving (Eq)
deriving (Eq,Generic)
instance NFData TermPattern
-- | Stratego source code is organized in modules consisting of a
-- signature describing possible shapes of terms and named strategies.
......@@ -61,16 +67,18 @@ type Strategies = HashMap StratVar Strategy
-- refer to other named strategies and arguments that refer to terms.
-- Additionally, a strategy takes and input term and eventually
-- produces an output term.
data Strategy = Strategy [StratVar] [TermVar] Strat deriving (Show,Eq)
data Strategy = Strategy [StratVar] [TermVar] Strat deriving (Show,Eq,Generic)
instance NFData Strategy
data Closure = Closure Strategy StratEnv deriving (Eq)
data Closure = Closure Strategy StratEnv deriving (Eq,Generic)
instance NFData Closure
instance Hashable Closure where
hashWithSalt s (Closure strat senv) = s `hashWithSalt` strat `hashWithSalt` senv
type StratEnv = HashMap StratVar Closure
newtype TermVar = TermVar Text deriving (Eq,Ord,Hashable)
newtype StratVar = StratVar Text deriving (Eq,Ord,IsString,Hashable)
newtype TermVar = TermVar Text deriving (Eq,Ord,Hashable,NFData)
newtype StratVar = StratVar Text deriving (Eq,Ord,IsString,Hashable,NFData)
leftChoice :: Strat -> Strat -> Strat
leftChoice f = GuardedChoice f Id
......
......@@ -432,7 +432,6 @@ spec = do
term :: (?ctx :: Context) => Sort -> Term
term s = Term s ?ctx
bottom :: (?ctx :: Context) => Term
bottom = term Bottom
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment