diff --git a/bench/Main.hs b/bench/Main.hs index 081d4a62..bdbc5bb3 100644 --- a/bench/Main.hs +++ b/bench/Main.hs @@ -5,9 +5,9 @@ -- Maintainer : cryptol@galois.com -- Stability : provisional -- Portability : portable -module Main where -import Control.DeepSeq +{-# LANGUAGE OverloadedStrings #-} +module Main where import qualified Data.Text.Lazy as T import qualified Data.Text.Lazy.IO as T @@ -20,7 +20,10 @@ import qualified Cryptol.Parser as P import qualified Cryptol.Parser.AST as P import qualified Cryptol.Parser.NoInclude as P -import qualified Cryptol.TypeCheck as T +import qualified Cryptol.Symbolic as S + +import qualified Cryptol.TypeCheck as T +import qualified Cryptol.TypeCheck.AST as T import Criterion.Main @@ -30,11 +33,26 @@ main = defaultMain [ parser "Prelude" "lib/Cryptol.cry" , parser "BigSequence" "bench/data/BigSequence.cry" , parser "BigSequenceHex" "bench/data/BigSequenceHex.cry" + , parser "AES" "bench/data/AES.cry" ] , bgroup "typechecker" [ tc "Prelude" "lib/Cryptol.cry" , tc "BigSequence" "bench/data/BigSequence.cry" , tc "BigSequenceHex" "bench/data/BigSequenceHex.cry" + , tc "AES" "bench/data/AES.cry" + ] + , bgroup "conc_eval" [ + ceval "AES" "bench/data/AES.cry" "bench bench_data" + ] + , bgroup "sym_eval" [ + seval False "AES" "bench/data/AES.cry" "aesEncrypt (zero, zero)" + , seval False "ZUC" + "bench/data/ZUC.cry" "ZUC_isResistantToCollisionAttack" + ] + , bgroup "sym_eval_ite" [ + seval True "aesEncrypt" "bench/data/AES.cry" "aesEncrypt (zero, zero)" + , seval True "ZUC" + "bench/data/ZUC.cry" "ZUC_isResistantToCollisionAttack" ] ] @@ -42,7 +60,7 @@ main = defaultMain [ parser :: String -> FilePath -> Benchmark parser name path = env (T.readFile path) $ \(~bytes) -> - bench name $ whnfIO $ do + bench name $ nfIO $ do let cfg = P.defaultConfig { P.cfgSource = path , P.cfgPreProc = P.guessPreProc path @@ -73,15 +91,37 @@ tc name path = M.renameModule npm return (scm, menv') in env setup $ \ ~(scm, menv) -> - bench name $ whnfIO $ M.runModuleM menv $ do + bench name $ nfIO $ M.runModuleM menv $ do let act = M.TCAction { M.tcAction = T.tcModule , M.tcLinter = M.moduleLinter (P.thing (P.mName scm)) } M.typecheck act scm =<< M.importIfacesTc (map P.thing (P.mImports scm)) --- FIXME: this should only throw off the first benchmark run, but still... -instance NFData P.Module where - rnf _ = () +ceval :: String -> FilePath -> T.Text -> Benchmark +ceval name path expr = + let setup = do + menv <- M.initialModuleEnv + (Right (texpr, menv'), _) <- M.runModuleM menv $ do + m <- M.loadModuleByPath path + M.setFocusedModule (T.mName m) + let Right pexpr = P.parseExpr expr + (_, texpr, _) <- M.checkExpr pexpr + return texpr + return (texpr, menv') + in env setup $ \ ~(texpr, menv) -> + bench name $ nfIO $ M.runModuleM menv $ M.evalExpr texpr --- FIXME: this should only throw off the first benchmark run, but still... -instance NFData M.ModuleEnv where - rnf _ = () +seval :: Bool-> String -> FilePath -> T.Text -> Benchmark +seval useIte name path expr = + let setup = do + menv <- M.initialModuleEnv + (Right (texpr, menv'), _) <- M.runModuleM menv $ do + m <- M.loadModuleByPath path + M.setFocusedModule (T.mName m) + let Right pexpr = P.parseExpr expr + (_, texpr, _) <- M.checkExpr pexpr + return texpr + return (texpr, menv') + in env setup $ \ ~(texpr, menv) -> + bench name $ flip nf texpr $ \texpr' -> + let senv = S.evalDecls (S.emptyEnv useIte) (S.allDeclGroups menv) + in S.evalExpr senv texpr' diff --git a/src/Cryptol/Eval/Env.hs b/src/Cryptol/Eval/Env.hs index e4d66a42..b1056c42 100644 --- a/src/Cryptol/Eval/Env.hs +++ b/src/Cryptol/Eval/Env.hs @@ -8,7 +8,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE Safe #-} - +{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} module Cryptol.Eval.Env where import Cryptol.Eval.Value @@ -17,6 +17,9 @@ import Cryptol.Utils.PP import qualified Data.Map as Map +import GHC.Generics (Generic) +import Control.DeepSeq + #if __GLASGOW_HASKELL__ < 710 import Data.Monoid (Monoid(..)) #endif @@ -28,7 +31,7 @@ type ReadEnv = EvalEnv data EvalEnv = EvalEnv { envVars :: Map.Map QName Value , envTypes :: Map.Map TVar TValue - } + } deriving (Generic, NFData) instance Monoid EvalEnv where mempty = EvalEnv diff --git a/src/Cryptol/Eval/Value.hs b/src/Cryptol/Eval/Value.hs index 52e806ed..d713c4a5 100644 --- a/src/Cryptol/Eval/Value.hs +++ b/src/Cryptol/Eval/Value.hs @@ -11,7 +11,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE Safe #-} - +{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} module Cryptol.Eval.Value where import qualified Cryptol.Eval.Arch as Arch @@ -26,6 +26,8 @@ import Data.List(genericTake) import Data.Bits (setBit,testBit,(.&.),shiftL) import Numeric (showIntAtBase) +import GHC.Generics (Generic) +import Control.DeepSeq -- Utilities ------------------------------------------------------------------- @@ -75,8 +77,9 @@ finTValue tval = -- Values ---------------------------------------------------------------------- -data BV = BV !Integer !Integer -- ^ width, value - -- The value may contain junk bits +-- | width, value +-- The value may contain junk bits +data BV = BV !Integer !Integer deriving (Generic, NFData) -- | Smart constructor for 'BV's that checks for the width limit mkBv :: Integer -> Integer -> BV @@ -95,12 +98,13 @@ data GenValue b w | VStream [GenValue b w] -- @ [inf]a @ | VFun (GenValue b w -> GenValue b w) -- functions | VPoly (TValue -> GenValue b w) -- polymorphic values (kind *) + deriving (Generic, NFData) type Value = GenValue Bool BV -- | An evaluated type. -- These types do not contain type variables, type synonyms, or type functions. -newtype TValue = TValue { tValTy :: Type } +newtype TValue = TValue { tValTy :: Type } deriving (Generic, NFData) instance Show TValue where showsPrec p (TValue v) = showsPrec p v diff --git a/src/Cryptol/ModuleSystem/Env.hs b/src/Cryptol/ModuleSystem/Env.hs index 64f5a12f..0bd54a2b 100644 --- a/src/Cryptol/ModuleSystem/Env.hs +++ b/src/Cryptol/ModuleSystem/Env.hs @@ -8,7 +8,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE PatternGuards #-} - +{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} module Cryptol.ModuleSystem.Env where #ifndef RELOCATABLE @@ -33,6 +33,9 @@ import System.Environment(getExecutablePath) import System.FilePath ((), normalise, joinPath, splitPath, takeDirectory) import qualified Data.List as List +import GHC.Generics (Generic) +import Control.DeepSeq + #if __GLASGOW_HASKELL__ < 710 import Data.Monoid (Monoid(..)) #endif @@ -49,10 +52,11 @@ data ModuleEnv = ModuleEnv , meMonoBinds :: !Bool , meSolverConfig :: T.SolverConfig , meCoreLint :: CoreLint - } + } deriving (Generic, NFData) data CoreLint = NoCoreLint -- ^ Don't run core lint | CoreLint -- ^ Run core lint + deriving (Generic, NFData) resetModuleEnv :: ModuleEnv -> ModuleEnv resetModuleEnv env = env @@ -159,7 +163,7 @@ loadModuleEnv processIface me = do newtype LoadedModules = LoadedModules { getLoadedModules :: [LoadedModule] - } deriving (Show) + } deriving (Show, Generic, NFData) -- ^ Invariant: All the dependencies of any module `m` must precede `m` in the list. instance Monoid LoadedModules where @@ -172,7 +176,7 @@ data LoadedModule = LoadedModule , lmFilePath :: FilePath , lmInterface :: Iface , lmModule :: T.Module - } deriving (Show) + } deriving (Show, Generic, NFData) isLoaded :: ModName -> LoadedModules -> Bool isLoaded mn lm = any ((mn ==) . lmName) (getLoadedModules lm) @@ -213,7 +217,7 @@ data DynamicEnv = DEnv { deNames :: R.NamingEnv , deDecls :: [T.DeclGroup] , deEnv :: EvalEnv - } + } deriving (Generic, NFData) instance Monoid DynamicEnv where mempty = DEnv diff --git a/src/Cryptol/ModuleSystem/Interface.hs b/src/Cryptol/ModuleSystem/Interface.hs index 6054730b..c968ce37 100644 --- a/src/Cryptol/ModuleSystem/Interface.hs +++ b/src/Cryptol/ModuleSystem/Interface.hs @@ -7,6 +7,7 @@ -- Portability : portable {-# LANGUAGE PatternGuards #-} +{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} module Cryptol.ModuleSystem.Interface ( Iface(..) , IfaceDecls(..) @@ -26,6 +27,9 @@ import Cryptol.Utils.PP import qualified Data.Map as Map +import GHC.Generics (Generic) +import Control.DeepSeq + #if __GLASGOW_HASKELL__ < 710 import Data.Monoid (Monoid(..)) #endif @@ -35,13 +39,13 @@ data Iface = Iface { ifModName :: ModName , ifPublic :: IfaceDecls , ifPrivate :: IfaceDecls - } deriving (Show) + } deriving (Show, Generic, NFData) data IfaceDecls = IfaceDecls { ifTySyns :: Map.Map QName [IfaceTySyn] , ifNewtypes :: Map.Map QName [IfaceNewtype] , ifDecls :: Map.Map QName [IfaceDecl] - } deriving (Show) + } deriving (Show, Generic, NFData) instance Monoid IfaceDecls where mempty = IfaceDecls Map.empty Map.empty Map.empty @@ -84,7 +88,7 @@ data IfaceDecl = IfaceDecl , ifDeclInfix :: Bool , ifDeclFixity :: Maybe Fixity , ifDeclDoc :: Maybe String - } deriving (Show) + } deriving (Show, Generic, NFData) mkIfaceDecl :: Decl -> IfaceDecl mkIfaceDecl d = IfaceDecl diff --git a/src/Cryptol/ModuleSystem/Monad.hs b/src/Cryptol/ModuleSystem/Monad.hs index f5dc5051..8a4ef9fb 100644 --- a/src/Cryptol/ModuleSystem/Monad.hs +++ b/src/Cryptol/ModuleSystem/Monad.hs @@ -7,7 +7,7 @@ -- Portability : portable {-# LANGUAGE FlexibleContexts #-} - +{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} module Cryptol.ModuleSystem.Monad where import Cryptol.Eval.Env (EvalEnv) @@ -30,6 +30,9 @@ import Data.Function (on) import Data.Maybe (isJust) import MonadLib +import GHC.Generics (Generic) +import Control.DeepSeq + #if __GLASGOW_HASKELL__ < 710 import Control.Applicative (Applicative(..)) #endif @@ -39,7 +42,7 @@ import Control.Applicative (Applicative(..)) data ImportSource = FromModule P.ModName | FromImport (Located P.Import) - deriving (Show) + deriving (Show,Generic,NFData) instance Eq ImportSource where (==) = (==) `on` importedModule @@ -82,6 +85,23 @@ data ModuleError -- ^ Two modules loaded from different files have the same module name deriving (Show) +instance NFData ModuleError where + rnf e = case e of + ModuleNotFound src path -> src `deepseq` path `deepseq` () + CantFindFile path -> path `deepseq` () + OtherIOError path exn -> path `deepseq` exn `seq` () + ModuleParseError source err -> source `deepseq` err `deepseq` () + RecursiveModules mods -> mods `deepseq` () + RenamerErrors src errs -> src `deepseq` errs `deepseq` () + NoPatErrors src errs -> src `deepseq` errs `deepseq` () + NoIncludeErrors src errs -> src `deepseq` errs `deepseq` () + TypeCheckingFailed src errs -> src `deepseq` errs `deepseq` () + ModuleNameMismatch expected found -> + expected `deepseq` found `deepseq` () + DuplicateModuleName name path1 path2 -> + name `deepseq` path1 `deepseq` path2 `deepseq` () + OtherFailure x -> x `deepseq` () + instance PP ModuleError where ppPrec _ e = case e of @@ -184,7 +204,7 @@ duplicateModuleName name path1 path2 = data ModuleWarning = TypeCheckWarnings [(Range,T.Warning)] | RenamerWarnings [RenamerWarning] - deriving (Show) + deriving (Show,Generic,NFData) instance PP ModuleWarning where ppPrec _ w = case w of diff --git a/src/Cryptol/ModuleSystem/Name.hs b/src/Cryptol/ModuleSystem/Name.hs index b374dd39..8020e4e6 100644 --- a/src/Cryptol/ModuleSystem/Name.hs +++ b/src/Cryptol/ModuleSystem/Name.hs @@ -1,18 +1,21 @@ +{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} module Cryptol.ModuleSystem.Name where +import GHC.Generics (Generic) +import Control.DeepSeq -- | Module names are just namespaces. -- -- INVARIANT: the list of strings should never be empty in a valid module name. newtype ModName = ModName [String] - deriving (Eq,Ord,Show) + deriving (Eq,Ord,Show,Generic,NFData) data Name = Name String | NewName Pass Int - deriving (Eq,Ord,Show) + deriving (Eq,Ord,Show,Generic,NFData) data QName = QName (Maybe ModName) Name - deriving (Eq,Ord,Show) + deriving (Eq,Ord,Show,Generic,NFData) -- XXX It would be nice to also mark this as a name that doesn't need to be -- resolved, if it's going to be created before renaming. @@ -30,4 +33,4 @@ unqual (QName _ n) = n data Pass = NoPat | MonoValues - deriving (Eq,Ord,Show) + deriving (Eq,Ord,Show,Generic,NFData) diff --git a/src/Cryptol/ModuleSystem/NamingEnv.hs b/src/Cryptol/ModuleSystem/NamingEnv.hs index 2bfdd35c..a126a716 100644 --- a/src/Cryptol/ModuleSystem/NamingEnv.hs +++ b/src/Cryptol/ModuleSystem/NamingEnv.hs @@ -6,6 +6,7 @@ -- Stability : provisional -- Portability : portable +{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} module Cryptol.ModuleSystem.NamingEnv where import Cryptol.ModuleSystem.Interface @@ -19,6 +20,9 @@ import Cryptol.Utils.Panic (panic) import Data.Maybe (catMaybes) import qualified Data.Map as Map +import GHC.Generics (Generic) +import Control.DeepSeq + #if __GLASGOW_HASKELL__ < 710 import Control.Applicative (Applicative, (<$>), (<*>), pure) import Data.Monoid (Monoid(..)) @@ -30,7 +34,7 @@ import Data.Traversable (traverse) data NameOrigin = Local (Located QName) | Imported QName - deriving (Show) + deriving (Show,Generic,NFData) instance PP NameOrigin where ppPrec _ o = case o of @@ -47,13 +51,13 @@ instance PP NameOrigin where data EName = EFromBind (Located QName) | EFromNewtype (Located QName) | EFromMod QName - deriving (Show) + deriving (Show, Generic, NFData) data TName = TFromParam QName | TFromSyn (Located QName) | TFromNewtype (Located QName) | TFromMod QName - deriving (Show) + deriving (Show, Generic, NFData) class HasQName a where qname :: a -> QName @@ -93,7 +97,7 @@ data NamingEnv = NamingEnv { neExprs :: Map.Map QName [EName] , neTypes :: Map.Map QName [TName] -- ^ Type renaming environment , neFixity:: Map.Map QName [Fixity] - } deriving (Show) + } deriving (Show, Generic, NFData) instance Monoid NamingEnv where mempty = diff --git a/src/Cryptol/ModuleSystem/Renamer.hs b/src/Cryptol/ModuleSystem/Renamer.hs index 8033eda3..e6a2595a 100644 --- a/src/Cryptol/ModuleSystem/Renamer.hs +++ b/src/Cryptol/ModuleSystem/Renamer.hs @@ -10,7 +10,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE RecordWildCards #-} - +{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} module Cryptol.ModuleSystem.Renamer ( NamingEnv(), shadowing , BindsNames(..) @@ -31,6 +31,9 @@ import Cryptol.Utils.PP import MonadLib import qualified Data.Map as Map +import GHC.Generics (Generic) +import Control.DeepSeq + #if __GLASGOW_HASKELL__ < 710 import Control.Applicative(Applicative(..),(<$>)) import Data.Foldable (foldMap) @@ -67,7 +70,7 @@ data RenamerError | InvalidConstraint Type -- ^ When it's not possible to produce a Prop from a Type. - deriving (Show) + deriving (Show,Generic,NFData) instance PP RenamerError where ppPrec _ e = case e of @@ -115,7 +118,7 @@ instance PP RenamerError where data RenamerWarning = SymbolShadowed NameOrigin [NameOrigin] - deriving (Show) + deriving (Show,Generic,NFData) instance PP RenamerWarning where ppPrec _ (SymbolShadowed new originals) = diff --git a/src/Cryptol/Parser/AST.hs b/src/Cryptol/Parser/AST.hs index 795954e1..ee9a2c09 100644 --- a/src/Cryptol/Parser/AST.hs +++ b/src/Cryptol/Parser/AST.hs @@ -11,6 +11,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} module Cryptol.Parser.AST ( -- * Names ModName(..), {-splitNamespace, parseModName, nsChar,-} modRange @@ -78,6 +79,9 @@ import Data.Bits(shiftR) import Data.Maybe (catMaybes) import Numeric(showIntAtBase) +import GHC.Generics (Generic) +import Control.DeepSeq + #if __GLASGOW_HASKELL__ < 710 import Data.Foldable (Foldable(..)) import Data.Monoid (Monoid(..)) @@ -101,7 +105,7 @@ newtype Program = Program [TopDecl] data Module = Module { mName :: Located ModName , mImports :: [Located Import] , mDecls :: [TopDecl] - } deriving (Show) + } deriving (Show, Generic, NFData) modRange :: Module -> Range modRange m = rCombs $ catMaybes @@ -115,7 +119,7 @@ modRange m = rCombs $ catMaybes data TopDecl = Decl (TopLevel Decl) | TDNewtype (TopLevel Newtype) | Include (Located FilePath) - deriving (Show) + deriving (Show,Generic,NFData) data Decl = DSignature [LQName] Schema | DFixity !Fixity [LQName] @@ -124,13 +128,13 @@ data Decl = DSignature [LQName] Schema | DPatBind Pattern Expr | DType TySyn | DLocated Decl Range - deriving (Eq,Show) + deriving (Eq,Show,Generic,NFData) -- | An import declaration. data Import = Import { iModule :: ModName , iAs :: Maybe ModName , iSpec :: Maybe ImportSpec - } deriving (Eq,Show) + } deriving (Eq,Show,Generic,NFData) -- | The list of names following an import. -- @@ -139,10 +143,10 @@ data Import = Import { iModule :: ModName -- present. data ImportSpec = Hiding [Name] | Only [Name] - deriving (Eq,Show) + deriving (Eq,Show,Generic,NFData) data TySyn = TySyn LQName [TParam] Type - deriving (Eq,Show) + deriving (Eq,Show,Generic,NFData) {- | Bindings. Notes: @@ -165,17 +169,17 @@ data Bind = Bind { bName :: LQName -- ^ Defined thing , bPragmas :: [Pragma] -- ^ Optional pragmas , bMono :: Bool -- ^ Is this a monomorphic binding , bDoc :: Maybe String -- ^ Optional doc string - } deriving (Eq,Show) + } deriving (Eq,Show,Generic,NFData) type LBindDef = Located BindDef data BindDef = DPrim | DExpr Expr - deriving (Eq,Show) + deriving (Eq,Show,Generic,NFData) data Fixity = Fixity { fAssoc :: !Assoc , fLevel :: !Int - } deriving (Eq,Show) + } deriving (Eq,Show,Generic,NFData) data FixityCmp = FCError | FCLeft @@ -198,12 +202,12 @@ defaultFixity = Fixity LeftAssoc 100 data Pragma = PragmaNote String | PragmaProperty - deriving (Eq,Show) + deriving (Eq,Show,Generic,NFData) data Newtype = Newtype { nName :: LQName -- ^ Type name , nParams :: [TParam] -- ^ Type params , nBody :: [Named Type] -- ^ Constructor - } deriving (Eq,Show) + } deriving (Eq,Show,Generic,NFData) -- | Input at the REPL, which can either be an expression or a @let@ -- statement. @@ -214,19 +218,19 @@ data ReplInput = ExprInput Expr -- | Export information for a declaration. data ExportType = Public | Private - deriving (Eq,Show,Ord) + deriving (Eq,Show,Ord,Generic,NFData) data TopLevel a = TopLevel { tlExport :: ExportType , tlDoc :: Maybe (Located String) , tlValue :: a - } deriving (Show) + } deriving (Show,Generic,NFData) instance Functor TopLevel where fmap f tl = tl { tlValue = f (tlValue tl) } data ExportSpec = ExportSpec { eTypes :: Set.Set QName , eBinds :: Set.Set QName - } deriving (Show) + } deriving (Show,Generic,NFData) instance Monoid ExportSpec where mempty = ExportSpec { eTypes = mempty, eBinds = mempty } @@ -261,12 +265,12 @@ data NumInfo = BinLit Int -- ^ n-digit binary literal | HexLit Int -- ^ n-digit hex literal | CharLit -- ^ character literal | PolyLit Int -- ^ polynomial literal - deriving (Eq,Show) + deriving (Eq,Show,Generic,NFData) -- | Literals. data Literal = ECNum Integer NumInfo -- ^ @0x10@ (HexLit 2) | ECString String -- ^ @\"hello\"@ - deriving (Eq,Show) + deriving (Eq,Show,Generic,NFData) data Expr = EVar QName -- ^ @ x @ | ELit Literal -- ^ @ 0x10 @ @@ -288,11 +292,11 @@ data Expr = EVar QName -- ^ @ x @ | EParens Expr -- ^ @ (e) @ (Removed by Fixity) | EInfix Expr (LQName) Fixity Expr-- ^ @ a + b @ (Removed by Fixity) - deriving (Eq,Show) + deriving (Eq,Show,Generic,NFData) data TypeInst = NamedInst (Named Type) | PosInst Type - deriving (Eq,Show) + deriving (Eq,Show,Generic,NFData) {- | Selectors are used for projecting from various components. @@ -312,11 +316,11 @@ data Selector = TupleSel Int (Maybe Int) | ListSel Int (Maybe Int) -- ^ List selection. -- Optionally specifies the length of the list. - deriving (Eq,Show,Ord) + deriving (Eq,Show,Ord,Generic,NFData) data Match = Match Pattern Expr -- ^ p <- e | MatchLet Bind - deriving (Eq,Show) + deriving (Eq,Show,Generic,NFData) data Pattern = PVar LName -- ^ @ x @ | PWild -- ^ @ _ @ @@ -326,27 +330,27 @@ data Pattern = PVar LName -- ^ @ x @ | PTyped Pattern Type -- ^ @ x : [8] @ | PSplit Pattern Pattern -- ^ @ (x # y) @ | PLocated Pattern Range -- ^ Location information - deriving (Eq,Show) + deriving (Eq,Show,Generic,NFData) data Named a = Named { name :: Located Name, value :: a } - deriving (Eq,Show,Foldable,Traversable) + deriving (Eq,Show,Foldable,Traversable,Generic,NFData) instance Functor Named where fmap f x = x { value = f (value x) } data Schema = Forall [TParam] [Prop] Type (Maybe Range) - deriving (Eq,Show) + deriving (Eq,Show,Generic,NFData) data Kind = KNum | KType - deriving (Eq,Show) + deriving (Eq,Show,Generic,NFData) data TParam = TParam { tpName :: Name , tpKind :: Maybe Kind , tpRange :: Maybe Range } - deriving (Eq,Show) + deriving (Eq,Show,Generic,NFData) tpQName :: TParam -> QName tpQName = mkUnqual . tpName @@ -366,7 +370,7 @@ data Type = TFun Type Type -- ^ @[8] -> [8]@ | TLocated Type Range -- ^ Location information | TParens Type -- ^ @ (ty) @ | TInfix Type LQName Fixity Type -- ^ @ ty + ty @ - deriving (Eq,Show) + deriving (Eq,Show,Generic,NFData) data Prop = CFin Type -- ^ @ fin x @ | CEqual Type Type -- ^ @ x == 10 @ @@ -376,7 +380,7 @@ data Prop = CFin Type -- ^ @ fin x @ | CLocated Prop Range -- ^ Location information | CType Type -- ^ After parsing - deriving (Eq,Show) + deriving (Eq,Show,Generic,NFData) -------------------------------------------------------------------------------- diff --git a/src/Cryptol/Parser/LexerUtils.hs b/src/Cryptol/Parser/LexerUtils.hs index 579866e7..3356ce1d 100644 --- a/src/Cryptol/Parser/LexerUtils.hs +++ b/src/Cryptol/Parser/LexerUtils.hs @@ -8,6 +8,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} +{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} module Cryptol.Parser.LexerUtils where import Cryptol.Parser.Position @@ -22,6 +23,8 @@ import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as T import Data.Word(Word8) +import GHC.Generics (Generic) +import Control.DeepSeq data Config = Config { cfgSource :: !FilePath -- ^ File that we are working on @@ -352,14 +355,14 @@ virt cfg pos x = Located { srcRange = Range -------------------------------------------------------------------------------- data Token = Token { tokenType :: TokenT, tokenText :: Text } - deriving Show + deriving (Show, Generic, NFData) -- | Virtual tokens, inserted by layout processing. data TokenV = VCurlyL| VCurlyR | VSemi - deriving (Eq,Show) + deriving (Eq,Show,Generic,NFData) data TokenW = BlockComment | LineComment | Space | DocStr - deriving (Eq,Show) + deriving (Eq,Show,Generic,NFData) data TokenKW = KW_Arith | KW_Bit @@ -393,7 +396,7 @@ data TokenKW = KW_Arith | KW_infixr | KW_infix | KW_primitive - deriving (Eq,Show) + deriving (Eq,Show,Generic,NFData) -- | The named operators are a special case for parsing types, and 'Other' is -- used for all other cases that lexed as an operator. @@ -401,7 +404,7 @@ data TokenOp = Plus | Minus | Mul | Div | Exp | Mod | Equal | LEQ | GEQ | Complement | Hash | Other [String] String - deriving (Eq,Show) + deriving (Eq,Show,Generic,NFData) data TokenSym = Bar | ArrL | ArrR | FatArrR @@ -419,7 +422,7 @@ data TokenSym = Bar | CurlyL | CurlyR | TriL | TriR | Underscore - deriving (Eq,Show) + deriving (Eq,Show,Generic,NFData) data TokenErr = UnterminatedComment | UnterminatedString @@ -427,7 +430,7 @@ data TokenErr = UnterminatedComment | InvalidString | InvalidChar | LexicalError - deriving (Eq,Show) + deriving (Eq,Show,Generic,NFData) data TokenT = Num Integer Int Int -- ^ value, base, number of digits | ChrLit Char -- ^ character literal @@ -440,7 +443,7 @@ data TokenT = Num Integer Int Int -- ^ value, base, number of digits | White TokenW -- ^ white space token | Err TokenErr -- ^ error token | EOF - deriving (Eq,Show) + deriving (Eq,Show,Generic,NFData) instance PP Token where ppPrec _ (Token _ s) = text (T.unpack s) diff --git a/src/Cryptol/Parser/NoInclude.hs b/src/Cryptol/Parser/NoInclude.hs index ebd15600..c53a006b 100644 --- a/src/Cryptol/Parser/NoInclude.hs +++ b/src/Cryptol/Parser/NoInclude.hs @@ -7,7 +7,7 @@ -- Portability : portable {-# LANGUAGE RecordWildCards #-} - +{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} module Cryptol.Parser.NoInclude ( removeIncludesModule , IncludeError(..), ppIncludeError @@ -28,6 +28,9 @@ import MonadLib import qualified Control.Exception as X import System.FilePath (takeDirectory,(),isAbsolute) +import GHC.Generics (Generic) +import Control.DeepSeq + #if MIN_VERSION_directory(1,2,2) import System.Directory (makeAbsolute) #else @@ -50,7 +53,7 @@ data IncludeError = IncludeFailed (Located FilePath) | IncludeParseError ParseError | IncludeCycle [Located FilePath] - deriving (Show) + deriving (Show,Generic,NFData) ppIncludeError :: IncludeError -> Doc ppIncludeError ie = case ie of diff --git a/src/Cryptol/Parser/NoPat.hs b/src/Cryptol/Parser/NoPat.hs index 5f30dd6a..c1de4e48 100644 --- a/src/Cryptol/Parser/NoPat.hs +++ b/src/Cryptol/Parser/NoPat.hs @@ -13,6 +13,7 @@ {-# LANGUAGE PatternGuards #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} module Cryptol.Parser.NoPat (RemovePatterns(..),Error(..)) where import Cryptol.Parser.AST @@ -26,6 +27,9 @@ import Data.Maybe(maybeToList) import Data.Either(partitionEithers) import qualified Data.Map as Map +import GHC.Generics (Generic) +import Control.DeepSeq + #if __GLASGOW_HASKELL__ < 710 import Control.Applicative(Applicative(..),(<$>),(<$)) import Data.Traversable(traverse) @@ -445,7 +449,7 @@ data Error = MultipleSignatures QName [Located Schema] | MultipleFixities QName [Range] | FixityNoBind (Located QName) | MultipleDocs QName [Range] - deriving (Show) + deriving (Show,Generic,NFData) instance Functor NoPatM where fmap = liftM instance Applicative NoPatM where pure = return; (<*>) = ap diff --git a/src/Cryptol/Parser/ParserUtils.hs b/src/Cryptol/Parser/ParserUtils.hs index 9a08ce79..c312095c 100644 --- a/src/Cryptol/Parser/ParserUtils.hs +++ b/src/Cryptol/Parser/ParserUtils.hs @@ -7,6 +7,7 @@ -- Portability : portable {-# LANGUAGE Safe, PatternGuards #-} +{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} module Cryptol.Parser.ParserUtils where import Cryptol.Parser.AST @@ -22,6 +23,9 @@ import Control.Monad(liftM,ap,unless) import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as T +import GHC.Generics (Generic) +import Control.DeepSeq + #if __GLASGOW_HASKELL__ < 710 import Control.Applicative ((<$>),Applicative(..)) import Data.Traversable (mapM) @@ -61,7 +65,7 @@ lexerP k = P $ \cfg p (S ts) -> data ParseError = HappyError FilePath Position (Maybe Token) | HappyErrorMsg Range String - deriving Show + deriving (Show, Generic, NFData) newtype S = S [Located Token] diff --git a/src/Cryptol/Parser/Position.hs b/src/Cryptol/Parser/Position.hs index 7f4098bb..b08b764e 100644 --- a/src/Cryptol/Parser/Position.hs +++ b/src/Cryptol/Parser/Position.hs @@ -7,23 +7,27 @@ -- Portability : portable {-# LANGUAGE Safe #-} +{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} module Cryptol.Parser.Position where import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as T +import GHC.Generics (Generic) +import Control.DeepSeq + import Cryptol.Utils.PP data Located a = Located { srcRange :: !Range, thing :: a } - deriving (Eq,Show) + deriving (Eq,Show,Generic,NFData) data Position = Position { line :: !Int, col :: !Int } - deriving (Eq,Ord,Show) + deriving (Eq,Ord,Show,Generic,NFData) data Range = Range { from :: !Position , to :: !Position , source :: FilePath } - deriving (Eq,Show) + deriving (Eq,Show,Generic,NFData) -- | An empty range. -- diff --git a/src/Cryptol/Prims/Syntax.hs b/src/Cryptol/Prims/Syntax.hs index cc84c958..695da91c 100644 --- a/src/Cryptol/Prims/Syntax.hs +++ b/src/Cryptol/Prims/Syntax.hs @@ -6,6 +6,7 @@ -- Stability : provisional -- Portability : portable +{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} module Cryptol.Prims.Syntax ( TFun(..), tBinOpPrec, tfunNames ) where @@ -14,6 +15,8 @@ import Cryptol.ModuleSystem.Name (QName,Name(Name),mkUnqual) import Cryptol.Utils.PP import qualified Data.Map as Map +import GHC.Generics (Generic) +import Control.DeepSeq -- | Built-in types. data TFun @@ -35,7 +38,7 @@ data TFun | TCLenFromThenTo -- ^ @ : Num -> Num -> Num -> Num@ -- Example: @[ 1, 5 .. 9 ] :: [lengthFromThenTo 1 5 9][b]@ - deriving (Show, Eq, Ord, Bounded, Enum) + deriving (Show, Eq, Ord, Bounded, Enum, Generic, NFData) tBinOpPrec :: Map.Map TFun (Assoc,Int) diff --git a/src/Cryptol/TypeCheck/AST.hs b/src/Cryptol/TypeCheck/AST.hs index e0e01827..b14f57c8 100644 --- a/src/Cryptol/TypeCheck/AST.hs +++ b/src/Cryptol/TypeCheck/AST.hs @@ -10,6 +10,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE FlexibleInstances, FlexibleContexts #-} +{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} module Cryptol.TypeCheck.AST ( module Cryptol.TypeCheck.AST , TFun(..) @@ -35,6 +36,9 @@ import Cryptol.Utils.Panic(panic) import Cryptol.TypeCheck.PP import Cryptol.TypeCheck.Solver.InfNat +import GHC.Generics (Generic) +import Control.DeepSeq + import Data.Map (Map) import qualified Data.Map as Map import qualified Data.IntMap as IntMap @@ -48,7 +52,7 @@ data Module = Module { mName :: ModName , mTySyns :: Map QName TySyn , mNewtypes :: Map QName Newtype , mDecls :: [DeclGroup] - } deriving Show + } deriving (Show, Generic, NFData) -- | Kinds, classify types. @@ -56,13 +60,13 @@ data Kind = KType | KNum | KProp | Kind :-> Kind - deriving (Eq,Show) + deriving (Eq, Show, Generic, NFData) infixr 5 :-> -- | The types of polymorphic values. data Schema = Forall { sVars :: [TParam], sProps :: [Prop], sType :: Type } - deriving (Eq, Show) + deriving (Eq, Show, Generic, NFData) -- | Type synonym. data TySyn = TySyn { tsName :: QName -- ^ Name @@ -70,21 +74,21 @@ data TySyn = TySyn { tsName :: QName -- ^ Name , tsConstraints :: [Prop] -- ^ Ensure body is OK , tsDef :: Type -- ^ Definition } - deriving (Eq, Show) + deriving (Eq, Show, Generic, NFData) -- | Named records data Newtype = Newtype { ntName :: QName , ntParams :: [TParam] , ntConstraints :: [Prop] , ntFields :: [(Name,Type)] - } deriving (Show) + } deriving (Show, Generic, NFData) -- | Type parameters. data TParam = TParam { tpUnique :: !Int -- ^ Parameter identifier , tpKind :: Kind -- ^ Kind of parameter , tpName :: Maybe QName-- ^ Name from source, if any. } - deriving (Show) + deriving (Show, Generic, NFData) instance Eq TParam where x == y = tpUnique x == tpUnique y @@ -113,7 +117,7 @@ data Type = TCon TCon [Type] | TRec [(Name,Type)] -- ^ Record type - deriving (Show,Eq,Ord) + deriving (Show,Eq,Ord,Generic,NFData) -- | The type is supposed to be of kind `KProp` type Prop = Type @@ -129,11 +133,11 @@ data TVar = TVFree !Int Kind (Set TVar) Doc | TVBound !Int Kind - deriving Show + deriving (Show,Generic,NFData) -- | Type constants. data TCon = TC TC | PC PC | TF TFun - deriving (Show,Eq,Ord) + deriving (Show,Eq,Ord,Generic,NFData) -- | Built-in type constants. @@ -147,7 +151,7 @@ data PC = PEqual -- ^ @_ == _@ | PHas Selector -- ^ @Has sel type field@ does not appear in schemas | PArith -- ^ @Arith _@ | PCmp -- ^ @Cmp _@ - deriving (Show,Eq,Ord) + deriving (Show,Eq,Ord,Generic,NFData) -- | 1-1 constants. data TC = TCNum Integer -- ^ Numbers @@ -157,10 +161,10 @@ data TC = TCNum Integer -- ^ Numbers | TCFun -- ^ @_ -> _@ | TCTuple Int -- ^ @(_, _, _)@ | TCNewtype UserTC -- ^ user-defined, @T@ - deriving (Show,Eq,Ord) + deriving (Show,Eq,Ord,Generic,NFData) data UserTC = UserTC QName Kind - deriving Show + deriving (Show,Generic,NFData) instance Eq UserTC where UserTC x _ == UserTC y _ = x == y @@ -237,19 +241,19 @@ data Expr = EList [Expr] Type -- ^ List value (with type of elements) | EWhere Expr [DeclGroup] - deriving Show + deriving (Show, Generic, NFData) data Match = From QName Type Expr-- ^ do we need this type? it seems like it -- can be computed from the expr | Let Decl - deriving Show + deriving (Show, Generic, NFData) data DeclGroup = Recursive [Decl] -- ^ Mutually recursive declarations | NonRecursive Decl -- ^ Non-recursive declaration - deriving Show + deriving (Show,Generic,NFData) groupDecls :: DeclGroup -> [Decl] groupDecls dg = case dg of @@ -263,11 +267,11 @@ data Decl = Decl { dName :: QName , dInfix :: !Bool , dFixity :: Maybe Fixity , dDoc :: Maybe String - } deriving (Show) + } deriving (Show,Generic,NFData) data DeclDef = DPrim | DExpr Expr - deriving (Show) + deriving (Show,Generic,NFData) diff --git a/src/Cryptol/TypeCheck/InferTypes.hs b/src/Cryptol/TypeCheck/InferTypes.hs index 4a5af79e..bd5f6923 100644 --- a/src/Cryptol/TypeCheck/InferTypes.hs +++ b/src/Cryptol/TypeCheck/InferTypes.hs @@ -10,7 +10,7 @@ {-# LANGUAGE Safe #-} {-# LANGUAGE FlexibleInstances, FlexibleContexts #-} - +{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} module Cryptol.TypeCheck.InferTypes where import Cryptol.TypeCheck.AST @@ -27,13 +27,14 @@ import qualified Data.Set as Set import qualified Data.Map as Map import qualified Data.IntMap as IntMap - +import GHC.Generics (Generic) +import Control.DeepSeq data SolverConfig = SolverConfig { solverPath :: FilePath -- ^ The SMT solver to invoke , solverArgs :: [String] -- ^ Additional arguments to pass to the solver , solverVerbose :: Int -- ^ How verbose to be when type-checking - } deriving Show + } deriving (Show, Generic, NFData) -- | The types of variables in the environment. @@ -60,7 +61,7 @@ data Goal = Goal { goalSource :: ConstraintSource -- ^ With it is about , goalRange :: Range -- ^ Part of source code that caused goal , goal :: Prop -- ^ What needs to be proved - } deriving Show + } deriving (Show,Generic,NFData) data HasGoal = HasGoal { hasName :: !Int @@ -73,7 +74,7 @@ data DelayedCt = DelayedCt , dctForall :: [TParam] , dctAsmps :: [Prop] , dctGoals :: [Goal] - } deriving Show + } deriving (Show,Generic,NFData) data Solved = Solved (Maybe Subst) [Goal] -- ^ Solved, assuming the sub-goals. | Unsolved -- ^ We could not solved the goal. @@ -83,7 +84,7 @@ data Solved = Solved (Maybe Subst) [Goal] -- ^ Solved, assuming the sub-goals. data Warning = DefaultingKind P.TParam P.Kind | DefaultingWildType P.Kind | DefaultingTo Doc Type - deriving Show + deriving (Show,Generic,NFData) -- | Various errors that might happen during type checking/inference data Error = ErrorMsg Doc @@ -162,7 +163,7 @@ data Error = ErrorMsg Doc | AmbiguousType [QName] - deriving Show + deriving (Show,Generic,NFData) -- | Information about how a constraint came to be, used in error reporting. data ConstraintSource @@ -176,10 +177,10 @@ data ConstraintSource | CtDefaulting -- ^ Just defaulting on the command line | CtPartialTypeFun TyFunName -- ^ Use of a partial type function. | CtImprovement - deriving Show + deriving (Show,Generic,NFData) data TyFunName = UserTyFun QName | BuiltInTyFun TFun - deriving Show + deriving (Show,Generic,NFData) instance PP TyFunName where ppPrec c (UserTyFun x) = ppPrec c x diff --git a/src/Cryptol/TypeCheck/Monad.hs b/src/Cryptol/TypeCheck/Monad.hs index d03dfe5e..ad63e439 100644 --- a/src/Cryptol/TypeCheck/Monad.hs +++ b/src/Cryptol/TypeCheck/Monad.hs @@ -12,6 +12,7 @@ #else {-# LANGUAGE DoRec #-} #endif +{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} module Cryptol.TypeCheck.Monad ( module Cryptol.TypeCheck.Monad , module Cryptol.TypeCheck.InferTypes @@ -37,6 +38,9 @@ import MonadLib import qualified Control.Applicative as A import Control.Monad.Fix(MonadFix(..)) +import GHC.Generics (Generic) +import Control.DeepSeq + #if __GLASGOW_HASKELL__ < 710 import Data.Functor #endif @@ -59,7 +63,7 @@ data InferInput = InferInput data NameSeeds = NameSeeds { seedTVar :: !Int , seedGoal :: !Int - } deriving Show + } deriving (Show, Generic, NFData) -- | The initial seeds, used when checking a fresh program. nameSeeds :: NameSeeds diff --git a/src/Cryptol/Utils/PP.hs b/src/Cryptol/Utils/PP.hs index 69b7cfd2..4b4f66a6 100644 --- a/src/Cryptol/Utils/PP.hs +++ b/src/Cryptol/Utils/PP.hs @@ -8,6 +8,7 @@ {-# LANGUAGE Safe #-} {-# LANGUAGE PatternGuards #-} +{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} module Cryptol.Utils.PP where import Cryptol.ModuleSystem.Name @@ -18,6 +19,8 @@ import qualified Data.Monoid as M import Data.String (IsString(..)) import qualified Text.PrettyPrint as PJ +import GHC.Generics (Generic) +import Control.DeepSeq -- | How to display names. newtype NameEnv = NameEnv (Map QName NameInfo) @@ -43,7 +46,7 @@ instance M.Monoid NameEnv where mempty = NameEnv Map.empty mappend (NameEnv a) (NameEnv b) = NameEnv (Map.union a b) -newtype Doc = Doc (NameEnv -> PJ.Doc) +newtype Doc = Doc (NameEnv -> PJ.Doc) deriving (Generic, NFData) runDoc :: NameEnv -> Doc -> PJ.Doc runDoc names (Doc f) = f names @@ -73,7 +76,7 @@ optParens b body | b = parens body -- | Information about associativity. data Assoc = LeftAssoc | RightAssoc | NonAssoc - deriving (Show,Eq) + deriving (Show,Eq,Generic,NFData) -- | Information about an infix expression of some sort. data Infix op thing = Infix