mirror of
https://github.com/GaloisInc/cryptol.git
synced 2024-09-11 14:06:13 +03:00
178 lines
6.5 KiB
Haskell
178 lines
6.5 KiB
Haskell
-- |
|
|
-- Module : Main
|
|
-- Copyright : (c) 2015-2016 Galois, Inc.
|
|
-- License : BSD3
|
|
-- Maintainer : cryptol@galois.com
|
|
-- Stability : provisional
|
|
-- Portability : portable
|
|
|
|
{-# LANGUAGE ImplicitParams #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
module Main where
|
|
|
|
import Control.DeepSeq ( force )
|
|
import Control.Monad.IO.Class( liftIO )
|
|
import qualified Data.Text as T
|
|
import qualified Data.Text.IO as T
|
|
import System.FilePath ((</>))
|
|
import qualified System.Directory as Dir
|
|
|
|
import qualified Cryptol.Eval as E
|
|
import qualified Cryptol.Eval.Value as E
|
|
import qualified Cryptol.Eval.Concrete as C
|
|
|
|
import qualified Cryptol.ModuleSystem.Base as M
|
|
import qualified Cryptol.ModuleSystem.Env as M
|
|
import qualified Cryptol.ModuleSystem.Monad as M
|
|
import qualified Cryptol.ModuleSystem.NamingEnv as M
|
|
import Cryptol.ModuleSystem.Interface (noIfaceParams)
|
|
|
|
import qualified Cryptol.Parser as P
|
|
import qualified Cryptol.Parser.AST as P
|
|
import qualified Cryptol.Parser.NoInclude as P
|
|
|
|
import qualified Cryptol.Eval.SBV as S
|
|
|
|
import qualified Cryptol.TypeCheck as T
|
|
import qualified Cryptol.TypeCheck.AST as T
|
|
|
|
import qualified Cryptol.Utils.Ident as I
|
|
import Cryptol.Utils.Logger(quietLogger)
|
|
|
|
import qualified Data.SBV.Dynamic as SBV
|
|
|
|
import Criterion.Main
|
|
|
|
main :: IO ()
|
|
main = do
|
|
cd <- Dir.getCurrentDirectory
|
|
defaultMain [
|
|
bgroup "parser" [
|
|
parser "Prelude" "lib/Cryptol.cry"
|
|
, parser "BigSequence" "bench/data/BigSequence.cry"
|
|
, parser "BigSequenceHex" "bench/data/BigSequenceHex.cry"
|
|
, parser "AES" "bench/data/AES.cry"
|
|
, parser "SHA512" "bench/data/SHA512.cry"
|
|
]
|
|
, bgroup "typechecker" [
|
|
tc cd "Prelude" "lib/Cryptol.cry"
|
|
, tc cd "BigSequence" "bench/data/BigSequence.cry"
|
|
, tc cd "BigSequenceHex" "bench/data/BigSequenceHex.cry"
|
|
, tc cd "AES" "bench/data/AES.cry"
|
|
, tc cd "SHA512" "bench/data/SHA512.cry"
|
|
]
|
|
, bgroup "conc_eval" [
|
|
ceval cd "AES" "bench/data/AES.cry" "bench_correct"
|
|
, ceval cd "ZUC" "bench/data/ZUC.cry" "ZUC_TestVectors"
|
|
, ceval cd "SHA512" "bench/data/SHA512.cry" "testVector1 ()"
|
|
]
|
|
, bgroup "sym_eval" [
|
|
seval cd "AES" "bench/data/AES.cry" "bench_correct"
|
|
, seval cd "ZUC" "bench/data/ZUC.cry" "ZUC_TestVectors"
|
|
, seval cd "SHA512" "bench/data/SHA512.cry" "testVector1 ()"
|
|
]
|
|
]
|
|
|
|
-- | Evaluation options, mostly used by `trace`.
|
|
-- Since the benchmarks likely do not use base, these don't matter very much
|
|
evOpts :: E.EvalOpts
|
|
evOpts = E.EvalOpts { E.evalLogger = quietLogger
|
|
, E.evalPPOpts = E.defaultPPOpts
|
|
}
|
|
|
|
-- | Make a benchmark for parsing a Cryptol module
|
|
parser :: String -> FilePath -> Benchmark
|
|
parser name path =
|
|
env (T.readFile path) $ \(~bytes) ->
|
|
bench name $ nfIO $ do
|
|
let cfg = P.defaultConfig
|
|
{ P.cfgSource = path
|
|
, P.cfgPreProc = P.guessPreProc path
|
|
}
|
|
case P.parseModule cfg bytes of
|
|
Right pm -> return pm
|
|
Left err -> error (show err)
|
|
|
|
-- | Make a benchmark for typechecking a Cryptol module. Does parsing
|
|
-- in the setup phase in order to isolate typechecking
|
|
tc :: String -> String -> FilePath -> Benchmark
|
|
tc cd name path =
|
|
let withLib = M.withPrependedSearchPath [cd </> "lib"] in
|
|
let setup = do
|
|
bytes <- T.readFile path
|
|
let cfg = P.defaultConfig
|
|
{ P.cfgSource = path
|
|
, P.cfgPreProc = P.guessPreProc path
|
|
}
|
|
Right pm = P.parseModule cfg bytes
|
|
menv <- M.initialModuleEnv
|
|
(eres, _) <- M.runModuleM (evOpts,menv) $ withLib $ do
|
|
-- code from `loadModule` and `checkModule` in
|
|
-- `Cryptol.ModuleSystem.Base`
|
|
let pm' = M.addPrelude pm
|
|
M.loadDeps pm'
|
|
enim <- M.io (P.removeIncludesModule path pm')
|
|
nim <- either (error "Failed to remove includes") return enim
|
|
npm <- M.noPat nim
|
|
(tcEnv,declsEnv,scm) <- M.renameModule npm
|
|
prims <- if P.thing (P.mName pm) == I.preludeName
|
|
then return (M.toPrimMap declsEnv)
|
|
else M.getPrimMap
|
|
return (prims, scm, tcEnv)
|
|
case eres of
|
|
Right ((prims, scm, tcEnv), menv') ->
|
|
return (prims, scm, tcEnv, menv')
|
|
Left _ -> error $ "Failed to load " ++ name
|
|
in env setup $ \ ~(prims, scm, tcEnv, menv) ->
|
|
bench name $ whnfIO $ M.runModuleM (evOpts,menv) $ withLib $ do
|
|
let act = M.TCAction { M.tcAction = T.tcModule
|
|
, M.tcLinter = M.moduleLinter (P.thing (P.mName scm))
|
|
, M.tcPrims = prims
|
|
}
|
|
M.typecheck act scm noIfaceParams tcEnv
|
|
|
|
ceval :: String -> String -> FilePath -> T.Text -> Benchmark
|
|
ceval cd name path expr =
|
|
let withLib = M.withPrependedSearchPath [cd </> "lib"] in
|
|
let setup = do
|
|
menv <- M.initialModuleEnv
|
|
(eres, _) <- M.runModuleM (evOpts,menv) $ withLib $ do
|
|
m <- M.loadModuleByPath path
|
|
M.setFocusedModule (T.mName m)
|
|
let Right pexpr = P.parseExpr expr
|
|
(_, texpr, _) <- M.checkExpr pexpr
|
|
return texpr
|
|
case eres of
|
|
Right (texpr, menv') -> return (texpr, menv')
|
|
Left _ -> error $ "Failed to load " ++ name
|
|
in env setup $ \ ~(texpr, menv) ->
|
|
bench name $ nfIO $ E.runEval evOpts $ do
|
|
let ?evalPrim = C.evalPrim
|
|
env' <- E.evalDecls C.Concrete (M.allDeclGroups menv) mempty
|
|
(e :: C.Value) <- E.evalExpr C.Concrete env' texpr
|
|
E.forceValue e
|
|
|
|
|
|
seval :: String -> String -> FilePath -> T.Text -> Benchmark
|
|
seval cd name path expr =
|
|
let withLib = M.withPrependedSearchPath [cd </> "lib"] in
|
|
let setup = do
|
|
menv <- M.initialModuleEnv
|
|
(eres, _) <- M.runModuleM (evOpts,menv) $ withLib $ do
|
|
m <- M.loadModuleByPath path
|
|
M.setFocusedModule (T.mName m)
|
|
let Right pexpr = P.parseExpr expr
|
|
(_, texpr, _) <- M.checkExpr pexpr
|
|
return texpr
|
|
case eres of
|
|
Right (texpr, menv') -> return (texpr, menv')
|
|
Left _ -> error $ "Failed to load " ++ name
|
|
in env setup $ \ ~(texpr, menv) ->
|
|
bench name $ whnfIO $ fmap force E.runEval evOpts $ S.sbvEval $ do
|
|
let ?evalPrim = S.evalPrim
|
|
env' <- E.evalDecls S.SBV (M.allDeclGroups menv) mempty
|
|
(e :: S.Value) <- E.evalExpr S.SBV env' texpr
|
|
liftIO $ SBV.generateSMTBenchmark False $
|
|
return (E.fromVBit e)
|