mirror of
https://github.com/GaloisInc/cryptol.git
synced 2024-08-16 17:30:27 +03:00
Merge branch 'release/2.5.0' into releases
This commit is contained in:
commit
78fa3f2c5f
20
.appveyor.yml
Normal file
20
.appveyor.yml
Normal file
@ -0,0 +1,20 @@
|
||||
install:
|
||||
# Using '-y' and 'refreshenv' as a workaround to:
|
||||
# https://github.com/haskell/cabal/issues/3687
|
||||
- choco install -y ghc --version 8.0.2
|
||||
- refreshenv
|
||||
# See http://help.appveyor.com/discussions/problems/6312-curl-command-not-found#comment_42195491
|
||||
# NB: Do this after refreshenv, otherwise it will be clobbered!
|
||||
- set PATH=C:\Program Files\Git\mingw64\bin;%PATH%;C:\msys64\usr\bin
|
||||
- curl -o cabal.zip --progress-bar https://www.haskell.org/cabal/release/cabal-install-1.24.0.0/cabal-install-1.24.0.0-x86_64-unknown-mingw32.zip
|
||||
- 7z x -bd cabal.zip
|
||||
- cabal --version
|
||||
- cabal update
|
||||
- curl -o z3.zip -L https://github.com/Z3Prover/z3/releases/download/z3-4.5.0/z3-4.5.0-x64-win.zip
|
||||
- 7z x -bd z3.zip
|
||||
- cp z3-4.5.0-x64-win/bin/z3.exe .
|
||||
|
||||
build_script:
|
||||
- cabal sandbox init
|
||||
- cabal install Cabal
|
||||
- make
|
3
.gitignore
vendored
3
.gitignore
vendored
@ -5,6 +5,8 @@
|
||||
cabal.sandbox.config
|
||||
dist
|
||||
results.xml
|
||||
dist-newstyle
|
||||
.stack-work
|
||||
|
||||
# don't check in generated documentation
|
||||
#docs/CryptolPrims.pdf
|
||||
@ -20,3 +22,4 @@ cryptol-2.*
|
||||
/ICryptol/profile.tar
|
||||
/ICryptol/profile_cryptol/security/
|
||||
/ICryptol/profile_cryptol/startup/
|
||||
/bench*.xml
|
||||
|
40
.travis.yml
40
.travis.yml
@ -1,10 +1,42 @@
|
||||
language: haskell
|
||||
ghc: 7.6
|
||||
dist: trusty
|
||||
sudo: false
|
||||
|
||||
language: c
|
||||
|
||||
matrix:
|
||||
include:
|
||||
- env: CABALVER="1.24" GHCVER="8.0.2"
|
||||
compiler: ": #GHC 8.0.2"
|
||||
addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.2], sources: [hvr-ghc]}}
|
||||
- os: osx
|
||||
env: CABALVER="1.24" GHCVER="8.0.2"
|
||||
compiler: ": #GHC 8.0.2"
|
||||
|
||||
before_install:
|
||||
- if [[ $TRAVIS_OS_NAME == 'linux' ]];
|
||||
then
|
||||
mkdir -p $HOME/bin;
|
||||
export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$HOME/bin:$HOME/.cabal/bin:$PATH;
|
||||
curl https://saw.galois.com/builds/z3/z3 > z3;
|
||||
chmod +x z3;
|
||||
mv z3 $HOME/bin/z3;
|
||||
z3 --version;
|
||||
fi
|
||||
- if [[ $TRAVIS_OS_NAME == 'osx' ]];
|
||||
then
|
||||
brew install ghc cabal-install z3;
|
||||
export PATH=$HOME/.cabal/bin:$PATH;
|
||||
fi
|
||||
- env
|
||||
|
||||
install:
|
||||
- cabal update
|
||||
- cabal sandbox init
|
||||
- cabal install Cabal
|
||||
- make
|
||||
|
||||
script:
|
||||
- make test
|
||||
- make test DIFF=""
|
||||
|
||||
notifications:
|
||||
email: false
|
||||
email: false
|
||||
|
7
Makefile
7
Makefile
@ -111,7 +111,7 @@ endif
|
||||
|
||||
CRYPTOL_SRC := \
|
||||
$(shell find src cryptol cryptol-server bench \
|
||||
\( -name \*.hs -or -name \*.x -or -name \*.y \) \
|
||||
\( -name \*.hs -or -name \*.lhs -or -name \*.x -or -name \*.y \) \
|
||||
-and \( -not -name \*\#\* \) -print) \
|
||||
$(shell find lib -name \*.cry) \
|
||||
${GIT_INFO_FILES}
|
||||
@ -271,7 +271,10 @@ test: ${CS_BIN}/cryptol-test-runner
|
||||
bench: cryptol.cabal Makefile | ${CS_BIN}/alex ${CS_BIN}/happy
|
||||
$(CABAL_INSTALL) --only-dependencies --enable-benchmarks
|
||||
$(CABAL) configure --enable-benchmarks
|
||||
$(CABAL) bench --benchmark-option=--junit --benchmark-option=$(call adjust-path,$(CURDIR)/bench.xml)
|
||||
$(CABAL) bench --benchmark-option=--junit --benchmark-option=$(call adjust-path,$(CURDIR)/bench-parser.xml) --benchmark-option='parser/'
|
||||
$(CABAL) bench --benchmark-option=--junit --benchmark-option=$(call adjust-path,$(CURDIR)/bench-typechecker.xml) --benchmark-option='typechecker/'
|
||||
$(CABAL) bench --benchmark-option=--junit --benchmark-option=$(call adjust-path,$(CURDIR)/bench-conc_eval.xml) --benchmark-option='conc_eval/'
|
||||
$(CABAL) bench --benchmark-option=--junit --benchmark-option=$(call adjust-path,$(CURDIR)/bench-sym_eval.xml) --benchmark-option='sym_eval/'
|
||||
rm -rf dist/setup-config
|
||||
|
||||
.PHONY: clean
|
||||
|
52
README.md
52
README.md
@ -1,3 +1,6 @@
|
||||
[![Build
|
||||
Status](https://travis-ci.org/GaloisInc/cryptol.svg?branch=master)](https://travis-ci.org/GaloisInc/cryptol)
|
||||
|
||||
# Cryptol, version 2
|
||||
|
||||
This version of Cryptol is (C) 2013-2016 Galois, Inc., and
|
||||
@ -39,13 +42,16 @@ cryptol` to get the latest stable version.
|
||||
|
||||
## Getting Z3
|
||||
|
||||
Cryptol currently uses Microsoft Research's
|
||||
[Z3 SMT solver](https://github.com/Z3Prover/z3) by default to solve
|
||||
constraints during type checking, and as the default solver for the
|
||||
`:sat` and `:prove` commands. You can download Z3 binaries for a
|
||||
variety of platforms from their
|
||||
[releases page](https://github.com/Z3Prover/z3/releases). Note that if you
|
||||
install Cryptol using Homebrew, Z3 will be installed automatically.
|
||||
Cryptol currently uses Microsoft Research's [Z3 SMT
|
||||
solver](https://github.com/Z3Prover/z3) by default to solve constraints
|
||||
during type checking, and as the default solver for the `:sat` and
|
||||
`:prove` commands. You can download Z3 binaries for a variety of
|
||||
platforms from their [releases page](https://github.com/Z3Prover/z3/releases).
|
||||
|
||||
Cryptol generally requires the most recent version of Z3, which at the
|
||||
time of writing this file is 4.5.0. Note that if you install Cryptol
|
||||
using Homebrew, the appropriate version of Z3 will be installed
|
||||
automatically.
|
||||
|
||||
After installation, make sure that `z3` (or `z3.exe` on Windows)
|
||||
is on your PATH.
|
||||
@ -114,6 +120,20 @@ of these `make` targets, you will end up with a binary in
|
||||
or use the results of `tarball` or `dist` to install Cryptol in a
|
||||
location of your choice.
|
||||
|
||||
## Configuring Cryptol
|
||||
|
||||
Cryptol depends on several external files for complete operation. These
|
||||
files are contained in the `lib` directory of the Cryptol repository. If
|
||||
you install with `cabal install`, these files will be automaticall
|
||||
copied into a directory that the `cryptol` executable can find. If you
|
||||
install in other ways, you will have to do more manual configuration.
|
||||
There are two options:
|
||||
|
||||
* Copy the contents of the `lib` directory into `$HOME/.cryptol`.
|
||||
|
||||
* Set the `CRYPTOLPATH` environment variable to name some other
|
||||
directory that contains those files.
|
||||
|
||||
# Contributing
|
||||
|
||||
We believe that anyone who uses Cryptol is making an important
|
||||
@ -157,24 +177,6 @@ be happy to incorporate your changes.
|
||||
well as the Cryptol sources and expected outputs that comprise that
|
||||
suite
|
||||
|
||||
### Cryptol Notebook (Experimental)
|
||||
|
||||
The ICryptol notebook interface is now a
|
||||
[standalone project](https://github.com/GaloisInc/ICryptol).
|
||||
|
||||
### Cryptol Server and pycryptol (Experimental)
|
||||
|
||||
This package includes an executable in `/cryptol-server` that provides
|
||||
an interface to the Cryptol interpreter via JSON over
|
||||
ZeroMQ. Currently this is used to support the
|
||||
[`pycryptol`](http://pycryptol.readthedocs.org/en/latest/) library. It
|
||||
is part of this package because we intend to eventually make the
|
||||
console REPL a client of that server as well. The `cryptol-server`
|
||||
executable is included in any builds if the `CRYPTOL_SERVER`
|
||||
environment variable is non-empty when running `make`, for example:
|
||||
|
||||
CRYPTOL_SERVER=1 make dist
|
||||
|
||||
# Where to Look Next
|
||||
|
||||
The `docs` directory of the installation package contains an
|
||||
|
@ -7,10 +7,17 @@
|
||||
-- Portability : portable
|
||||
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
module Main where
|
||||
|
||||
import qualified Data.Text.Lazy as T
|
||||
import qualified Data.Text.Lazy.IO as T
|
||||
import System.FilePath ((</>))
|
||||
import qualified System.Directory as Dir
|
||||
|
||||
import qualified Cryptol.Eval as E
|
||||
import qualified Cryptol.Eval.Monad as E
|
||||
import qualified Cryptol.Eval.Value as E
|
||||
|
||||
import qualified Cryptol.ModuleSystem.Base as M
|
||||
import qualified Cryptol.ModuleSystem.Env as M
|
||||
@ -22,41 +29,50 @@ import qualified Cryptol.Parser.AST as P
|
||||
import qualified Cryptol.Parser.NoInclude as P
|
||||
|
||||
import qualified Cryptol.Symbolic as S
|
||||
import qualified Cryptol.Symbolic.Value as S
|
||||
|
||||
import qualified Cryptol.TypeCheck as T
|
||||
import qualified Cryptol.TypeCheck.AST as T
|
||||
|
||||
import qualified Cryptol.Utils.Ident as I
|
||||
|
||||
import qualified Data.SBV.Dynamic as SBV
|
||||
|
||||
import Criterion.Main
|
||||
|
||||
main :: IO ()
|
||||
main = defaultMain [
|
||||
main = do
|
||||
cd <- Dir.getCurrentDirectory
|
||||
defaultMain [
|
||||
bgroup "parser" [
|
||||
parser "Prelude" "lib/Cryptol.cry"
|
||||
, parser "Extras" "lib/Cryptol/Extras.cry"
|
||||
, parser "PreludeWithExtras" "bench/data/PreludeWithExtras.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 "Prelude" "lib/Cryptol.cry"
|
||||
, tc "BigSequence" "bench/data/BigSequence.cry"
|
||||
, tc "BigSequenceHex" "bench/data/BigSequenceHex.cry"
|
||||
, tc "AES" "bench/data/AES.cry"
|
||||
, tc "SHA512" "bench/data/SHA512.cry"
|
||||
, bgroup "typechecker" [
|
||||
tc cd "Prelude" "lib/Cryptol.cry"
|
||||
, tc cd "Extras" "lib/Cryptol/Extras.cry"
|
||||
, tc cd "PreludeWithExtras" "bench/data/PreludeWithExtras.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 "AES" "bench/data/AES.cry" "bench bench_data"
|
||||
, ceval "SHA512" "bench/data/SHA512.cry" "testVector1 ()"
|
||||
, 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 "AES" "bench/data/AES.cry" "aesEncrypt (zero, zero)"
|
||||
, seval "ZUC" "bench/data/ZUC.cry"
|
||||
"ZUC_isResistantToCollisionAttack"
|
||||
, seval "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 ()"
|
||||
]
|
||||
]
|
||||
]
|
||||
|
||||
-- | Make a benchmark for parsing a Cryptol module
|
||||
parser :: String -> FilePath -> Benchmark
|
||||
@ -73,8 +89,9 @@ parser name path =
|
||||
|
||||
-- | Make a benchmark for typechecking a Cryptol module. Does parsing
|
||||
-- in the setup phase in order to isolate typechecking
|
||||
tc :: String -> FilePath -> Benchmark
|
||||
tc name path =
|
||||
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
|
||||
@ -83,7 +100,7 @@ tc name path =
|
||||
}
|
||||
Right pm = P.parseModule cfg bytes
|
||||
menv <- M.initialModuleEnv
|
||||
(Right ((prims, scm, tcEnv), menv'), _) <- M.runModuleM menv $ do
|
||||
(Right ((prims, scm, tcEnv), menv'), _) <- M.runModuleM menv $ withLib $ do
|
||||
-- code from `loadModule` and `checkModule` in
|
||||
-- `Cryptol.ModuleSystem.Base`
|
||||
let pm' = M.addPrelude pm
|
||||
@ -97,18 +114,19 @@ tc name path =
|
||||
return (prims, scm, tcEnv)
|
||||
return (prims, scm, tcEnv, menv')
|
||||
in env setup $ \ ~(prims, scm, tcEnv, menv) ->
|
||||
bench name $ nfIO $ M.runModuleM menv $ do
|
||||
bench name $ nfIO $ M.runModuleM 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 tcEnv
|
||||
|
||||
ceval :: String -> FilePath -> T.Text -> Benchmark
|
||||
ceval name path expr =
|
||||
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
|
||||
(Right (texpr, menv'), _) <- M.runModuleM menv $ do
|
||||
(Right (texpr, menv'), _) <- M.runModuleM menv $ withLib $ do
|
||||
m <- M.loadModuleByPath path
|
||||
M.setFocusedModule (T.mName m)
|
||||
let Right pexpr = P.parseExpr expr
|
||||
@ -116,13 +134,18 @@ ceval name path expr =
|
||||
return texpr
|
||||
return (texpr, menv')
|
||||
in env setup $ \ ~(texpr, menv) ->
|
||||
bench name $ nfIO $ M.runModuleM menv $ M.evalExpr texpr
|
||||
bench name $ nfIO $ E.runEval $ do
|
||||
env' <- E.evalDecls (S.allDeclGroups menv) mempty
|
||||
(e :: E.Value) <- E.evalExpr env' texpr
|
||||
E.forceValue e
|
||||
|
||||
seval :: String -> FilePath -> T.Text -> Benchmark
|
||||
seval name path expr =
|
||||
|
||||
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
|
||||
(Right (texpr, menv'), _) <- M.runModuleM menv $ do
|
||||
(Right (texpr, menv'), _) <- M.runModuleM menv $ withLib $ do
|
||||
m <- M.loadModuleByPath path
|
||||
M.setFocusedModule (T.mName m)
|
||||
let Right pexpr = P.parseExpr expr
|
||||
@ -130,6 +153,8 @@ seval name path expr =
|
||||
return texpr
|
||||
return (texpr, menv')
|
||||
in env setup $ \ ~(texpr, menv) ->
|
||||
bench name $ flip nf texpr $ \texpr' ->
|
||||
let senv = S.evalDecls mempty (S.allDeclGroups menv)
|
||||
in S.evalExpr senv texpr'
|
||||
bench name $ nfIO $ E.runEval $ do
|
||||
env' <- E.evalDecls (S.allDeclGroups menv) mempty
|
||||
(e :: S.Value) <- E.evalExpr env' texpr
|
||||
E.io $ SBV.generateSMTBenchmark False $
|
||||
return (S.fromVBit e)
|
||||
|
@ -242,9 +242,17 @@ property AESCorrect msg key = aesDecrypt (aesEncrypt (msg, key), key) == msg
|
||||
|
||||
type nblocks = 128
|
||||
|
||||
bench_data : [128 * nblocks]
|
||||
bench_data = random 0
|
||||
property bench_correct = bench bench_data == bench_result
|
||||
|
||||
bench : [128 * nblocks] -> [128 * nblocks]
|
||||
bench data = join [ aesEncrypt (block, key) | block <- split data ]
|
||||
where key = 0x3243f6a8885a308d313198a2e0370734
|
||||
where key = 0x3243f6a8885a308d313198a2e0370734
|
||||
|
||||
bench_data : [128 * nblocks]
|
||||
bench_data = //random 0
|
||||
0xcddf97f18ad18da94ae27558e975608f673c896a718cffbc90c746160a003d540e353ea1a32cf650c25298cf353b36849f68360e07ad40a9e6c0e4dd2351dce8c06dd82c27642a5e9ce3804780d531af41768b4697b45383d58dfd98c9f2e6d5788e671229529d239b40fc9a52436c437e716cef3c5503d567eff3c2f35d806ae4431455ec096526b1b584cb4a80efde3174361e912a46bf8b7b8d3ca4cebacea935ccd766976614885f5330441ca4acee37c9728fb53708042d9952d8ef3ca544c870a7ee689f8b6d78764368e849274946d0e8bdc69f4a4004cbbce034f1d0a6f8447a756a5f9c217e377909d0c4bde859732e7263c03013c623cb1f2478b77f7838b3d3581e0aba9da951dd18466a131bca89252fc17b9bbe475530d425ac7a79cbc26a941dcc16ded680dddada735c76fa469ebeadf1c8fc33a2c7dc00b865eaec95f1448583425302a9023d39c3bb794685a5e30f196f7c0bdc2b8790d35f8bb9c4359e17ca53e8450da4db030bb67fb4cab68ef4a5edfbe120f1c9824b4faa0cc767bb7304238a798534f065cc1cc8fe310d76c2b440b64348a8e16873eddb5931313573c2cb43a47c2ff0f9c8ec264a0a6ec6474c1056fc7f376c01e5d3b6fea382b5086c7c80bb4c5505f2d4f18dc01cff4baa71eac658ca78e5acbde546dbe85dd71708fb46c8ec00ef75b9b577f93a3c550781a642d5bc4fa2da325656f737d272875b9185fe86a0e0e3eefaf51294d0f06340db93715c99df443e286c0d1e2ae869a7e0d705d6369362a220617ac4803fd205de679ea6ed82881cc2315d73c9cc8f4512ee61afaf127eac098d1d31b075c16aa902024594337c6b2a290cedcbd44190105d20de7ef16fb310400ccbc9ca6a1f4de0a9b1f82b780ee3eda52af664b883c32dd70c860905c0f9e83ee0ae5fc016b81c4c4ca70c05703035637e4988a827bf6e230ba30dc78b8c5663e14273827fb6c4aa700b95a04f1456ce15d18740ee79b7aeb85feffac9f5bd54c9a9bd494a9fc8fab4280316ac8f6552849a798e2b5d7326bb2208fdf2cf6b372311edcd87bb2b1805afd1b6e085fad1a28bc4578e1abea57227f49c141d7d08893d8083249e32cc9645748684cc5d4d492abbdaf5f8373b5e2e4bd91c15346e1d455415395bc0342185665ebeb94fda5fdf7e601961bf1f1109373e935a077a0088980844ce1c87f347380f3c805b01407cf9154f5818db41a6f5d87994df790421a9dbf7d56c11a5e723ec853f32bcf7dc0eef03bbf164564167c6212c35ddd9d6112eb43e4826d1da8f065b804fd48b5ff863b4f4246ba6ebaef90396843e084168d6826abf5f6b0e82c7a7a96707e650e86f82862c5910e0c4d6a48182656e0e76be4017c739feb2da56bb69db4b0885c772180607ce880b15064b5b9878cd1c3d4ae9657c5fdf5ca5d7755807d74e2a57aed4e9fe90c49ed4f01ae3cb812ada6b15c7009d98930d8a41cf23e8f5a962e93c8cecef6044cfcc8843d1f6b5dfb868de036fa5d992c861f056f504f54e8d077028143a2807676c02faf35435ee43cb1ece1a82c7f142be774c824b7e8e3fcad737f58f4818994842ab40a211f9569ad476beef0f2f97be0fb515cf0754641748b2af38d58937c3428a147647911734d54bf06be7f3fcab19b874ff52893af6a45c44adf11c17bf177fc0e90539327373e6594e249aca3a386272d1405455e7e8b463029c0460a31b59b9dc1a15d18cdf1997df250721735651c5e7de7059cb755aa4a0c99962e6485b2ccb02ffecb022fc867e36a63ef77ee8740af2e6f25b0d497d3bcc213a939a47a64057caf107e79661d15f469f8e32b2175bed98af21776a9a2cde4e4982ecd695b4dcef8822806cf74ac73aa5b9d8e6dc0a6d2b97b75d11553a9478296631b7a3c340113247f32bf7a7c42e85b9e517b4f9a09ab453de795f156f09d2704bfa56f5ade38e0eae826796bd54165967332985ecdd4991b8e2bb4016e0d2da173690feace03245c2ef868b44ea7892c0ce15d818a32e5bf57d53a1d86cbb3074221083cfa570c17104da26c063b3a349ce35facd3b7bf267383235a5620217d58201c74105302f3445e024313338fe93dd6f617088b41c836083ceae512782e458c4f5c74bd1987ccb098d1d89fe63a5e5881e56b0c5aba87ef2c5e8d6333d91e9dcbdc45a3c16d67b32c4e51e95231aa7e0b9342c599ebdc6ebb6e4dce1fcd98add42d6ab08707a6f5a38154ad5a3674e8a05105c5ecec180f9661122da31a94e9ad7d337ff5ab4a28a5c5cba9a393f484ed5e5f37bbb4b7caecbf9cbb432cae0b2f6bd5ce6068104f012d6428a9b172847e18f12708de6248cdf0401c865292645fb30114f4f4b53d4473b6ffc53ae0870e85c24f631f52c04d227ea9bc0a59828b6f9eafd95cac13ccfb1cdbae3550b0cd99e1812346d5d01b5a782d1d50fbedf858a4a044fd9384e3a6c10cb4227e276c7399b897b9dcbd2a5cb4e14d8341dd32029938f444fa3dcf2d23198f6bf042439cf96a534f3041774a6c3d5b6bb5bfcd8d7af57402431c7dd758da93ccef39495977cece58087ecc80b278d3e9966b7bd8b183f0379f28aa3c9a885065b8a090f3af15a15acb553b36a73d25a581e7f54f5e1f6f49c4f638ce40ba67629e910a04444d5f6b66c4548b611f851feb08d64fa4d99b83ad218d182d0e86e7f87d4923599a547effed6b9c86e853aef9e60767bff33de916bd799eaf3922ae80abadcc91c95f47e702e2fbd2631d0b77ef85f092204141250c4162b0369be64c1d6bdc2d58c02981cc1de13ae3efba34fbfb3dd0ef3ac4c502a1b87c6ee6bc1a9131b098a85d31560c60c599398d0bd80b37bf4d20df81522b2acc749178fb785
|
||||
|
||||
|
||||
bench_result : [128 * nblocks]
|
||||
bench_result =
|
||||
0x9b00ae426bcc2cd6150a0af62b8be77fbb389c5b061a893588d1918f50f1f31ea1183bd81fd7faae77b4f6321a17130f46e21a2653b1f7dc520bf13305c5e7141cee9d8809d58b9b8ec2aa225120ea6ecec21fba09678bbbeda0b483ad299a8adb7b306599531cf717fd67a1c25e2adeeb48521619991e122b053c3a842936b14b6eea74734a6fc2abea6c1fc4780b2df8059ce9715299eeff7b6577409ebae71285929379cd065df0c249f9696e1b28da476ae52d55d0b1f676c619271d37d4211906d402e4eaf4df3031be5bc00962b7747e7b880bf55bee2882e5008e1c1fed70beb7e54be0545100a2e122b94536b888aaea25dde9e0715dfc892dee2b4fb8e94c6b15a2e77adad1f98e50ffef837309998fcdfd9bcb3d16dcd2a162a3b66c2533474981ba72321aaa9a611c670015fa6cbf9f7d7f26b3da415eccf01872cc3a686f659c0cc0d1d08a1d41470b0ceab527bd6499433a2f2df865982b3f616c246fe49f3a15b676983f7f853f6355bc2f4cdc39e5a29347f7031ab7d2659d0ddfb259fbdfe37eaee2e4dcbdfe0ac584038c5a98d85182ca2424f0e75b7f84d512828ed20bbd05065ed4ba0b850b51c31ecb231f2c879993038d7c9487e0fa46a84a02d4f5408faabd9f41edbbef5d6183dd880ea5b7272a2c46900e02357550c036f4b84168a3e891cd8fe33c2d521ce060a2863bb735e97614d0f5bf40068bfacb02297351db4a5bd80d8140a7e0734550967b2445d4236411e04f83e7f15f5148c9d758994cb8427238cea307ddde786dd74e5565b1dd905d085ebb5a7c725d72164adeeafd7387636c31eee2e729bd0fdf95686f957befdb190101cc23cc9b8e39c652e937bd1e21adad99b86d3b2ed0e4ed4ea4bd9d9ed2ad2b99adf40577fba6b25364cd6d96f79cb0f24ae551021904b57c1d469cfac780ea8469c530ab9d2fe6e98c270c5e1babed259878f48ab5824ebf327d8d18fd2e460334cc0ca9f3b0208c0b322a074185830c460cf58c45cef2234aa5ceb6ac294325bd4d4f9e569531165b9e731c84ffc92f453ce92464658592396f83555284a5f69288e3263d7bd083fa3257b0a11a9d8e4702ed06ebd172eacb7f559527637e0259573b1723c079465d593d5e89163e187ae7ac629ed75e398274daf9c420cac2d3b8f0de82dc9d50cd85d93460213416e3e5c0960c563d26fdb56e1e0dc79b251e95364389f6acbd78edd2664be1edc789b2c7a45b2101c69b3cdb8f9f6a2d7316d2cdca02fb5119d76c9bc93f7bc4e075eee1d453fa4668f368919d14035a7ba293d9787744f44e734443e9abc79a8d7aea71918f0a925026809cf43ae2fd1f6ea00fae2f87d4e7d83e4e86c81695d77e48d5f7080d61d878bde080cec46f4ed19d78f2b0c14db0bb6c871e6506064aa1c7b23c7d2baa9b5db5be3fc94923e09fddc13cd8322d05d990b3a9c5ce418c542eb80b1839a23ed7bc0b588ec957db3df1e1389ff0d541ec2f5331ab92fa7f85efa5ae9ec1c513365df179bb29d4f1914940c68468bd12e9fce04c8d08b6d3f1a4e2d632303ca99656bb248efbb6becad7ac6535678d6534aec746fbca6ec3dec85e4db505872e88bde65214b92eba09b91aff63c5db7e440a1f0ef0bca38759f9aaa35c0b8c565ec4307cc07a3226c992163aaa968ab9b9e507fa4b1910d1c24442615ffea299a8d7fcaf7aa2db3fac83d9f3b8a90bd9ae9100167944e01a07c011d0115870f5079d991d3dccd71fdd23b383b69409a1ba519c22194de6d1048e1195a4c716e0b27055aef816218d94972177732b0abd9df432d8f09293d8b22cc83e05522f7fa46742cd29b63357096601137130dc772717f8f4d02b5651fae2d74f72b25e9266090b95bf3ecb6ddda78edfa47346cf336e79548f9ea09eebe95da8903c86af35cb0abdaa4b78f05b2ef66342072b229a7f030e5b2f8e2ead7a8f5ea2a512cf0f02a4b0fc23e5aef4518f1c40674f5552a040cddf2daf47eec38103e6703720bdf40d68f8de4a9c9a39b1a21a2ea15337772526128abb3234bdce85dd7187a827f7aed625b862887f4ef41f656cc76c5311e34e654e0babe2230d3c1f7554106bab1dcdf18361e5579cf794af967421a1f06f80cfc254a9fa0a5b2a7bebd6dc8bbbf178f9647e356a4fd61e41301386784ba90dfaf5823a0007e50e61a0c3720b9b54edb800ba805e3817cddc7015febed997de87030f3341fad7249ce4530d55f5e0b3aac5a9de0d72c6c5672bc29440354d3a7d88873abdd090f41fa1db8740736583f74c7bfe526b283274f4bc08dea4884ccd75d34df9d8410f7e488b541f467331c5e7da352faa1019c394535472aa0f1ed1512928591e0b4335271df7a7d2d9d7fa1f7f4522be394b39bf15a7bc7a97ad21e171a638eb27d44efd57921938ed70335e3f3a8922553392db8a07e02cd4dc1184edbfbadaf09f97c50268d25dd5e7064968fde486d68b1051cef118d80c7a2c911a8cad22b26fd94f559cc12972b655ce014914cd3c20542815a0ff98ee166611eb2edc147bf2989d4fa1d72d88f7d211d05fe8e312b441edb3627982da6606d0cfa1c696979af5ff371e293c0a749f172343ab5f87ccd8a9d1c364f032e763a939f0696989a5316b48df43763d42170f598326579acba84e16508b5d4ffac1723c9bb98f7736e961c67caf3243b07760b3be602be9995a1a6b8c5360357e9fefab445229ccddd6214476a2c3af0eeadcd067db77ecaf7c84d605b99c89ab583edac68c3c8d951cce207c2df274709fe2d25477f14a8e50bc05f82b2cf49d9b56d97182b90a9395d90f23b9ee734d70d9312c9f6278f0ecd5f90c82f67693a589a94a6555f3abd8eac5408259879603acdc67b6fb
|
506
bench/data/PreludeWithExtras.cry
Normal file
506
bench/data/PreludeWithExtras.cry
Normal file
@ -0,0 +1,506 @@
|
||||
/*
|
||||
* Copyright (c) 2013-2016 Galois, Inc.
|
||||
* Distributed under the terms of the BSD3 license (see LICENSE file)
|
||||
*/
|
||||
|
||||
module Cryptol where
|
||||
|
||||
/**
|
||||
* The value corresponding to a numeric type.
|
||||
*/
|
||||
primitive demote : {val, bits} (fin val, fin bits, bits >= width val) => [bits]
|
||||
|
||||
infixr 10 ||
|
||||
infixr 20 &&
|
||||
infix 30 ==, ===, !=, !==
|
||||
infix 40 >, >=, <, <=
|
||||
infixl 50 ^
|
||||
infixr 60 #
|
||||
infixl 70 <<, <<<, >>, >>>
|
||||
infixl 80 +, -
|
||||
infixl 90 *, /, %
|
||||
infixr 95 ^^
|
||||
infixl 100 @, @@, !, !!
|
||||
|
||||
/**
|
||||
* Add two values.
|
||||
* * For words, addition uses modulo arithmetic.
|
||||
* * Structured values are added element-wise.
|
||||
*/
|
||||
primitive (+) : {a} (Arith a) => a -> a -> a
|
||||
|
||||
/**
|
||||
* For words, subtraction uses modulo arithmetic.
|
||||
* Structured values are subtracted element-wise. Defined as:
|
||||
* a - b = a + negate b
|
||||
* See also: `negate'.
|
||||
*/
|
||||
primitive (-) : {a} (Arith a) => a -> a -> a
|
||||
|
||||
/**
|
||||
* For words, multiplies two words, modulus 2^^a.
|
||||
* Structured values are multiplied element-wise.
|
||||
*/
|
||||
primitive (*) : {a} (Arith a) => a -> a -> a
|
||||
|
||||
/**
|
||||
* For words, divides two words, modulus 2^^a.
|
||||
* Structured values are divided element-wise.
|
||||
*/
|
||||
primitive (/) : {a} (Arith a) => a -> a -> a
|
||||
|
||||
/**
|
||||
* For words, takes the modulus of two words, modulus 2^^a.
|
||||
* Over structured values, operates element-wise.
|
||||
* Be careful, as this will often give unexpected results due to interaction of
|
||||
* the two moduli.
|
||||
*/
|
||||
primitive (%) : {a} (Arith a) => a -> a -> a
|
||||
|
||||
/**
|
||||
* For words, takes the exponent of two words, modulus 2^^a.
|
||||
* Over structured values, operates element-wise.
|
||||
* Be careful, due to its fast-growing nature, exponentiation is prone to
|
||||
* interacting poorly with defaulting.
|
||||
*/
|
||||
primitive (^^) : {a} (Arith a) => a -> a -> a
|
||||
|
||||
/**
|
||||
* Log base two.
|
||||
*
|
||||
* For words, computes the ceiling of log, base 2, of a number.
|
||||
* Over structured values, operates element-wise.
|
||||
*/
|
||||
primitive lg2 : {a} (Arith a) => a -> a
|
||||
|
||||
|
||||
type Bool = Bit
|
||||
|
||||
/**
|
||||
* The constant True. Corresponds to the bit value 1.
|
||||
*/
|
||||
primitive True : Bit
|
||||
|
||||
/**
|
||||
* The constant False. Corresponds to the bit value 0.
|
||||
*/
|
||||
primitive False : Bit
|
||||
|
||||
/**
|
||||
* Returns the twos complement of its argument.
|
||||
* Over structured values, operates element-wise.
|
||||
* negate a = ~a + 1
|
||||
*/
|
||||
primitive negate : {a} (Arith a) => a -> a
|
||||
|
||||
/**
|
||||
* Binary complement.
|
||||
*/
|
||||
primitive complement : {a} a -> a
|
||||
|
||||
/**
|
||||
* Operator form of binary complement.
|
||||
*/
|
||||
(~) : {a} a -> a
|
||||
(~) = complement
|
||||
|
||||
/**
|
||||
* Less-than. Only works on comparable arguments.
|
||||
*/
|
||||
primitive (<) : {a} (Cmp a) => a -> a -> Bit
|
||||
|
||||
/**
|
||||
* Greater-than of two comparable arguments.
|
||||
*/
|
||||
primitive (>) : {a} (Cmp a) => a -> a -> Bit
|
||||
|
||||
/**
|
||||
* Less-than or equal of two comparable arguments.
|
||||
*/
|
||||
primitive (<=) : {a} (Cmp a) => a -> a -> Bit
|
||||
|
||||
/**
|
||||
* Greater-than or equal of two comparable arguments.
|
||||
*/
|
||||
primitive (>=) : {a} (Cmp a) => a -> a -> Bit
|
||||
|
||||
/**
|
||||
* Compares any two values of the same type for equality.
|
||||
*/
|
||||
primitive (==) : {a} (Cmp a) => a -> a -> Bit
|
||||
|
||||
/**
|
||||
* Compares any two values of the same type for inequality.
|
||||
*/
|
||||
primitive (!=) : {a} (Cmp a) => a -> a -> Bit
|
||||
|
||||
/**
|
||||
* Compare the outputs of two functions for equality
|
||||
*/
|
||||
(===) : {a,b} (Cmp b) => (a -> b) -> (a -> b) -> (a -> Bit)
|
||||
f === g = \ x -> f x == g x
|
||||
|
||||
/**
|
||||
* Compare the outputs of two functions for inequality
|
||||
*/
|
||||
(!==) : {a,b} (Cmp b) => (a -> b) -> (a -> b) -> (a -> Bit)
|
||||
f !== g = \x -> f x != g x
|
||||
|
||||
/**
|
||||
* Returns the smaller of two comparable arguments.
|
||||
*/
|
||||
min : {a} (Cmp a) => a -> a -> a
|
||||
min x y = if x < y then x else y
|
||||
|
||||
/**
|
||||
* Returns the greater of two comparable arguments.
|
||||
*/
|
||||
max : {a} (Cmp a) => a -> a -> a
|
||||
max x y = if x > y then x else y
|
||||
|
||||
/**
|
||||
* Logical `and' over bits. Extends element-wise over sequences, tuples.
|
||||
*/
|
||||
primitive (&&) : {a} a -> a -> a
|
||||
|
||||
/**
|
||||
* Logical `or' over bits. Extends element-wise over sequences, tuples.
|
||||
*/
|
||||
primitive (||) : {a} a -> a -> a
|
||||
|
||||
/**
|
||||
* Logical `exclusive or' over bits. Extends element-wise over sequences, tuples.
|
||||
*/
|
||||
primitive (^) : {a} a -> a -> a
|
||||
|
||||
/**
|
||||
* Gives an arbitrary shaped value whose bits are all False.
|
||||
* ~zero likewise gives an arbitrary shaped value whose bits are all True.
|
||||
*/
|
||||
primitive zero : {a} a
|
||||
|
||||
/**
|
||||
* Left shift. The first argument is the sequence to shift, the second is the
|
||||
* number of positions to shift by.
|
||||
*/
|
||||
primitive (<<) : {a, b, c} (fin b) => [a]c -> [b] -> [a]c
|
||||
|
||||
/**
|
||||
* Right shift. The first argument is the sequence to shift, the second is the
|
||||
* number of positions to shift by.
|
||||
*/
|
||||
primitive (>>) : {a, b, c} (fin b) => [a]c -> [b] -> [a]c
|
||||
|
||||
/**
|
||||
* Left rotate. The first argument is the sequence to rotate, the second is the
|
||||
* number of positions to rotate by.
|
||||
*/
|
||||
primitive (<<<) : {a, b, c} (fin a, fin b) => [a]c -> [b] -> [a]c
|
||||
|
||||
/**
|
||||
* Right rotate. The first argument is the sequence to rotate, the second is
|
||||
* the number of positions to rotate by.
|
||||
*/
|
||||
primitive (>>>) : {a, b, c} (fin a, fin b) => [a]c -> [b] -> [a]c
|
||||
|
||||
primitive (#) : {front, back, a} (fin front) => [front]a -> [back]a
|
||||
-> [front + back] a
|
||||
|
||||
|
||||
/**
|
||||
* Split a sequence into a tuple of sequences.
|
||||
*/
|
||||
primitive splitAt : {front, back, a} (fin front) => [front + back]a
|
||||
-> ([front]a, [back]a)
|
||||
/**
|
||||
* Joins sequences.
|
||||
*/
|
||||
primitive join : {parts, each, a} (fin each) => [parts][each]a
|
||||
-> [parts * each]a
|
||||
|
||||
/**
|
||||
* Splits a sequence into 'parts' groups with 'each' elements.
|
||||
*/
|
||||
primitive split : {parts, each, a} (fin each) => [parts * each]a
|
||||
-> [parts][each]a
|
||||
|
||||
/**
|
||||
* Reverses the elements in a sequence.
|
||||
*/
|
||||
primitive reverse : {a, b} (fin a) => [a]b -> [a]b
|
||||
|
||||
/**
|
||||
* Transposes an [a][b] matrix into a [b][a] matrix.
|
||||
*/
|
||||
primitive transpose : {a, b, c} [a][b]c -> [b][a]c
|
||||
|
||||
/**
|
||||
* Index operator. The first argument is a sequence. The second argument is
|
||||
* the zero-based index of the element to select from the sequence.
|
||||
*/
|
||||
primitive (@) : {a, b, c} (fin c) => [a]b -> [c] -> b
|
||||
|
||||
/**
|
||||
* Bulk index operator. The first argument is a sequence. The second argument
|
||||
* is a sequence of the zero-based indices of the elements to select.
|
||||
*/
|
||||
primitive (@@) : {a, b, c, d} (fin d) => [a]b -> [c][d] -> [c]b
|
||||
|
||||
/**
|
||||
* Reverse index operator. The first argument is a finite sequence. The second
|
||||
* argument is the zero-based index of the element to select, starting from the
|
||||
* end of the sequence.
|
||||
*/
|
||||
primitive (!) : {a, b, c} (fin a, fin c) => [a]b -> [c] -> b
|
||||
|
||||
/**
|
||||
* Bulk reverse index operator. The first argument is a finite sequence. The
|
||||
* second argument is a sequence of the zero-based indices of the elements to
|
||||
z select, starting from the end of the sequence.
|
||||
*/
|
||||
primitive (!!) : {a, b, c, d} (fin a, fin d) => [a]b -> [c][d] -> [c]b
|
||||
|
||||
primitive fromThen : {first, next, bits, len}
|
||||
( fin first, fin next, fin bits
|
||||
, bits >= width first, bits >= width next
|
||||
, lengthFromThen first next bits == len) => [len][bits]
|
||||
|
||||
primitive fromTo : {first, last, bits} (fin last, fin bits, last >= first,
|
||||
bits >= width last) => [1 + (last - first)][bits]
|
||||
|
||||
primitive fromThenTo : {first, next, last, bits, len} (fin first, fin next,
|
||||
fin last, fin bits, bits >= width first,
|
||||
bits >= width next, bits >= width last,
|
||||
lengthFromThenTo first next last == len) => [len][bits]
|
||||
|
||||
primitive infFrom : {bits} (fin bits) => [bits] -> [inf][bits]
|
||||
|
||||
primitive infFromThen : {bits} (fin bits) => [bits] -> [bits] -> [inf][bits]
|
||||
|
||||
primitive error : {at, len} (fin len) => [len][8] -> at
|
||||
|
||||
|
||||
/**
|
||||
* Performs multiplication of polynomials over GF(2).
|
||||
*/
|
||||
primitive pmult : {a, b} (fin a, fin b) => [a] -> [b] -> [max 1 (a + b) - 1]
|
||||
|
||||
/**
|
||||
* Performs division of polynomials over GF(2).
|
||||
*/
|
||||
primitive pdiv : {a, b} (fin a, fin b) => [a] -> [b] -> [a]
|
||||
|
||||
/**
|
||||
* Performs modulus of polynomials over GF(2).
|
||||
*/
|
||||
primitive pmod : {a, b} (fin a, fin b) => [a] -> [1 + b] -> [b]
|
||||
|
||||
/**
|
||||
* Generates random values from a seed. When called with a function, currently
|
||||
* generates a function that always returns zero.
|
||||
*/
|
||||
primitive random : {a} [256] -> a
|
||||
|
||||
type String n = [n][8]
|
||||
type Word n = [n]
|
||||
type Char = [8]
|
||||
|
||||
take : {front,back,elem} (fin front) => [front + back] elem -> [front] elem
|
||||
take (x # _) = x
|
||||
|
||||
drop : {front,back,elem} (fin front) => [front + back] elem -> [back] elem
|
||||
drop ((_ : [front] _) # y) = y
|
||||
|
||||
tail : {a, b} [1 + a]b -> [a]b
|
||||
tail xs = drop`{1} xs
|
||||
|
||||
width : {bits,len,elem} (fin len, fin bits, bits >= width len) => [len] elem -> [bits]
|
||||
width _ = `len
|
||||
|
||||
undefined : {a} a
|
||||
undefined = error "undefined"
|
||||
|
||||
groupBy : {each,parts,elem} (fin each) =>
|
||||
[parts * each] elem -> [parts][each]elem
|
||||
groupBy = split`{parts=parts}
|
||||
|
||||
/**
|
||||
* Define the base 2 logarithm function in terms of width
|
||||
*/
|
||||
type lg2 n = width (max n 1 - 1)
|
||||
|
||||
/**
|
||||
* Debugging function for tracing. The first argument is a string,
|
||||
* which is prepended to the printed value of the second argument.
|
||||
* This combined string is then printed when the trace function is
|
||||
* evaluated. The return value is equal to the third argument.
|
||||
*
|
||||
* The exact timing and number of times the trace message is printed
|
||||
* depend on the internal details of the Cryptol evaluation order,
|
||||
* which are unspecified. Thus, the output produced by this
|
||||
* operation may be difficult to predict.
|
||||
*/
|
||||
primitive trace : {n, a, b} [n][8] -> a -> b -> b
|
||||
|
||||
/**
|
||||
* Debugging function for tracing values. The first argument is a string,
|
||||
* which is prepended to the printed value of the second argument.
|
||||
* This combined string is then printed when the trace function is
|
||||
* evaluated. The return value is equal to the second argument.
|
||||
*
|
||||
* The exact timing and number of times the trace message is printed
|
||||
* depend on the internal details of the Cryptol evaluation order,
|
||||
* which are unspecified. Thus, the output produced by this
|
||||
* operation may be difficult to predict.
|
||||
*/
|
||||
traceVal : {n, a} [n][8] -> a -> a
|
||||
traceVal msg x = trace msg x x
|
||||
|
||||
/*
|
||||
* Copyright (c) 2016 Galois, Inc.
|
||||
* Distributed under the terms of the BSD3 license (see LICENSE file)
|
||||
*
|
||||
* This module contains definitions that we wish to eventually promote
|
||||
* into the Prelude, but which currently cause typechecking of the
|
||||
* Prelude to take too long (see #299)
|
||||
*/
|
||||
|
||||
infixr 5 ==>
|
||||
|
||||
/**
|
||||
* Logical implication
|
||||
*/
|
||||
(==>) : Bit -> Bit -> Bit
|
||||
a ==> b = if a then b else True
|
||||
|
||||
/**
|
||||
* Logical negation
|
||||
*/
|
||||
not : {a} a -> a
|
||||
not a = ~ a
|
||||
|
||||
/**
|
||||
* Conjunction
|
||||
*/
|
||||
and : {n} (fin n) => [n]Bit -> Bit
|
||||
and xs = ~zero == xs
|
||||
|
||||
/**
|
||||
* Disjunction
|
||||
*/
|
||||
or : {n} (fin n) => [n]Bit -> Bit
|
||||
or xs = zero != xs
|
||||
|
||||
/**
|
||||
* Conjunction after applying a predicate to all elements.
|
||||
*/
|
||||
all : {a,n} (fin n) => (a -> Bit) -> [n]a -> Bit
|
||||
all f xs = and (map f xs)
|
||||
|
||||
/**
|
||||
* Disjunction after applying a predicate to all elements.
|
||||
*/
|
||||
any : {a,n} (fin n) => (a -> Bit) -> [n]a -> Bit
|
||||
any f xs = or (map f xs)
|
||||
|
||||
/**
|
||||
* Map a function over an array.
|
||||
*/
|
||||
map : {a, b, n} (a -> b) -> [n]a -> [n]b
|
||||
map f xs = [f x | x <- xs]
|
||||
|
||||
/**
|
||||
* Functional left fold.
|
||||
*
|
||||
* foldl (+) 0 [1,2,3] = ((0 + 1) + 2) + 3
|
||||
*/
|
||||
foldl : {a, b, n} (fin n) => (a -> b -> a) -> a -> [n]b -> a
|
||||
foldl f acc xs = ys ! 0
|
||||
where ys = [acc] # [f a x | a <- ys | x <- xs]
|
||||
|
||||
/**
|
||||
* Functional right fold.
|
||||
*
|
||||
* foldr (-) 0 [1,2,3] = 0 - (1 - (2 - 3))
|
||||
*/
|
||||
foldr : {a,b,n} (fin n) => (a -> b -> b) -> b -> [n]a -> b
|
||||
foldr f acc xs = ys ! 0
|
||||
where ys = [acc] # [f x a | a <- ys | x <- reverse xs]
|
||||
|
||||
/**
|
||||
* Compute the sum of the words in the array.
|
||||
*/
|
||||
sum : {a,n} (fin n, Arith a) => [n]a -> a
|
||||
sum xs = foldl (+) zero xs
|
||||
|
||||
/**
|
||||
* Scan left is like a fold that emits the intermediate values.
|
||||
*/
|
||||
scanl : {b, a, n} (b -> a -> b) -> b -> [n]a -> [n+1]b
|
||||
scanl f acc xs = ys
|
||||
where
|
||||
ys = [acc] # [f a x | a <- ys | x <- xs]
|
||||
|
||||
/**
|
||||
* Scan right
|
||||
*/
|
||||
scanr : {a,b,n} (fin n) => (a -> b -> b) -> b -> [n]a -> [n+1]b
|
||||
scanr f acc xs = reverse ys
|
||||
where
|
||||
ys = [acc] # [f x a | a <- ys | x <- reverse xs]
|
||||
|
||||
/**
|
||||
* Zero extension
|
||||
*/
|
||||
extend : {total,n} (fin total, fin n, total >= n) => [n]Bit -> [total]Bit
|
||||
extend n = zero # n
|
||||
|
||||
/**
|
||||
* Signed extension. `extendSigned 0bwxyz : [8] == 0bwwwwwxyz`.
|
||||
*/
|
||||
extendSigned : {total,n} (fin total, fin n, n >= 1, total >= n+1) => [n]Bit -> [total]Bit
|
||||
extendSigned xs = repeat (xs @ 0) # xs
|
||||
|
||||
/**
|
||||
* Repeat a value.
|
||||
*/
|
||||
repeat : {n, a} a -> [n]a
|
||||
repeat x = [ x | _ <- zero ]
|
||||
|
||||
/**
|
||||
* `elem x xs` Returns true if x is equal to a value in xs.
|
||||
*/
|
||||
elem : {n,a} (fin n, Cmp a) => a -> [n]a -> Bit
|
||||
elem a xs = any (\x -> x == a) xs
|
||||
|
||||
/**
|
||||
* Create a list of tuples from two lists.
|
||||
*/
|
||||
zip : {a,b,n} [n]a -> [n]b -> [n](a,b)
|
||||
zip xs ys = [(x,y) | x <- xs | y <- ys]
|
||||
|
||||
/**
|
||||
* Create a list by applying the function to each pair of elements in the input.
|
||||
* lists
|
||||
*/
|
||||
zipWith : {a,b,c,n} (a -> b -> c) -> [n]a -> [n]b -> [n]c
|
||||
zipWith f xs ys = [f x y | x <- xs | y <- ys]
|
||||
|
||||
/**
|
||||
* Transform a function into uncurried form.
|
||||
*/
|
||||
uncurry : {a,b,c} (a -> b -> c) -> (a,b) -> c
|
||||
uncurry f = \(a,b) -> f a b
|
||||
|
||||
/**
|
||||
* Transform a function into curried form.
|
||||
*/
|
||||
curry : {a,b,c} ((a, b) -> c) -> a -> b -> c
|
||||
curry f = \a b -> f (a,b)
|
||||
|
||||
/**
|
||||
* Map a function iteratively over a seed value, producing an infinite
|
||||
* list of successive function applications.
|
||||
*/
|
||||
iterate : { a } (a -> a) -> a -> [inf]a
|
||||
iterate f x = [x] # [ f v | v <- iterate f x ]
|
@ -2,11 +2,14 @@
|
||||
|
||||
module SHA512 where
|
||||
|
||||
/*
|
||||
sha512 : {b, a} (a*1024 == 128 + b + 1 + 1024 - (b+129) % 1024,
|
||||
a*1024 % 1024 == 0,
|
||||
a * 1024 - b >= 129,
|
||||
2^^128 - 1 >= b,
|
||||
fin (a + 1)) => [b] -> [512]
|
||||
|
||||
*/
|
||||
sha512 M = result
|
||||
where
|
||||
M' = (pad M)
|
||||
@ -95,4 +98,4 @@ K = [
|
||||
]
|
||||
|
||||
|
||||
property testVector1 x = sha512 0xfd2203e467574e834ab07c9097ae164532f24be1eb5d88f1af7748ceff0d2c67a21f4e4097f9d3bb4e9fbf97186e0db6db0100230a52b453d421f8ab9c9a6043aa3295ea20d2f06a2f37470d8a99075f1b8a8336f6228cf08b5942fc1fb4299c7d2480e8e82bce175540bdfad7752bc95b577f229515394f3ae5cec870a4b2f8 == 0xa21b1077d52b27ac545af63b32746c6e3c51cb0cb9f281eb9f3580a6d4996d5c9917d2a6e484627a9d5a06fa1b25327a9d710e027387fc3e07d7c4d14c6086cc
|
||||
property testVector1 x = sha512 0xfd2203e467574e834ab07c9097ae164532f24be1eb5d88f1af7748ceff0d2c67a21f4e4097f9d3bb4e9fbf97186e0db6db0100230a52b453d421f8ab9c9a6043aa3295ea20d2f06a2f37470d8a99075f1b8a8336f6228cf08b5942fc1fb4299c7d2480e8e82bce175540bdfad7752bc95b577f229515394f3ae5cec870a4b2f8 == 0xa21b1077d52b27ac545af63b32746c6e3c51cb0cb9f281eb9f3580a6d4996d5c9917d2a6e484627a9d5a06fa1b25327a9d710e027387fc3e07d7c4d14c6086cc
|
||||
|
2114
cabal.GHC710.config
2114
cabal.GHC710.config
File diff suppressed because it is too large
Load Diff
2000
cabal.GHC80.config
2000
cabal.GHC80.config
File diff suppressed because it is too large
Load Diff
107
cryptol.cabal
107
cryptol.cabal
@ -1,5 +1,5 @@
|
||||
Name: cryptol
|
||||
Version: 2.4.0
|
||||
Version: 2.5.0
|
||||
Synopsis: Cryptol: The Language of Cryptography
|
||||
Description: Cryptol is a domain-specific language for specifying cryptographic algorithms. A Cryptol implementation of an algorithm resembles its mathematical specification more closely than an implementation in a general purpose language. For more, see <http://www.cryptol.net/>.
|
||||
License: BSD3
|
||||
@ -8,13 +8,13 @@ Author: Galois, Inc.
|
||||
Maintainer: cryptol@galois.com
|
||||
Homepage: http://www.cryptol.net/
|
||||
Bug-reports: https://github.com/GaloisInc/cryptol/issues
|
||||
Copyright: 2013-2016 Galois Inc.
|
||||
Copyright: 2013-2017 Galois Inc.
|
||||
Category: Language
|
||||
Build-type: Simple
|
||||
Cabal-version: >= 1.18
|
||||
extra-source-files: bench/data/*.cry
|
||||
|
||||
data-files: *.cry Cryptol/*.cry
|
||||
data-files: *.cry Cryptol/*.cry *.z3
|
||||
data-dir: lib
|
||||
|
||||
source-repository head
|
||||
@ -24,7 +24,7 @@ source-repository head
|
||||
source-repository this
|
||||
type: git
|
||||
location: https://github.com/GaloisInc/cryptol.git
|
||||
tag: 2.4.0
|
||||
tag: 2.5.0
|
||||
|
||||
flag static
|
||||
default: False
|
||||
@ -34,9 +34,10 @@ flag relocatable
|
||||
default: True
|
||||
description: Don't use the Cabal-provided data directory for looking up Cryptol libraries. This is useful when the data directory can't be known ahead of time, like for a relocatable distribution.
|
||||
|
||||
flag server
|
||||
default: False
|
||||
description: Build with the ZeroMQ/JSON cryptol-server executable
|
||||
-- Note: the Cryptol server needs to be updated to some new APIs.
|
||||
--flag server
|
||||
-- default: False
|
||||
-- description: Build with the ZeroMQ/JSON cryptol-server executable
|
||||
|
||||
library
|
||||
Default-language:
|
||||
@ -61,16 +62,18 @@ library
|
||||
process >= 1.2,
|
||||
QuickCheck >= 2.7,
|
||||
random >= 1.0.1,
|
||||
sbv >= 5.12,
|
||||
sbv >= 7.0,
|
||||
smtLib >= 1.0.7,
|
||||
simple-smt >= 0.6.0,
|
||||
simple-smt >= 0.7.0,
|
||||
syb >= 0.4,
|
||||
text >= 1.1,
|
||||
template-haskell,
|
||||
tf-random >= 0.5,
|
||||
transformers >= 0.3,
|
||||
transformers-base >= 0.4,
|
||||
utf8-string >= 0.3
|
||||
utf8-string >= 0.3,
|
||||
mtl >= 2.2.1,
|
||||
time >= 1.6.0.1
|
||||
|
||||
Build-tools: alex, happy
|
||||
hs-source-dirs: src
|
||||
@ -94,6 +97,7 @@ library
|
||||
Cryptol.Utils.Panic,
|
||||
Cryptol.Utils.Debug,
|
||||
Cryptol.Utils.Misc,
|
||||
Cryptol.Utils.Patterns,
|
||||
Cryptol.Version,
|
||||
|
||||
Cryptol.ModuleSystem,
|
||||
@ -106,6 +110,9 @@ library
|
||||
Cryptol.ModuleSystem.Renamer,
|
||||
|
||||
Cryptol.TypeCheck,
|
||||
Cryptol.TypeCheck.Type,
|
||||
Cryptol.TypeCheck.TypePat,
|
||||
Cryptol.TypeCheck.SimpType,
|
||||
Cryptol.TypeCheck.AST,
|
||||
Cryptol.TypeCheck.Monad,
|
||||
Cryptol.TypeCheck.Infer,
|
||||
@ -117,16 +124,20 @@ library
|
||||
Cryptol.TypeCheck.Depends,
|
||||
Cryptol.TypeCheck.PP,
|
||||
Cryptol.TypeCheck.Solve,
|
||||
Cryptol.TypeCheck.SimpleSolver,
|
||||
Cryptol.TypeCheck.TypeMap,
|
||||
Cryptol.TypeCheck.TypeOf,
|
||||
Cryptol.TypeCheck.Sanity,
|
||||
|
||||
Cryptol.TypeCheck.Solver.Types,
|
||||
Cryptol.TypeCheck.Solver.SMT,
|
||||
Cryptol.TypeCheck.Solver.InfNat,
|
||||
Cryptol.TypeCheck.Solver.Class,
|
||||
Cryptol.TypeCheck.Solver.Selector,
|
||||
Cryptol.TypeCheck.Solver.Utils,
|
||||
Cryptol.TypeCheck.Solver.Simplify,
|
||||
|
||||
Cryptol.TypeCheck.Solver.Numeric,
|
||||
Cryptol.TypeCheck.Solver.Improve,
|
||||
Cryptol.TypeCheck.Solver.CrySAT,
|
||||
Cryptol.TypeCheck.Solver.Numeric.AST,
|
||||
Cryptol.TypeCheck.Solver.Numeric.ImportExport,
|
||||
@ -134,7 +145,6 @@ library
|
||||
Cryptol.TypeCheck.Solver.Numeric.Fin,
|
||||
Cryptol.TypeCheck.Solver.Numeric.Interval,
|
||||
Cryptol.TypeCheck.Solver.Numeric.Simplify,
|
||||
Cryptol.TypeCheck.Solver.Numeric.Simplify1,
|
||||
Cryptol.TypeCheck.Solver.Numeric.SimplifyExpr,
|
||||
Cryptol.TypeCheck.Solver.Numeric.NonLin,
|
||||
Cryptol.TypeCheck.Solver.Numeric.SMT,
|
||||
@ -145,7 +155,8 @@ library
|
||||
Cryptol.Eval,
|
||||
Cryptol.Eval.Arch,
|
||||
Cryptol.Eval.Env,
|
||||
Cryptol.Eval.Error,
|
||||
Cryptol.Eval.Monad,
|
||||
Cryptol.Eval.Reference,
|
||||
Cryptol.Eval.Type,
|
||||
Cryptol.Eval.Value,
|
||||
|
||||
@ -196,10 +207,10 @@ executable cryptol
|
||||
, monad-control
|
||||
, process
|
||||
, random
|
||||
, sbv
|
||||
, sbv >= 7.0
|
||||
, tf-random
|
||||
, transformers
|
||||
GHC-options: -Wall -O2 -threaded -rtsopts -with-rtsopts=-N1
|
||||
GHC-options: -Wall -O2 -threaded -rtsopts "-with-rtsopts=-N1 -A64m"
|
||||
if impl(ghc >= 8.0.1)
|
||||
ghc-options: -Wno-redundant-constraints
|
||||
ghc-prof-options: -auto-all -rtsopts
|
||||
@ -207,43 +218,44 @@ executable cryptol
|
||||
if os(linux) && flag(static)
|
||||
ld-options: -static -pthread
|
||||
|
||||
executable cryptol-server
|
||||
main-is: Main.hs
|
||||
hs-source-dirs: cryptol-server
|
||||
other-modules: Cryptol.Aeson
|
||||
default-language: Haskell2010
|
||||
default-extensions: OverloadedStrings
|
||||
GHC-options: -Wall -O2 -threaded -rtsopts -with-rtsopts=-N1
|
||||
if impl(ghc >= 8.0.1)
|
||||
ghc-options: -Wno-redundant-constraints
|
||||
ghc-prof-options: -auto-all -rtsopts
|
||||
if os(linux) && flag(static)
|
||||
ld-options: -static -pthread
|
||||
if flag(server)
|
||||
build-depends: aeson >= 0.10
|
||||
, aeson-pretty >= 0.7
|
||||
, base
|
||||
, base-compat
|
||||
, bytestring >= 0.10
|
||||
, containers
|
||||
, cryptol
|
||||
, filepath
|
||||
, monad-control
|
||||
, optparse-applicative >= 0.12
|
||||
, text
|
||||
, transformers
|
||||
, unix
|
||||
, unordered-containers >= 0.2
|
||||
, zeromq4-haskell >= 0.6
|
||||
else
|
||||
buildable: False
|
||||
-- Note: the Cryptol server needs to be updated to some new APIs.
|
||||
--executable cryptol-server
|
||||
-- main-is: Main.hs
|
||||
-- hs-source-dirs: cryptol-server
|
||||
-- other-modules: Cryptol.Aeson
|
||||
-- default-language: Haskell2010
|
||||
-- default-extensions: OverloadedStrings
|
||||
-- GHC-options: -Wall -O2 -threaded -rtsopts "-with-rtsopts=-N1 -A64m"
|
||||
-- if impl(ghc >= 8.0.1)
|
||||
-- ghc-options: -Wno-redundant-constraints
|
||||
-- ghc-prof-options: -auto-all -rtsopts
|
||||
-- if os(linux) && flag(static)
|
||||
-- ld-options: -static -pthread
|
||||
-- if flag(server)
|
||||
-- build-depends: aeson >= 0.10
|
||||
-- , aeson-pretty >= 0.7
|
||||
-- , base
|
||||
-- , base-compat
|
||||
-- , bytestring >= 0.10
|
||||
-- , containers
|
||||
-- , cryptol
|
||||
-- , filepath
|
||||
-- , monad-control
|
||||
-- , optparse-applicative >= 0.12
|
||||
-- , text
|
||||
-- , transformers
|
||||
-- , unix
|
||||
-- , unordered-containers >= 0.2
|
||||
-- , zeromq4-haskell >= 0.6
|
||||
-- else
|
||||
-- buildable: False
|
||||
|
||||
benchmark cryptol-bench
|
||||
type: exitcode-stdio-1.0
|
||||
main-is: Main.hs
|
||||
hs-source-dirs: bench
|
||||
default-language: Haskell2010
|
||||
GHC-options: -Wall -O2 -threaded -rtsopts -with-rtsopts=-N
|
||||
GHC-options: -Wall -O2 -threaded -rtsopts "-with-rtsopts=-N1 -A64m"
|
||||
if impl(ghc >= 8.0.1)
|
||||
ghc-options: -Wno-redundant-constraints
|
||||
ghc-prof-options: -auto-all -rtsopts
|
||||
@ -253,4 +265,7 @@ benchmark cryptol-bench
|
||||
, criterion
|
||||
, cryptol
|
||||
, deepseq
|
||||
, directory
|
||||
, filepath
|
||||
, sbv >= 7.0
|
||||
, text
|
||||
|
@ -13,7 +13,7 @@ module Main where
|
||||
|
||||
import OptParser
|
||||
|
||||
import Cryptol.REPL.Command (loadCmd,loadPrelude)
|
||||
import Cryptol.REPL.Command (loadCmd,loadPrelude,CommandExitCode(..))
|
||||
import Cryptol.REPL.Monad (REPL,updateREPLTitle,setUpdateREPLTitle,
|
||||
io,prependSearchPath,setSearchPath)
|
||||
import qualified Cryptol.REPL.Monad as REPL
|
||||
@ -33,7 +33,7 @@ import System.Console.GetOpt
|
||||
(OptDescr(..),ArgOrder(..),ArgDescr(..),getOpt,usageInfo)
|
||||
import System.Directory (getTemporaryDirectory, removeFile)
|
||||
import System.Environment (getArgs, getProgName, lookupEnv)
|
||||
import System.Exit (exitFailure)
|
||||
import System.Exit (exitFailure,exitSuccess)
|
||||
import System.FilePath (searchPathSeparator, splitSearchPath, takeDirectory)
|
||||
import System.IO (hClose, hPutStr, openTempFile)
|
||||
|
||||
@ -41,14 +41,19 @@ import System.IO (hClose, hPutStr, openTempFile)
|
||||
import Prelude ()
|
||||
import Prelude.Compat
|
||||
|
||||
data ColorMode = AutoColor | NoColor | AlwaysColor
|
||||
deriving (Show, Eq)
|
||||
|
||||
data Options = Options
|
||||
{ optLoad :: [FilePath]
|
||||
, optVersion :: Bool
|
||||
, optHelp :: Bool
|
||||
, optBatch :: Maybe FilePath
|
||||
, optCommands :: [String]
|
||||
, optColorMode :: ColorMode
|
||||
, optCryptolrc :: Cryptolrc
|
||||
, optCryptolPathOnly :: Bool
|
||||
, optStopOnError :: Bool
|
||||
} deriving (Show)
|
||||
|
||||
defaultOptions :: Options
|
||||
@ -58,8 +63,10 @@ defaultOptions = Options
|
||||
, optHelp = False
|
||||
, optBatch = Nothing
|
||||
, optCommands = []
|
||||
, optColorMode = AutoColor
|
||||
, optCryptolrc = CryrcDefault
|
||||
, optCryptolPathOnly = False
|
||||
, optStopOnError = False
|
||||
}
|
||||
|
||||
options :: [OptDescr (OptParser Options)]
|
||||
@ -67,12 +74,20 @@ options =
|
||||
[ Option "b" ["batch"] (ReqArg setBatchScript "FILE")
|
||||
"run the script provided and exit"
|
||||
|
||||
, Option "e" ["stop-on-error"] (NoArg setStopOnError)
|
||||
"stop script execution as soon as an error occurs."
|
||||
|
||||
, Option "c" ["command"] (ReqArg addCommand "COMMAND")
|
||||
(concat [ "run the given command and then exit; if multiple --command "
|
||||
, "arguments are given, run them in the order they appear "
|
||||
, "on the command line (overrides --batch)"
|
||||
])
|
||||
|
||||
, Option "" ["color"] (ReqArg setColorMode "MODE")
|
||||
(concat [ "control the color output for the terminal, which may be "
|
||||
, "'auto', 'none' or 'always' (default: 'auto')"
|
||||
])
|
||||
|
||||
, Option "v" ["version"] (NoArg setVersion)
|
||||
"display version number"
|
||||
|
||||
@ -99,10 +114,21 @@ addCommand :: String -> OptParser Options
|
||||
addCommand cmd =
|
||||
modify $ \ opts -> opts { optCommands = cmd : optCommands opts }
|
||||
|
||||
-- | Stop script (batch mode) execution on first error.
|
||||
setStopOnError :: OptParser Options
|
||||
setStopOnError = modify $ \opts -> opts { optStopOnError = True }
|
||||
|
||||
-- | Set a batch script to be run.
|
||||
setBatchScript :: String -> OptParser Options
|
||||
setBatchScript path = modify $ \ opts -> opts { optBatch = Just path }
|
||||
|
||||
-- | Set the color mode of the terminal output.
|
||||
setColorMode :: String -> OptParser Options
|
||||
setColorMode "auto" = modify $ \ opts -> opts { optColorMode = AutoColor }
|
||||
setColorMode "none" = modify $ \ opts -> opts { optColorMode = NoColor }
|
||||
setColorMode "always" = modify $ \ opts -> opts { optColorMode = AlwaysColor }
|
||||
setColorMode x = OptFailure ["invalid color mode: " ++ x ++ "\n"]
|
||||
|
||||
-- | Signal that version should be displayed.
|
||||
setVersion :: OptParser Options
|
||||
setVersion = modify $ \ opts -> opts { optVersion = True }
|
||||
@ -180,13 +206,18 @@ main = do
|
||||
| optVersion opts -> displayVersion
|
||||
| otherwise -> do
|
||||
(opts', mCleanup) <- setupCmdScript opts
|
||||
repl (optCryptolrc opts')
|
||||
(optBatch opts')
|
||||
(setupREPL opts')
|
||||
status <- repl (optCryptolrc opts')
|
||||
(optBatch opts')
|
||||
(optStopOnError opts')
|
||||
(setupREPL opts')
|
||||
case mCleanup of
|
||||
Nothing -> return ()
|
||||
Just cmdFile -> removeFile cmdFile
|
||||
|
||||
case status of
|
||||
CommandError -> exitFailure
|
||||
CommandOk -> exitSuccess
|
||||
|
||||
setupCmdScript :: Options -> IO (Options, Maybe FilePath)
|
||||
setupCmdScript opts =
|
||||
case optCommands opts of
|
||||
@ -202,16 +233,6 @@ setupCmdScript opts =
|
||||
|
||||
setupREPL :: Options -> REPL ()
|
||||
setupREPL opts = do
|
||||
smoke <- REPL.smokeTest
|
||||
case smoke of
|
||||
[] -> return ()
|
||||
_ -> io $ do
|
||||
print (hang "Errors encountered on startup; exiting:"
|
||||
4 (vcat (map pp smoke)))
|
||||
exitFailure
|
||||
displayLogo True
|
||||
setUpdateREPLTitle setREPLTitle
|
||||
updateREPLTitle
|
||||
mCryptolPath <- io $ lookupEnv "CRYPTOLPATH"
|
||||
case mCryptolPath of
|
||||
Nothing -> return ()
|
||||
@ -223,6 +244,22 @@ setupREPL opts = do
|
||||
#else
|
||||
where path' = splitSearchPath path
|
||||
#endif
|
||||
smoke <- REPL.smokeTest
|
||||
case smoke of
|
||||
[] -> return ()
|
||||
_ -> io $ do
|
||||
print (hang "Errors encountered on startup; exiting:"
|
||||
4 (vcat (map pp smoke)))
|
||||
exitFailure
|
||||
|
||||
color <- case optColorMode opts of
|
||||
AlwaysColor -> return True
|
||||
NoColor -> return False
|
||||
AutoColor -> canDisplayColor
|
||||
displayLogo color
|
||||
|
||||
setUpdateREPLTitle (shouldSetREPLTitle >>= \b -> when b setREPLTitle)
|
||||
updateREPLTitle
|
||||
case optBatch opts of
|
||||
Nothing -> return ()
|
||||
-- add the directory containing the batch file to the module search path
|
||||
@ -230,8 +267,14 @@ setupREPL opts = do
|
||||
case optLoad opts of
|
||||
[] -> loadPrelude `REPL.catch` \x -> io $ print $ pp x
|
||||
[l] -> loadCmd l `REPL.catch` \x -> do
|
||||
io $ print $ pp x
|
||||
-- If the requested file fails to load, load the prelude instead
|
||||
loadPrelude `REPL.catch` \y -> do
|
||||
io $ print $ pp y
|
||||
io $ print $ pp x
|
||||
-- If the requested file fails to load, load the prelude instead...
|
||||
loadPrelude `REPL.catch` \y -> do
|
||||
io $ print $ pp y
|
||||
-- ... but make sure the loaded module is set to the file
|
||||
-- we tried, instead of the Prelude
|
||||
REPL.setLoadedMod REPL.LoadedModule
|
||||
{ REPL.lName = Nothing
|
||||
, REPL.lPath = l
|
||||
}
|
||||
_ -> io $ putStrLn "Only one file may be loaded at the command line."
|
||||
|
@ -18,13 +18,15 @@ import Cryptol.REPL.Trie
|
||||
import Cryptol.Utils.PP
|
||||
|
||||
import qualified Control.Exception as X
|
||||
import Control.Monad (guard, join, when)
|
||||
import Control.Monad (guard, join)
|
||||
import qualified Control.Monad.Trans.Class as MTL
|
||||
import Control.Monad.Trans.Control
|
||||
import Data.Char (isAlphaNum, isSpace)
|
||||
import Data.Maybe(isJust)
|
||||
import Data.Function (on)
|
||||
import Data.List (isPrefixOf,nub,sortBy,sort)
|
||||
import System.Console.ANSI (setTitle)
|
||||
import System.IO (stdout)
|
||||
import System.Console.ANSI (setTitle, hSupportsANSI)
|
||||
import System.Console.Haskeline
|
||||
import System.Directory ( doesFileExist
|
||||
, getHomeDirectory
|
||||
@ -34,70 +36,87 @@ import System.FilePath ((</>))
|
||||
import Prelude ()
|
||||
import Prelude.Compat
|
||||
|
||||
-- | Haskeline-specific repl implementation.
|
||||
repl :: Cryptolrc -> Maybe FilePath -> REPL () -> IO ()
|
||||
repl cryrc mbBatch begin =
|
||||
do settings <- setHistoryFile (replSettings isBatch)
|
||||
runREPL isBatch (runInputTBehavior behavior settings body)
|
||||
where
|
||||
body = withInterrupt $ do
|
||||
MTL.lift evalCryptolrc
|
||||
MTL.lift begin
|
||||
loop
|
||||
|
||||
-- | One REPL invocation, either form a file or from the terminal.
|
||||
crySession :: Maybe FilePath -> Bool -> REPL CommandExitCode
|
||||
crySession mbBatch stopOnError =
|
||||
do settings <- io (setHistoryFile (replSettings isBatch))
|
||||
let act = runInputTBehavior behavior settings (withInterrupt loop)
|
||||
if isBatch then asBatch act else act
|
||||
where
|
||||
(isBatch,behavior) = case mbBatch of
|
||||
Nothing -> (False,defaultBehavior)
|
||||
Just path -> (True,useFile path)
|
||||
|
||||
loop = do
|
||||
prompt <- MTL.lift getPrompt
|
||||
mb <- handleInterrupt (return (Just "")) (getInputLines prompt [])
|
||||
case mb of
|
||||
loop :: InputT REPL CommandExitCode
|
||||
loop =
|
||||
do ln <- getInputLines =<< MTL.lift getPrompt
|
||||
case ln of
|
||||
NoMoreLines -> return CommandOk
|
||||
Interrupted
|
||||
| isBatch && stopOnError -> return CommandError
|
||||
| otherwise -> loop
|
||||
NextLine line
|
||||
| all isSpace line -> loop
|
||||
| otherwise -> doCommand line
|
||||
|
||||
Just line
|
||||
| Just cmd <- parseCommand findCommandExact line -> do
|
||||
continue <- MTL.lift $ do
|
||||
handleInterrupt handleCtrlC (runCommand cmd)
|
||||
shouldContinue
|
||||
when continue loop
|
||||
doCommand txt =
|
||||
case parseCommand findCommandExact txt of
|
||||
Nothing | isBatch && stopOnError -> return CommandError
|
||||
| otherwise -> loop -- say somtething?
|
||||
Just cmd -> join $ MTL.lift $
|
||||
do status <- handleInterrupt (handleCtrlC CommandError) (runCommand cmd)
|
||||
case status of
|
||||
CommandError | isBatch && stopOnError -> return (return status)
|
||||
_ -> do goOn <- shouldContinue
|
||||
return (if goOn then loop else return status)
|
||||
|
||||
| otherwise -> loop
|
||||
|
||||
Nothing -> return ()
|
||||
data NextLine = NextLine String | NoMoreLines | Interrupted
|
||||
|
||||
getInputLines prompt ls =
|
||||
getInputLines :: String -> InputT REPL NextLine
|
||||
getInputLines = handleInterrupt (MTL.lift (handleCtrlC Interrupted)) . loop []
|
||||
where
|
||||
loop ls prompt =
|
||||
do mb <- getInputLine prompt
|
||||
let newPropmpt = map (\_ -> ' ') prompt
|
||||
case mb of
|
||||
Nothing -> return Nothing
|
||||
Just l | not (null l) && last l == '\\' ->
|
||||
getInputLines newPropmpt (init l : ls)
|
||||
| otherwise -> return $ Just $ unlines $ reverse $ l : ls
|
||||
Nothing -> return NoMoreLines
|
||||
Just l
|
||||
| not (null l) && last l == '\\' -> loop (init l : ls) newPropmpt
|
||||
| otherwise -> return $ NextLine $ unlines $ reverse $ l : ls
|
||||
|
||||
evalCryptolrc =
|
||||
case cryrc of
|
||||
CryrcDefault -> do
|
||||
here <- io $ getCurrentDirectory
|
||||
home <- io $ getHomeDirectory
|
||||
let dcHere = here </> ".cryptolrc"
|
||||
dcHome = home </> ".cryptolrc"
|
||||
isHere <- io $ doesFileExist dcHere
|
||||
isHome <- io $ doesFileExist dcHome
|
||||
if | isHere -> slurp dcHere
|
||||
| isHome -> slurp dcHome
|
||||
| otherwise -> whenDebug $ io $ putStrLn "no .cryptolrc found"
|
||||
CryrcFiles paths -> mapM_ slurp paths
|
||||
CryrcDisabled -> return ()
|
||||
loadCryRC :: Cryptolrc -> REPL CommandExitCode
|
||||
loadCryRC cryrc =
|
||||
case cryrc of
|
||||
CryrcDisabled -> return CommandOk
|
||||
CryrcDefault -> check [ getCurrentDirectory, getHomeDirectory ]
|
||||
CryrcFiles opts -> loadMany opts
|
||||
where
|
||||
check [] = return CommandOk
|
||||
check (place : others) =
|
||||
do dir <- io place
|
||||
let file = dir </> ".cryptolrc"
|
||||
present <- io (doesFileExist file)
|
||||
if present
|
||||
then crySession (Just file) True
|
||||
else check others
|
||||
|
||||
loadMany [] = return CommandOk
|
||||
loadMany (f : fs) = do status <- crySession (Just f) True
|
||||
case status of
|
||||
CommandOk -> loadMany fs
|
||||
_ -> return status
|
||||
|
||||
-- | Haskeline-specific repl implementation.
|
||||
repl :: Cryptolrc -> Maybe FilePath -> Bool -> REPL () -> IO CommandExitCode
|
||||
repl cryrc mbBatch stopOnError begin =
|
||||
runREPL (isJust mbBatch) $
|
||||
do status <- loadCryRC cryrc
|
||||
case status of
|
||||
CommandOk -> begin >> crySession mbBatch stopOnError
|
||||
_ -> return status
|
||||
|
||||
-- | Actually read the contents of a file, but don't save the
|
||||
-- history
|
||||
--
|
||||
-- XXX: friendlier error message would be nice if the file can't be
|
||||
-- found, but since these will be specified on the command line it
|
||||
-- should be obvious what's going wrong
|
||||
slurp path = do
|
||||
let settings' = defaultSettings { autoAddHistory = False }
|
||||
runInputTBehavior (useFile path) settings' (withInterrupt loop)
|
||||
|
||||
|
||||
-- | Try to set the history file.
|
||||
@ -151,6 +170,22 @@ setREPLTitle = do
|
||||
lm <- getLoadedMod
|
||||
io (setTitle (mkTitle lm))
|
||||
|
||||
-- | In certain environments like Emacs, we shouldn't set the terminal
|
||||
-- title. Note: this does not imply we can't use color output. We can
|
||||
-- use ANSI color sequences in places like Emacs, but not terminal
|
||||
-- codes.
|
||||
--
|
||||
-- This checks that @'stdout'@ is a proper terminal handle, and that the
|
||||
-- terminal mode is not @dumb@, which is set by Emacs and others.
|
||||
shouldSetREPLTitle :: REPL Bool
|
||||
shouldSetREPLTitle = io (hSupportsANSI stdout)
|
||||
|
||||
-- | Whether we can display color titles. This checks that @'stdout'@
|
||||
-- is a proper terminal handle, and that the terminal mode is not
|
||||
-- @dumb@, which is set by Emacs and others.
|
||||
canDisplayColor :: REPL Bool
|
||||
canDisplayColor = io (hSupportsANSI stdout)
|
||||
|
||||
-- Completion ------------------------------------------------------------------
|
||||
|
||||
-- | Completion for cryptol commands.
|
||||
|
@ -49,4 +49,4 @@ logo useColor =
|
||||
lineLen = length (head ls)
|
||||
|
||||
displayLogo :: Bool -> REPL ()
|
||||
displayLogo useColor =unlessBatch (io (mapM_ putStrLn (logo useColor)))
|
||||
displayLogo useColor = unlessBatch (io (mapM_ putStrLn (logo useColor)))
|
||||
|
@ -67,11 +67,14 @@ Sequences
|
||||
reverse : {n,a} (fin n) => [n]a -> [n]a
|
||||
transpose : {n,m,a} [n][m]a -> [m][n]a
|
||||
|
||||
(@) : {n a m} [n]a -> [m] -> a
|
||||
(@@) : {n a m i} [n]a -> [m][i] -> [m]a
|
||||
(!) : {n a m} (fin n) => [n]a -> [m] -> a
|
||||
(!!) : {n a m i} (fin n) => [n]a -> [m][i] -> [m]a
|
||||
|
||||
(@) : {n,a,m} [n]a -> [m] -> a
|
||||
(@@) : {n,a,m,i} [n]a -> [m][i] -> [m]a
|
||||
(!) : {n,a,m} (fin n) => [n]a -> [m] -> a
|
||||
(!!) : {n,a,m,i} (fin n) => [n]a -> [m][i] -> [m]a
|
||||
update : {n,a,m} (fin m) => [n]a -> [m] -> a -> [n]a
|
||||
updateEnd : {n,a,m} (fin n, fin m) => [n]a -> [m] -> a -> [n]a
|
||||
updates : {n,a,m,d} (fin m, fin d) => [n]a -> [d][m] -> [d]a -> [n]a
|
||||
updatesEnd : {n,a,m,d} (fin n, fin m, fin d) => [n]a -> [d][m] -> [d]a -> [n]a
|
||||
|
||||
// Abbreviations
|
||||
groupBy n = split`{each = n}
|
||||
@ -106,3 +109,5 @@ Debugging
|
||||
|
||||
undefined : {a} a
|
||||
error : {n a} [n][8] -> a
|
||||
trace : {n, a, b} [n][8] -> a -> b -> b
|
||||
traceVal : {n, a} [n][8] -> a -> a
|
||||
|
Binary file not shown.
@ -1,4 +1,4 @@
|
||||
MARKDOWN = Syntax.pdf CryptolPrims.pdf Version2Changes.pdf
|
||||
MARKDOWN = Syntax.pdf CryptolPrims.pdf Version2Changes.pdf Semantics.pdf
|
||||
BOOK = Cryptol.pdf
|
||||
|
||||
.PHONY: all
|
||||
@ -7,6 +7,9 @@ all: markdown book
|
||||
Version2Table.pdf: Version2Table.md
|
||||
pandoc -f markdown+tex_math_dollars -V geometry:"margin=0.25in" $^ -o $@
|
||||
|
||||
Semantics.pdf: ../src/Cryptol/Eval/Reference.lhs
|
||||
pandoc -f markdown+lhs -V geometry:"margin=1.25in" $^ --toc -o $@
|
||||
|
||||
.PHONY: markdown
|
||||
markdown: ${MARKDOWN}
|
||||
|
||||
|
Binary file not shown.
@ -124,7 +124,7 @@ Rcon : [8] -> [4]GF28
|
||||
Rcon i = [(gf28Pow (<| x |>, i-1)), 0, 0, 0]
|
||||
|
||||
SubWord : [4]GF28 -> [4]GF28
|
||||
SubWord bs = [ SubByte b | b <- bs ]
|
||||
SubWord bs = [ SubByte' b | b <- bs ]
|
||||
|
||||
RotWord : [4]GF28 -> [4]GF28
|
||||
RotWord [a0, a1, a2, a3] = [a1, a2, a3, a0]
|
||||
@ -149,9 +149,6 @@ keyWS seed = xs
|
||||
| old <- xs
|
||||
]
|
||||
|
||||
checkKey = take`{16} (drop`{8} (keyWS ["abcd", "defg", "1234", "5678"]))
|
||||
checkKey2 = [transpose g | g <- groupBy`{4}checkKey]
|
||||
|
||||
ExpandKey : [AESKeySize] -> KeySchedule
|
||||
ExpandKey key = (keys @ 0, keys @@ [1 .. (Nr - 1)], keys @ `Nr)
|
||||
where seed : [Nk][4][8]
|
||||
|
@ -28,7 +28,7 @@ Referring to the standard as you work your way through this chapter is
|
||||
recommended.
|
||||
|
||||
Some surprises may be at hand for the reader who has never deeply
|
||||
examined a modern cryptography algorithm before.
|
||||
examined a modern cryptography algorithm before.
|
||||
|
||||
First, algorithms like AES are typically composed of many smaller
|
||||
units of varying kinds. Consequently, the entire algorithm is
|
||||
@ -61,8 +61,8 @@ community of cryptographers.
|
||||
\section{Parameters}
|
||||
\label{sec:aesparams}
|
||||
|
||||
The AES algorithm always takes 128-bits of input, and always produces
|
||||
128-bits of output, regardless of the key size. The key-size can be
|
||||
The AES algorithm always takes 128 bits of input, and always produces
|
||||
128 bits of output, regardless of the key size. The key-size can be
|
||||
one of 128 (AES128), 192 (AES192), or 256 (AES256). Following the
|
||||
standard, we define the following three parameters~\cite[Section
|
||||
2.2]{aes}:
|
||||
@ -95,9 +95,9 @@ The following derived type is helpful in signatures:
|
||||
\sectionWithAnswers{Polynomials in \texorpdfstring{GF($2^8$)}{GF(2,8)}}{sec:polynomials}
|
||||
|
||||
AES\indAES works on a two-dimensional representation of the input
|
||||
arranged into bytes, called the {\em state}.\indAESState For an
|
||||
arranged into bytes, called the {\em state}.\indAESState For a
|
||||
128-bit input, we have precisely 4 rows, each containing {\tt Nb}
|
||||
(i.e., 4) bytes, each of which is 8-bits wide, totaling
|
||||
(i.e., 4) bytes, each of which is 8 bits wide, totaling
|
||||
$4\times4\times8 = 128$ bits. The bytes themselves are treated as
|
||||
finite field elements in the Galois field
|
||||
GF($2^8$)~\cite{wiki:galoisfield}\indGF, giving rise to the following
|
||||
@ -111,7 +111,7 @@ The hard-encoding of \texttt{GF28} in this specification is completely
|
||||
appropriate because the construction of AES depends entirely upon the
|
||||
Galois field GF($2^8$). It is conceivable that other algorithms might
|
||||
be parameterized across GF($2^k$) for some $k$, in which case the
|
||||
underyling type declaration would also be parameterized.
|
||||
underlying type declaration would also be parameterized.
|
||||
|
||||
While a basic understanding Galois field operations is helpful, the
|
||||
details are not essential for our modeling purposes. It suffices to
|
||||
@ -153,13 +153,11 @@ cancel each other out. When interpreted as a word, both addition and
|
||||
subtraction amount to a simple exclusive-or operation. Cryptol's
|
||||
\Verb|^|\indXOr operator captures this idiom concisely:
|
||||
\begin{Verbatim}
|
||||
Cryptol> (<| x^^4 + x^^2 |> ^ <| x^^5 + x^^2 + 1 |>) == \
|
||||
<| x^^5 + x^^4 + 1 |>
|
||||
Cryptol> <| x^^4 + x^^2 |> ^ <| x^^5 + x^^2 + 1 |> == \
|
||||
<| x^^5 + x^^4 + 1 |>
|
||||
True
|
||||
\end{Verbatim}
|
||||
Note that the term $x^2$ cancels since it appears in both
|
||||
polynomials. Also note the parentheses are required due to the
|
||||
precedence of {\tt ==} vs. {\tt \Verb|^|}.
|
||||
Note that the term $x^2$ cancels since it appears in both polynomials.
|
||||
\begin{Exercise}\label{ex:gf:0}
|
||||
Adding a polynomial to itself in GF($2^n$) will always yield {\tt 0}
|
||||
since all the terms will cancel each other. Write and prove a
|
||||
@ -198,7 +196,7 @@ that adds all the elements given.
|
||||
\end{code}
|
||||
\end{Answer}
|
||||
|
||||
\paragraph*{Multiplication} Multiplication GF($2^n$) follows the usual
|
||||
\paragraph*{Multiplication} Multiplication in GF($2^n$) follows the usual
|
||||
polynomial multiplication algorithm, where we multiply the first
|
||||
polynomial with each term of the second, and add all the partial sums
|
||||
(i.e., compute their exclusive-or). While this operation can be
|
||||
@ -508,6 +506,7 @@ can make a table containing the precomputed values for all possible
|
||||
these values each time we need it. In fact, Figure~7 on page 16 of
|
||||
the AES\indAES standard lists these precomputed values for
|
||||
us~\cite[Section 5.1.1]{aes}. We capture this table below in Cryptol:
|
||||
\todo[inline]{We should consistently use either ``look-up'' or ``lookup''.}
|
||||
|
||||
\vspace{0.25cm}
|
||||
\begin{minipage}{\textwidth}
|
||||
@ -542,8 +541,9 @@ us~\cite[Section 5.1.1]{aes}. We capture this table below in Cryptol:
|
||||
\end{code}
|
||||
}
|
||||
\end{minipage}
|
||||
\vspace{0.25cm}
|
||||
|
||||
\noindent With this definition of {\tt sbox}, the look up variants of
|
||||
\noindent With this definition of {\tt sbox}, the look-up variants of
|
||||
{\tt SubByte} and {\tt SubBytes} becomes:\label{aes:subbytetl}
|
||||
\begin{code}
|
||||
SubByte' : GF28 -> GF28
|
||||
@ -666,8 +666,8 @@ $$
|
||||
$$
|
||||
|
||||
As you might recall from linear algebra, given two \emph{compatible}
|
||||
matrices $A$ and $B$, the $ij$'th element of $A\times B$ is the
|
||||
dot-product of the $i$'th row of $A$ and the $j$'th column of $B$.
|
||||
matrices $A$ and $B$, the $ij$th element of $A\times B$ is the
|
||||
dot-product of the $i$th row of $A$ and the $j$th column of $B$.
|
||||
(By \emph{compatible} we mean the number of columns of $A$ must be the
|
||||
same as the number of rows of $B$. All our matrices are $4\times 4$,
|
||||
so they are always compatible.) The dot-product is defined as
|
||||
@ -695,8 +695,8 @@ such that {\tt gf28DotProduct} returns the dot-product of two length $n$ vectors
|
||||
\todo[inline]{Check correct with theorem support.}
|
||||
|
||||
\begin{Exercise}\label{ex:aesmc:1}
|
||||
Write properties stating that the dot-matrix operation {\tt
|
||||
gf28DotProduct} is commutative and distributive over vector
|
||||
Write properties stating that the vector operation
|
||||
\texttt{gf28DotProduct} is commutative and distributive over vector
|
||||
addition:
|
||||
\begin{eqnarray*}
|
||||
a \cdot b &=& b \cdot a \\
|
||||
@ -704,7 +704,7 @@ a \cdot (b + c) &=& a\cdot b + a\cdot b
|
||||
\end{eqnarray*}
|
||||
Addition over vectors is defined element-wise. Prove the commutativity
|
||||
property for vectors of length 10. Distributivity will take much
|
||||
longer, so you might want to do a {\tt :check} on it.\indCmdCheck
|
||||
longer, so you might want to do a \texttt{:check} on it.\indCmdCheck
|
||||
\todo[inline]{Explain why distributivity is so much harder to prove.}
|
||||
\end{Exercise}
|
||||
\begin{Answer}\ansref{ex:aesmc:1}
|
||||
@ -807,12 +807,12 @@ row-based ordering.
|
||||
their composition.}
|
||||
|
||||
Recall from Section~\ref{sec:aesparams} that AES takes 128, 192, or
|
||||
256 bit keys. The key is not used as-is, however. Instead, AES\indAES
|
||||
256-bit keys. The key is not used as-is, however. Instead, AES\indAES
|
||||
expands the key into a number of round keys, called the {\em key
|
||||
schedule}. Construction of the key schedule relies on a number of
|
||||
auxiliary definitions, as we shall see shortly.
|
||||
|
||||
\paragraph*{Round constants} AES\indAES standard refers to the constant
|
||||
\paragraph*{Round constants} The AES\indAES standard refers to the constant
|
||||
array {\tt Rcon} used during key expansion. For each {\tt i}, {\tt
|
||||
Rcon[i]} contains 4 words, the last three being 0~\cite[Section
|
||||
5.2]{aes}. The first element is given by $x^{i-1}$, where
|
||||
@ -896,7 +896,7 @@ We have:
|
||||
% explore in Exercise~\ref{aes:keyexpansion}~\ref{ex:rconsafety}.
|
||||
% \end{Answer}
|
||||
|
||||
\paragraph*{The {\ttfamily{\textbf SubWord}} function} AES\indAES
|
||||
\paragraph*{The {\ttfamily{\textbf SubWord}} function} The AES\indAES
|
||||
specification refers to a function named {\tt SubWord}~\cite[Section
|
||||
5.2]{aes}, that takes a 32-bit word and applies the {\tt SubByte}
|
||||
transformation from Section~\ref{aes:subbytes}. This function is
|
||||
@ -909,7 +909,7 @@ Note that we have used the table-lookup version ({\tt SubByte'},
|
||||
Pg~\pageref{aes:subbytetl}) above.
|
||||
|
||||
\paragraph*{The {\ttfamily{\textbf RotWord}} function} The last
|
||||
function we need for key-expansion is named {\tt RotWord} by the
|
||||
function we need for key expansion is named {\tt RotWord} by the
|
||||
AES\indAES standard~\cite[Section 5.2]{aes}. This function merely
|
||||
rotates a given word cyclically to the left:
|
||||
\begin{code}
|
||||
@ -926,18 +926,18 @@ purposes of clarity.
|
||||
|
||||
\paragraph*{The key schedule} Recall that AES\indAES operates on 128,
|
||||
192, or 256 bit keys. These keys are used to construct a sequence of
|
||||
so called {\em round-keys}, each of which is 128-bits wide, and is
|
||||
so-called \emph{round keys}, each of which is 128 bits wide, and is
|
||||
viewed the same way as the {\tt State}:\todo[inline]{\emph{Viewed} or
|
||||
\emph{used}? Isn't this type abuse?}
|
||||
\begin{code}
|
||||
type RoundKey = State
|
||||
\end{code}
|
||||
The expanded key schedule, contains {\tt Nr}+1 round-keys. (Recall
|
||||
The expanded key schedule contains {\tt Nr}+1 round-keys. (Recall
|
||||
from Section~\ref{sec:aesparams} that {\tt Nr} is the number of
|
||||
rounds.) It also helps to separate out the first and the last keys,
|
||||
as they are used in a slightly different fashion. Based on this
|
||||
discussion, we use the following Cryptol type to capture the
|
||||
key-schedule:
|
||||
key schedule:
|
||||
\begin{code}
|
||||
type KeySchedule = (RoundKey, [Nr-1]RoundKey, RoundKey)
|
||||
\end{code}
|
||||
@ -992,9 +992,9 @@ infinite regression of elements:\indDrop\indTranspose
|
||||
| old <- keyWS
|
||||
]
|
||||
\end{code}
|
||||
Note how {\tt prev} tracks the previous 32-bits of the expanded key
|
||||
Note how {\tt prev} tracks the previous 32 bits of the expanded key
|
||||
(by dropping the first {\tt Nk-1} elements), while {\tt old} tracks
|
||||
the {\tt i-Nk}'th recurrence for {\tt keyWS}. Once we have the
|
||||
the {\tt i-Nk}th recurrence for {\tt keyWS}. Once we have the
|
||||
infinite expansion, it is easy to extract just the amount we need by
|
||||
using number of rounds ({\tt Nr}) as our guide:\indIndex\indIndexs
|
||||
\begin{code}
|
||||
@ -1011,7 +1011,7 @@ elements.
|
||||
\paragraph*{Testing {\ttfamily{\textbf ExpandKey}}} The completion of
|
||||
{\tt ExpandKey} is an important milestone in our AES\indAES
|
||||
development, and it is worth testing it before we proceed. The AES
|
||||
specification has example key-expansions that we can use. The
|
||||
specification has example key expansions that we can use. The
|
||||
following function will be handy in viewing the output correctly
|
||||
aligned:
|
||||
\begin{code}
|
||||
@ -1119,7 +1119,7 @@ transformation:
|
||||
\end{code}
|
||||
|
||||
\paragraph*{Forming the input/output blocks} Recall that AES processes
|
||||
input in blocks of 128-bits, producing 128-bits of output, regardless
|
||||
input in blocks of 128 bits, producing 128 bits of output, regardless
|
||||
of the key size. We will need two helper functions to convert 128-bit
|
||||
messages to and from AES states. Conversion from a message to a state
|
||||
is easy to define:
|
||||
@ -1127,11 +1127,11 @@ is easy to define:
|
||||
msgToState : [128] -> State
|
||||
msgToState msg = transpose (split (split msg))
|
||||
\end{code}
|
||||
The first call to {\tt split} gives us 4 32-bit words, which we again
|
||||
The first call to \texttt{split} gives us four 32-bit words, which we again
|
||||
split into bytes. We then form the AES state by transposing the
|
||||
resulting matrix. In the other direction, we simply transpose the
|
||||
state and perform the necessary {\tt
|
||||
join}'s:\indTranspose\indJoin\indReverse\indSplit
|
||||
state and perform the necessary
|
||||
\texttt{join}s:\indTranspose\indJoin\indReverse\indSplit
|
||||
\begin{code}
|
||||
stateToMsg : State -> [128]
|
||||
stateToMsg st = join (join (transpose st))
|
||||
@ -1156,8 +1156,8 @@ We have:
|
||||
\end{Answer}
|
||||
|
||||
\paragraph*{Putting it together} To encrypt, AES merely expands the
|
||||
given key and calls the round-functions. The starting state ({\tt
|
||||
state0} below) is constructed by adding the first round key to the
|
||||
given key and calls the round functions. The starting state (\texttt{state0}
|
||||
below) is constructed by adding the first round key to the
|
||||
input. We then run all the middle rounds using a simple comprehension,
|
||||
and finish up by applying the last round~\cite[Figure 5, Section
|
||||
5.1]{aes}:\indRIndex
|
||||
@ -1173,10 +1173,10 @@ and finish up by applying the last round~\cite[Figure 5, Section
|
||||
|
||||
\paragraph*{Testing} We can now run some test vectors. Note that, just
|
||||
because a handful of test vectors pass, we cannot claim that our
|
||||
implementation of AES is correct.
|
||||
implementation of AES is correct.
|
||||
|
||||
The first example comes from Appendix~B of the AES\indAES
|
||||
standard:~\cite{aes}:
|
||||
standard~\cite{aes}:
|
||||
\begin{Verbatim}
|
||||
Cryptol> aesEncrypt (0x3243f6a8885a308d313198a2e0370734, \
|
||||
0x2b7e151628aed2a6abf7158809cf4f3c)
|
||||
@ -1207,13 +1207,13 @@ aesEncrypt(0x00112233445566778899aabbccddeeff, 0x000102030405060708090a0b0c0d0e0
|
||||
}
|
||||
|
||||
\paragraph*{Other key sizes} Our development of AES has been key-size
|
||||
agnostic, relying on the definition of the parameter {\tt Nk} (See
|
||||
agnostic, relying on the definition of the parameter \texttt{Nk}. (See
|
||||
Section~\ref{sec:aesparams}.) To obtain AES192, all we need is to set
|
||||
{\tt Nk} to be 6, no additional code change is needed. Similarly, we
|
||||
merely need to set {\tt Nk} to be 8 for AES256.
|
||||
\texttt{Nk} to be 6, no additional code change is needed. Similarly, we
|
||||
merely need to set \texttt{Nk} to be 8 for AES256.
|
||||
|
||||
\begin{Exercise}\label{ex:aes192}
|
||||
By setting {\tt Nk} to be 6 and 8 respectively, try the test vectors
|
||||
By setting \texttt{Nk} to be 6 and 8 respectively, try the test vectors
|
||||
given in Appendices C.2 and C.3 of the AES\indAES
|
||||
standard~\cite{aes}.
|
||||
\end{Exercise}
|
||||
@ -1225,7 +1225,7 @@ merely need to set {\tt Nk} to be 8 for AES256.
|
||||
|
||||
AES decryption is fairly similar to encryption, except it uses inverse
|
||||
transformations~\cite[Figure 12, Section 5.3]{aes}. Armed with all the
|
||||
machinery we have built so far, the inverse transformations is
|
||||
machinery we have built so far, the inverse transformations are
|
||||
relatively easy to define.
|
||||
|
||||
%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||||
@ -1272,7 +1272,7 @@ We have:
|
||||
\end{Verbatim}
|
||||
\end{Answer}
|
||||
|
||||
\unparagraph We can now define the inverse s-box
|
||||
\unparagraph We can now define the inverse S-box
|
||||
transform,\indAESInvSbox using the multiplicative inverse function
|
||||
{\tt gf28Inverse} you have defined in
|
||||
Exercise~\ref{aes:subbytes}~\ref{ex:gfmi:01}:
|
||||
@ -1281,9 +1281,9 @@ Exercise~\ref{aes:subbytes}~\ref{ex:gfmi:01}:
|
||||
InvSubByte b = gf28Inverse (xformByte' b)
|
||||
|
||||
InvSubBytes : State -> State
|
||||
InvSubBytes state =[ [ InvSubByte b | b <- row ]
|
||||
| row <- state
|
||||
]
|
||||
InvSubBytes state = [ [ InvSubByte b | b <- row ]
|
||||
| row <- state
|
||||
]
|
||||
\end{code}
|
||||
|
||||
\begin{Exercise}\label{ex:invsb:2}
|
||||
@ -1302,7 +1302,7 @@ We have:
|
||||
\end{Answer}
|
||||
|
||||
\begin{Exercise}\label{ex:invsb:3}
|
||||
The AES specification provides an inverse s-box table~\cite[Figure
|
||||
The AES specification provides an inverse S-box table~\cite[Figure
|
||||
14, Section 5.3.2]{aes}. Write a Cryptol function {\tt InvSubBytes'}
|
||||
using the table lookup technique. Make sure your implementation is
|
||||
correct (i.e., equivalent to {\tt InvSubBytes}) by writing and
|
||||
@ -1382,7 +1382,7 @@ take much longer. Below we show the {\tt :check} results instead:
|
||||
\section{The inverse cipher}
|
||||
\label{sec:inverse-cipher}
|
||||
|
||||
We now also have all the ingrediants to encode AES decryption.
|
||||
We now also have all the ingredients to encode AES decryption.
|
||||
Following Figure~12 (Section 5.3) of the AES\indAES
|
||||
standard~\cite{aes}: {\small
|
||||
\begin{code}
|
||||
@ -1395,7 +1395,7 @@ standard~\cite{aes}: {\small
|
||||
|
||||
aesDecrypt : ([128], [AESKeySize]) -> [128]
|
||||
aesDecrypt (ct, key) = stateToMsg (AESFinalInvRound (kFinal, rounds ! 0))
|
||||
where
|
||||
where
|
||||
(kFinal, ks, kInit) = ExpandKey key
|
||||
state0 = AddRoundKey(kInit, msgToState ct)
|
||||
rounds = [state0] # [ AESInvRound (rk, s)
|
||||
@ -1406,7 +1406,7 @@ standard~\cite{aes}: {\small
|
||||
}
|
||||
|
||||
Note how we use the results of {\tt ExpandedKey}, by carefully naming
|
||||
the first and last round keys and using the middle-keys in reverse.
|
||||
the first and last round keys and using the middle keys in reverse.
|
||||
|
||||
\paragraph*{Testing} Let us repeat the tests for AES encryption. Again,
|
||||
the first example comes from Appendix~B of the AES\indAES
|
||||
@ -1453,13 +1453,13 @@ Appendix~\ref{app:aes}.
|
||||
|
||||
While test vectors do provide good evidence of AES\indAES working
|
||||
correctly, they do not provide a proof that we have implemented the
|
||||
standard faithfully. In fact, for a block-cipher like AES, it is not
|
||||
standard faithfully. In fact, for a block cipher like AES, it is not
|
||||
possible to state what correctness would mean. Tweaking some
|
||||
parameters, or changing the s-box appropriately can give us a brand
|
||||
parameters, or changing the S-box appropriately can give us a brand
|
||||
new cipher. And it would be impossible to tell this new cipher apart
|
||||
from AES aside from running it against published test vectors.
|
||||
|
||||
\todo[inline]{Is this claim about correctness really true?!}
|
||||
\todo[inline]{Is this claim about correctness really true?!}
|
||||
|
||||
What we can do, however, is gain assurance that our implementation
|
||||
demonstrably has the desired properties. We have done this throughout
|
||||
@ -1488,6 +1488,7 @@ assurance by running it through the {\tt :check} command:\indCmdCheck
|
||||
Checking case 1000 of 1000 (100.00%)
|
||||
1000 tests passed OK
|
||||
\end{Verbatim}
|
||||
\todo[inline]{The \texttt{:check} output here is out of date.}
|
||||
% [Coverage: 0.00%. (1000/11579208923731619542357098500868790785326998466564
|
||||
% ...0564039457584007913129639936)]
|
||||
You will notice that even running quick-check will take a while for
|
||||
|
@ -6,7 +6,7 @@ detailed discussion on how AES works, and the construction of the
|
||||
Cryptol model below.
|
||||
|
||||
In the below code, simply set {\tt Nk} to be 4 for AES128, 6 for
|
||||
AES192, and 8 for AES256 on line 15. No other modifications are
|
||||
AES192, and 8 for AES256 on line 19. No other modifications are
|
||||
required for obtaining these AES variants. Note that we have
|
||||
rearranged the code given in Chapter~\ref{chapter:aes} below for ease
|
||||
of reading.
|
||||
|
@ -17,7 +17,7 @@ f x = x + y + z
|
||||
g y = y
|
||||
\end{verbatim}
|
||||
|
||||
This group has two declaration, one for \texttt{f} and one for
|
||||
This group has two declarations, one for \texttt{f} and one for
|
||||
\texttt{g}. All the lines between \texttt{f} and \texttt{g} that are
|
||||
indented more then \texttt{f} belong to \texttt{f}.
|
||||
|
||||
@ -91,14 +91,14 @@ Operator & Associativity\tabularnewline
|
||||
Operator & Associativity\tabularnewline
|
||||
\midrule
|
||||
\endhead
|
||||
\texttt{\textbar{}\textbar{}} & left\tabularnewline
|
||||
\texttt{\^{}} & left\tabularnewline
|
||||
\texttt{\&\&} & left\tabularnewline
|
||||
\texttt{-\textgreater{}} (types) & right\tabularnewline
|
||||
\texttt{\textbar{}\textbar{}} & right\tabularnewline
|
||||
\texttt{\&\&} & right\tabularnewline
|
||||
\texttt{!=} \texttt{==} & not associative\tabularnewline
|
||||
\texttt{\textgreater{}} \texttt{\textless{}} \texttt{\textless{}=}
|
||||
\texttt{\textgreater{}=} & not associative\tabularnewline
|
||||
\texttt{\#} & right\tabularnewline
|
||||
\texttt{\^{}} & left\tabularnewline
|
||||
\texttt{\#} & left\tabularnewline
|
||||
\texttt{\textgreater{}\textgreater{}} \texttt{\textless{}\textless{}}
|
||||
\texttt{\textgreater{}\textgreater{}\textgreater{}}
|
||||
\texttt{\textless{}\textless{}\textless{}} & left\tabularnewline
|
||||
@ -162,12 +162,12 @@ Operator & Associativity & Description\tabularnewline
|
||||
Operator & Associativity & Description\tabularnewline
|
||||
\midrule
|
||||
\endhead
|
||||
\texttt{\textbar{}\textbar{}} & left & Logical or\tabularnewline
|
||||
\texttt{\^{}} & left & Exclusive-or\tabularnewline
|
||||
\texttt{\&\&} & left & Logical and\tabularnewline
|
||||
\texttt{\textbar{}\textbar{}} & right & Logical or\tabularnewline
|
||||
\texttt{\&\&} & right & Logical and\tabularnewline
|
||||
\texttt{!=} \texttt{==} & none & Not equals, equals\tabularnewline
|
||||
\texttt{\textgreater{}} \texttt{\textless{}} \texttt{\textless{}=}
|
||||
\texttt{\textgreater{}=} & none & Comparisons\tabularnewline
|
||||
\texttt{\^{}} & left & Exclusive-or\tabularnewline
|
||||
\texttt{\textasciitilde{}} & right & Logical negation\tabularnewline
|
||||
\bottomrule
|
||||
\end{longtable}
|
||||
@ -188,9 +188,9 @@ x = if y % 2 == 0 then 1
|
||||
|
||||
\section{Tuples and Records}\label{tuples-and-records}
|
||||
|
||||
Tuples and records are used for packaging multiples values together.
|
||||
Tuples are enclosed in parenthesis, while records are enclosed in
|
||||
braces. The components of both tuples and records are separated by
|
||||
Tuples and records are used for packaging multiple values together.
|
||||
Tuples are enclosed in parentheses, while records are enclosed in
|
||||
curly braces. The components of both tuples and records are separated by
|
||||
commas. The components of tuples are expressions, while the components
|
||||
of records are a label and a value separated by an equal sign. Examples:
|
||||
|
||||
@ -335,7 +335,7 @@ explicit type signature.
|
||||
If \texttt{f} is a polymorphic value with type:
|
||||
|
||||
\begin{verbatim}
|
||||
f : { tyParam }
|
||||
f : { tyParam } tyParam
|
||||
f = zero
|
||||
\end{verbatim}
|
||||
|
||||
@ -352,7 +352,7 @@ The value corresponding to a numeric type may be accessed using the
|
||||
following notation:
|
||||
|
||||
\begin{verbatim}
|
||||
`{t}
|
||||
`t
|
||||
\end{verbatim}
|
||||
|
||||
Here \texttt{t} should be a type expression with numeric kind. The
|
||||
@ -360,7 +360,7 @@ resulting expression is a finite word, which is sufficiently large to
|
||||
accommodate the value of the type:
|
||||
|
||||
\begin{verbatim}
|
||||
`{t} : {w >= width t}. [w]
|
||||
`t : {a} (fin a, a >= width t} => [a]
|
||||
\end{verbatim}
|
||||
|
||||
\section{Explicit Type Annotations}\label{explicit-type-annotations}
|
||||
|
@ -14,13 +14,13 @@ That's some 2500 years ago, and surely we do not use those methods
|
||||
anymore in modern day cryptography. However, the basic techniques are
|
||||
still relevant for appreciating the art of secret writing.
|
||||
|
||||
Shift ciphers\indShiftcipher construct the \glosCiphertext
|
||||
ciphertext\indCiphertext from the \glosPlaintext
|
||||
plaintext\indPlaintext\ by means of a predefined {\em shifting}
|
||||
Shift ciphers\indShiftcipher construct the
|
||||
ciphertext\glosCiphertext\indCiphertext from the
|
||||
plaintext\glosPlaintext\indPlaintext\ by means of a predefined \emph{shifting}
|
||||
operation,\glosCipherkey where the cipherkey of a particular shift
|
||||
algorithm defines the shift amount of the cipher.\indCipherkey
|
||||
Transposition ciphers work by keeping the plaintext the same, but {\em
|
||||
rearrange} the order of the characters according to a certain rule.
|
||||
Transposition ciphers work by keeping the plaintext the same, but
|
||||
\emph{rearrange} the order of the characters according to a certain rule.
|
||||
The cipherkey is essentially the description of how this transposition
|
||||
is done.\indTranspositioncipher Substitution
|
||||
ciphers\indSubstitutioncipher generalize shifts and transpositions,
|
||||
@ -82,15 +82,15 @@ Section~\ref{sec:tsyn} that a {\tt String n} is simply a sequence of n
|
||||
where map = ['A' .. 'Z'] <<< s
|
||||
shift c = map @ (c - 'A')
|
||||
\end{code}
|
||||
In this definition, we simply get a message {\tt msg} of type {\tt
|
||||
String n}, and perform a {\tt shift} operation on each one of the
|
||||
elements. The {\tt shift} function is defined locally in the {\tt
|
||||
where}-clause.\indWhere To compute the shift, we first find the
|
||||
distance of the letter from the character {\tt 'A'} (via {\tt c -
|
||||
'A'}), and look it up in the mapping imposed by the shift. The {\tt
|
||||
map} is simply the alphabet rotated to the left by the shift amount,
|
||||
{\tt s}. Note how we use the enumeration {\tt ['A' .. 'Z']} to get all
|
||||
the letters in the alphabet.\indEnum
|
||||
In this definition, we simply get a message \texttt{msg} of type
|
||||
\texttt{String n}, and perform a \texttt{shift} operation on each one
|
||||
of the elements. The \texttt{shift} function is defined locally in the
|
||||
\texttt{where} clause.\indWhere To compute the shift, we first find
|
||||
the distance of the letter from the character \texttt{'A'} (via
|
||||
\texttt{c - 'A'}), and look it up in the mapping imposed by the shift.
|
||||
The {\tt map} is simply the alphabet rotated to the left by the shift
|
||||
amount, \texttt{s}. Note how we use the enumeration
|
||||
\texttt{['A' ..\ 'Z']} to get all the letters in the alphabet.\indEnum
|
||||
|
||||
\begin{Exercise}\label{ex:caesar:0}
|
||||
What is the map corresponding to a shift of 2? Use Cryptol's
|
||||
@ -107,13 +107,13 @@ Why do we use a left-rotate, instead of a right-rotate?
|
||||
\begin{Answer}\ansref{ex:caesar:0}
|
||||
Here is the alphabet and the corresponding shift-2 Caesar's alphabet:
|
||||
\begin{verbatim}
|
||||
Cryptol> ['A'..'Z']
|
||||
Cryptol> ['A'..'Z']
|
||||
"ABCDEFGHIJKLMNOPQRSTUVWXYZ"
|
||||
Cryptol> ['A'..'Z'] <<< 2
|
||||
"CDEFGHIJKLMNOPQRSTUVWXYZAB"
|
||||
\end{verbatim}
|
||||
We use a left rotate to get the characters lined up correctly, as
|
||||
illustrated above. \indRotLeft\indRotRight
|
||||
illustrated above.\indRotLeft\indRotRight
|
||||
\end{Answer}
|
||||
|
||||
\begin{Exercise}\label{ex:caesar:1}
|
||||
|
@ -13,7 +13,7 @@ Cryptol. This chapter provides an introduction to Cryptol, just to
|
||||
get you started. The exposition is not meant to be comprehensive, but
|
||||
rather as an overview to give you a feel of the most important tools
|
||||
available. If a particular topic appears hard to approach, feel free
|
||||
to skim it over for future reference.
|
||||
to skim it over for future reference.
|
||||
|
||||
A full language reference is beyond the scope of this document at this
|
||||
time.
|
||||
@ -37,13 +37,13 @@ Cryptol provides four basic data types: bits, sequences, tuples, and
|
||||
records. Words (i.e., numbers) are a special case of sequences. Note
|
||||
that, aside from bits, all other Cryptol types can be nested as deep
|
||||
as you like. That is, we can have records of sequences containing
|
||||
tuples that comprise of other records, etc., giving us a rich
|
||||
tuples made up of other records, etc., giving us a rich
|
||||
type-system for precisely describing the shapes of data our programs
|
||||
manipulate.
|
||||
|
||||
While Cryptol is statically typed, it uses type inference to supply
|
||||
unspecified types. That is, the user does {\em not} have to write the
|
||||
types of all expressions, they will be automatically inferred by the
|
||||
types of all expressions; they will be automatically inferred by the
|
||||
type-inference engine. Of course, in certain contexts the user might
|
||||
choose to supply a type explicitly. The notation is simple: we simply
|
||||
put the expression, followed by {\tt :} and the type. For instance:
|
||||
@ -140,7 +140,7 @@ in a non-standard base.\footnote{Cryptol does not support the input of
|
||||
|
||||
\note{Decimal numbers pose a problem in a bit-precise language like
|
||||
Cryptol. Numbers represented in a base that is a power of two
|
||||
unambiguausly specify the number of bits required to store each
|
||||
unambiguously specify the number of bits required to store each
|
||||
digit. For example {\tt 0b101} takes three bits to store. A
|
||||
hexadecimal digit takes 4 bits to store, so {\tt 0xabc} needs 12
|
||||
bits. On the other hand, in decimal, the number of bits is
|
||||
@ -148,7 +148,7 @@ in a non-standard base.\footnote{Cryptol does not support the input of
|
||||
to represent. When given a choice, Cryptol assumes the
|
||||
\emph{smallest} number of bits required to represent a decimal
|
||||
number. This is why Cryptol often prints messages like {\tt Assuming
|
||||
a = 3}; the value emitted are the number of bits necessary to
|
||||
a = 3}; the value emitted is the number of bits necessary to
|
||||
faithfully represent the decimal value on the corresponding line.}
|
||||
|
||||
\todo[inline]{2.1: Make decision about
|
||||
@ -365,7 +365,7 @@ Here are the responses from Cryptol:
|
||||
[10, 7, 4, 1]
|
||||
[]
|
||||
\end{Verbatim}
|
||||
Note how {\tt [10, 11 .. 1]} and {\tt [10, 9 .. 20]} give us empty
|
||||
Note how \texttt{[10, 11 ..\ 1]} and \texttt{[10, 9 ..\ 20]} give us empty
|
||||
sequences, since the upper bound is smaller than the lower bound in
|
||||
the former, and larger in the latter.
|
||||
\end{Answer}
|
||||
@ -395,7 +395,7 @@ can certainly be defined using Cryptol comprehensions.
|
||||
\begin{Verbatim}
|
||||
[ (x, y) | x <- [1 .. 3], y <- [4, 5] ]
|
||||
[ x + y | x <- [1 .. 3], y <- [] ]
|
||||
[ (x + y, z) | x <- [1, 2], y <- [1], z <- [3, 4] ]
|
||||
[ (x + y, z) | x <- [1, 2], y <- [1], z <- [3, 4] ]
|
||||
\end{Verbatim}
|
||||
What is the number of elements in the resulting sequence, with respect
|
||||
to the sizes of components?
|
||||
@ -403,7 +403,7 @@ to the sizes of components?
|
||||
\note{Recall that, when you type the expressions above, you will get
|
||||
messages from Cryptol such as {\tt Assuming a = 2}. This is Cryptol
|
||||
letting you know it has decided to use 2 bits to represent, for
|
||||
example, the value {\tt 3} in {\tt [1 .. 3]}. This information may
|
||||
example, the value \texttt{3} in \texttt{[1 ..\ 3]}. This information may
|
||||
not seem to matter now but it can be very helpful later
|
||||
on.}
|
||||
\end{Exercise}
|
||||
@ -415,9 +415,9 @@ Here are the responses from Cryptol:
|
||||
[(2, 3) (2, 4) (3, 3) (3, 4)]
|
||||
\end{Verbatim}
|
||||
The size of the result will be the sizes of the components
|
||||
multiplied. For instance, in the first example, the generator {\tt x
|
||||
<- [1 .. 3]} assigns 3 values to {\tt x}, and the generator {\tt y
|
||||
<- [4, 5]} assigns 2 values to {\tt y}; and hence the result has
|
||||
multiplied. For instance, in the first example, the generator
|
||||
\texttt{x <- [1 ..\ 3]} assigns 3 values to \texttt{x}, and the generator
|
||||
\texttt{y <- [4, 5]} assigns 2 values to \texttt{y}; and hence the result has
|
||||
$2\times 3 = 6$ elements.
|
||||
\end{Answer}
|
||||
|
||||
@ -442,16 +442,16 @@ Here are the responses from Cryptol:
|
||||
[(2, 3)]
|
||||
\end{Verbatim}
|
||||
In this case, the size of the result will be the minimum of the
|
||||
component sizes. For the first example, the generator {\tt x <- [1
|
||||
.. 3]} assigns 3 values to {\tt x}, and the generator {\tt y <- [4,
|
||||
5]} assigns 2 values to {\tt y}; and hence the result has $\min(2,3)
|
||||
= 2$ elements.
|
||||
component sizes. For the first example, the generator
|
||||
\texttt{x <- [1 ..\ 3]} assigns 3 values to \texttt{x}, and the generator
|
||||
\texttt{y <- [4, 5]} assigns 2 values to \texttt{y}; and hence the result has
|
||||
$\min(2,3) = 2$ elements.
|
||||
\end{Answer}
|
||||
|
||||
\begin{tip}
|
||||
One can mix parallel and cartesian comprehensions, where each
|
||||
parallel arm can contain multiple cartesian
|
||||
generators, or vice-versa.\indComp\indCartesian\indParallel
|
||||
generators.\indComp\indCartesian\indParallel
|
||||
\end{tip}
|
||||
|
||||
\begin{tip}
|
||||
@ -510,11 +510,11 @@ makes sense to you.
|
||||
|
||||
For sequences, the two basic operations are appending\indAppend ({\tt
|
||||
\#}) and selecting\indIndex elements out ({\tt @}, {\tt @@}, {\tt
|
||||
!}, and {\tt !!}). Forward selection operator ({\tt @}), starts
|
||||
!}, and {\tt !!}). The forward selection operator (\texttt{@}) starts
|
||||
counting from the beginning, while the backward selection
|
||||
operator\indRIndex ({\tt !}) starts from the end. Indexing always
|
||||
starts at zero: That is {\tt xs @ 0} is the first element of {\tt xs},
|
||||
while {\tt xs ! 0} is the last. The permutation\indIndexs
|
||||
starts at zero: that is, {\tt xs @ 0} is the first element of {\tt xs},
|
||||
while \texttt{xs !\ 0} is the last. The permutation\indIndexs
|
||||
versions\indRIndexs ({\tt @@} and {\tt !!}, respectively) allow us to
|
||||
concisely select multiple elements: they allow us to extract elements
|
||||
in any order (which makes them very useful for permuting sequences).
|
||||
@ -581,7 +581,7 @@ Here are Cryptol's responses:
|
||||
\begin{Exercise}\label{ex:seq:8}
|
||||
The permutation operators ({\tt @@} and {\tt !!}) can be defined
|
||||
using sequence comprehensions. Write an expression that selects the
|
||||
even indexed elements out of the sequence {\tt [0 .. 10]} first
|
||||
even indexed elements out of the sequence \texttt{[0 ..\ 10]} first
|
||||
using {\tt @@}, and then using a sequence comprehension.
|
||||
\end{Exercise}
|
||||
\begin{Answer}\ansref{ex:seq:8}
|
||||
@ -612,7 +612,7 @@ elements available as demanded by the program.
|
||||
\begin{Exercise}\label{ex:seq:9}
|
||||
Try the following infinite enumerations:
|
||||
\begin{Verbatim}
|
||||
[1:[32] ... ]
|
||||
[1:[32] ...]
|
||||
[1:[32], 3 ...]
|
||||
[1:[32] ...] @ 2000
|
||||
[1:[32], 3 ...] @@ [300, 500, 700]
|
||||
@ -644,7 +644,7 @@ Try the following infinite enumerations:
|
||||
\begin{Answer}\ansref{ex:seq:10}
|
||||
Here is a simple test case:
|
||||
\begin{Verbatim}
|
||||
Cryptol> ([1 ... ]:[inf][32])!3
|
||||
Cryptol> ([1 ...]:[inf][32])!3
|
||||
|
||||
[error] at <interactive>:1:1--1:21:
|
||||
Unsolved constraint:
|
||||
@ -784,26 +784,26 @@ the result:\indSignature
|
||||
%% cryptol 1 said: : {a b c} (fin c,c >= 4,a*b == 12) => [a][b][c]
|
||||
|
||||
A complex type signature like this one first defines a set of type
|
||||
variables {\tt \Verb|{a, b, c}|}, a set of constraints on those
|
||||
variables {\tt \Verb|(a >= 4, fin a, fin c, 12 == b * c)|}, a {\tt =>}
|
||||
and finally the shape description. In this case, Cryptol's {\tt
|
||||
[b][c][a]} is telling us that the result will be a sequence of {\tt
|
||||
b} things, each of which is a sequence of {\tt c} things, each of
|
||||
which is a word of size {\tt a}. The type constraints tell us that
|
||||
{\tt a} is at least 4, because the maximum element of the sequence is 12,
|
||||
and it takes at least 4 bits to represent the value 12. The
|
||||
constraints are that {\tt b * c == 12}, which means we should
|
||||
completely cover the entire input, and that the lengths {\tt a} and
|
||||
{\tt c} need to be finite. As you can see, {\tt split} is a very
|
||||
powerful function. The flexibility afforded by {\tt split} comes in
|
||||
very handy in Cryptol. We shall see one example of its usage later in
|
||||
variables \verb|{a, b, c}|, a set of constraints on those variables
|
||||
\verb|(fin b, fin c, b * a == 12, c >= 4)|, a \texttt{=>} and finally
|
||||
the shape description. In this case, Cryptol's \texttt{[a][b][c]} is
|
||||
telling us that the result will be a sequence of \texttt{a} things,
|
||||
each of which is a sequence of \texttt{b} things, each of which is a
|
||||
word of size \texttt{c}. The type constraints tell us that \texttt{c}
|
||||
is at least 4, because the maximum element of the sequence is 12, and
|
||||
it takes at least 4 bits to represent the value 12. The other constraints
|
||||
are that \texttt{b * a == 12}, which means we should completely cover
|
||||
the entire input, and that the lengths \texttt{a} and \texttt{c} need
|
||||
to be finite. As you can see, \texttt{split} is a very powerful
|
||||
function. The flexibility afforded by \texttt{split} comes in very
|
||||
handy in Cryptol. We shall see one example of its usage later in
|
||||
Section~\ref{sec:scytale}.
|
||||
|
||||
\begin{Exercise}\label{ex:split:0}
|
||||
With a sequence of length 12, as in the above example, there are
|
||||
precisely 6 ways of splitting it: 1--12, 2--6, 3--4, 4--3, 6--2, and
|
||||
12--1. We have seen the first three splits above. Write the
|
||||
expressions corresponding to the latter 3.\indSplit
|
||||
expressions corresponding to the latter three.\indSplit
|
||||
\end{Exercise}
|
||||
\begin{Answer}\ansref{ex:split:0}
|
||||
Here they are:\indSplit
|
||||
@ -818,8 +818,8 @@ Here they are:\indSplit
|
||||
\end{Answer}
|
||||
|
||||
\begin{Exercise}\label{ex:split:1}
|
||||
What happens when you type {\tt split [1 .. 12] :
|
||||
[5][2][8]}?\indSplit
|
||||
What happens when you type
|
||||
\texttt{split [1 ..\ 12] :\ [5][2][8]}?\indSplit
|
||||
\end{Exercise}
|
||||
\begin{Answer}\ansref{ex:split:1}
|
||||
Cryptol will issue a type error:\indSplit
|
||||
@ -836,8 +836,8 @@ result (5*2), but the input has 12.
|
||||
\end{Answer}
|
||||
|
||||
\begin{Exercise}\label{ex:split:2}
|
||||
Write a {\tt split} expression to turn the sequence {\tt [1 .. 120]
|
||||
: [120][8]} into a nested sequence with type {\tt [3][4][10][8]},
|
||||
Write a \texttt{split} expression to turn the sequence \texttt{[1 ..\ 120]
|
||||
:\ [120][8]} into a nested sequence with type {\tt [3][4][10][8]},
|
||||
keeping the elements in the same order.\indSplit \lhint{Use nested
|
||||
comprehensions.} \indComp
|
||||
\end{Exercise}
|
||||
@ -1012,7 +1012,7 @@ observe:\indTake\indDrop\indSplit\indGroup
|
||||
\end{Verbatim}
|
||||
\end{Exercise}
|
||||
\noindent Recall that the notation {\tt 12:[6]} means the constant 12
|
||||
with the type precisely 6-bits wide.
|
||||
with the type precisely 6 bits wide.
|
||||
\begin{Answer}\ansref{ex:words:4}
|
||||
Remember that Cryptol is big-endian\indEndianness and hence {\tt
|
||||
12:[6]} is precisely {\tt [False, False, True, True, False,
|
||||
@ -1075,9 +1075,9 @@ shift a word, say {\tt 12:[6]} by one to the right:
|
||||
(12:[6]) >> 1
|
||||
= [False, False, True, True, False, False] >> 1
|
||||
= [False, False, False, True, True, False]
|
||||
= 6
|
||||
= 6
|
||||
\end{Verbatim}
|
||||
That is shifting-right by one effectively divides the word by 2. This
|
||||
That is shifting right by one effectively divides the word by 2. This
|
||||
is due to Cryptol's ``big-endian'' representation of
|
||||
numbers\footnote{This is a significant change from Cryptol version 1,
|
||||
which interpreted the leftmost element of a sequence as the
|
||||
@ -1110,8 +1110,8 @@ Here are Cryptol's responses:
|
||||
comes up often in computer science, with no clear
|
||||
winner.\indEndianness Since Cryptol allows indexing from the beginning
|
||||
or the end of a (finite) sequence, you can access the 0th
|
||||
(least-significant) bit of a sequence $k$ with $k$!0, the 1st bit with
|
||||
$k$!1, and so on.\indIndex
|
||||
(least-significant) bit of a sequence \texttt{k} with \texttt{k!0}, the 1st bit with
|
||||
\texttt{k!1}, and so on.\indIndex
|
||||
|
||||
%=====================================================================
|
||||
\section{Characters and strings}
|
||||
@ -1165,7 +1165,7 @@ which can be thought of records without field names\footnote{In fact,
|
||||
with their names being their 0-indexed position in the tuple. So
|
||||
{\tt (1,2).1 == 2}.}. Like a tuple, the fields of a record can be of
|
||||
any type. We construct records by listing the fields inside
|
||||
curly-braces, separated by commas. We project fields out of a record
|
||||
curly braces, separated by commas. We project fields out of a record
|
||||
with the usual dot-notation. Note that the order of fields in a
|
||||
record is immaterial.\indTheRecordType\indTheTupleType
|
||||
|
||||
@ -1287,9 +1287,9 @@ The {\tt zero} function returns {\tt 0}, ignoring its argument.
|
||||
\sectionWithAnswers{Arithmetic}{sec:arithmetic}
|
||||
|
||||
Cryptol supports the usual binary arithmetic operators {\tt +}, {\tt
|
||||
-}, {\tt *}, {\tt \Verb|^^|} (exponentiate), {\tt /} (integer
|
||||
-}, {\tt *}, {\tt \Verb|^^|} (exponentiation), {\tt /} (integer
|
||||
division), {\tt \%} (integer modulus), along with \emph{ceiling}
|
||||
logarithm base 2 {\tt lg2} and binary {\tt min} and {\tt max}.
|
||||
base-2 logarithm {\tt lg2} and binary {\tt min} and {\tt max}.
|
||||
|
||||
The important thing to remember is that all arithmetic in Cryptol is
|
||||
modular,\indModular with respect to the underlying word size. As a
|
||||
@ -1303,8 +1303,8 @@ explicitly.\indOverflow\indUnderflow\indPlus\indMinus\indTimes\indDiv\indMod\ind
|
||||
What is the value of {\tt 1+1}? Surprised?
|
||||
\end{Exercise}
|
||||
\begin{Answer}\ansref{ex:arith:1}
|
||||
Since {\tt 1} requires only 1-bit to represent, the result also has
|
||||
1-bits. In other words, the arithmetic is done modulo $2^1 =
|
||||
Since {\tt 1} requires only 1 bit to represent, the result also has
|
||||
1 bit. In other words, the arithmetic is done modulo $2^1 =
|
||||
2$. Therefore, {\tt 1+1 = 0}.
|
||||
\end{Answer}
|
||||
|
||||
@ -1312,28 +1312,28 @@ What is the value of {\tt 1+1}? Surprised?
|
||||
What is the value of {\tt 1+(1:[8])}? Why?
|
||||
\end{Exercise}
|
||||
\begin{Answer}\ansref{ex:arith:2}
|
||||
Now we have 8-bits to work with, so the result is {\tt 2}. Since we
|
||||
have 8-bits to work with, overflow will not happen until we get a
|
||||
Now we have 8 bits to work with, so the result is {\tt 2}. Since we
|
||||
have 8 bits to work with, overflow will not happen until we get a
|
||||
sum that is at least 256.
|
||||
\end{Answer}
|
||||
|
||||
\begin{Exercise}\label{ex:arith:3}
|
||||
What is the value of {\tt 3 - 5}? How about {\tt (3 - 5) : [8]}?
|
||||
What is the value of \texttt{3 - 5}? How about \texttt{(3 - 5) :\ [8]}?
|
||||
\end{Exercise}
|
||||
\begin{Answer}\ansref{ex:arith:3}
|
||||
Recall from Section~\ref{sec:words} that there are no negative
|
||||
numbers in Cryptol. The values {\tt 3} and {\tt 5} can be
|
||||
represented in 3 bits, so Cryptol uses 3-bits to represent the
|
||||
numbers in Cryptol. The values \texttt{3} and \texttt{5} can be
|
||||
represented in 3 bits, so Cryptol uses 3 bits to represent the
|
||||
result, so the arithmetic is done modulo $2^3=8$. Hence, the result
|
||||
is {\tt 6}. In the second expression, we have 8-bits to work with,
|
||||
so the modulus is $2^8 = 256$; so the subtraction results in {\tt
|
||||
254} (or {\tt 0xfe}).
|
||||
is \texttt{6}. In the second expression, we have 8 bits to work with,
|
||||
so the modulus is $2^8 = 256$; so the subtraction results in
|
||||
\texttt{254} (or \texttt{0xfe}).
|
||||
\end{Answer}
|
||||
|
||||
\note{Cryptol supports subtraction both as a binary operator, and as a
|
||||
unary operator. When used in a unary fashion (a.k.a., unary
|
||||
minus),\indUnaryMinus it simply means subtraction from {\tt 0}. For
|
||||
instance, {\tt -5} precisely means {\tt 0-5}, and is subject to the
|
||||
unary operator. When used in a unary fashion (a.k.a. unary
|
||||
minus),\indUnaryMinus it simply means subtraction from \texttt{0}.
|
||||
For instance, \texttt{-5} precisely means \texttt{0-5}, and is subject to the
|
||||
usual modular arithmetic rules.}\indModular\indMinus
|
||||
|
||||
\begin{Exercise}\label{ex:arith:4}
|
||||
@ -1408,8 +1408,8 @@ How about {\tt max 5 (-2:[8])}? Why?\indMin\indModular\indUnaryMinus
|
||||
\end{Answer}
|
||||
|
||||
\begin{Exercise}\label{ex:arith:7}
|
||||
Write an expression that computes the sum of two sequences {\tt [1
|
||||
.. 10]} and {\tt [10, 9 .. 1]}.\indPlus
|
||||
Write an expression that computes the sum of two sequences
|
||||
\texttt{[1..\ 10]} and \texttt{[10, 9 ..\ 1]}.\indPlus
|
||||
\end{Exercise}
|
||||
\begin{Answer}\ansref{ex:arith:7}
|
||||
The idiomatic Cryptol way of summing two sequences is to use a
|
||||
@ -1448,7 +1448,7 @@ Exercise~\ref{sec:sequences}--\ref{ex:seq:9}, we wrote the infinite
|
||||
enumeration\indEnum\indInfSeq starting at {\tt 1} using an explicit
|
||||
type as follows:
|
||||
\begin{Verbatim}
|
||||
[(1:[32]) ... ]
|
||||
[(1:[32]) ...]
|
||||
\end{Verbatim}
|
||||
As expected, Cryptol evaluates this expression to:
|
||||
\begin{Verbatim}
|
||||
@ -1463,7 +1463,7 @@ simply, by using a smaller bit size for the constant {\tt 1}:
|
||||
\begin{Verbatim}
|
||||
Cryptol> [(1:[2])...]
|
||||
[1, 2, 3, 0, 1 ...
|
||||
Cryptol> take`{20} [(1:[2])... ]
|
||||
Cryptol> take`{20} [(1:[2])...]
|
||||
[1, 2, 3, 0, 1, 2, 3, 0, 1, 2, 3, 0, 1, 2, 3, 0, 1, 2, 3, 0]
|
||||
\end{Verbatim}
|
||||
We still get an infinite sequence, but the numbers will repeat
|
||||
@ -1473,12 +1473,12 @@ Cryptol's modular arithmetic.\indModular
|
||||
There is one more case to look at. What happens if we completely leave
|
||||
out the signature?
|
||||
\begin{Verbatim}
|
||||
Cryptol> [1 ... ]
|
||||
Cryptol> [1 ...]
|
||||
[1, 0, 1, 0, 1, ...]
|
||||
\end{Verbatim}
|
||||
In this case, Cryptol figured out that the number {\tt 1} requires
|
||||
precisely 1-bits, and hence the arithmetic is done modulo $2^1 = 2$,
|
||||
giving us the sequence $1$-$0$-$1$-$0$ \ldots. In particular, an
|
||||
precisely 1 bit, and hence the arithmetic is done modulo $2^1 = 2$,
|
||||
giving us the sequence $1,0,1,0,\ldots$ In particular, an
|
||||
enumeration of the form:
|
||||
\begin{Verbatim}
|
||||
[k ...]
|
||||
@ -1488,18 +1488,18 @@ will be treated as if the user has written:
|
||||
[k, (k+1) ...]
|
||||
\end{Verbatim}
|
||||
and type inference will assign the smallest bit-size possible to
|
||||
represent {\tt k}. \note{if the user evaluates the value of {\tt
|
||||
represent {\tt k}. \note{If the user evaluates the value of {\tt
|
||||
k+1}, then the result may be different. For example, {\tt [1, 1+1
|
||||
...]} results in the {\tt [ 1, 0, 1 ...]} behavior, but {\tt [1, 2
|
||||
...]} results in the {\tt [1, 0, 1 ...]} behavior, but {\tt [1, 2
|
||||
...]} adds another bit, resulting in {\tt [1, 2, 3, 0, 1, 2, 3
|
||||
...]}. If Cryptol evaluates the value of {\tt k+1}, the answer is
|
||||
modulo {\tt k}, so another bit is not added. For the curious, this
|
||||
subtle behavior was introduced to allow the sequence of all zeros to
|
||||
be written {\tt [0 ... ]}.}
|
||||
be written \texttt{[0 ...]}.}
|
||||
|
||||
\begin{Exercise}\label{ex:arith:9}
|
||||
Remember from Exercise~\ref{sec:words2}--\ref{ex:words:2} that the
|
||||
constant {\tt 0} requires 0-bits to represent. Based on this, what
|
||||
constant {\tt 0} requires 0 bits to represent. Based on this, what
|
||||
is the value of the enumeration {\tt [0..]}? What about {\tt
|
||||
[0...]}? Surprised?
|
||||
\end{Exercise}
|
||||
@ -1509,31 +1509,31 @@ Here are Cryptol's responses:\indModular\indEnum\indInfSeq
|
||||
[0]
|
||||
[0, 0, 0, 0, 0, ...]
|
||||
\end{Verbatim}
|
||||
as opposed to {\tt [0, 1, 0, 1, 0 ..]}, as one might
|
||||
as opposed to \texttt{[0, 1, 0, 1, 0, ...]}, as one might
|
||||
expect\footnote{This is one of the subtle changes from Cryptol 1. The
|
||||
previous behavior can be achieved by dropping the first element from
|
||||
{\tt [1 ... ]}.}. This behavior follows from the specification that
|
||||
\texttt{[1 ...]}.}. This behavior follows from the specification that
|
||||
the width of the elements of the sequence are derived from the width of
|
||||
the elements in the seed, which in this case is 0.
|
||||
\end{Answer}
|
||||
|
||||
\begin{Exercise}\label{ex:arith:10}
|
||||
What is the value of {\tt [1 .. 10]}? Explain in terms of the above
|
||||
What is the value of \texttt{[1 ..\ 10]}? Explain in terms of the above
|
||||
discussion on modular arithmetic.\indModular
|
||||
\end{Exercise}
|
||||
\begin{Answer}\ansref{ex:arith:10}
|
||||
The expression {\tt [1 .. 10]} is equivalent to {\tt [1, (1+1)
|
||||
.. 10]}, and Cryptol knows that {\tt 10} requires at least 4-bits
|
||||
The expression \texttt{[1 ..\ 10]} is equivalent to \texttt{[1, (1+1) ..\ 10]},
|
||||
and Cryptol knows that \texttt{10} requires at least 4 bits
|
||||
to represent and uses the minimum implied by all the available
|
||||
information. Hence we get: {\tt [1, 2, 3, 4, 5, 6, 7, 8, 9, 10]}.
|
||||
You can use the {\tt :t} command to see the type Cryptol infers for
|
||||
information. Hence we get: \texttt{[1, 2, 3, 4, 5, 6, 7, 8, 9, 10]}.
|
||||
You can use the \texttt{:t} command to see the type Cryptol infers for
|
||||
this expression explicitly:
|
||||
\begin{Verbatim}
|
||||
Cryptol> :t [1 .. 10]
|
||||
{a} (a >= 4, fin a) => [10][a]
|
||||
\end{Verbatim}
|
||||
Cryptol tells us that the sequence has precisely $10$ elements, and each
|
||||
element is at least $4$-bits wide.
|
||||
element is at least $4$ bits wide.
|
||||
\todo[inline]{Reflect upon this ``at least'' a bit more.}
|
||||
\end{Answer}
|
||||
|
||||
@ -1551,7 +1551,7 @@ types can be used to specify the exact width of values, or shapes of
|
||||
sequences using a rich yet concise notation. In some cases, it may
|
||||
make sense to omit a type signature and let Cryptol {\em infer} the
|
||||
type for you. At the interpreter, you can check what type Cryptol
|
||||
inferred with the {\tt :t} command.
|
||||
inferred with the \texttt{:t} command.
|
||||
|
||||
\todo[inline]{More structured discussion of top and bottom types, \texttt{inf}
|
||||
and \texttt{fin}, and the precise kinds of type constraints that are
|
||||
@ -1562,14 +1562,14 @@ inferred with the {\tt :t} command.
|
||||
\label{sec:monomorphic-types}
|
||||
|
||||
A monomorphic type is one that represents a concrete value. Most of
|
||||
the examples we have seen so far falls into this category. Below, we
|
||||
the examples we have seen so far fall into this category. Below, we
|
||||
review the basic Cryptol types that make up all the monomorphic values
|
||||
in Cryptol.
|
||||
|
||||
\paragraph*{Bits}\indTheBitType\indTrue\indFalse There are precisely
|
||||
two bit values in Cryptol: {\tt True} and {\tt
|
||||
False}. The type itself is written {\tt Bit}. When we want to be
|
||||
explicit, we can write it as follows: {\tt (2 >= 3) : Bit}. However,
|
||||
explicit, we can write it as follows: \texttt{(2 >= 3) :\ Bit}. However,
|
||||
with type inference\indTypeInference writing the {\tt Bit} type
|
||||
explicitly is almost never needed.
|
||||
|
||||
@ -1591,22 +1591,22 @@ type {\tt [17]} is {\tt [17]Bit}, which we would say in English as
|
||||
collection of arbitrary number of
|
||||
elements. Just like we write a tuple value by enclosing it in
|
||||
parentheses, we write the tuple type by enclosing the component types
|
||||
in parentheses, separated by commas: {\tt (3, 5, True) : ([8], [32],
|
||||
Bit)}. Tuples' types follow the same structure: {\tt (2, (False, 3),
|
||||
5) : ([8], (Bit, [32]), [32])}. A tuple component can be any type:
|
||||
in parentheses, separated by commas: \texttt{(3, 5, True) :\ ([8], [32],
|
||||
Bit)}. Tuples' types follow the same structure: \texttt{(2, (False, 3),
|
||||
5) :\ ([8], (Bit, [32]), [32])}. A tuple component can be any type:
|
||||
a word, another tuple, sequence, record, etc. Again, type inference
|
||||
makes writing tuple types hardly ever necessary.\indTypeInference
|
||||
|
||||
\paragraph*{Sequences}\indTheSequenceType A sequence is simply a
|
||||
collection of homogeneous elements. If the element type is {\tt t},
|
||||
then we write the type of a sequence of {\tt n} elements as: {\tt
|
||||
[n]t}. Note that {\tt t} itself can be a sequence itself. For
|
||||
instance, the type: {\tt [12][3][6]} reads as follows: A sequence of
|
||||
\paragraph*{Sequences}\indTheSequenceType A sequence is simply a
|
||||
collection of homogeneous elements. If the element type is $t$,
|
||||
then we write the type of a sequence of $n$ elements as \texttt{[}$n$\texttt{]}$t$.
|
||||
Note that $t$ can be a sequence type itself. For
|
||||
instance, the type {\tt [12][3][6]} reads as follows: A sequence of
|
||||
12 elements, each of which is a sequence of 3 elements, each of which
|
||||
is a 6-bit wide word.
|
||||
is a 6-bit-wide word.
|
||||
|
||||
The type of an infinite sequence is written {\tt [inf]t}, where {\tt
|
||||
t} is the type of the elements.\indInfSeq \indInf
|
||||
The type of an infinite sequence is written \texttt{[inf]}$t$, where $t$
|
||||
is the type of the elements.\indInfSeq \indInf
|
||||
|
||||
\begin{Exercise}\label{ex:types:1}
|
||||
What is the total number of bits in the type {\tt [12][3][6]}?
|
||||
@ -1619,7 +1619,7 @@ What is the total number of bits in the type {\tt [12][3][6]}?
|
||||
|
||||
\begin{Exercise}\label{ex:types:2}
|
||||
How would you write the type of an infinite sequence where each
|
||||
element itself is an infinite sequence of 32 bit words? What is the
|
||||
element itself is an infinite sequence of 32-bit words? What is the
|
||||
total bit size of this type?
|
||||
\end{Exercise}
|
||||
\begin{Answer}\ansref{ex:types:2} {\tt [inf][inf][32]}. The size of
|
||||
@ -1630,8 +1630,8 @@ What is the total number of bits in the type {\tt [12][3][6]}?
|
||||
A record is a heterogeneous collection of arbitrary number of labeled
|
||||
elements. In a sense, they generalize tuples by allowing the
|
||||
programmer to give explicit names to fields. The type of a record is
|
||||
written by enclosing it in braces, separated by commas: {\tt \{x :
|
||||
[32], y : [32]\}}. Records can be nested and can contain arbitrary
|
||||
written by enclosing it in braces, separated by commas:
|
||||
\texttt{\{x :\ [32], y :\ [32]\}}. Records can be nested and can contain arbitrary
|
||||
types of elements (records, sequences, functions, etc.).
|
||||
|
||||
%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||||
@ -1658,7 +1658,7 @@ element from a sequence, returning the remainder:
|
||||
Cryptol> tail [(False, (1:[8])), (True, 12), (False, 3)]
|
||||
[(True, 12), (False, 3)]
|
||||
Cryptol> tail [ (1:[16])... ]
|
||||
[2, 3, 4, 5, 6, ...
|
||||
[2, 3, 4, 5, 6, ...]
|
||||
\end{Verbatim}
|
||||
What exactly is the type of {\tt tail}? If we look at the first
|
||||
example, one can deduce that {\tt tail} must have the type:
|
||||
@ -1678,12 +1678,12 @@ must have the following types, respectively:
|
||||
tail : [inf][16] -> [inf][16]
|
||||
\end{Verbatim}
|
||||
|
||||
As we have emphasized before, Cryptol is strongly-typed, meaning that
|
||||
As we have emphasized before, Cryptol is strongly typed, meaning that
|
||||
every entity (whether a Cryptol primitive or a user-defined function)
|
||||
must have a well-defined type. Clearly, the types we provided for {\tt
|
||||
tail} above are quite different from each other. In particular, the
|
||||
must have a well-defined type. Clearly, the types we provided for
|
||||
\texttt{tail} above are quite different from each other. In particular, the
|
||||
first example uses numbers as the element type, while the second has
|
||||
tuples. So, how can {\tt tail} be assigned a type that will make it
|
||||
tuples. So, how can \texttt{tail} be assigned a type that will make it
|
||||
work on all these inputs?
|
||||
|
||||
If you are familiar C++ templates or Java generics, you might think
|
||||
@ -1705,9 +1705,9 @@ This is quite a different type from what we have seen so far. In
|
||||
particular, it is a polymorphic type, one that can work over multiple
|
||||
concrete instantiations of it. Here's how we read this type in
|
||||
Cryptol:
|
||||
\begin{quote} {\em tail} is a polymorphic function, parameterized over
|
||||
\begin{quote} \texttt{tail} is a polymorphic function, parameterized over
|
||||
{\tt a} and {\tt b}. The input is a sequence that contains {\tt a+1}
|
||||
elements. The elements can be of an arbitrary type {\tt b}, there
|
||||
elements. The elements can be of an arbitrary type {\tt b}; there
|
||||
is no restriction on their structure. The result is a sequence that
|
||||
contains {\tt a} elements, where the elements themselves has the
|
||||
same type as those of the input. \end{quote} In the case for {\tt
|
||||
@ -1724,7 +1724,7 @@ our running examples:
|
||||
offended or disappointed.}
|
||||
|
||||
\begin{center}
|
||||
\begin{adjustbox}{width={\textwidth},keepaspectratio}
|
||||
%\begin{adjustbox}{width={\textwidth},keepaspectratio}
|
||||
\begin{tabular}[h]{c||c|c|l}
|
||||
{\tt [a+1]b -> [a]b} & {\tt a} & {\tt b} & Notes \\ \hline\hline
|
||||
{\tt [5][8] -> [4][8]} & 4 & {\tt [8]} & {\tt a+1 = 5} $\Rightarrow$ {\tt a = 4} \\\hline
|
||||
@ -1732,7 +1732,7 @@ our running examples:
|
||||
{\tt [3](Bit, [8]) -> [2](Bit, [8])} & 2 & {\tt (Bit, [8])} & The type {\tt b} is now a tuple \\\hline
|
||||
{\tt [inf][16] -> [inf][16]} & {\tt inf} & {\tt [16]} & {\tt a+1 = inf} $\Rightarrow$ {\tt a = inf}
|
||||
\end{tabular}
|
||||
\end{adjustbox}
|
||||
%\end{adjustbox}
|
||||
\end{center}
|
||||
|
||||
In the last instantiation, Cryptol knows that $\infty - 1 = \infty$,
|
||||
@ -1751,7 +1751,7 @@ instantiation can not be found:
|
||||
Cryptol is telling us that it cannot match the types {\tt Bit} and the
|
||||
sequence {\tt [a+1]b}, causing a type error statically at compile
|
||||
time. (The funny notation of {\tt ?a} and {\tt ?b} are due to how type
|
||||
instantiations proceed under-the-hood. While they look funny at first,
|
||||
instantiations proceed under the hood. While they look funny at first,
|
||||
you soon get used to the notation.)
|
||||
|
||||
We should emphasize that Cryptol polymorphism\indPolymorphism
|
||||
@ -1775,8 +1775,8 @@ Is there any way to make the last example work by giving a type signature?
|
||||
Here is the type of {\tt groupBy}:
|
||||
\begin{Verbatim}
|
||||
Cryptol> :t groupBy
|
||||
groupBy : {each, parts, elem}
|
||||
(fin each) => [parts * each]elem
|
||||
groupBy : {each, parts, elem}
|
||||
(fin each) => [parts * each]elem
|
||||
-> [parts][each]elem
|
||||
\end{Verbatim}
|
||||
At every use case of {\tt groupBy} we must instantiate the parameters
|
||||
@ -1784,7 +1784,7 @@ At every use case of {\tt groupBy} we must instantiate the parameters
|
||||
instantiation will match the use case. In the first example, we can
|
||||
simply take: {\tt each = 3}, {\tt parts = 3}, and {\tt elem = [4]}. In
|
||||
the second, we can take {\tt each=3}, {\tt parts=4}, and {\tt
|
||||
elem=[4]}. The third expression does not type check. Cryptol tells
|
||||
elem=[4]}. The third expression does not type-check. Cryptol tells
|
||||
us:
|
||||
\begin{Verbatim}
|
||||
Cryptol> groupBy`{3} [1..10] : [3][2][8]
|
||||
@ -1816,7 +1816,7 @@ sizes.\indPredicates To illustrate the notion, consider the type of
|
||||
the Cryptol primitive {\tt take}\indTake:
|
||||
\begin{Verbatim}
|
||||
Cryptol> :t take
|
||||
take : {front, back, elem} (fin front) => [front + back]elem
|
||||
take : {front, back, elem} (fin front) => [front + back]elem
|
||||
-> [front]elem
|
||||
\end{Verbatim}
|
||||
|
||||
@ -1837,7 +1837,7 @@ Cryptol is telling us that it is unable to satisfy this instantiation
|
||||
(since {\tt front} is 10 and the sequence has 5
|
||||
elements).\indTake\indPredicates
|
||||
|
||||
In general, type predicates exclusively describe \texttt{arithmetic
|
||||
In general, type predicates exclusively describe \textit{arithmetic
|
||||
constraints on type variables}. Cryptol does not have a
|
||||
general-purpose dependent type system, but a \emph{size-polymorphic
|
||||
type system}. Often type variables' values are of finite size,
|
||||
@ -1862,7 +1862,7 @@ Here is another way, more direct but somewhat less satisfying:
|
||||
\begin{verbatim}
|
||||
{k} ((k - 128) * (k - 192) * (k - 256) == 0) => [k]
|
||||
\end{verbatim}
|
||||
Note that Cryptol's type constraints do not include {\em or} predicates,
|
||||
Note that Cryptol's type constraints do not include {\em or} predicates,
|
||||
hence we cannot just list the possibilities in a list.
|
||||
\end{Answer}
|
||||
|
||||
@ -1899,7 +1899,7 @@ these algorithms.
|
||||
%% Cryptol> :t 42
|
||||
%% 42 : [6]
|
||||
%%\end{Verbatim}
|
||||
%% However, {\tt 42} can in fact be of any size that is at least 6-bits
|
||||
%% However, {\tt 42} can in fact be of any size that is at least 6 bits
|
||||
%% wide. So, why does Cryptol think it is just 6 bits? The reason is
|
||||
%% because of defaulting.\indDefaulting The defaulting rule says that
|
||||
%% Cryptol will pick the minimum size that will satisfy the
|
||||
@ -1948,13 +1948,13 @@ these algorithms.
|
||||
|
||||
There is a spectrum of type systems employed by programming languages,
|
||||
all the way from completely untyped to fancier dependently typed
|
||||
languages. There is no simple answer to the question what type system
|
||||
languages. There is no simple answer to the question, what type system
|
||||
is the best? It depends on the application domain. We have found that
|
||||
Cryptol's size-polymorphic type system is a good fit for programming
|
||||
problems that arise in the domain of cryptography. The bit-precise
|
||||
type system makes sure that we never pass an argument that is 32-bits
|
||||
type system makes sure that we never pass an argument that is 32 bits
|
||||
wide in a buffer that can only fit 16. The motto is: {\em Well typed
|
||||
programs do not go wrong}.
|
||||
programs do not go wrong}.
|
||||
|
||||
In practical terms, this means that the type system catches most of
|
||||
the common mistakes that programmers tend to make. Size-polymorphism
|
||||
@ -1972,7 +1972,7 @@ the type system will reject some programs that makes perfect
|
||||
sense. But what is more important is that the type system will reject
|
||||
programs that will indeed go wrong at run-time. And the price you pay
|
||||
to make sure your program type-checks is negligible, and the savings
|
||||
due to type-checking can be enormous.
|
||||
due to type checking can be enormous.
|
||||
|
||||
The crucial question is not whether we want type systems, but rather
|
||||
what type system is the best for a given particular application
|
||||
@ -1991,7 +1991,7 @@ it gave us answers. This is great for experimenting, and exploring
|
||||
Cryptol itself. The next fundamental Cryptol idiom is the notion of a
|
||||
function. You have already used built-in functions {\tt +}, {\tt
|
||||
take}, etc.\indPlus\indLg Of course, users can define their own
|
||||
functions as well. Currently the Cryptol interpeter does not support
|
||||
functions as well. Currently the Cryptol interpreter does not support
|
||||
defining functions, so you must define them in a file and load it, as
|
||||
in the next exercises.
|
||||
|
||||
@ -2016,7 +2016,7 @@ In particular, try the following invocations:
|
||||
increment 255
|
||||
increment 912
|
||||
\end{Verbatim}
|
||||
Do you expect the last call to type check?
|
||||
Do you expect the last call to type-check?
|
||||
\end{Exercise}
|
||||
\begin{Answer}\ansref{ex:fn:0}
|
||||
Here are some example uses of {\tt increment}:
|
||||
@ -2035,15 +2035,15 @@ Note how type inference rejects application when applied to an
|
||||
argument of the wrong size: 912 is too big to fit into 8 bits.
|
||||
\end{Answer}
|
||||
|
||||
\note{Note that we do not have to parenthesize the argument to {\tt
|
||||
\note{We do not have to parenthesize the argument to {\tt
|
||||
increment}, as in {\tt increment(3)}. Function application is
|
||||
simply juxtaposition in Cryptol. However, you can put the
|
||||
simply juxtaposition in Cryptol. However, you can write the
|
||||
parentheses if you want to, and you must use parentheses if you want
|
||||
to pass a negative argument (e.g., {\tt increment(-2)} (recall
|
||||
\autoref{ex:arith:5})}\indFunApp
|
||||
to pass a negative argument, e.g. \texttt{increment(-2)} (recall
|
||||
Exercise~\autoref{ex:arith:5}).}\indFunApp
|
||||
|
||||
%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||||
\subsection{Local names: {\ttfamily{\textbf where}}-clauses}
|
||||
\subsection{Local names: {\ttfamily{\textbf where}} clauses}
|
||||
\label{sec:local-names:-ttfam}
|
||||
|
||||
You can create local bindings in a {\tt where} clause\indWhere, to
|
||||
@ -2077,15 +2077,16 @@ What is the signature of the function telling us?
|
||||
\begin{Answer}\ansref{ex:fn:1.1}
|
||||
Here is the type Cryptol infers:
|
||||
\begin{verbatim}
|
||||
Cryptol> :t twoPlusXY
|
||||
Cryptol> :t twoPlusXY
|
||||
twoPlusXY : {a} (a >= 2, fin a) => ([a],[a]) -> [a]
|
||||
\end{verbatim}
|
||||
That is, our function will actually work over arbitrary (finite) sized
|
||||
words, as long as they are at least 2-bits wide. The 2-bit requirement
|
||||
words, as long as they are at least 2 bits wide. The 2-bit requirement
|
||||
comes from the constant 2, which requires at least 2 bits to
|
||||
represent.
|
||||
\end{Answer}
|
||||
|
||||
\todo[inline]{The Cmp class has not been introduced yet. At least, add a forward reference to the ``Type classes'' section.}
|
||||
\begin{Exercise}\label{ex:fn:2}
|
||||
Define a function with the following signature:
|
||||
\begin{Verbatim}
|
||||
@ -2160,12 +2161,12 @@ for obvious reasons, and hence the {\tt fin n} constraint.
|
||||
%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||||
\subsection{\texorpdfstring{\lamexs}{Lambda-expressions}}\label{sec:lamex}
|
||||
|
||||
One particular use case of a {\tt where}-clause\indWhere is to
|
||||
One particular use case of a {\tt where} clause\indWhere is to
|
||||
introduce a helper function. If the function is simple enough, though,
|
||||
it may not be worth giving it a name. A \lamex fits the bill in these
|
||||
cases, where you can introduce an unnamed function as an
|
||||
expression. The syntax differs from ordinary definitions in two minor
|
||||
details: instead of the name we use the backslash or ``wack''
|
||||
details: instead of the name we use the backslash or ``whack''
|
||||
character, `{\tt \Verb|\|}', and the equals sign is replaced by an
|
||||
arrow `{\tt ->}'. (Since these functions do not have explicit names,
|
||||
they are sometimes referred to as ``anonymous functions'' as well. We
|
||||
@ -2219,10 +2220,10 @@ sequence {\tt xs} yield {\tt True} for the function {\tt f}.
|
||||
Cryptol> all eqTen [10, 10, 10, 5] where eqTen x = x == 10
|
||||
False
|
||||
\end{Verbatim}
|
||||
(The {\tt where}-clause introduces a local definition that is in scope
|
||||
in the current expression. We will see the details in
|
||||
(The {\tt where} clause introduces a local definition that is in scope
|
||||
in the current expression. We have seen the details in
|
||||
Section~\ref{sec:funcs}.\indWhere) What is the value of {\tt all f []}
|
||||
for any {\tt f}? Is this reasonable?
|
||||
for an arbitrary function {\tt f}? Is this reasonable?
|
||||
\end{Exercise}
|
||||
\begin{Answer}\ansref{ex:zero:1}
|
||||
\begin{code}
|
||||
@ -2635,7 +2636,7 @@ In this diagram the stream is seeded with four initial values ({\tt
|
||||
3F, E2, 65, CA}). The subsequent elements ({\tt new}) are appended
|
||||
to the stream, and are computed by xor-ing the current stream element
|
||||
with two additional elements extracted from further into the stream.
|
||||
The output from the stream is a sequence of values, known as 'a's.
|
||||
The output from the stream is a sequence of values, known as $a$s.
|
||||
|
||||
The Cryptol code corresponding to this stream equation is:
|
||||
\begin{code}
|
||||
@ -2647,7 +2648,7 @@ The Cryptol code corresponding to this stream equation is:
|
||||
\end{code}
|
||||
|
||||
% \vfill
|
||||
% \eject
|
||||
% \eject
|
||||
\todo[inline]{Make sure pagination looks good, particularly for figures.}
|
||||
|
||||
\begin{Exercise}\label{ex:streamEq}
|
||||
@ -2693,7 +2694,7 @@ be used for readability and documentation. Type synonyms allow users
|
||||
to give names to arbitrary types. In this sense, they are akin to
|
||||
{\tt typedef} declarations in C~\cite{TheCProgrammingLanguage}.
|
||||
However, Cryptol's type synonyms are significantly more powerful than
|
||||
C's {\tt typedef}'s, since they can be parameterized by other types,
|
||||
C's {\tt typedef}s, since they can be parameterized by other types,
|
||||
much like in Haskell~\cite{Has98}.
|
||||
|
||||
\todo[inline]{Add a discussion of N-queens or AES or something more compelling
|
||||
@ -2713,7 +2714,7 @@ Type synonyms are either unparameterized (as in {\tt Word8} and {\tt
|
||||
Synonyms may depend upon other synonyms, as in the {\tt CheckedWord}
|
||||
example. Once the synonym is given, it acts as an additional name for
|
||||
the underlying type, making it much easier to read and
|
||||
maintain.
|
||||
maintain.
|
||||
|
||||
For instance, we can write the function that returns the x-coordinate
|
||||
of a point as follows:
|
||||
@ -2726,7 +2727,8 @@ Note that type synonyms, while maintained within the type and value
|
||||
context shown via the \texttt{:browse} command, are
|
||||
\emph{value-based}, not \emph{name-based}. When viewed from the
|
||||
types-as-sets interpretation, two types in Cryptol are synonymous if
|
||||
their values happen to be equal.
|
||||
their values happen to be equal.
|
||||
\todo[inline]{The above paragraph is very confusing!}
|
||||
|
||||
For example, consider the following declarations:
|
||||
%% not "code" to avoid conflicting with previous Word8
|
||||
@ -2748,6 +2750,7 @@ Within this type context, while six \emph{names} are declared, only
|
||||
\emph{two} types are declared (\texttt{[8]} and the pair \texttt{([8],
|
||||
[8])}. Likewise, the function types of \texttt{foo} and \texttt{bar}
|
||||
are identical, thus \texttt{bar} can call \texttt{foo}.
|
||||
\todo[inline]{Also very confusing! What does it mean that two types are declared?}
|
||||
|
||||
\begin{Exercise}\label{ex:tsyn:1}
|
||||
Define a type synonym for 3-dimensional points and write a function
|
||||
@ -2776,7 +2779,7 @@ predefined in Cryptol:
|
||||
type String n = [n]Char
|
||||
type Word n = [n]
|
||||
\end{Verbatim}
|
||||
For instance, a {\tt String n} is simply a sequence of precisely n
|
||||
For instance, a {\tt String n} is simply a sequence of precisely $n$
|
||||
8-bit words.\indTSWord\indTSString\indTSBool
|
||||
|
||||
\todo[inline]{Discussion of \texttt{String} as a type synonym is an
|
||||
@ -2795,12 +2798,12 @@ Type classes are a way of describing behaviors shared by multiple
|
||||
types. As an example, consider the type of the function {\tt ==}:
|
||||
\begin{Verbatim}
|
||||
Cryptol> :t (==)
|
||||
== : {a} (Cmp a) => a -> a -> Bit
|
||||
(==) : {a} (Cmp a) => a -> a -> Bit
|
||||
\end{Verbatim}
|
||||
|
||||
This operator type is interpreted ``equality is an operator that takes
|
||||
two objects of any single type that can be compared and returns a
|
||||
Bit.''
|
||||
Bit.''
|
||||
|
||||
Cryptol defines exactly two basic type classes: {\tt Cmp} and {\tt
|
||||
Arith}. These appear in the type signature of operators and
|
||||
@ -2812,9 +2815,11 @@ The \texttt{Cmp} typeclass includes the binary relation operators
|
||||
\texttt{<}, \texttt{>}, \texttt{<=}, \texttt{>=}, \texttt{==}, and
|
||||
\texttt{!=}, as well as the binary functions \texttt{min} and
|
||||
\texttt{max}. Note that equality is defined on function types (i.e.,
|
||||
\texttt{{a b} (Cmp b) => (a -> b) -> (a -> b) -> a -> Bit}). Unlike
|
||||
\texttt{\{a b\} (Cmp b) => (a -> b) -> (a -> b) -> a -> Bit}). Unlike
|
||||
in many other languages, equality and comparison are bundled into a
|
||||
single typeclass.
|
||||
\todo[inline]{``many'' other languages? Like what?}
|
||||
\todo[inline]{``equality is defined on function types'' is misleading, can't use == for this.}
|
||||
|
||||
The \texttt{Arith} typeclass include the binary operators \texttt{+},
|
||||
\texttt{-}, \texttt{*}, \texttt{/}, \verb+%+, \verb+^^+, as well
|
||||
@ -2852,7 +2857,7 @@ in functions such as {\tt groupBy}, that when you call a function in
|
||||
Cryptol, there are two kinds of parameters you can pass: {\it value
|
||||
variables} and {\it type variables}.
|
||||
|
||||
Consider the \emph{groupBy} function that we previously examined in
|
||||
Consider the \texttt{groupBy} function that we previously examined in
|
||||
\autoref{ex:poly:groupBy}. Recall that \texttt{groupBy}'s type is:
|
||||
\begin{verbatim}
|
||||
groupBy : {each, parts, elem} (fin each) =>
|
||||
@ -2910,8 +2915,8 @@ to our example is:
|
||||
Note the use of an underscore in order to pass \texttt{3} in the
|
||||
second position. Positional arguments are most often used when the
|
||||
type argument is the first argument and when the name of the argument
|
||||
does not add clarity. The {\tt groupBy\Verb|`{_,3}|} is not as self-
|
||||
explanatory as {\tt groupBy\Verb|`{parts=3}|}. On the other hand, our
|
||||
does not add clarity. The {\tt groupBy\Verb|`{_,3}|} is not as
|
||||
self-explanatory as {\tt groupBy\Verb|`{parts=3}|}. On the other hand, our
|
||||
use of positional arguments to {\tt take} in previous chapters is very
|
||||
clear, as in:
|
||||
\begin{Verbatim}
|
||||
@ -2921,7 +2926,7 @@ clear, as in:
|
||||
|
||||
\begin{tip}
|
||||
Cryptol programs that use named arguments are more maintainable and
|
||||
robust during program evolution. E.g., you can reorder paramters or
|
||||
robust during program evolution. E.g., you can reorder parameters or
|
||||
refactor function definitions much more easily if invocations of
|
||||
those functions use named, rather than positional, arguments.
|
||||
\end{tip}
|
||||
@ -2934,11 +2939,11 @@ clear, as in:
|
||||
\label{sec:type-context-vs}
|
||||
|
||||
You have seen, in the discussion of type variables above, that Cryptol
|
||||
has two kinds of variables -- type variables and value variables. Type
|
||||
has two kinds of variables---type variables and value variables. Type
|
||||
variables normally show up in type signatures, and value variables
|
||||
normally show up in function definitions. Sometimes you may want to
|
||||
use a type variable in a context where value variables would normally
|
||||
be used. To do this, use the backtick character {\tt \Verb|`|}.
|
||||
be used. To do this, use the backtick character {\tt \Verb|`|}.
|
||||
|
||||
The definition of the built-in {\tt width} function is a good example
|
||||
of the use of backtick:
|
||||
@ -2968,12 +2973,12 @@ of the use of backtick:
|
||||
right thing.
|
||||
\end{tip}
|
||||
|
||||
The bounds in a finite sequence literal (such as {\tt [1 .. 10]}) in
|
||||
The bounds in a finite sequence literal (such as \texttt{[1 ..\ 10]}) in
|
||||
Cryptol are type-level values because the length of a sequence is part
|
||||
of its type. Only type-level values can appear in a finite sequence
|
||||
definition. You cannot write {\tt [a .. b]} where either {\tt a} or
|
||||
{\tt b} are arguments to a function. On the other hand, an infinite
|
||||
sequence's type is fixed ({\tt [inf]a}), so the initial value in an
|
||||
definition. You cannot write \texttt{[a ..\ b]} where either \texttt{a} or
|
||||
\texttt{b} are arguments to a function. On the other hand, an infinite
|
||||
sequence's type is fixed (\texttt{[inf]a}), so the initial value in an
|
||||
infinite sequence can be a runtime variable or a type variable, but
|
||||
type variables are escaped here using a {\tt \Verb|`|}.
|
||||
|
||||
@ -3008,7 +3013,7 @@ syntax for this should look familiar:
|
||||
\end{code}
|
||||
|
||||
This defines a function that takes two bytes as input, and returns their sum.
|
||||
Note that the use of {\tt( )}'s is mandatory.
|
||||
Note that the use of parentheses \texttt{( )} is mandatory.
|
||||
|
||||
Here is a more interesting example:
|
||||
\begin{code}
|
||||
@ -3024,7 +3029,7 @@ Here is a more interesting example:
|
||||
When a cryptographic specification gets very large it can make sense
|
||||
to decompose its functions into modules.\indModuleSystem\indImport
|
||||
Doing this well encourages
|
||||
code re-use, so it's a generally good thing to do. Cryptol's module
|
||||
code reuse, so it's a generally good thing to do. Cryptol's module
|
||||
system is simple and easy to use. Here's a quick overview:
|
||||
|
||||
A module's name should be the same as the filename the module is
|
||||
@ -3057,7 +3062,7 @@ that include it by using the \verb+private+ keyword, like this:\indPrivate
|
||||
|
||||
As you can tell, by default definitions are exported to including modules.
|
||||
|
||||
For large project it can be convenient to place modules in a directory
|
||||
For a large project it can be convenient to place modules in a directory
|
||||
structure. In this case, the directory structure becomes part of the modules'
|
||||
names. For example, when placing \verb+SHA3.cry+ in the \verb+Hash+ directory and
|
||||
accessing it from \verb+HMAC.cry+ you would need to name the modules
|
||||
@ -3077,8 +3082,7 @@ module Hash::SHA3 where
|
||||
import Hash::SHA3
|
||||
import Cryptol::Extras
|
||||
|
||||
hmac : {keySize, msgSize} (fin keySize, fin msgSize) => [keySize] -> [msgSize]
|
||||
-> [512]
|
||||
hmac : {keySize, msgSize} (fin keySize, fin msgSize) => [keySize] -> [msgSize] -> [512]
|
||||
hmac k m = sha3 (ko # sha3 (ki # m))
|
||||
where ko = zipWith (^) kFull (join (repeat 0x5c))
|
||||
ki = zipWith (^) kFull (join (repeat 0x36))
|
||||
|
@ -42,7 +42,7 @@ Enigma essentially implements a polyalphabetic substitution cipher
|
||||
of rotating units that jumble up the alphabet. The first component is
|
||||
the so called plugboard ({\em steckerbrett} in
|
||||
German)\indEnigmaPlugboard. In the original Enigma, the plugboard
|
||||
provided a means of interchanging 6-pairs or letters. For instance,
|
||||
provided a means of interchanging 6 pairs of letters. For instance,
|
||||
the plugboard could be set-up so that pressing the {\tt B} key would
|
||||
actually engage the {\tt Q} key, etc. We will slightly generalize and
|
||||
allow any number of pairings, as we are not limited by the
|
||||
@ -88,7 +88,7 @@ Why do we subtract the {\tt 'A'} when indexing?
|
||||
\sectionWithAnswers{Scrambler rotors}{sec:enigma:scramblerrotors}
|
||||
|
||||
The next component of the Enigma are the rotors that scramble the
|
||||
letters. Rotors ({\em walzen} in German)\indEnigmaRotor are
|
||||
letters. Rotors (\textit{walzen} in German)\indEnigmaRotor are
|
||||
essentially permutations, with one little twist: as their name
|
||||
implies, they rotate. This rotation ensures that the next character
|
||||
the rotor will process will be encrypted using a different alphabet,
|
||||
@ -104,15 +104,15 @@ fact, more advanced models of Enigma allowed for two notches per
|
||||
rotor, i.e., two distinct positions on the rotor that will allow the
|
||||
next rotor in sequence to rotate itself. We will allow ourselves to
|
||||
have any number of notches, by simply pairing each substituted letter
|
||||
with a bit value saying whether it has an associated notch:
|
||||
\footnote{The type definition for {\tt Char} was given in
|
||||
with a bit value saying whether it has an associated
|
||||
notch:\footnote{The type definition for {\tt Char} was given in
|
||||
Example~\ref{section:subst}-\ref{ex:subst:1}.}
|
||||
|
||||
\begin{code}
|
||||
type Rotor = [26](Char, Bit)
|
||||
\end{code}
|
||||
The function {\tt mkRotor} will create a rotor for us from a given permutation of the letters and the notch
|
||||
locations:~\footnote{The function {\tt elem} was defined in Exercise~\ref{sec:recandrec}-\ref{ex:recfun:4:1}.\indElem}
|
||||
locations:\footnote{The function {\tt elem} was defined in Exercise~\ref{sec:recandrec}-\ref{ex:recfun:4:1}.\indElem}
|
||||
\begin{code}
|
||||
mkRotor : {n} (fin n) => (Permutation, String n) -> Rotor
|
||||
mkRotor (perm, notchLocations) = [ (p, elem (p, notchLocations))
|
||||
@ -223,7 +223,7 @@ determine if we have our notch engaged, all we need to do is to look
|
||||
at the first elements notch value, using Cryptol's selection operator
|
||||
({\tt @ 0}\indIndex), and we ignore the permutation value there this
|
||||
time, again using pattern matching. Finally, to determine {\tt
|
||||
rotor'} we merely rotate-left by 1\indRotLeft if the {\tt rotate}
|
||||
rotor'} we merely rotate left by 1\indRotLeft if the {\tt rotate}
|
||||
signal was received. Otherwise, we leave the {\tt rotor} unchanged.
|
||||
|
||||
\begin{Exercise}\label{ex:enigma:3}
|
||||
@ -607,7 +607,7 @@ of the Enigma machine as a Cryptol record\indTheRecordType, which will
|
||||
simplify our final construction. At any stage, the state of an Enigma
|
||||
machine is given by the status of its rotors. We will use the
|
||||
following record to represent this state, for an Enigma machine
|
||||
containing $n$ rotors:
|
||||
containing \texttt{n} rotors:
|
||||
\begin{code}
|
||||
type Enigma n = { plugboard : Plugboard,
|
||||
rotors : [n]Rotor,
|
||||
|
@ -14,7 +14,7 @@
|
||||
Writing correct software is the holy grail of programming. Bugs
|
||||
inevitably exist, however, even in thoroughly tested projects. One
|
||||
fundamental issue is the lack of support in typical programming
|
||||
languages to let the programmer {\em state} what it means to be
|
||||
languages to let the programmer \emph{state} what it means to be
|
||||
correct, let alone formally establish any notion of correctness. To
|
||||
address this shortcoming, Cryptol advocates the high-assurance
|
||||
programming approach: programmers explicitly state correctness
|
||||
@ -53,7 +53,7 @@ The above declaration reads as follows: {\tt sqDiffsCorrect} is a
|
||||
property stating that for all {\tt x} and {\tt y}, the expression {\tt
|
||||
sqDiff1 (x, y) == sqDiff2(x, y)} evaluates to {\tt
|
||||
True}. Furthermore, the type signature restricts the type of the
|
||||
property to apply to only 8-bit values. As usual, the type-signature
|
||||
property to apply to only 8-bit values. As usual, the type signature
|
||||
is optional.\indSignature If not given, Cryptol will infer one for
|
||||
you.
|
||||
|
||||
@ -73,7 +73,7 @@ What do you see?\indCmdInfo
|
||||
\end{Answer}
|
||||
|
||||
\note{It is important to emphasize that the mathematical equality
|
||||
above and the Cryptol property are {\em not} stating precisely the
|
||||
above and the Cryptol property are \emph{not} stating precisely the
|
||||
same property. Remember that all Cryptol arithmetic is
|
||||
modular,\indModular while the mathematical equation is over
|
||||
arbitrary numbers, including negative, real, or even complex
|
||||
@ -132,21 +132,21 @@ What do you see?\indCmdInfo
|
||||
\end{code}
|
||||
\end{Answer}
|
||||
|
||||
\note{A {\tt property} declaration simply introduces a property about
|
||||
your program, which may or may {\em not} actually hold. It is an
|
||||
\note{A \texttt{property} declaration simply introduces a property about
|
||||
your program, which may or may \emph{not} actually hold. It is an
|
||||
assertion about your program, without any claim of correctness. In
|
||||
particular, you can clearly write properties that simply do not
|
||||
hold:}
|
||||
\begin{code}
|
||||
property bogus x = x != x
|
||||
\end{code}
|
||||
It is important to distinguish between {\em stating} a property and
|
||||
actually {\em proving} it. So far, our focus is purely on
|
||||
It is important to distinguish between \emph{stating} a property and
|
||||
actually \emph{proving} it. So far, our focus is purely on
|
||||
specification. We will focus on actual proofs in
|
||||
Section~\ref{sec:establishcorrectness}.
|
||||
|
||||
%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||||
\subsection{Property-function correspondence}\indThmFuncCorr
|
||||
\subsection{Property--function correspondence}\indThmFuncCorr
|
||||
\label{sec:prop-funct-corr}
|
||||
|
||||
In Cryptol, properties can be used just like ordinary definitions:
|
||||
@ -157,7 +157,7 @@ In Cryptol, properties can be used just like ordinary definitions:
|
||||
sqDiffsCorrect : ([8],[8]) -> Bit
|
||||
\end{Verbatim}
|
||||
That is, a property over {\tt$(x, y)$} is the same as a function over
|
||||
the tuple {\tt (x, y)}. We call this the property-function
|
||||
the tuple {\tt (x, y)}. We call this the property--function
|
||||
correspondence. Property declarations, aside from the slightly
|
||||
different syntax, are \emph{precisely} the same as Cryptol functions
|
||||
whose return type is \texttt{Bit}. There is no separate language for
|
||||
@ -175,8 +175,8 @@ vectors:\indZero
|
||||
where f x = x + 1
|
||||
testVector = [(3, 4), (4, 5), (12, 13), (78, 79)]
|
||||
\end{code}
|
||||
Notice that the property {\tt inctest} does not have any parameters
|
||||
(no {\em forall} section), and thus acts as a simple {\tt Bit} value
|
||||
Notice that the property \texttt{inctest} does not have any parameters
|
||||
(no \emph{forall} section), and thus acts as a simple \texttt{Bit} value
|
||||
that will be true precisely when the given test case succeeds.
|
||||
|
||||
\todo[inline]{Figure out how to re-run Cryptol in this chapter to make
|
||||
@ -202,7 +202,7 @@ If we ask Cryptol the type of {\tt multShift}, we get:
|
||||
That is, it is a property about all words of size at least two. The
|
||||
question is whether this property does indeed hold? In the particular
|
||||
case of {\tt multShift} that is indeed the case, below are some
|
||||
examples using the property-function correspondence:\indThmFuncCorr
|
||||
examples using the property--function correspondence:\indThmFuncCorr
|
||||
\begin{Verbatim}
|
||||
Cryptol> multShift (5 : [8])
|
||||
True
|
||||
@ -211,7 +211,7 @@ examples using the property-function correspondence:\indThmFuncCorr
|
||||
Cryptol> multShift (5 : [16])
|
||||
True
|
||||
\end{Verbatim}
|
||||
However, this is {\em not} always the case for all polymorphic Cryptol
|
||||
However, this is \emph{not} always the case for all polymorphic Cryptol
|
||||
properties! The following example demonstrates:
|
||||
\begin{code}
|
||||
property flipNeverIdentity x = x != ~x
|
||||
@ -246,7 +246,7 @@ certain monomorphic types, but not at all types.\indMonomorphism
|
||||
|
||||
\begin{Exercise}\label{ex:polythm:1}
|
||||
Demonstrate another monomorphic type where {\tt flipNeverIdentity}
|
||||
does {\em not} hold.
|
||||
does \emph{not} hold.
|
||||
\end{Exercise}
|
||||
\begin{Answer}\ansref{ex:polythm:1}
|
||||
There are many such types, all sharing the property that they do not
|
||||
@ -317,7 +317,7 @@ remembering that the 0'th bit of an even number is always {\tt
|
||||
% \label{sec:establishcorrectness}
|
||||
\sectionWithAnswers{Establishing correctness}{sec:establishcorrectness}
|
||||
|
||||
Our focus so far has been using Cryptol to {\em state} properties of
|
||||
Our focus so far has been using Cryptol to \emph{state} properties of
|
||||
our programs, without actually trying to prove them correct. This
|
||||
separation of concerns is essential for a pragmatic development
|
||||
approach. Properties act as contracts that programmers state along
|
||||
@ -396,7 +396,7 @@ purposes.\indCounterExample
|
||||
|
||||
If you try to prove an invalid property that encodes a test vector
|
||||
(Section~\ref{sec:thmvec}), then you will get a mere indication that
|
||||
you have a contradiction, since there is no universally quantified
|
||||
you have a contradiction, since there are no universally quantified
|
||||
variables to instantiate to show you a
|
||||
counterexample.\indContradiction If the expression evaluates to {\tt
|
||||
True}, then it will be a trivial proof, as expected:
|
||||
@ -406,9 +406,9 @@ counterexample.\indContradiction If the expression evaluates to {\tt
|
||||
Cryptol> :prove True
|
||||
Q.E.D.
|
||||
Cryptol> :prove 2 == 3
|
||||
2==3 = False
|
||||
(2 == 3) = False
|
||||
Cryptol> :prove reverse [1, 2] == [1, 2]
|
||||
reverse [1, 2] == [1,2] = False
|
||||
(reverse [1, 2] == [1,2]) = False
|
||||
Cryptol> :prove 1+1 == 0
|
||||
Q.E.D.
|
||||
\end{Verbatim}
|
||||
@ -423,8 +423,8 @@ As we mentioned before, Cryptol properties can be polymorphic. As we
|
||||
explored before, we cannot directly prove polymorphic properties as
|
||||
they may hold for certain monomorphic instances while not for others.
|
||||
In this cases, we must tell Cryptol what particular monomorphic
|
||||
instance we would like it to prove the property at. Let us
|
||||
demonstrate this with the {\tt multShift} property from
|
||||
instance of the property we would like it to prove. Let us
|
||||
demonstrate this with the \texttt{multShift} property from
|
||||
Section~\ref{sec:polythm}:
|
||||
\begin{Verbatim}
|
||||
Cryptol> :prove multShift
|
||||
@ -542,9 +542,9 @@ case. Depending on how natural it is to express the side-condition or
|
||||
its negation, you can use one of the following two patterns:
|
||||
% the following looks ODDLY laid out in the source but comes out OK when latex'ed
|
||||
\begin{Verbatim}[commandchars=\\\{\}]
|
||||
if {\em side-condition-holds} if {\em side-condition-fails}
|
||||
then{\em property-expression} then True
|
||||
else True else {\em property-expression}
|
||||
if \emph{side-condition-holds} if \emph{side-condition-fails}
|
||||
then \emph{property-expression} then True
|
||||
else True else \emph{property-expression}
|
||||
\end{Verbatim}
|
||||
|
||||
\begin{Exercise}\label{ex:cond:1}
|
||||
@ -680,7 +680,7 @@ machine, and the prover you choose.
|
||||
Cryptol's {\tt :prove} command\indCmdProve constructs rigorous formal
|
||||
proofs using push-button tools.\footnote{While some of the solvers
|
||||
that Cryptol uses are capable of \emph{emitting} proofs, such
|
||||
functionality is not exposes as a Cryptol feature.} The underlying
|
||||
functionality is not exposed as a Cryptol feature.} The underlying
|
||||
technique used by Cryptol (SAT-\glosSAT and SMT-based\glosSMT
|
||||
equivalence checking) is complete\indProofCompleteness, i.e., it will
|
||||
always either prove the property or find a
|
||||
@ -742,7 +742,7 @@ the size of the message.
|
||||
\end{Answer}
|
||||
|
||||
\begin{Exercise}\label{ex:quick:1}
|
||||
If the property is {\em small} in size, {\tt :check} might as well
|
||||
If the property is \emph{small} in size, {\tt :check} might as well
|
||||
prove/disprove it. Try the following commands:
|
||||
\begin{Verbatim}
|
||||
:check True
|
||||
@ -808,7 +808,7 @@ satisfiability. In satisfiability checking,\indCmdSat we would like to find
|
||||
arguments to a bit-valued function such that it will evaluate to {\tt True},
|
||||
i.e., it will be satisfied.\indSat
|
||||
|
||||
One way to think about satisfiability checking is {\em intelligently}
|
||||
One way to think about satisfiability checking is \emph{intelligently}
|
||||
searching for a solution. Here is a simple example. Let us assume we
|
||||
would like to compute the modular square-root of 9 as an 8-bit
|
||||
value. The obvious solution is {\tt 3}, of course, but we are
|
||||
@ -820,7 +820,7 @@ return {\tt True} if its argument is a square-root of 9:
|
||||
isSqrtOf9 x = x*x == 9
|
||||
\end{code}
|
||||
Any square-root of 9 will make the function {\tt isSqrtOf9} return
|
||||
{\tt True}, i.e., it will {\em satisfy} it. Thus, we can use
|
||||
{\tt True}, i.e., it will \emph{satisfy} it. Thus, we can use
|
||||
Cryptol's satisfiability checker to find those values of {\tt x}
|
||||
automatically:
|
||||
\begin{Verbatim}
|
||||
@ -858,7 +858,7 @@ more solutions using the {\tt satNum} setting:
|
||||
\end{Verbatim}
|
||||
By default, {\tt satNum} is set to {\tt 1}, so we only see one
|
||||
solution. When we change it to {\tt 4}, the satisfiability checker
|
||||
will try to find {\em up to} 4 solutions. We can also set it to {\tt
|
||||
will try to find \emph{up to} 4 solutions. We can also set it to {\tt
|
||||
all}, which will try to find as many solutions as possible.
|
||||
\begin{Verbatim}
|
||||
Cryptol> :set satNum = all
|
||||
@ -951,7 +951,7 @@ instance as you increase the bit-size.
|
||||
%% safety violations, such as trying to put in the number 1000 in a
|
||||
%% buffer that is only 8-bits wide, or trying to multiply a string
|
||||
%% with an integer; but certain run-time exceptions are still
|
||||
%% possible. The goal of {\em safety checking} is to ensure that these
|
||||
%% possible. The goal of \emph{safety checking} is to ensure that these
|
||||
%% exceptions cannot happen at run-time.\indSafe\indCmdSafe
|
||||
|
||||
%% Here is a simple example to demonstrate:
|
||||
@ -965,7 +965,7 @@ instance as you increase the bit-size.
|
||||
%% *** 1 problem found.
|
||||
%%\end{Verbatim}
|
||||
%%Cryptol is telling us that the function {\tt $\backslash$(x, y) ->
|
||||
%% x/y} is {\em not} safe. When given the argument {\tt (0, 0)} it
|
||||
%% x/y} is \emph{not} safe. When given the argument {\tt (0, 0)} it
|
||||
%% will cause a division by zero exception. If we properly guard for
|
||||
%% the condition, then the safety check will indeed pass:
|
||||
%%\begin{Verbatim}
|
||||
@ -1066,11 +1066,11 @@ instance as you increase the bit-size.
|
||||
%%
|
||||
%%\paragraph*{Over-conservative safety checking}
|
||||
%% Cryptol's safety checker is very conservative: If it says that a
|
||||
%% function is {\em safe to execute}, you are guaranteed that the
|
||||
%% function is \emph{safe to execute}, you are guaranteed that the
|
||||
%% execution can not raise any run-time exception. However, the
|
||||
%% converse is not always true: In certain cases, Cryptol can signal a
|
||||
%% potential safety violation which will actually not cause an error
|
||||
%% when {\em run in the normal interpreter}.
|
||||
%% when \emph{run in the normal interpreter}.
|
||||
%%
|
||||
%% Here is an example to illustrate the idea. (The example is somewhat
|
||||
%% contrived, but similar patterns of coding does arise in Cryptol
|
||||
@ -1082,7 +1082,7 @@ instance as you increase the bit-size.
|
||||
%%\end{Verbatim}
|
||||
%%
|
||||
%%Cryptol's {\tt undefined}\indUndefined is useful when representing
|
||||
%% values that should {\em not} be needed during execution, as
|
||||
%% values that should \emph{not} be needed during execution, as
|
||||
%% illustrated below:
|
||||
%%\begin{code}
|
||||
%% choose : [8] -> [8]
|
||||
@ -1113,7 +1113,7 @@ instance as you increase the bit-size.
|
||||
%% mode, this program will indeed not produce any exceptions. However,
|
||||
%% Cryptol programs can also be compiled to other targets, such as C
|
||||
%% or Java, or other hardware platforms. What Cryptol is telling us is
|
||||
%% that these translations are {\em not} guaranteed to be exception
|
||||
%% that these translations are \emph{not} guaranteed to be exception
|
||||
%% free, and hence it is worth making sure the generated code will
|
||||
%% behave properly.
|
||||
%%
|
||||
|
@ -14,12 +14,12 @@ primsPlaceHolder=1;
|
||||
\paragraph*{Comparisons}
|
||||
\begin{Verbatim}
|
||||
==, != : {a} (Cmp a) => a -> a -> Bit
|
||||
<, >, <=, >= : {a} (Cmp a) => [a] -> [a] -> Bit
|
||||
<, >, <=, >= : {a} (Cmp a) => a -> a -> Bit
|
||||
\end{Verbatim}
|
||||
\paragraph*{Arithmetic}
|
||||
\begin{Verbatim}
|
||||
+, -, *, /, %, ** : {a} (Arith a) => a -> a -> a
|
||||
lg2 : {a, b} (Arith a) => a -> a
|
||||
lg2 : {a} (Arith a) => a -> a
|
||||
\end{Verbatim}
|
||||
% negate : {a b} (a >= 1) => [a]b -> [a]b
|
||||
\paragraph*{Polynomial arithmetic}
|
||||
@ -30,42 +30,50 @@ primsPlaceHolder=1;
|
||||
\end{Verbatim}
|
||||
\paragraph*{Sequences}
|
||||
\begin{Verbatim}
|
||||
take : {front, back, elem} (fin front)
|
||||
take : {front, back, elem} (fin front)
|
||||
=> [front + back]elem -> [front]elem
|
||||
drop : {front, back, elem} (fin front)
|
||||
drop : {front, back, elem} (fin front)
|
||||
=> [front + back]elem -> [front]elem
|
||||
tail : {a, b} [a+1]b -> [a]b
|
||||
# : {a, b, c} (fin a) => ([a]b,[c]b) -> [a+c]b
|
||||
join : {parts, each, a} (fin each)
|
||||
# : {front, back, a} (fin front) =>
|
||||
=> [front]a -> [back]a -> [front + back]a
|
||||
join : {parts, each, a} (fin each)
|
||||
=> [parts][each]a -> [parts * each]a
|
||||
split : {parts, each, a} (fin a)
|
||||
=> [parts * each]a -> [parts][each]a
|
||||
|
||||
groupBy : {each, parts, elem} (fin each)
|
||||
groupBy : {each, parts, elem} (fin each)
|
||||
=> [parts * each]elem -> [parts][each]elem
|
||||
reverse : {a, b} (fin a) => [a]b -> [a]b
|
||||
@ : {a, b, c} ([a]b,[c]) -> b
|
||||
! : {a, b, c} (fin a) => ([a]b,[c]) -> b
|
||||
@@ : {a, b, c, d} ([a]b,[c][d]) -> [c]b
|
||||
!! : {a, b, c, d} (fin a) => ([a]b,[c][d]) -> [c]b
|
||||
width : {a, b, c} (c >= width a) => [a]b -> [c]
|
||||
@ : {a, b, c} (fin c) => [a]b -> [c] -> b
|
||||
! : {a, b, c} (fin a, fin c) => [a]b -> [c] -> b
|
||||
@@ : {a, b, c, d} (fin d) => [a]b -> [c][d] -> [c]b
|
||||
!! : {a, b, c, d} (fin a, fin d) => [a]b -> [c][d] -> [c]b
|
||||
update : {a, b, c} (fin c) => [a]b -> [c] -> b -> [a]b
|
||||
updateEnd : {a, b, c} (fin a, fin c) => [a]b -> [c] -> b -> [a]b
|
||||
updates : {a,b,c,d} (fin c, fin d) => [a]b -> [d]([c], b) -> [a]b
|
||||
updatesEnd : {a,b,c,d} (fin a, fin c, fin d) => [a]b -> [d]([c], b) -> [a]b
|
||||
width : {bits,len,elem} (fin len, fin bits, bits >= width len)
|
||||
=> [len] elem -> [bits]
|
||||
\end{Verbatim}
|
||||
\paragraph*{Shifting, rotating}
|
||||
\begin{Verbatim}
|
||||
>>, <<, >>>, <<< : {a b c} (fin a,c >= lg2 a)
|
||||
=> ([a]b,[c]) -> [a]b
|
||||
>>, << : {a, b, c} (fin b) => [a]c -> [b] -> [a]c
|
||||
>>>, <<< : {a, b, c} (fin a, fin b) => [a]c -> [b] -> [a]c
|
||||
\end{Verbatim}
|
||||
\paragraph*{Miscellaneous}
|
||||
\begin{Verbatim}
|
||||
zero : {a} a
|
||||
transpose : {a, b, c} [a][b]c -> [b][a]c
|
||||
min, max : {a} (fin a) => ([a],[a]) -> [a]
|
||||
min, max : {a} (Cmp a) => a -> a -> a
|
||||
\end{Verbatim}
|
||||
% parity : {a} (fin a) => [a] -> Bit
|
||||
\paragraph*{Representing exceptions}
|
||||
\begin{Verbatim}
|
||||
error : {a, b} [a][8] -> b
|
||||
undefined : {a} a
|
||||
trace : {n, a, b} [n][8] -> a -> b -> b
|
||||
traceVal : {n, a} [n][8] -> a -> a
|
||||
\end{Verbatim}
|
||||
\todo[inline]{\texttt{error} and \texttt{undefined} are not covered in
|
||||
the book at the moment.}
|
||||
|
@ -262,6 +262,7 @@ aliases you have defined, along with their types.
|
||||
\texttt{debug} & \texttt{off} & whether to print verbose debugging information \\
|
||||
\texttt{infLength} & \texttt{5} & number of elements to show from an infinite sequence \\
|
||||
\texttt{prover} & \texttt{z3} & which SMT solver to use for \texttt{:prove} \\
|
||||
\texttt{prover-stats} & \texttt{on} & whether to print timing statistics about proofs \\
|
||||
\texttt{tests} & \texttt{100} & number of tests to run for \texttt{:check} \\
|
||||
\texttt{warnDefaulting} & \texttt{on} & \todo[inline]{talk to Iavor} \\
|
||||
\hline
|
||||
@ -277,9 +278,12 @@ options are summarized in~\autoref{tab:set_options}.
|
||||
\todo[inline]{Ensure index references exist for all commands.}
|
||||
|
||||
\paragraph*{Quitting}
|
||||
You can quit Cryptol by using the command {\tt :quit} (aka
|
||||
\texttt{:q}). On Mac/Linux you can press Ctrl-D, and on Windows use
|
||||
Ctrl-Z, for the same effect.\indCmdQuit
|
||||
You can quit Cryptol by using the command {\tt :quit} (aka \texttt{:q}).
|
||||
On Mac/Linux you can press Ctrl-D, and on Windows use Ctrl-Z, for the
|
||||
same effect. Quitting normally in this way sets the exit code of the
|
||||
\texttt{cryptol} process to zero. If the interpreter quits early due to
|
||||
any error of some sort, it sets the exit code to a non-zero
|
||||
value.\indCmdQuit
|
||||
|
||||
\paragraph*{Loading and reloading files}
|
||||
You load your program in Cryptol using {\tt :load <filename>} (or
|
||||
|
@ -13,19 +13,19 @@ prompt. Commands all begin with the {\tt :} character.
|
||||
The Cryptol language is a size-polymorphic dependently-typed
|
||||
programming language with support for polymorphic recursive functions.
|
||||
It has a small syntax tuned for applied cryptography, a lightweight
|
||||
module system, a pseudo-Real/Eval/Print/Loop (REPL) top-level, and a
|
||||
module system, a Read--Eval--Print loop (REPL) top-level, and a
|
||||
rich set of built-in tools for performing high-assurance (literate)
|
||||
programming. Cryptol performs fairly advanced type inference, though
|
||||
as with most mainstream strongly typed functional languages, types can
|
||||
be manually specified as well. What follows is a brief tour of
|
||||
Cryptol's most salient language features.
|
||||
|
||||
\paragraph*{Case sensitivity}
|
||||
\paragraph*{Case sensitivity}
|
||||
Cryptol identifiers are case sensitive. {\tt A} and {\tt a} are two
|
||||
different things.\indCaseSensitive
|
||||
|
||||
\paragraph*{Indentation and whitespace}
|
||||
Cryptol uses indentation-level (instead of \{\}'s) to denote blocks.
|
||||
\paragraph*{Indentation and whitespace}
|
||||
Cryptol uses indentation level (instead of \texttt{\{\}}) to denote blocks.
|
||||
Whitespace within a line is immaterial, as is the specific amount of
|
||||
indentation. However, consistent indentation will save you tons of
|
||||
trouble down the road! Do not mix tabs and spaces for your
|
||||
@ -33,7 +33,7 @@ indentation. Spaces are generally preferred.
|
||||
|
||||
\paragraph*{Escape characters}
|
||||
Long lines can be continued with the end-of-line escape character
|
||||
\texttt{$\backslash$}, as in many programming languages.\indLineCont
|
||||
\texttt{\textbackslash}, as in many programming languages.\indLineCont
|
||||
There are no built-in character escape characters, as Cryptol performs
|
||||
no interpretation on bytes beyond printing byte streams out in ASCII,
|
||||
as discussed above.
|
||||
@ -45,7 +45,7 @@ line.
|
||||
|
||||
\paragraph*{Order of definitions}
|
||||
The order of definitions is immaterial. You can write your definitions
|
||||
in any order, and earlier entries can refer to latter ones.
|
||||
in any order, and earlier entries can refer to later ones.
|
||||
|
||||
\paragraph*{Typing}
|
||||
Cryptol is strongly typed. This means that the interpreter will catch
|
||||
@ -58,25 +58,25 @@ signatures because the inference engine will supply
|
||||
them.\indTypeInference
|
||||
|
||||
\paragraph*{Type signatures}
|
||||
While writing type signatures are optional, writing them down is
|
||||
While explicit type signatures are optional, writing them down is
|
||||
considered good practice.\indSignature
|
||||
|
||||
\paragraph*{Polymorphism}
|
||||
Cryptol functions can be polymorphic, which means they can operate on
|
||||
many different types. Beware that the type which Cryptol infers might
|
||||
many different types. Be aware that the type which Cryptol infers might
|
||||
be too polymorphic, so it is good practice to write your signatures,
|
||||
or at least check what Cryptol inferred is what you had in
|
||||
mind.\indPolymorphism\indSignature
|
||||
|
||||
\paragraph*{Module system}
|
||||
Each Cryptol file defines a {\it module}. Modules allow Cryptol
|
||||
\paragraph*{Module system}
|
||||
Each Cryptol file defines a \textit{module}. Modules allow Cryptol
|
||||
developers to manage which definitions are exported (the default
|
||||
behavior) and which definitions are internal-only ({\it private}). At
|
||||
the beginning of each Cryptol file, you specify its name and use {\tt
|
||||
import}\indImport to specify the modules on which it
|
||||
relies.\indModuleSystem Definitions are {\tt public} by default, but
|
||||
you can hide them from modules that import your code via the {\tt
|
||||
private} keyword at the start of each private definition,\indPrivate
|
||||
behavior) and which definitions are internal-only (\textit{private}). At
|
||||
the beginning of each Cryptol file, you specify its name and use
|
||||
\texttt{import}\indImport to specify the modules on which it
|
||||
relies.\indModuleSystem Definitions are \texttt{public} by default, but
|
||||
you can hide them from modules that import your code via the
|
||||
\texttt{private} keyword at the start of each private definition,\indPrivate
|
||||
like this:
|
||||
\begin{Verbatim}
|
||||
module test where
|
||||
@ -85,8 +85,8 @@ like this:
|
||||
// end of indented block indicates symbols are available to importing modules
|
||||
revealedConst = 0x15
|
||||
\end{Verbatim}
|
||||
Note that the filename should correspond to the module name, so {\tt
|
||||
module test} must be defined in a file called {\tt test.cry}.
|
||||
Note that the filename should correspond to the module name, so
|
||||
\texttt{module test} must be defined in a file called \texttt{test.cry}.
|
||||
|
||||
\todo[inline]{Say what happens if you try to put multiple modules into a
|
||||
single file.}
|
||||
@ -95,10 +95,10 @@ Note that the filename should correspond to the module name, so {\tt
|
||||
lambda or default modules; what modules are visible in the top level
|
||||
- talk about Cryptol prelude here?}
|
||||
|
||||
\paragraph*{Literate programming}
|
||||
You can feed \LaTeX~files to Cryptol (i.e., files with extension {\tt
|
||||
.tex}). Cryptol will look for \verb|\begin{code}| and
|
||||
\verb|\end{code}| marks to extract Cryptol code. Everything else
|
||||
\paragraph*{Literate programming}
|
||||
You can feed \LaTeX~files to Cryptol (i.e., files with extension
|
||||
\texttt{.tex}). Cryptol will look for \verb|\begin{code}| and
|
||||
\verb|\end{code}| marks to extract Cryptol code. Everything else
|
||||
will be comments as far as Cryptol is concerned. In fact, the book
|
||||
you are reading is a Literate Cryptol program.\indLiterateProgramming
|
||||
|
||||
@ -107,7 +107,7 @@ you are reading is a Literate Cryptol program.\indLiterateProgramming
|
||||
|
||||
\paragraph*{Completion}
|
||||
On UNIX-based machines, you can press tab at any time and Cryptol will
|
||||
suggests completions based on the context. You can retrieve your
|
||||
suggest completions based on the context. You can retrieve your
|
||||
prior commands using the usual means (arrow keys or Emacs
|
||||
keybindings).\indCompletion
|
||||
|
||||
@ -127,17 +127,17 @@ function, ask Cryptol its type, and copy the response back to your
|
||||
source code. While this is somewhat contrived, it is usually better
|
||||
than not writing signatures at all.\indSignature In order to query the
|
||||
type of an infix operator (e.g., {\tt +}, {\tt ==}, etc.) you will need
|
||||
to surround the operator with {\tt ()}'s, like this:
|
||||
to surround the operator with {\tt ()}, like this:
|
||||
\begin{Verbatim}
|
||||
Cryptol> :t (+)
|
||||
+ : {a} (Arith a) => a -> a -> a
|
||||
(+) : {a} (Arith a) => a -> a -> a
|
||||
\end{Verbatim}
|
||||
|
||||
\paragraph*{Browsing definitions}
|
||||
The command {\tt :browse} (or {\tt :b} for short) will display all the
|
||||
names you have defined, along with their types.\indCmdBrowse
|
||||
|
||||
\paragraph*{Getting help}
|
||||
\paragraph*{Getting help}
|
||||
The command {\tt :help} will show you all the available
|
||||
commands.\indCmdHelp Other useful implicit help invocations are:
|
||||
(a)~to type tab at the {\tt Cryptol>} prompt, which will list all of
|
||||
|
BIN
docs/Semantics.pdf
Normal file
BIN
docs/Semantics.pdf
Normal file
Binary file not shown.
@ -271,13 +271,15 @@ Note: the bounds in finite unbounded (those with ..) sequences are
|
||||
type expressions, while the bounds in bounded-finite and infinite
|
||||
sequences are value expressions.
|
||||
|
||||
Operator Description
|
||||
-------- -----------
|
||||
`#` Sequence concatenation
|
||||
`>>` `<<` Shift (right,left)
|
||||
`>>>` `<<<` Rotate (right,left)
|
||||
`@` `!` Access elements (front,back)
|
||||
`@@` `!!` Access sub-sequence (front,back)
|
||||
Operator Description
|
||||
--------------------------- -----------
|
||||
`#` Sequence concatenation
|
||||
`>>` `<<` Shift (right,left)
|
||||
`>>>` `<<<` Rotate (right,left)
|
||||
`@` `!` Access elements (front,back)
|
||||
`@@` `!!` Access sub-sequence (front,back)
|
||||
`update` `updateEnd` Update the value of a sequence at a location (front,back)
|
||||
`updates` `updatesEnd` Update multiple values of a sequence (front,back)
|
||||
|
||||
Table: Sequence operations.
|
||||
|
||||
|
BIN
docs/Syntax.pdf
BIN
docs/Syntax.pdf
Binary file not shown.
236
examples/AES.cry
Normal file
236
examples/AES.cry
Normal file
@ -0,0 +1,236 @@
|
||||
// Cryptol AES Implementation
|
||||
// Copyright (c) 2010-2013, Galois Inc.
|
||||
// www.cryptol.net
|
||||
// You can freely use this source code for educational purposes.
|
||||
|
||||
// This is a fairly close implementation of the FIPS-197 standard:
|
||||
// http://csrc.nist.gov/publications/fips/fips197/fips-197.pdf
|
||||
|
||||
// Nk: Number of blocks in the key
|
||||
// Must be one of 4 (AES128), 6 (AES192), or 8 (AES256)
|
||||
// Aside from this line, no other code below needs to change for
|
||||
// implementing AES128, AES192, or AES256
|
||||
module AES where
|
||||
|
||||
type AES128 = 4
|
||||
type AES192 = 6
|
||||
type AES256 = 8
|
||||
|
||||
type Nk = AES128
|
||||
|
||||
// For Cryptol 2.x | x > 0
|
||||
// NkValid: `Nk -> Bit
|
||||
// property NkValid k = (k == `AES128) || (k == `AES192) || (k == `AES256)
|
||||
|
||||
// Number of blocks and Number of rounds
|
||||
type Nb = 4
|
||||
type Nr = 6 + Nk
|
||||
|
||||
type AESKeySize = (Nk*32)
|
||||
|
||||
// Helper type definitions
|
||||
type GF28 = [8]
|
||||
type State = [4][Nb]GF28
|
||||
type RoundKey = State
|
||||
type KeySchedule = (RoundKey, [Nr-1]RoundKey, RoundKey)
|
||||
// GF28 operations
|
||||
gf28Add : {n} (fin n) => [n]GF28 -> GF28
|
||||
gf28Add ps = sums ! 0
|
||||
where sums = [zero] # [ p ^ s | p <- ps | s <- sums ]
|
||||
|
||||
irreducible = <| x^^8 + x^^4 + x^^3 + x + 1 |>
|
||||
|
||||
gf28Mult : (GF28, GF28) -> GF28
|
||||
gf28Mult (x, y) = pmod(pmult x y) irreducible
|
||||
|
||||
gf28Pow : (GF28, [8]) -> GF28
|
||||
gf28Pow (n, k) = pow k
|
||||
where sq x = gf28Mult (x, x)
|
||||
odd x = x ! 0
|
||||
pow i = if i == 0 then 1
|
||||
else if odd i
|
||||
then gf28Mult(n, sq (pow (i >> 1)))
|
||||
else sq (pow (i >> 1))
|
||||
|
||||
gf28Inverse : GF28 -> GF28
|
||||
gf28Inverse x = gf28Pow (x, 254)
|
||||
|
||||
gf28DotProduct : {n} (fin n) => ([n]GF28, [n]GF28) -> GF28
|
||||
gf28DotProduct (xs, ys) = gf28Add [ gf28Mult (x, y) | x <- xs
|
||||
| y <- ys ]
|
||||
|
||||
gf28VectorMult : {n, m} (fin n) => ([n]GF28, [m][n]GF28) -> [m]GF28
|
||||
gf28VectorMult (v, ms) = [ gf28DotProduct(v, m) | m <- ms ]
|
||||
|
||||
gf28MatrixMult : {n, m, k} (fin m) => ([n][m]GF28, [m][k]GF28) -> [n][k]GF28
|
||||
gf28MatrixMult (xss, yss) = [ gf28VectorMult(xs, yss') | xs <- xss ]
|
||||
where yss' = transpose yss
|
||||
|
||||
// The affine transform and its inverse
|
||||
xformByte : GF28 -> GF28
|
||||
xformByte b = gf28Add [b, (b >>> 4), (b >>> 5), (b >>> 6), (b >>> 7), c]
|
||||
where c = 0x63
|
||||
|
||||
xformByte' : GF28 -> GF28
|
||||
xformByte' b = gf28Add [(b >>> 2), (b >>> 5), (b >>> 7), d] where d = 0x05
|
||||
// The SubBytes transform and its inverse
|
||||
SubByte : GF28 -> GF28
|
||||
SubByte b = xformByte (gf28Inverse b)
|
||||
|
||||
SubByte' : GF28 -> GF28
|
||||
SubByte' b = sbox@b
|
||||
|
||||
SubBytes : State -> State
|
||||
SubBytes state = [ [ SubByte' b | b <- row ] | row <- state ]
|
||||
|
||||
|
||||
InvSubByte : GF28 -> GF28
|
||||
InvSubByte b = gf28Inverse (xformByte' b)
|
||||
|
||||
InvSubBytes : State -> State
|
||||
InvSubBytes state = [ [ InvSubByte b | b <- row ] | row <- state ]
|
||||
|
||||
// The ShiftRows transform and its inverse
|
||||
ShiftRows : State -> State
|
||||
ShiftRows state = [ row <<< shiftAmount | row <- state
|
||||
| shiftAmount <- [0 .. 3]
|
||||
]
|
||||
|
||||
InvShiftRows : State -> State
|
||||
InvShiftRows state = [ row >>> shiftAmount | row <- state
|
||||
| shiftAmount <- [0 .. 3]
|
||||
]
|
||||
|
||||
// The MixColumns transform and its inverse
|
||||
MixColumns : State -> State
|
||||
MixColumns state = gf28MatrixMult (m, state)
|
||||
where m = [[2, 3, 1, 1],
|
||||
[1, 2, 3, 1],
|
||||
[1, 1, 2, 3],
|
||||
[3, 1, 1, 2]]
|
||||
|
||||
InvMixColumns : State -> State
|
||||
InvMixColumns state = gf28MatrixMult (m, state)
|
||||
where m = [[0x0e, 0x0b, 0x0d, 0x09],
|
||||
[0x09, 0x0e, 0x0b, 0x0d],
|
||||
[0x0d, 0x09, 0x0e, 0x0b],
|
||||
[0x0b, 0x0d, 0x09, 0x0e]]
|
||||
|
||||
// The AddRoundKey transform
|
||||
AddRoundKey : (RoundKey, State) -> State
|
||||
AddRoundKey (rk, s) = rk ^ s
|
||||
// Key expansion
|
||||
Rcon : [8] -> [4]GF28
|
||||
Rcon i = [(gf28Pow (<| x |>, i-1)), 0, 0, 0]
|
||||
|
||||
SubWord : [4]GF28 -> [4]GF28
|
||||
SubWord bs = [ SubByte' b | b <- bs ]
|
||||
|
||||
RotWord : [4]GF28 -> [4]GF28
|
||||
RotWord [a0, a1, a2, a3] = [a1, a2, a3, a0]
|
||||
|
||||
NextWord : ([8],[4][8],[4][8]) -> [4][8]
|
||||
NextWord(i, prev, old) = old ^ mask
|
||||
where mask = if i % `Nk == 0
|
||||
then SubWord(RotWord(prev)) ^ Rcon (i / `Nk)
|
||||
else if (`Nk > 6) && (i % `Nk == 4)
|
||||
then SubWord(prev)
|
||||
else prev
|
||||
|
||||
|
||||
ExpandKeyForever : [Nk][4][8] -> [inf]RoundKey
|
||||
ExpandKeyForever seed = [ transpose g | g <- groupBy`{4} (keyWS seed) ]
|
||||
|
||||
keyWS : [Nk][4][8] -> [inf][4][8]
|
||||
keyWS seed = xs
|
||||
where xs = seed # [ NextWord(i, prev, old)
|
||||
| i <- [ `Nk ... ]
|
||||
| prev <- drop`{Nk-1} xs
|
||||
| old <- xs
|
||||
]
|
||||
|
||||
ExpandKey : [AESKeySize] -> KeySchedule
|
||||
ExpandKey key = (keys @ 0, keys @@ [1 .. (Nr - 1)], keys @ `Nr)
|
||||
where seed : [Nk][4][8]
|
||||
seed = split (split key)
|
||||
keys = ExpandKeyForever seed
|
||||
|
||||
fromKS : KeySchedule -> [Nr+1][4][32]
|
||||
fromKS (f, ms, l) = [ formKeyWords (transpose k) | k <- [f] # ms # [l] ]
|
||||
where formKeyWords bbs = [ join bs | bs <- bbs ]
|
||||
|
||||
// AES rounds and inverses
|
||||
AESRound : (RoundKey, State) -> State
|
||||
AESRound (rk, s) = AddRoundKey (rk, MixColumns (ShiftRows (SubBytes s)))
|
||||
|
||||
AESFinalRound : (RoundKey, State) -> State
|
||||
AESFinalRound (rk, s) = AddRoundKey (rk, ShiftRows (SubBytes s))
|
||||
|
||||
AESInvRound : (RoundKey, State) -> State
|
||||
AESInvRound (rk, s) =
|
||||
InvMixColumns (AddRoundKey (rk, InvSubBytes (InvShiftRows s)))
|
||||
AESFinalInvRound : (RoundKey, State) -> State
|
||||
AESFinalInvRound (rk, s) = AddRoundKey (rk, InvSubBytes (InvShiftRows s))
|
||||
|
||||
// Converting a 128 bit message to a State and back
|
||||
msgToState : [128] -> State
|
||||
msgToState msg = transpose (split (split msg))
|
||||
|
||||
stateToMsg : State -> [128]
|
||||
stateToMsg st = join (join (transpose st))
|
||||
|
||||
// AES Encryption
|
||||
aesEncrypt : ([128], [AESKeySize]) -> [128]
|
||||
aesEncrypt (pt, key) = stateToMsg (AESFinalRound (kFinal, rounds ! 0))
|
||||
where (kInit, ks, kFinal) = ExpandKey key
|
||||
state0 = AddRoundKey(kInit, msgToState pt)
|
||||
rounds = [state0] # [ AESRound (rk, s) | rk <- ks
|
||||
| s <- rounds
|
||||
]
|
||||
|
||||
// AES Decryption
|
||||
aesDecrypt : ([128], [AESKeySize]) -> [128]
|
||||
aesDecrypt (ct, key) = stateToMsg (AESFinalInvRound (kFinal, rounds ! 0))
|
||||
where (kFinal, ks, kInit) = ExpandKey key
|
||||
state0 = AddRoundKey(kInit, msgToState ct)
|
||||
rounds = [state0] # [ AESInvRound (rk, s)
|
||||
| rk <- reverse ks
|
||||
| s <- rounds
|
||||
]
|
||||
|
||||
sbox : [256]GF28
|
||||
sbox = [
|
||||
0x63, 0x7c, 0x77, 0x7b, 0xf2, 0x6b, 0x6f, 0xc5, 0x30, 0x01, 0x67,
|
||||
0x2b, 0xfe, 0xd7, 0xab, 0x76, 0xca, 0x82, 0xc9, 0x7d, 0xfa, 0x59,
|
||||
0x47, 0xf0, 0xad, 0xd4, 0xa2, 0xaf, 0x9c, 0xa4, 0x72, 0xc0, 0xb7,
|
||||
0xfd, 0x93, 0x26, 0x36, 0x3f, 0xf7, 0xcc, 0x34, 0xa5, 0xe5, 0xf1,
|
||||
0x71, 0xd8, 0x31, 0x15, 0x04, 0xc7, 0x23, 0xc3, 0x18, 0x96, 0x05,
|
||||
0x9a, 0x07, 0x12, 0x80, 0xe2, 0xeb, 0x27, 0xb2, 0x75, 0x09, 0x83,
|
||||
0x2c, 0x1a, 0x1b, 0x6e, 0x5a, 0xa0, 0x52, 0x3b, 0xd6, 0xb3, 0x29,
|
||||
0xe3, 0x2f, 0x84, 0x53, 0xd1, 0x00, 0xed, 0x20, 0xfc, 0xb1, 0x5b,
|
||||
0x6a, 0xcb, 0xbe, 0x39, 0x4a, 0x4c, 0x58, 0xcf, 0xd0, 0xef, 0xaa,
|
||||
0xfb, 0x43, 0x4d, 0x33, 0x85, 0x45, 0xf9, 0x02, 0x7f, 0x50, 0x3c,
|
||||
0x9f, 0xa8, 0x51, 0xa3, 0x40, 0x8f, 0x92, 0x9d, 0x38, 0xf5, 0xbc,
|
||||
0xb6, 0xda, 0x21, 0x10, 0xff, 0xf3, 0xd2, 0xcd, 0x0c, 0x13, 0xec,
|
||||
0x5f, 0x97, 0x44, 0x17, 0xc4, 0xa7, 0x7e, 0x3d, 0x64, 0x5d, 0x19,
|
||||
0x73, 0x60, 0x81, 0x4f, 0xdc, 0x22, 0x2a, 0x90, 0x88, 0x46, 0xee,
|
||||
0xb8, 0x14, 0xde, 0x5e, 0x0b, 0xdb, 0xe0, 0x32, 0x3a, 0x0a, 0x49,
|
||||
0x06, 0x24, 0x5c, 0xc2, 0xd3, 0xac, 0x62, 0x91, 0x95, 0xe4, 0x79,
|
||||
0xe7, 0xc8, 0x37, 0x6d, 0x8d, 0xd5, 0x4e, 0xa9, 0x6c, 0x56, 0xf4,
|
||||
0xea, 0x65, 0x7a, 0xae, 0x08, 0xba, 0x78, 0x25, 0x2e, 0x1c, 0xa6,
|
||||
0xb4, 0xc6, 0xe8, 0xdd, 0x74, 0x1f, 0x4b, 0xbd, 0x8b, 0x8a, 0x70,
|
||||
0x3e, 0xb5, 0x66, 0x48, 0x03, 0xf6, 0x0e, 0x61, 0x35, 0x57, 0xb9,
|
||||
0x86, 0xc1, 0x1d, 0x9e, 0xe1, 0xf8, 0x98, 0x11, 0x69, 0xd9, 0x8e,
|
||||
0x94, 0x9b, 0x1e, 0x87, 0xe9, 0xce, 0x55, 0x28, 0xdf, 0x8c, 0xa1,
|
||||
0x89, 0x0d, 0xbf, 0xe6, 0x42, 0x68, 0x41, 0x99, 0x2d, 0x0f, 0xb0,
|
||||
0x54, 0xbb, 0x16]
|
||||
|
||||
// Test runs:
|
||||
|
||||
// cryptol> aesEncrypt (0x3243f6a8885a308d313198a2e0370734, \
|
||||
// 0x2b7e151628aed2a6abf7158809cf4f3c)
|
||||
// 0x3925841d02dc09fbdc118597196a0b32
|
||||
// cryptol> aesEncrypt (0x00112233445566778899aabbccddeeff, \
|
||||
// 0x000102030405060708090a0b0c0d0e0f)
|
||||
// 0x69c4e0d86a7b0430d8cdb78070b4c55a
|
||||
property AESCorrect msg key = aesDecrypt (aesEncrypt (msg, key), key) == msg
|
@ -865,8 +865,8 @@ Acc + block = 2d8adaf23b0337fa7cccfb4ea344ca153
|
||||
|
||||
```cryptol
|
||||
property polyBlocksOK =
|
||||
(blocks @ 1 == 0x02c88c77849d64ae9147ddeb88e69c83fc) &&
|
||||
(blocks @ 2 == 0x02d8adaf23b0337fa7cccfb4ea344b30de) &&
|
||||
(blocks @ 1 == 0x02c88c77849d64ae9147ddeb88e69c83fc) /\
|
||||
(blocks @ 2 == 0x02d8adaf23b0337fa7cccfb4ea344b30de) /\
|
||||
(lastBlock == 0x028d31b7caff946c77c8844335369d03a7) where
|
||||
(blocks, lastBlock) = AccumBlocks Poly1305TestKey Poly1305TestMessage
|
||||
```
|
||||
@ -1266,7 +1266,7 @@ property AeadTag_correct = AeadTag == AeadTagTestVector
|
||||
|
||||
property AeadConstruction_correct = (AeadConstruction AeadAAD AeadCT) == AeadConstructionTestVector
|
||||
|
||||
property AeadDecrypt_correct = ptMatches && isValid where
|
||||
property AeadDecrypt_correct = ptMatches /\ isValid where
|
||||
(pt,isValid) = AEAD_CHACHA20_POLY1305_DECRYPT AeadKey (AeadIV # AeadC) cypherText AeadAAD
|
||||
cypherText = (AEAD_CHACHA20_POLY1305 AeadKey (AeadIV # AeadC) AeadPt AeadAAD)
|
||||
ptMatches = AeadPt == pt
|
||||
@ -1463,7 +1463,7 @@ TV_block_Keystream_correct key nonce blockcounter keystream =
|
||||
take`{0x40} (groupBy`{8} (join (join (ChaCha20ExpandKey key nonce blockcounter)))) == keystream
|
||||
|
||||
ChaCha20_block_correct key nonce blockcounter result keystream =
|
||||
TV_block_correct key nonce blockcounter result &&
|
||||
TV_block_correct key nonce blockcounter result /\
|
||||
TV_block_Keystream_correct key nonce blockcounter keystream
|
||||
```
|
||||
|
||||
@ -1582,10 +1582,10 @@ TV5_block_KeyStream = [
|
||||
property TV5_block_correct = ChaCha20_block_correct TV5_block_Key TV5_block_Nonce TV5_block_BlockCounter TV5_block_After20 TV5_block_KeyStream
|
||||
|
||||
property all_block_tests_correct =
|
||||
TV1_block_correct &&
|
||||
TV2_block_correct &&
|
||||
TV3_block_correct &&
|
||||
TV4_block_correct &&
|
||||
TV1_block_correct /\
|
||||
TV2_block_correct /\
|
||||
TV3_block_correct /\
|
||||
TV4_block_correct /\
|
||||
TV5_block_correct
|
||||
|
||||
```
|
||||
@ -1716,8 +1716,8 @@ TV3_enc_cyphertext = [
|
||||
property TV3_enc_correct = ChaCha20_enc_correct TV3_enc_Key TV3_enc_Nonce TV3_enc_BlockCounter TV3_enc_plaintext TV3_enc_cyphertext
|
||||
|
||||
property all_enc_tests_correct =
|
||||
TV1_enc_correct &&
|
||||
TV2_enc_correct &&
|
||||
TV1_enc_correct /\
|
||||
TV2_enc_correct /\
|
||||
TV3_enc_correct
|
||||
```
|
||||
|
||||
@ -1904,16 +1904,16 @@ TV11_MAC_tag = split(0x13 # 0): [16][8]
|
||||
property TV11_MAC_correct = poly1305_MAC_correct TV11_MAC_Key TV11_MAC_text TV11_MAC_tag
|
||||
|
||||
property all_MAC_tests_correct =
|
||||
TV1_MAC_correct &&
|
||||
TV2_MAC_correct &&
|
||||
TV3_MAC_correct &&
|
||||
TV4_MAC_correct &&
|
||||
TV5_MAC_correct &&
|
||||
TV6_MAC_correct &&
|
||||
TV7_MAC_correct &&
|
||||
TV8_MAC_correct &&
|
||||
TV9_MAC_correct &&
|
||||
TV10_MAC_correct &&
|
||||
TV1_MAC_correct /\
|
||||
TV2_MAC_correct /\
|
||||
TV3_MAC_correct /\
|
||||
TV4_MAC_correct /\
|
||||
TV5_MAC_correct /\
|
||||
TV6_MAC_correct /\
|
||||
TV7_MAC_correct /\
|
||||
TV8_MAC_correct /\
|
||||
TV9_MAC_correct /\
|
||||
TV10_MAC_correct /\
|
||||
TV11_MAC_correct
|
||||
|
||||
```
|
||||
@ -1965,8 +1965,8 @@ TV3_key_OneTimeKey = join([
|
||||
property TV3_key_correct = Poly1305_key_correct TV3_key_Key TV3_key_Nonce TV3_key_OneTimeKey
|
||||
|
||||
property all_key_tests_correct =
|
||||
TV1_key_correct &&
|
||||
TV2_key_correct &&
|
||||
TV1_key_correct /\
|
||||
TV2_key_correct /\
|
||||
TV3_key_correct
|
||||
```
|
||||
|
||||
@ -1979,7 +1979,7 @@ particular protocol, we’ll assume that there is no padding of the
|
||||
plaintext.
|
||||
|
||||
```cryptol
|
||||
AEAD_correct key nonce cypherText tag AAD = ptMatches && isValid where
|
||||
AEAD_correct key nonce cypherText tag AAD = ptMatches /\ isValid where
|
||||
(pt,isValid) = AEAD_CHACHA20_POLY1305_DECRYPT key nonce cypherText AAD
|
||||
cypherText = (AEAD_CHACHA20_POLY1305 key nonce AeadPt AAD)
|
||||
ptMatches = tag == pt
|
||||
@ -2093,20 +2093,20 @@ TV1_plaintext = [
|
||||
|
||||
TV1_calculate_plaintext = AEAD_CHACHA20_POLY1305_DECRYPT TV1_AEAD_key TV1_AEAD_nonce (TV1_AEAD_cypherText # TV1_AEAD_tag) TV1_AEAD_AAD
|
||||
|
||||
property TV1_plaintext_correct = isValid && pt == TV1_plaintext where
|
||||
property TV1_plaintext_correct = isValid /\ pt == TV1_plaintext where
|
||||
(pt,isValid) = TV1_calculate_plaintext
|
||||
|
||||
property decryption_vector_correct =
|
||||
TV1_plaintext_correct &&
|
||||
TV1_tag_correct &&
|
||||
TV1_plaintext_correct /\
|
||||
TV1_tag_correct /\
|
||||
TV1_otk_correct
|
||||
|
||||
|
||||
property all_test_vectors_correct =
|
||||
all_block_tests_correct &&
|
||||
all_enc_tests_correct &&
|
||||
all_MAC_tests_correct &&
|
||||
all_key_tests_correct &&
|
||||
all_block_tests_correct /\
|
||||
all_enc_tests_correct /\
|
||||
all_MAC_tests_correct /\
|
||||
all_key_tests_correct /\
|
||||
decryption_vector_correct
|
||||
```
|
||||
|
||||
@ -2136,8 +2136,8 @@ parseHexString : {n} (fin n) => [3*n][8] -> [n][8]
|
||||
parseHexString hexString = [ charsToByte (take`{2} cs) | cs <- groupBy`{3} hexString ] where
|
||||
charsToByte : [2][8] -> [8]
|
||||
charsToByte [ ub, lb ] = (charToByte ub) << 4 || (charToByte lb)
|
||||
charToByte c = if c >= '0' && c <= '9' then c-'0'
|
||||
| c >= 'a' && c <= 'f' then 10+(c-'a')
|
||||
charToByte c = if c >= '0' /\ c <= '9' then c-'0'
|
||||
| c >= 'a' /\ c <= 'f' then 10+(c-'a')
|
||||
else 0 // error case
|
||||
|
||||
property parseHexString_check =
|
||||
@ -2147,32 +2147,32 @@ property parseHexString_check =
|
||||
0x000102030405060708090a0b0c0d0e0f101112131415161718191a1b1c1d1e1f
|
||||
|
||||
property AllPropertiesPass =
|
||||
ChaChaQuarterround_passes_test &&
|
||||
ChaChaQuarterround_passes_column_test &&
|
||||
FirstRow_correct &&
|
||||
BuildState_correct &&
|
||||
ChaChaStateAfter20_correct &&
|
||||
ChaCha20_test1 &&
|
||||
SunscreenBuildState_correct &&
|
||||
SunscreenBuildState2_correct &&
|
||||
SunscreenBlock1_correct &&
|
||||
SunscreenBlock2_correct &&
|
||||
SunscreenKeystream_correct SunscreenKeystream &&
|
||||
ChaCha_encrypt_sunscreen_correct &&
|
||||
Sunscreen_decrypt_correct &&
|
||||
poly1306Sokay &&
|
||||
polyBlocksOK &&
|
||||
Poly1305_passes_test &&
|
||||
PolyBuildState_correct &&
|
||||
PolyChaCha_correct &&
|
||||
Poly_passes_test &&
|
||||
AeadPolyKeyBuildState_correct &&
|
||||
AeadPolyChaCha_correct &&
|
||||
poly1305Test_correct &&
|
||||
AeadTag_correct &&
|
||||
AeadConstruction_correct &&
|
||||
AeadDecrypt_correct &&
|
||||
parseHexString_check &&
|
||||
ChaChaQuarterround_passes_test /\
|
||||
ChaChaQuarterround_passes_column_test /\
|
||||
FirstRow_correct /\
|
||||
BuildState_correct /\
|
||||
ChaChaStateAfter20_correct /\
|
||||
ChaCha20_test1 /\
|
||||
SunscreenBuildState_correct /\
|
||||
SunscreenBuildState2_correct /\
|
||||
SunscreenBlock1_correct /\
|
||||
SunscreenBlock2_correct /\
|
||||
SunscreenKeystream_correct SunscreenKeystream /\
|
||||
ChaCha_encrypt_sunscreen_correct /\
|
||||
Sunscreen_decrypt_correct /\
|
||||
poly1306Sokay /\
|
||||
polyBlocksOK /\
|
||||
Poly1305_passes_test /\
|
||||
PolyBuildState_correct /\
|
||||
PolyChaCha_correct /\
|
||||
Poly_passes_test /\
|
||||
AeadPolyKeyBuildState_correct /\
|
||||
AeadPolyChaCha_correct /\
|
||||
poly1305Test_correct /\
|
||||
AeadTag_correct /\
|
||||
AeadConstruction_correct /\
|
||||
AeadDecrypt_correct /\
|
||||
parseHexString_check /\
|
||||
all_test_vectors_correct
|
||||
|
||||
```
|
||||
|
@ -17,15 +17,15 @@ des_evttest cipher = evttest (cipher, 0x0101010101010101 : [64], vt)
|
||||
des_ekatest cipher = ekatest (cipher, ka)
|
||||
|
||||
vktest cipher
|
||||
= [ (a, b, e && d)
|
||||
= [ (a, b, e /\ d)
|
||||
| (a, e) <- evktest (cipher, vk, zero : [64])
|
||||
| (b, d) <- dvktest (cipher, vk, zero : [64]) ]
|
||||
vttest cipher
|
||||
= [ (a, b, e && d)
|
||||
= [ (a, b, e /\ d)
|
||||
| (a, e) <- evttest (cipher, 0x0101010101010101 : [64], vt)
|
||||
| (b, d) <- dvttest (cipher, 0x0101010101010101 : [64], vt) ]
|
||||
katest cipher
|
||||
= [ (a, b, e && d)
|
||||
= [ (a, b, e /\ d)
|
||||
| (a, e) <- ekatest (cipher, ka)
|
||||
| (b, d) <- dkatest (cipher, ka) ]
|
||||
|
||||
|
@ -6,13 +6,13 @@ Define the minilock file format, encoding only.
|
||||
```cryptol
|
||||
module File where
|
||||
|
||||
import Keys
|
||||
import CfrgCurves
|
||||
import Blake2s
|
||||
import Base64
|
||||
import Poly1305
|
||||
import Salsa20
|
||||
import CryptoBox
|
||||
import Keys
|
||||
```
|
||||
|
||||
|
||||
|
@ -72,4 +72,4 @@ testPriv_computed =
|
||||
testPriv = [0x12, 0x86, 0xe0, 0x18, 0xc6, 0x68, 0x34, 0x96, 0x09, 0x2e, 0x53, 0x32, 0x37, 0x76, 0x80, 0x3c, 0x30, 0xb4, 0x75, 0x2d, 0xd7, 0x70,0xea, 0xa9, 0x6f, 0x0d, 0xda, 0x25, 0xc7, 0xfe, 0x28, 0x1f]
|
||||
|
||||
testPub = Curve25519 testPriv basePoint25519
|
||||
property kat_pub_id_eq = testPub == (decodeID testID).1 && encodeID testPub == testID && testID == testID_computed && testPriv == testPriv_computed
|
||||
property kat_pub_id_eq = testPub == (decodeID testID).1 /\ encodeID testPub == testID /\ testID == testID_computed /\ testPriv == testPriv_computed
|
||||
|
@ -42,11 +42,11 @@ base64dec ms = (split (join [debase x | x <- ms]), nrEq)
|
||||
|
||||
debase' : [8] -> [8]
|
||||
debase' x =
|
||||
if x >= 'A' && x <= 'Z'
|
||||
if x >= 'A' /\ x <= 'Z'
|
||||
then x - 'A'
|
||||
else if x >= 'a' && x <= 'z'
|
||||
else if x >= 'a' /\ x <= 'z'
|
||||
then x - 'a' + 26
|
||||
else if x >= '0' && x <= '9'
|
||||
else if x >= '0' /\ x <= '9'
|
||||
then x - '0' + 52
|
||||
else if x == '+'
|
||||
then 62
|
||||
|
@ -133,7 +133,7 @@ blake2Update ctx d = { state = newState, counter = newCount }
|
||||
|
||||
postprocess : {ll} (64 >= ll, 64 >= width ll) => BCounter -> [ll][8] -> Block
|
||||
postprocess c m =
|
||||
if c == 0 && `ll == (zero:[64])
|
||||
if c == 0 /\ `ll == (zero:[64])
|
||||
then zero
|
||||
else split (join m # zero)
|
||||
|
||||
|
@ -10,20 +10,20 @@ import Salsa20
|
||||
import Poly1305
|
||||
import CfrgCurves
|
||||
|
||||
crypto_box : {msgBytes} (fin msgBytes, 2^^64 >= msgBytes + 32) => [msgBytes][8] -> [24][8] -> Public25519 -> Private25519 -> [msgBytes + 16][8]
|
||||
crypto_box : {msgBytes} (fin msgBytes, 64 >= width (32 + msgBytes)) => [msgBytes][8] -> [24][8] -> Public25519 -> Private25519 -> [msgBytes + 16][8]
|
||||
crypto_box m n pub priv = crypto_secretbox m k n
|
||||
where
|
||||
s = Curve25519 priv pub
|
||||
k = HSalsa20_bytes `{r=20} s zero
|
||||
|
||||
crypto_box_open : {msgBytes} (fin msgBytes, 2^^64 >= msgBytes + 32) => [msgBytes+16][8] -> [24][8] -> Public25519 -> Private25519 -> (Bit,[msgBytes][8])
|
||||
crypto_box_open : {msgBytes} (fin msgBytes, 64 >= width (32 + msgBytes)) => [msgBytes+16][8] -> [24][8] -> Public25519 -> Private25519 -> (Bit,[msgBytes][8])
|
||||
crypto_box_open box n pub priv = crypto_secretbox_open box k n
|
||||
where
|
||||
(tag,ct) = splitAt `{16} box
|
||||
s = Curve25519 priv pub
|
||||
k = HSalsa20_bytes `{r=20} s zero
|
||||
|
||||
crypto_secretbox : {msgBytes} (fin msgBytes, 2^^64 >= msgBytes + 32)
|
||||
crypto_secretbox : {msgBytes} (fin msgBytes, 64 >= width (32 + msgBytes))
|
||||
=> [msgBytes][8] -> [32][8] -> [24][8] -> [msgBytes + 16][8]
|
||||
crypto_secretbox m k n = box
|
||||
where
|
||||
@ -33,7 +33,7 @@ crypto_secretbox m k n = box
|
||||
authTag = Poly1305 authKey ciphertext
|
||||
box = authTag # ciphertext
|
||||
|
||||
crypto_secretbox_open : {msgBytes} (fin msgBytes, 2^^64 >= msgBytes + 32)
|
||||
crypto_secretbox_open : {msgBytes} (fin msgBytes, 64 >= width (32 + msgBytes))
|
||||
=> [msgBytes + 16][8] -> [32][8] -> [24][8] -> (Bit,[msgBytes][8])
|
||||
crypto_secretbox_open box k n = (valid,pt)
|
||||
where
|
||||
|
@ -9,13 +9,13 @@ import HMAC
|
||||
|
||||
// PBKDF2 specialized to HMAC_SHA256 to avoid monomorphic type issues.
|
||||
pbkdf2 : {pwBytes, saltBytes, dkLenBits, C}
|
||||
( 32 >= width (pwBytes*8)
|
||||
( 64 >= width (8 * pwBytes)
|
||||
, dkLenBits >= 1
|
||||
, fin dkLenBits
|
||||
, 32 >= width (dkLenBits - 1)
|
||||
, C >= 1
|
||||
, 16 >= width C
|
||||
, 32 >= width (4 + saltBytes)
|
||||
, 32 >= width ((dkLenBits + 255)/256)
|
||||
)
|
||||
=> [pwBytes][8] -> [saltBytes][8] -> [dkLenBits]
|
||||
pbkdf2 P S = take `{dkLenBits} (join Ts)
|
||||
@ -25,7 +25,7 @@ pbkdf2 P S = take `{dkLenBits} (join Ts)
|
||||
type len = (dkLenBits + 255)/256
|
||||
|
||||
inner : {pwBytes, C}
|
||||
( 64 >= width (8 * (pwBytes + 32))
|
||||
( 64 >= width (8 * pwBytes)
|
||||
, C >= 1, 16 >= width C
|
||||
)
|
||||
=> [pwBytes][8] -> [32][8] -> [256]
|
||||
@ -34,7 +34,7 @@ inner P U0 = (Ts @ 0).0 // XXX should be ! 0
|
||||
// Ts : [_][([256],[32][8])]
|
||||
Ts = [(join U0, U0)] # [ F P t u | _ <- [1..C] : [_][16] | (t,u) <- Ts ]
|
||||
|
||||
F : {pwBytes} ( 64 >= width (8*(32+pwBytes))
|
||||
F : {pwBytes} ( 64 >= width (8 * pwBytes)
|
||||
) => [pwBytes][8] -> [256] -> [32][8] -> ([256],[32][8])
|
||||
F P Tprev Uprev = (Tnext,Unext)
|
||||
where
|
||||
|
@ -253,8 +253,8 @@ Acc + block = 2d8adaf23b0337fa7cccfb4ea344ca153
|
||||
|
||||
```cryptol
|
||||
property polyBlocksOK =
|
||||
(blocks @ 1 == 0x02c88c77849d64ae9147ddeb88e69c83fc) &&
|
||||
(blocks @ 2 == 0x02d8adaf23b0337fa7cccfb4ea344b30de) &&
|
||||
(blocks @ 1 == 0x02c88c77849d64ae9147ddeb88e69c83fc) /\
|
||||
(blocks @ 2 == 0x02d8adaf23b0337fa7cccfb4ea344b30de) /\
|
||||
(lastBlock == 0x028d31b7caff946c77c8844335369d03a7) where
|
||||
(blocks, lastBlock) = AccumBlocks Poly1305TestKey Poly1305TestMessage
|
||||
```
|
||||
@ -668,8 +668,8 @@ parseHexString : {n} (fin n) => [3*n][8] -> [n][8]
|
||||
parseHexString hexString = [ charsToByte (take`{2} cs) | cs <- groupBy`{3} hexString ] where
|
||||
charsToByte : [2][8] -> [8]
|
||||
charsToByte [ ub, lb ] = (charToByte ub) << 4 || (charToByte lb)
|
||||
charToByte c = if c >= '0' && c <= '9' then c-'0'
|
||||
| c >= 'a' && c <= 'f' then 10+(c-'a')
|
||||
charToByte c = if c >= '0' /\ c <= '9' then c-'0'
|
||||
| c >= 'a' /\ c <= 'f' then 10+(c-'a')
|
||||
else 0 // error case
|
||||
|
||||
property parseHexString_check =
|
||||
|
@ -39,13 +39,14 @@ SMix B = join (Xs ! 0)
|
||||
// SCrypt paper, page 11: MFCrypt specialized to sha256 (see the 'pbkdf2' function)
|
||||
// p = 1
|
||||
MFcrypt : { pwBytes, saltBytes, dkLen, r, N }
|
||||
( 4*r >= 1
|
||||
, 16 >= width (4*r)
|
||||
, ((dkLen*8 + 255) / 256) >= 1
|
||||
, 32 >= width (8*pwBytes)
|
||||
( fin dkLen
|
||||
, 4*r >= 1
|
||||
, 8 * dkLen >= 1
|
||||
, 64 >= width (8 * pwBytes)
|
||||
, 32 >= width (4 + saltBytes)
|
||||
, 16 >= width ((255 + 8 * dkLen) / 256)
|
||||
, N >= 1, 512 >= width N, 1+width N >= width (N-1)
|
||||
, 512 >= width N, 1+width N >= width (N-1)
|
||||
, 32 >= width ((255 + 8 * dkLen) / 256)
|
||||
, 32 >= width (4 + 128 * r)
|
||||
)
|
||||
=> [pwBytes][8] -> [saltBytes][8] -> [dkLen][8]
|
||||
MFcrypt P S = split DK
|
||||
@ -55,13 +56,13 @@ MFcrypt P S = split DK
|
||||
DK = pbkdf2 `{dkLenBits=dkLen*8, C=1} P (split B')
|
||||
|
||||
SCrypt : {pwBytes, saltBytes, dkBytes, r, N}
|
||||
( 4*r >= 1, 16 >= width (4*r)
|
||||
, (dkBytes * 8 + 255) / 256 >= 1
|
||||
, 16 >= width ((255 + 8 * dkBytes) / 256)
|
||||
, 8 * dkBytes == 256 * ((255 + 8 * dkBytes) / 256)
|
||||
, 32 >= width (8 * pwBytes)
|
||||
, 32 >= width (4 * saltBytes)
|
||||
, N >= 1, 512 >= width N, 1+width N >= width (N-1)
|
||||
( fin dkBytes, 4*r >= 1
|
||||
, 8 * dkBytes >= 1
|
||||
, 32 >= width ((255 + 8 * dkBytes) / 256)
|
||||
, 64 >= width (8 * pwBytes)
|
||||
, 512 >= width N, 1+width N >= width (N-1)
|
||||
, 32 >= width (4 + saltBytes)
|
||||
, 32 >= width (4 + 128 * r)
|
||||
)
|
||||
=> [pwBytes][8] -> [saltBytes][8] -> [dkBytes][8]
|
||||
SCrypt P S = MFcrypt `{r=r,N=N} P S
|
||||
|
@ -18,12 +18,12 @@ quarterround [y0, y1, y2, y3] = [z0, z1, z2, z3]
|
||||
z0 = y0 ^ ((z3 + z2) <<< 0x12)
|
||||
|
||||
property quarterround_passes_tests =
|
||||
(quarterround [0x00000000, 0x00000000, 0x00000000, 0x00000000] == [0x00000000, 0x00000000, 0x00000000, 0x00000000]) &&
|
||||
(quarterround [0x00000001, 0x00000000, 0x00000000, 0x00000000] == [0x08008145, 0x00000080, 0x00010200, 0x20500000]) &&
|
||||
(quarterround [0x00000000, 0x00000001, 0x00000000, 0x00000000] == [0x88000100, 0x00000001, 0x00000200, 0x00402000]) &&
|
||||
(quarterround [0x00000000, 0x00000000, 0x00000001, 0x00000000] == [0x80040000, 0x00000000, 0x00000001, 0x00002000]) &&
|
||||
(quarterround [0x00000000, 0x00000000, 0x00000000, 0x00000001] == [0x00048044, 0x00000080, 0x00010000, 0x20100001]) &&
|
||||
(quarterround [0xe7e8c006, 0xc4f9417d, 0x6479b4b2, 0x68c67137] == [0xe876d72b, 0x9361dfd5, 0xf1460244, 0x948541a3]) &&
|
||||
(quarterround [0x00000000, 0x00000000, 0x00000000, 0x00000000] == [0x00000000, 0x00000000, 0x00000000, 0x00000000]) /\
|
||||
(quarterround [0x00000001, 0x00000000, 0x00000000, 0x00000000] == [0x08008145, 0x00000080, 0x00010200, 0x20500000]) /\
|
||||
(quarterround [0x00000000, 0x00000001, 0x00000000, 0x00000000] == [0x88000100, 0x00000001, 0x00000200, 0x00402000]) /\
|
||||
(quarterround [0x00000000, 0x00000000, 0x00000001, 0x00000000] == [0x80040000, 0x00000000, 0x00000001, 0x00002000]) /\
|
||||
(quarterround [0x00000000, 0x00000000, 0x00000000, 0x00000001] == [0x00048044, 0x00000080, 0x00010000, 0x20100001]) /\
|
||||
(quarterround [0xe7e8c006, 0xc4f9417d, 0x6479b4b2, 0x68c67137] == [0xe876d72b, 0x9361dfd5, 0xf1460244, 0x948541a3]) /\
|
||||
(quarterround [0xd3917c5b, 0x55f1c407, 0x52a58a7a, 0x8f887a3b] == [0x3e2f308c, 0xd90a8f36, 0x6ab2a923, 0x2883524c])
|
||||
|
||||
rowround : [16][32] -> [16][32]
|
||||
@ -43,7 +43,7 @@ property rowround_passes_tests =
|
||||
[0x08008145, 0x00000080, 0x00010200, 0x20500000,
|
||||
0x20100001, 0x00048044, 0x00000080, 0x00010000,
|
||||
0x00000001, 0x00002000, 0x80040000, 0x00000000,
|
||||
0x00000001, 0x00000200, 0x00402000, 0x88000100]) &&
|
||||
0x00000001, 0x00000200, 0x00402000, 0x88000100]) /\
|
||||
(rowround [0x08521bd6, 0x1fe88837, 0xbb2aa576, 0x3aa26365,
|
||||
0xc54c6a5b, 0x2fc74c2f, 0x6dd39cc3, 0xda0a64f6,
|
||||
0x90a2f23d, 0x067f95a6, 0x06b35f61, 0x41e4732e,
|
||||
@ -76,7 +76,7 @@ property columnround_passes_tests =
|
||||
[0x10090288, 0x00000000, 0x00000000, 0x00000000,
|
||||
0x00000101, 0x00000000, 0x00000000, 0x00000000,
|
||||
0x00020401, 0x00000000, 0x00000000, 0x00000000,
|
||||
0x40a04001, 0x00000000, 0x00000000, 0x00000000]) &&
|
||||
0x40a04001, 0x00000000, 0x00000000, 0x00000000]) /\
|
||||
(columnround [0x08521bd6, 0x1fe88837, 0xbb2aa576, 0x3aa26365,
|
||||
0xc54c6a5b, 0x2fc74c2f, 0x6dd39cc3, 0xda0a64f6,
|
||||
0x90a2f23d, 0x067f95a6, 0x06b35f61, 0x41e4732e,
|
||||
@ -107,7 +107,7 @@ property doubleround_passes_tests =
|
||||
[0x8186a22d, 0x0040a284, 0x82479210, 0x06929051,
|
||||
0x08000090, 0x02402200, 0x00004000, 0x00800000,
|
||||
0x00010200, 0x20400000, 0x08008104, 0x00000000,
|
||||
0x20500000, 0xa0000040, 0x0008180a, 0x612a8020]) &&
|
||||
0x20500000, 0xa0000040, 0x0008180a, 0x612a8020]) /\
|
||||
(doubleround [0xde501066, 0x6f9eb8f7, 0xe4fbbd9b, 0x454e3f57,
|
||||
0xb75540d3, 0x43e93a4c, 0x3a6f2aa0, 0x726d6b36,
|
||||
0x9243f484, 0x9145d1e8, 0x4fa9d247, 0xdc8dee11,
|
||||
@ -134,7 +134,7 @@ property Salsa20_passes_tests =
|
||||
[ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
|
||||
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
|
||||
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
|
||||
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0]) &&
|
||||
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0]) /\
|
||||
(Salsa20 `{r=20}
|
||||
[211, 159, 13, 115, 76, 55, 82, 183, 3, 117, 222, 37, 191, 187, 234, 136,
|
||||
49, 237, 179, 48, 1, 106, 178, 219, 175, 199, 166, 48, 86, 16, 179, 207,
|
||||
@ -143,7 +143,7 @@ property Salsa20_passes_tests =
|
||||
[109, 42, 178, 168, 156, 240, 248, 238, 168, 196, 190, 203, 26, 110, 170, 154,
|
||||
29, 29, 150, 26, 150, 30, 235, 249, 190, 163, 251, 48, 69, 144, 51, 57,
|
||||
118, 40, 152, 157, 180, 57, 27, 94, 107, 42, 236, 35, 27, 111, 114, 114,
|
||||
219, 236, 232, 135, 111, 155, 110, 18, 24, 232, 95, 158, 179, 19, 48, 202]) &&
|
||||
219, 236, 232, 135, 111, 155, 110, 18, 24, 232, 95, 158, 179, 19, 48, 202]) /\
|
||||
(Salsa20 `{r=20}
|
||||
[ 88, 118, 104, 54, 79, 201, 235, 79, 3, 81, 156, 47, 203, 26, 244, 243,
|
||||
191, 187, 234, 136, 211, 159, 13, 115, 76, 55, 82, 183, 3, 117, 222, 37,
|
||||
@ -155,7 +155,7 @@ property Salsa20_passes_tests =
|
||||
27, 111, 114, 114, 118, 40, 152, 157, 180, 57, 27, 94, 107, 42, 236, 35])
|
||||
|
||||
property Salsa20_has_no_collisions x1 x2 =
|
||||
x1 == x2 || doubleround x1 != doubleround x2
|
||||
x1 == x2 \/ doubleround x1 != doubleround x2
|
||||
// if(x1 != x2) then (doubleround x1) != (doubleround x2) else True
|
||||
|
||||
property Salsa20_passes_scrypt_tests =
|
||||
@ -265,9 +265,9 @@ property theorem4 a = doubleround val == val
|
||||
,a,-a,a,-a
|
||||
,-a,a,-a,a]
|
||||
property theorem7 a b =
|
||||
a ^ b != diff || Salsa20Words a == Salsa20Words b
|
||||
a ^ b != diff \/ Salsa20Words a == Salsa20Words b
|
||||
where
|
||||
diff = [ 0x80000000 | _ <- [0..15]]
|
||||
diff = [ 0x80000000 | _ <- [0..15]:[_][4] ]
|
||||
|
||||
Salsa20Words : [16][32] -> [16][32]
|
||||
Salsa20Words x = [join (reverse r) | r <- split `{each=4} (Salsa20 `{r=20} (join [reverse (split `{4} v) | v <- x]))]
|
||||
|
@ -39,10 +39,10 @@ pad msg = split (msg # [True] # (zero:[padding]) # (`msgLen:[64]))
|
||||
|
||||
f : ([8], [32], [32], [32]) -> [32]
|
||||
f (t, x, y, z) =
|
||||
if (0 <= t) && (t <= 19) then (x && y) ^ (~x && z)
|
||||
| (20 <= t) && (t <= 39) then x ^ y ^ z
|
||||
| (40 <= t) && (t <= 59) then (x && y) ^ (x && z) ^ (y && z)
|
||||
| (60 <= t) && (t <= 79) then x ^ y ^ z
|
||||
if (0 <= t) /\ (t <= 19) then (x && y) ^ (~x && z)
|
||||
| (20 <= t) /\ (t <= 39) then x ^ y ^ z
|
||||
| (40 <= t) /\ (t <= 59) then (x && y) ^ (x && z) ^ (y && z)
|
||||
| (60 <= t) /\ (t <= 79) then x ^ y ^ z
|
||||
else error "f: t out of range"
|
||||
|
||||
Ks : [80][32]
|
||||
|
@ -322,7 +322,7 @@ E(K,X) = aesEncrypt (X,K)
|
||||
|
||||
aesCMAC : {m} (fin m) => Key -> [m] -> [128]
|
||||
aesCMAC K m =
|
||||
cmacBlocks K ((`m%128) == 0 && `m > 0) (split `{each=128,parts=blocks} full)
|
||||
cmacBlocks K ((`m%128) == 0 /\ `m > 0) (split `{each=128,parts=blocks} full)
|
||||
where
|
||||
pd = [True] # zero : [128]
|
||||
full = take `{front=128 * blocks, back = (m + 128) - 128*blocks} (m # pd)
|
||||
@ -554,14 +554,14 @@ ctr32 : {n} (2^^39 - 128 >= n) => Key -> [128] -> [n] -> [n]
|
||||
ctr32 k iv pt = pt ^ take stream
|
||||
where
|
||||
stream = join [E(k,v) | v <- ivs]
|
||||
ivs = [take `{96} iv # cnt + i | i <- [0,1..]]
|
||||
ivs = [take `{96} iv # cnt + i | i <- [0...]]
|
||||
cnt = drop `{back=32} iv
|
||||
|
||||
ctr64 : {n} (2^^71 - 128 >= n) => Key -> [128] -> [n] -> [n]
|
||||
ctr64 k iv pt = pt ^ take stream
|
||||
where
|
||||
stream = join [E(k,v) | v <- ivs]
|
||||
ivs = [take `{64} iv # cnt + i | i <- [0,1..]]
|
||||
ivs = [take `{64} iv # cnt + i | i <- [0...]]
|
||||
cnt = drop `{back=64} iv
|
||||
```
|
||||
|
||||
|
@ -16,12 +16,12 @@ quarterround [y0, y1, y2, y3] = [z0, z1, z2, z3]
|
||||
z0 = y0 ^ ((z3 + z2) <<< 0x12)
|
||||
|
||||
property quarterround_passes_tests =
|
||||
(quarterround [0x00000000, 0x00000000, 0x00000000, 0x00000000] == [0x00000000, 0x00000000, 0x00000000, 0x00000000]) &&
|
||||
(quarterround [0x00000001, 0x00000000, 0x00000000, 0x00000000] == [0x08008145, 0x00000080, 0x00010200, 0x20500000]) &&
|
||||
(quarterround [0x00000000, 0x00000001, 0x00000000, 0x00000000] == [0x88000100, 0x00000001, 0x00000200, 0x00402000]) &&
|
||||
(quarterround [0x00000000, 0x00000000, 0x00000001, 0x00000000] == [0x80040000, 0x00000000, 0x00000001, 0x00002000]) &&
|
||||
(quarterround [0x00000000, 0x00000000, 0x00000000, 0x00000001] == [0x00048044, 0x00000080, 0x00010000, 0x20100001]) &&
|
||||
(quarterround [0xe7e8c006, 0xc4f9417d, 0x6479b4b2, 0x68c67137] == [0xe876d72b, 0x9361dfd5, 0xf1460244, 0x948541a3]) &&
|
||||
(quarterround [0x00000000, 0x00000000, 0x00000000, 0x00000000] == [0x00000000, 0x00000000, 0x00000000, 0x00000000]) /\
|
||||
(quarterround [0x00000001, 0x00000000, 0x00000000, 0x00000000] == [0x08008145, 0x00000080, 0x00010200, 0x20500000]) /\
|
||||
(quarterround [0x00000000, 0x00000001, 0x00000000, 0x00000000] == [0x88000100, 0x00000001, 0x00000200, 0x00402000]) /\
|
||||
(quarterround [0x00000000, 0x00000000, 0x00000001, 0x00000000] == [0x80040000, 0x00000000, 0x00000001, 0x00002000]) /\
|
||||
(quarterround [0x00000000, 0x00000000, 0x00000000, 0x00000001] == [0x00048044, 0x00000080, 0x00010000, 0x20100001]) /\
|
||||
(quarterround [0xe7e8c006, 0xc4f9417d, 0x6479b4b2, 0x68c67137] == [0xe876d72b, 0x9361dfd5, 0xf1460244, 0x948541a3]) /\
|
||||
(quarterround [0xd3917c5b, 0x55f1c407, 0x52a58a7a, 0x8f887a3b] == [0x3e2f308c, 0xd90a8f36, 0x6ab2a923, 0x2883524c])
|
||||
|
||||
rowround : [16][32] -> [16][32]
|
||||
@ -41,7 +41,7 @@ property rowround_passes_tests =
|
||||
[0x08008145, 0x00000080, 0x00010200, 0x20500000,
|
||||
0x20100001, 0x00048044, 0x00000080, 0x00010000,
|
||||
0x00000001, 0x00002000, 0x80040000, 0x00000000,
|
||||
0x00000001, 0x00000200, 0x00402000, 0x88000100]) &&
|
||||
0x00000001, 0x00000200, 0x00402000, 0x88000100]) /\
|
||||
(rowround [0x08521bd6, 0x1fe88837, 0xbb2aa576, 0x3aa26365,
|
||||
0xc54c6a5b, 0x2fc74c2f, 0x6dd39cc3, 0xda0a64f6,
|
||||
0x90a2f23d, 0x067f95a6, 0x06b35f61, 0x41e4732e,
|
||||
@ -74,7 +74,7 @@ property columnround_passes_tests =
|
||||
[0x10090288, 0x00000000, 0x00000000, 0x00000000,
|
||||
0x00000101, 0x00000000, 0x00000000, 0x00000000,
|
||||
0x00020401, 0x00000000, 0x00000000, 0x00000000,
|
||||
0x40a04001, 0x00000000, 0x00000000, 0x00000000]) &&
|
||||
0x40a04001, 0x00000000, 0x00000000, 0x00000000]) /\
|
||||
(columnround [0x08521bd6, 0x1fe88837, 0xbb2aa576, 0x3aa26365,
|
||||
0xc54c6a5b, 0x2fc74c2f, 0x6dd39cc3, 0xda0a64f6,
|
||||
0x90a2f23d, 0x067f95a6, 0x06b35f61, 0x41e4732e,
|
||||
@ -105,7 +105,7 @@ property doubleround_passes_tests =
|
||||
[0x8186a22d, 0x0040a284, 0x82479210, 0x06929051,
|
||||
0x08000090, 0x02402200, 0x00004000, 0x00800000,
|
||||
0x00010200, 0x20400000, 0x08008104, 0x00000000,
|
||||
0x20500000, 0xa0000040, 0x0008180a, 0x612a8020]) &&
|
||||
0x20500000, 0xa0000040, 0x0008180a, 0x612a8020]) /\
|
||||
(doubleround [0xde501066, 0x6f9eb8f7, 0xe4fbbd9b, 0x454e3f57,
|
||||
0xb75540d3, 0x43e93a4c, 0x3a6f2aa0, 0x726d6b36,
|
||||
0x9243f484, 0x9145d1e8, 0x4fa9d247, 0xdc8dee11,
|
||||
@ -119,8 +119,8 @@ littleendian : [4][8] -> [32]
|
||||
littleendian b = join(reverse b)
|
||||
|
||||
property littleendian_passes_tests =
|
||||
(littleendian [ 0, 0, 0, 0] == 0x00000000) &&
|
||||
(littleendian [ 86, 75, 30, 9] == 0x091e4b56) &&
|
||||
(littleendian [ 0, 0, 0, 0] == 0x00000000) /\
|
||||
(littleendian [ 86, 75, 30, 9] == 0x091e4b56) /\
|
||||
(littleendian [255, 255, 255, 250] == 0xfaffffff)
|
||||
|
||||
littleendian_inverse : [32] -> [4][8]
|
||||
@ -143,7 +143,7 @@ property Salsa20_passes_tests =
|
||||
[ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
|
||||
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
|
||||
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
|
||||
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0]) &&
|
||||
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0]) /\
|
||||
(Salsa20 [211, 159, 13, 115, 76, 55, 82, 183, 3, 117, 222, 37, 191, 187, 234, 136,
|
||||
49, 237, 179, 48, 1, 106, 178, 219, 175, 199, 166, 48, 86, 16, 179, 207,
|
||||
31, 240, 32, 63, 15, 83, 93, 161, 116, 147, 48, 113, 238, 55, 204, 36,
|
||||
@ -151,7 +151,7 @@ property Salsa20_passes_tests =
|
||||
[109, 42, 178, 168, 156, 240, 248, 238, 168, 196, 190, 203, 26, 110, 170, 154,
|
||||
29, 29, 150, 26, 150, 30, 235, 249, 190, 163, 251, 48, 69, 144, 51, 57,
|
||||
118, 40, 152, 157, 180, 57, 27, 94, 107, 42, 236, 35, 27, 111, 114, 114,
|
||||
219, 236, 232, 135, 111, 155, 110, 18, 24, 232, 95, 158, 179, 19, 48, 202]) &&
|
||||
219, 236, 232, 135, 111, 155, 110, 18, 24, 232, 95, 158, 179, 19, 48, 202]) /\
|
||||
(Salsa20 [ 88, 118, 104, 54, 79, 201, 235, 79, 3, 81, 156, 47, 203, 26, 244, 243,
|
||||
191, 187, 234, 136, 211, 159, 13, 115, 76, 55, 82, 183, 3, 117, 222, 37,
|
||||
86, 16, 179, 207, 49, 237, 179, 48, 1, 106, 178, 219, 175, 199, 166, 48,
|
||||
|
@ -232,7 +232,7 @@ ZUC key iv =
|
||||
|
||||
// Test vectors
|
||||
property ZUC_TestVectors =
|
||||
t1 && t2 && t3 && t4
|
||||
t1 /\ t2 /\ t3 /\ t4
|
||||
where
|
||||
t1 = take (ZUC zero zero ) == [0x27BEDE74, 0x018082DA]
|
||||
t2 = take (ZUC (~zero) (~zero)) == [0x0657CFA0, 0x7096398B]
|
||||
|
@ -9,7 +9,7 @@
|
||||
/** Pick some permutation F (here we select one at random) */
|
||||
F = (generate_random_permutation 1942611697)
|
||||
|
||||
property is_a_permutation a = (unique a) && (leq a (width(a)-1))
|
||||
property is_a_permutation a = (unique a) /\ (leq a (width(a)-1))
|
||||
// Main> is_a_permutation (F:[10][4])
|
||||
// True
|
||||
|
||||
|
245
examples/contrib/MISTY1.cry
Normal file
245
examples/contrib/MISTY1.cry
Normal file
@ -0,0 +1,245 @@
|
||||
/*
|
||||
* Cryptol spec of the MISTY1 cipher. Based on RFC 2994, available at
|
||||
* https://tools.ietf.org/rfc/rfc2994.txt
|
||||
*
|
||||
* Author: Adrian Herrera
|
||||
*/
|
||||
|
||||
module MISTY1 where
|
||||
|
||||
//
|
||||
// Key scheduling part
|
||||
//
|
||||
|
||||
keySchedule : [16][8] -> [32][16]
|
||||
keySchedule K = EK_1 # EK_2 # EK_3 # EK_4
|
||||
where EK_1 = split (join K)
|
||||
EK_2 = [ FI ek_1 ek_1_shifted
|
||||
| ek_1 <- EK_1
|
||||
| ek_1_shifted <- EK_1 <<< 1
|
||||
]
|
||||
EK_3 = [extend (drop`{7} ek_2) | ek_2 <- EK_2]
|
||||
EK_4 = [extend (take`{7} ek_2) | ek_2 <- EK_2]
|
||||
|
||||
//
|
||||
// Data randomizing part
|
||||
//
|
||||
|
||||
FO : [32] -> [8] -> [32][16] -> [32]
|
||||
FO FO_IN k EK = (FO_OUT ! 0).1 # (FO_OUT ! 0).0
|
||||
where FO_OUT = [(take FO_IN, drop FO_IN)] # [ f t0 t1
|
||||
| f <- funcs
|
||||
| (t0, t1) <- FO_OUT
|
||||
]
|
||||
// t0, t1 as 16-bit integers
|
||||
funcs : [_]([16] -> [16] -> ([16], [16]))
|
||||
funcs = [\t0 t1 -> (t0 ^ (EK @ k), t1),
|
||||
\t0 t1 -> (FI t0 (EK @ ((k + 5) % 8 + 8)), t1),
|
||||
\t0 t1 -> (t0 ^ t1, t1),
|
||||
\t0 t1 -> (t0, t1 ^ (EK @ ((k + 2) % 8))),
|
||||
\t0 t1 -> (t0, FI t1 (EK @ ((k + 1) % 8 + 8))),
|
||||
\t0 t1 -> (t0, t1 ^ t0),
|
||||
\t0 t1 -> (t0 ^ EK @ ((k + 7) % 8), t1),
|
||||
\t0 t1 -> (FI t0 (EK @ ((k + 3) % 8 + 8)), t1),
|
||||
\t0 t1 -> (t0 ^ t1, t1),
|
||||
\t0 t1 -> (t0, t1 ^ EK @ ((k + 4) % 8))
|
||||
]
|
||||
|
||||
FI : [16] -> [16] -> [16]
|
||||
FI FI_IN FI_KEY = (FI_OUT ! 0).1 # (FI_OUT ! 0).0
|
||||
where FI_OUT = [(take FI_IN, drop FI_IN)] # [ f d9 d7
|
||||
| f <- funcs
|
||||
| (d9, d7) <- FI_OUT
|
||||
]
|
||||
// d9 as 9-bit integer
|
||||
// d7 as 7-bit integer
|
||||
funcs : [_]([9] -> [7] -> ([9], [7]))
|
||||
funcs = [\d9 d7 -> ((S9 @ d9) ^ (extend d7), d7),
|
||||
\d9 d7 -> (d9, drop (extend (S7 @ d7) ^ d9)),
|
||||
\d9 d7 -> (d9, d7 ^ drop (FI_KEY >> 9)),
|
||||
\d9 d7 -> (d9 ^ drop FI_KEY, d7),
|
||||
\d9 d7 -> ((S9 @ d9) ^ (extend d7), d7)
|
||||
]
|
||||
|
||||
S7 : [_][7]
|
||||
S7 = [27, 50, 51, 90, 59, 16, 23, 84, 91, 26, 114, 115, 107,
|
||||
44, 102, 73, 31, 36, 19, 108, 55, 46, 63, 74, 93, 15,
|
||||
64, 86, 37, 81, 28, 4, 11, 70, 32, 13, 123, 53, 68,
|
||||
66, 43, 30, 65, 20, 75, 121, 21, 111, 14, 85, 9, 54,
|
||||
116, 12, 103, 83, 40, 10, 126, 56, 2, 7, 96, 41, 25,
|
||||
18, 101, 47, 48, 57, 8, 104, 95, 120, 42, 76, 100, 69,
|
||||
117, 61, 89, 72, 3, 87, 124, 79, 98, 60, 29, 33, 94,
|
||||
39, 106, 112, 77, 58, 1, 109, 110, 99, 24, 119, 35, 5,
|
||||
38, 118, 0, 49, 45, 122, 127, 97, 80, 34, 17, 6, 71,
|
||||
22, 82, 78, 113, 62, 105, 67, 52, 92, 88, 125]
|
||||
|
||||
S9 : [_][9]
|
||||
S9 = [451, 203, 339, 415, 483, 233, 251, 53, 385, 185, 279, 491, 307,
|
||||
9, 45, 211, 199, 330, 55, 126, 235, 356, 403, 472, 163, 286,
|
||||
85, 44, 29, 418, 355, 280, 331, 338, 466, 15, 43, 48, 314,
|
||||
229, 273, 312, 398, 99, 227, 200, 500, 27, 1, 157, 248, 416,
|
||||
365, 499, 28, 326, 125, 209, 130, 490, 387, 301, 244, 414, 467,
|
||||
221, 482, 296, 480, 236, 89, 145, 17, 303, 38, 220, 176, 396,
|
||||
271, 503, 231, 364, 182, 249, 216, 337, 257, 332, 259, 184, 340,
|
||||
299, 430, 23, 113, 12, 71, 88, 127, 420, 308, 297, 132, 349,
|
||||
413, 434, 419, 72, 124, 81, 458, 35, 317, 423, 357, 59, 66,
|
||||
218, 402, 206, 193, 107, 159, 497, 300, 388, 250, 406, 481, 361,
|
||||
381, 49, 384, 266, 148, 474, 390, 318, 284, 96, 373, 463, 103,
|
||||
281, 101, 104, 153, 336, 8, 7, 380, 183, 36, 25, 222, 295,
|
||||
219, 228, 425, 82, 265, 144, 412, 449, 40, 435, 309, 362, 374,
|
||||
223, 485, 392, 197, 366, 478, 433, 195, 479, 54, 238, 494, 240,
|
||||
147, 73, 154, 438, 105, 129, 293, 11, 94, 180, 329, 455, 372,
|
||||
62, 315, 439, 142, 454, 174, 16, 149, 495, 78, 242, 509, 133,
|
||||
253, 246, 160, 367, 131, 138, 342, 155, 316, 263, 359, 152, 464,
|
||||
489, 3, 510, 189, 290, 137, 210, 399, 18, 51, 106, 322, 237,
|
||||
368, 283, 226, 335, 344, 305, 327, 93, 275, 461, 121, 353, 421,
|
||||
377, 158, 436, 204, 34, 306, 26, 232, 4, 391, 493, 407, 57,
|
||||
447, 471, 39, 395, 198, 156, 208, 334, 108, 52, 498, 110, 202,
|
||||
37, 186, 401, 254, 19, 262, 47, 429, 370, 475, 192, 267, 470,
|
||||
245, 492, 269, 118, 276, 427, 117, 268, 484, 345, 84, 287, 75,
|
||||
196, 446, 247, 41, 164, 14, 496, 119, 77, 378, 134, 139, 179,
|
||||
369, 191, 270, 260, 151, 347, 352, 360, 215, 187, 102, 462, 252,
|
||||
146, 453, 111, 22, 74, 161, 313, 175, 241, 400, 10, 426, 323,
|
||||
379, 86, 397, 358, 212, 507, 333, 404, 410, 135, 504, 291, 167,
|
||||
440, 321, 60, 505, 320, 42, 341, 282, 417, 408, 213, 294, 431,
|
||||
97, 302, 343, 476, 114, 394, 170, 150, 277, 239, 69, 123, 141,
|
||||
325, 83, 95, 376, 178, 46, 32, 469, 63, 457, 487, 428, 68,
|
||||
56, 20, 177, 363, 171, 181, 90, 386, 456, 468, 24, 375, 100,
|
||||
207, 109, 256, 409, 304, 346, 5, 288, 443, 445, 224, 79, 214,
|
||||
319, 452, 298, 21, 6, 255, 411, 166, 67, 136, 80, 351, 488,
|
||||
289, 115, 382, 188, 194, 201, 371, 393, 501, 116, 460, 486, 424,
|
||||
405, 31, 65, 13, 442, 50, 61, 465, 128, 168, 87, 441, 354,
|
||||
328, 217, 261, 98, 122, 33, 511, 274, 264, 448, 169, 285, 432,
|
||||
422, 205, 243, 92, 258, 91, 473, 324, 502, 173, 165, 58, 459,
|
||||
310, 383, 70, 225, 30, 477, 230, 311, 506, 389, 140, 143, 64,
|
||||
437, 190, 120, 0, 172, 272, 350, 292, 2, 444, 162, 234, 112,
|
||||
508, 278, 348, 76, 450]
|
||||
|
||||
FL : [32] -> [8] -> [32][16] -> [32]
|
||||
FL FL_IN k EK =
|
||||
if isEven k then
|
||||
d0_even # d1_even
|
||||
where d1_even = d1 ^ (d0 && (EK @ (k / 2)))
|
||||
d0_even = d0 ^ (d1_even || (EK @ ((k / 2 + 6) % 8 + 8)))
|
||||
else
|
||||
d0_odd # d1_odd
|
||||
where d1_odd = d1 ^ (d0 && (EK @ (((k - 1) / 2 + 2) % 8 + 8)))
|
||||
d0_odd = d0 ^ (d1_odd || (EK @ (((k - 1) / 2 + 4) % 8)))
|
||||
where // d0 as 16-bit integer
|
||||
d0 : [16]
|
||||
d0 = take FL_IN
|
||||
// d1 as 16-bit integer
|
||||
d1 : [16]
|
||||
d1 = drop FL_IN
|
||||
|
||||
FLINV : [32] -> [8] -> [32][16] -> [32]
|
||||
FLINV FL_IN k EK =
|
||||
if isEven k then
|
||||
d0_even # d1_even
|
||||
where d0_even = d0 ^ (d1 || (EK @ ((k / 2 + 6) % 8 + 8)))
|
||||
d1_even = d1 ^ (d0_even && (EK @ (k / 2)))
|
||||
else
|
||||
d0_odd # d1_odd
|
||||
where d0_odd = d0 ^ (d1 || (EK @ (((k - 1) / 2 + 4) % 8)))
|
||||
d1_odd = d1 ^ (d0_odd && (EK @ (((k - 1) / 2 + 2) % 8 + 8)))
|
||||
where // d0 as 16-bit integer
|
||||
d0 : [16]
|
||||
d0 = take FL_IN
|
||||
// d1 as 16-bit integer
|
||||
d1 : [16]
|
||||
d1 = drop FL_IN
|
||||
|
||||
//
|
||||
// Encrypt/decrypt
|
||||
//
|
||||
|
||||
misty1Encrypt : [64] -> [32][16] -> [64]
|
||||
misty1Encrypt P EK = (C ! 0).1 # (C ! 0).0
|
||||
where
|
||||
// 64-bit plaintext P is divided into the leftmost 32-bit D0 and the
|
||||
// rightmost 32-bit D1
|
||||
C = [(take P, drop P)] # [ f D0 D1
|
||||
| f <- funcs
|
||||
| (D0, D1) <- C
|
||||
]
|
||||
funcs : [_]([32] -> [32] -> ([32], [32]))
|
||||
funcs = [// 0 round
|
||||
\D0 D1 -> (FL D0 0 EK, D1),
|
||||
\D0 D1 -> (D0, FL D1 1 EK),
|
||||
\D0 D1 -> (D0, D1 ^ (FO D0 0 EK)),
|
||||
// 1 round
|
||||
\D0 D1 -> (D0 ^ (FO D1 1 EK), D1),
|
||||
// 2 round
|
||||
\D0 D1 -> (FL D0 2 EK, D1),
|
||||
\D0 D1 -> (D0, FL D1 3 EK),
|
||||
\D0 D1 -> (D0, D1 ^ (FO D0 2 EK)),
|
||||
// 3 round
|
||||
\D0 D1 -> (D0 ^ (FO D1 3 EK), D1),
|
||||
// 4 round
|
||||
\D0 D1 -> (FL D0 4 EK, D1),
|
||||
\D0 D1 -> (D0, FL D1 5 EK),
|
||||
\D0 D1 -> (D0, D1 ^ (FO D0 4 EK)),
|
||||
// 5 round
|
||||
\D0 D1 -> (D0 ^ (FO D1 5 EK), D1),
|
||||
// 6 round
|
||||
\D0 D1 -> (FL D0 6 EK, D1),
|
||||
\D0 D1 -> (D0, FL D1 7 EK),
|
||||
\D0 D1 -> (D0, D1 ^ (FO D0 6 EK)),
|
||||
// 7 round
|
||||
\D0 D1 -> (D0 ^ (FO D1 7 EK), D1),
|
||||
// final
|
||||
\D0 D1 -> (FL D0 8 EK, D1),
|
||||
\D0 D1 -> (D0, FL D1 9 EK)
|
||||
]
|
||||
|
||||
misty1Decrypt : [64] -> [32][16] -> [64]
|
||||
misty1Decrypt C EK = (P ! 0).0 # (P ! 0).1
|
||||
where P = [(drop C, take C)] # [ f D0 D1
|
||||
| f <- funcs
|
||||
| (D0, D1) <- P
|
||||
]
|
||||
funcs : [_]([32] -> [32] -> ([32], [32]))
|
||||
funcs = [\D0 D1 -> (FLINV D0 8 EK, D1),
|
||||
\D0 D1 -> (D0, FLINV D1 9 EK),
|
||||
\D0 D1 -> (D0 ^ (FO D1 7 EK), D1),
|
||||
\D0 D1 -> (D0, D1 ^ (FO D0 6 EK)),
|
||||
\D0 D1 -> (FLINV D0 6 EK, D1),
|
||||
\D0 D1 -> (D0, FLINV D1 7 EK),
|
||||
\D0 D1 -> (D0 ^ (FO D1 5 EK), D1),
|
||||
\D0 D1 -> (D0, D1 ^ (FO D0 4 EK)),
|
||||
\D0 D1 -> (FLINV D0 4 EK, D1),
|
||||
\D0 D1 -> (D0, FLINV D1 5 EK),
|
||||
\D0 D1 -> (D0 ^ (FO D1 3 EK), D1),
|
||||
\D0 D1 -> (D0, D1 ^ (FO D0 2 EK)),
|
||||
\D0 D1 -> (FLINV D0 2 EK, D1),
|
||||
\D0 D1 -> (D0, FLINV D1 3 EK),
|
||||
\D0 D1 -> (D0 ^ (FO D1 1 EK), D1),
|
||||
\D0 D1 -> (D0, D1 ^ (FO D0 0 EK)),
|
||||
\D0 D1 -> (FLINV D0 0 EK, D1),
|
||||
\D0 D1 -> (D0, FLINV D1 1 EK)
|
||||
]
|
||||
|
||||
//
|
||||
// Helper functions
|
||||
//
|
||||
|
||||
extend : {total, n} (fin total, fin n, total >= n) => [n] -> [total]
|
||||
extend n = zero # n
|
||||
|
||||
isEven : {a} (fin a) => [a] -> Bool
|
||||
isEven n = ~(n ! zero)
|
||||
|
||||
//
|
||||
// Examples
|
||||
//
|
||||
|
||||
property testMisty1Encrypt = [ misty1Encrypt block EK
|
||||
| block <- plaintext
|
||||
] == ciphertext
|
||||
where EK = keySchedule key
|
||||
key = [0x00, 0x11 .. 0xff]
|
||||
plaintext = [0x0123456789abcdef, 0xfedcba9876543210]
|
||||
ciphertext = [0x8b1da5f56ab3d07c, 0x04b68240b13be95d]
|
||||
|
||||
property misty1Correct pt key = misty1Decrypt (misty1Encrypt pt EK) EK == pt
|
||||
where EK = keySchedule key
|
@ -107,7 +107,7 @@ randXOR seed src = [s ^ r | s <- src
|
||||
|
||||
property otp_encdec =
|
||||
randXOR seedUnit "Deus Ex Machina" == c
|
||||
&& randXOR seedUnit c == "Deus Ex Machina"
|
||||
/\ randXOR seedUnit c == "Deus Ex Machina"
|
||||
where c = [ 0x28, 0x2b, 0x2c, 0xfa
|
||||
, 0x92, 0xca, 0xb3, 0xcb
|
||||
, 0xed, 0x50, 0xc2, 0x1b
|
||||
|
@ -3,14 +3,14 @@
|
||||
// The puzzle goes like this:
|
||||
// You've got 30 coins that add up to $1.09 - what are they?
|
||||
coinPuzzle : [10] -> [10] -> [10] -> [10] -> Bit
|
||||
coinPuzzle a b c d = (coinCount a b c d 30) && (coinSum a b c d 109)
|
||||
coinPuzzle a b c d = (coinCount a b c d 30) /\ (coinSum a b c d 109)
|
||||
|
||||
coinSum : [10] -> [10] -> [10] -> [10] -> [10] -> Bit
|
||||
coinSum a b c d s = (a + 5 * b + 10 * c + 25 * d) == s
|
||||
|
||||
coinCount : [10] -> [10] -> [10] -> [10] -> [10] -> Bit
|
||||
coinCount a b c d s = (((a + b + c + d) == s) && // the coin count adds up
|
||||
(a <= s && b <= s && c <= s && d <= s)) // and we don't wrap
|
||||
coinCount a b c d s = (((a + b + c + d) == s) /\ // the coin count adds up
|
||||
(a <= s /\ b <= s /\ c <= s /\ d <= s)) // and we don't wrap
|
||||
|
||||
// run it like this:
|
||||
// :set satNum = all
|
||||
|
@ -45,7 +45,7 @@ checkDiag qs (i, j) = (i >= j) || (diffR != diffC)
|
||||
diffC = j - i // we know i < j
|
||||
|
||||
nQueens : {n} (fin n, n >= 1) => Solution n
|
||||
nQueens qs = all (inRange qs, qs) && all (checkDiag qs, ijs `{n}) && distinct qs
|
||||
nQueens qs = all (inRange qs, qs) /\ all (checkDiag qs, ijs `{n}) /\ distinct qs
|
||||
|
||||
ijs : {n}(fin n, n>= 1)=> [_](Position n, Position n)
|
||||
ijs = [ (i, j) | i <- [0 .. (n-1)], j <- [0 .. (n-1)]]
|
||||
|
@ -67,8 +67,8 @@ validBoard b = join (b && ~posns) == zero
|
||||
|
||||
validRowJump : Board -> Board -> Bit
|
||||
validRowJump a a' = validBoard a
|
||||
&& validBoard a'
|
||||
&& validRowMove (differentRow a a')
|
||||
/\ validBoard a'
|
||||
/\ validRowMove (differentRow a a')
|
||||
|
||||
differentRow : Board -> Board -> ([7], [7])
|
||||
differentRow a a' = rows ! 0
|
||||
@ -79,18 +79,18 @@ differentRow a a' = rows ! 0
|
||||
| old <- rows ]
|
||||
|
||||
validRowMove : ([7], [7]) -> Bit
|
||||
validRowMove (r, r') = (xors == 0b0000111 ||
|
||||
xors == 0b0001110 ||
|
||||
xors == 0b0011100 ||
|
||||
xors == 0b0111000 ||
|
||||
xors == 0b1110000)
|
||||
&& (
|
||||
rxors == 0b0000011 ||
|
||||
rxors == 0b0000110 ||
|
||||
rxors == 0b0001100 ||
|
||||
rxors == 0b0011000 ||
|
||||
rxors == 0b0110000 ||
|
||||
rxors == 0b1100000)
|
||||
validRowMove (r, r') = (xors == 0b0000111 \/
|
||||
xors == 0b0001110 \/
|
||||
xors == 0b0011100 \/
|
||||
xors == 0b0111000 \/
|
||||
xors == 0b1110000)
|
||||
/\ (
|
||||
rxors == 0b0000011 \/
|
||||
rxors == 0b0000110 \/
|
||||
rxors == 0b0001100 \/
|
||||
rxors == 0b0011000 \/
|
||||
rxors == 0b0110000 \/
|
||||
rxors == 0b1100000)
|
||||
where xors = r ^ r'
|
||||
rxors = r && rxors
|
||||
|
||||
@ -98,7 +98,7 @@ validColJump : Board -> Board -> Bit
|
||||
validColJump a a' = validRowJump (transpose a) (transpose a')
|
||||
|
||||
validMove : Board -> Board -> Bit
|
||||
validMove a a' = validRowJump a a' || validColJump a a'
|
||||
validMove a a' = validRowJump a a' \/ validColJump a a'
|
||||
|
||||
validMoveSequence : {n} (fin n, n >= 1) => [n] Board -> Bit
|
||||
validMoveSequence moves = all [validMove a b | a <- moves | b <- drop`{1} moves]
|
||||
|
@ -78,7 +78,7 @@ malicious_k1 = [0x5a827999, 0x88e8ea68, 0x578059de, 0x54324a39]
|
||||
|
||||
bad_sha_eve1 = malicious_sha1 eve1 malicious_k1
|
||||
bad_sha_eve2 = malicious_sha1 eve2 malicious_k1
|
||||
property malicious_sha1_collision1 = eve1 != eve2 && bad_sha_eve1 == bad_sha_eve2
|
||||
property malicious_sha1_collision1 = eve1 != eve2 /\ bad_sha_eve1 == bad_sha_eve2
|
||||
|
||||
//hexdump malicious/eve1.sh
|
||||
eve1_galois = [
|
||||
@ -111,9 +111,9 @@ eve2_galois = [
|
||||
bad_sha_eve_galois1 = malicious_sha1 eve1_galois malicious_k1
|
||||
bad_sha_eve_galois2 = malicious_sha1 eve2_galois malicious_k1
|
||||
|
||||
property malicious_sha1_collision2 = eve1_galois != eve2_galois && bad_sha_eve_galois1 == bad_sha_eve_galois2
|
||||
property malicious_sha1_collision2 = eve1_galois != eve2_galois /\ bad_sha_eve_galois1 == bad_sha_eve_galois2
|
||||
|
||||
property all_same_hashes = bad_sha_eve_galois1 == bad_sha_eve1 && malicious_sha1_collision1 && malicious_sha1_collision2
|
||||
property all_same_hashes = bad_sha_eve_galois1 == bad_sha_eve1 /\ malicious_sha1_collision1 && malicious_sha1_collision2
|
||||
|
||||
/*
|
||||
As a summary, a "1" followed by m "0"s followed by a 64-
|
||||
@ -127,9 +127,8 @@ pad : {msgLen,contentLen,chunks,padding}
|
||||
( fin msgLen
|
||||
, 64 >= width msgLen // message width fits in a word
|
||||
, contentLen == msgLen + 65 // message + header
|
||||
, chunks == (contentLen+511) / 512
|
||||
, chunks == (contentLen+padding) / 512
|
||||
, padding == (512 - contentLen % 512) % 512 // prettier if type #'s could be < 0
|
||||
, msgLen == 512 * chunks - (65 + padding) // redundant, but Cryptol can't yet do the math
|
||||
)
|
||||
=> [msgLen] -> [chunks][512]
|
||||
pad msg = split (msg # [True] # (zero:[padding]) # (`msgLen:[64]))
|
||||
|
156
lib/Cryptol.cry
156
lib/Cryptol.cry
@ -10,15 +10,18 @@ module Cryptol where
|
||||
*/
|
||||
primitive demote : {val, bits} (fin val, fin bits, bits >= width val) => [bits]
|
||||
|
||||
infixr 10 ||
|
||||
infixr 20 &&
|
||||
infixr 5 ==>
|
||||
infixr 10 \/
|
||||
infixr 15 /\
|
||||
infixr 20 ||
|
||||
infixr 25 &&
|
||||
infix 30 ==, ===, !=, !==
|
||||
infix 40 >, >=, <, <=
|
||||
infixl 50 ^
|
||||
infixr 60 #
|
||||
infixl 70 <<, <<<, >>, >>>
|
||||
infixl 80 +, -
|
||||
infixl 90 *, /
|
||||
infixl 90 *, /, %
|
||||
infixr 95 ^^
|
||||
infixl 100 @, @@, !, !!
|
||||
|
||||
@ -94,16 +97,11 @@ primitive False : Bit
|
||||
primitive negate : {a} (Arith a) => a -> a
|
||||
|
||||
/**
|
||||
* Binary complement.
|
||||
* Bitwise complement. The prefix notation '~ x'
|
||||
* is syntactic sugar for 'complement x'.
|
||||
*/
|
||||
primitive complement : {a} a -> a
|
||||
|
||||
/**
|
||||
* Operator form of binary complement.
|
||||
*/
|
||||
(~) : {a} a -> a
|
||||
(~) = complement
|
||||
|
||||
/**
|
||||
* Less-than. Only works on comparable arguments.
|
||||
*/
|
||||
@ -135,13 +133,13 @@ primitive (==) : {a} (Cmp a) => a -> a -> Bit
|
||||
primitive (!=) : {a} (Cmp a) => a -> a -> Bit
|
||||
|
||||
/**
|
||||
* Compare the outputs of two functions for equality
|
||||
* Compare the outputs of two functions for equality.
|
||||
*/
|
||||
(===) : {a,b} (Cmp b) => (a -> b) -> (a -> b) -> (a -> Bit)
|
||||
f === g = \ x -> f x == g x
|
||||
|
||||
/**
|
||||
* Compare the outputs of two functions for inequality
|
||||
* Compare the outputs of two functions for inequality.
|
||||
*/
|
||||
(!==) : {a,b} (Cmp b) => (a -> b) -> (a -> b) -> (a -> Bit)
|
||||
f !== g = \x -> f x != g x
|
||||
@ -158,6 +156,30 @@ min x y = if x < y then x else y
|
||||
max : {a} (Cmp a) => a -> a -> a
|
||||
max x y = if x > y then x else y
|
||||
|
||||
/**
|
||||
* Short-cutting boolean conjuction function.
|
||||
* If the first argument is False, the second argument
|
||||
* is not evaluated.
|
||||
*/
|
||||
(/\) : Bit -> Bit -> Bit
|
||||
x /\ y = if x then y else False
|
||||
|
||||
/**
|
||||
* Short-cutting boolean disjuction function.
|
||||
* If the first argument is True, the second argument
|
||||
* is not evaluated.
|
||||
*/
|
||||
(\/) : Bit -> Bit -> Bit
|
||||
x \/ y = if x then True else y
|
||||
|
||||
/**
|
||||
* Short-cutting logical implication.
|
||||
* If the first argument is False, the second argument is
|
||||
* not evaluated.
|
||||
*/
|
||||
(==>) : Bit -> Bit -> Bit
|
||||
a ==> b = if a then b else True
|
||||
|
||||
/**
|
||||
* Logical `and' over bits. Extends element-wise over sequences, tuples.
|
||||
*/
|
||||
@ -212,7 +234,6 @@ primitive (#) : {front, back, a} (fin front) => [front]a -> [back]a
|
||||
*/
|
||||
primitive splitAt : {front, back, a} (fin front) => [front + back]a
|
||||
-> ([front]a, [back]a)
|
||||
|
||||
/**
|
||||
* Joins sequences.
|
||||
*/
|
||||
@ -257,25 +278,103 @@ primitive (!) : {a, b, c} (fin a, fin c) => [a]b -> [c] -> b
|
||||
/**
|
||||
* Bulk reverse index operator. The first argument is a finite sequence. The
|
||||
* second argument is a sequence of the zero-based indices of the elements to
|
||||
z select, starting from the end of the sequence.
|
||||
* select, starting from the end of the sequence.
|
||||
*/
|
||||
primitive (!!) : {a, b, c, d} (fin a, fin d) => [a]b -> [c][d] -> [c]b
|
||||
|
||||
/**
|
||||
* Update the given sequence with new value at the given index position.
|
||||
* The first argument is a sequence. The second argument is the zero-based
|
||||
* index of the element to update, starting from the front of the sequence.
|
||||
* The third argument is the new element. The return value is the
|
||||
* initial sequence updated so that the indicated index has the given value.
|
||||
*/
|
||||
primitive update : {a, b, c} (fin c) => [a]b -> [c] -> b -> [a]b
|
||||
|
||||
/**
|
||||
* Update the given sequence with new value at the given index position.
|
||||
* The first argument is a sequence. The second argument is the zero-based
|
||||
* index of the element to update, starting from the end of the sequence.
|
||||
* The third argument is the new element. The return value is the
|
||||
* initial sequence updated so that the indicated index has the given value.
|
||||
*/
|
||||
primitive updateEnd : {a, b, c} (fin a, fin c) => [a]b -> [c] -> b -> [a]b
|
||||
|
||||
/**
|
||||
* Perform a series of updates to a sequence. The first argument is
|
||||
* the initial sequence to update. The second argument is a sequence
|
||||
* of indices, and the third argument is a sequence of values.
|
||||
* This function applies the 'update' function in sequence with the
|
||||
* given update pairs.
|
||||
*/
|
||||
updates : {a,b,c,d} (fin c, fin d) => [a]b -> [d][c] -> [d]b -> [a]b
|
||||
updates xs0 idxs vals = xss!0
|
||||
where
|
||||
xss = [ xs0 ] #
|
||||
[ update xs i b
|
||||
| xs <- xss
|
||||
| i <- idxs
|
||||
| b <- vals
|
||||
]
|
||||
|
||||
/**
|
||||
* Perform a series of updates to a sequence. The first argument is
|
||||
* the initial sequence to update. The second argument is a sequence
|
||||
* of indices, and the third argument is a sequence of values.
|
||||
* This function applies the 'updateEnd' function in sequence with the
|
||||
* given update pairs.
|
||||
*/
|
||||
updatesEnd : {a,b,c,d} (fin a, fin c, fin d) => [a]b -> [d][c] -> [d]b -> [a]b
|
||||
updatesEnd xs0 idxs vals = xss!0
|
||||
where
|
||||
xss = [ xs0 ] #
|
||||
[ updateEnd xs i b
|
||||
| xs <- xss
|
||||
| i <- idxs
|
||||
| b <- vals
|
||||
]
|
||||
|
||||
/**
|
||||
* A finite arithmetic sequence starting with 'first' and 'next',
|
||||
* stopping when the values would wrap around modulo '2^^bits'.
|
||||
*
|
||||
* '[a,b..]' is syntactic sugar for 'fromThen`{first=a,next=b}'.
|
||||
*/
|
||||
primitive fromThen : {first, next, bits, len}
|
||||
( fin first, fin next, fin bits
|
||||
, bits >= width first, bits >= width next
|
||||
, lengthFromThen first next bits == len) => [len][bits]
|
||||
|
||||
/**
|
||||
* A finite sequence counting up from 'first' to 'last'.
|
||||
*
|
||||
* '[a..b]' is syntactic sugar for 'fromTo`{first=a,last=b}'.
|
||||
* '[a..]' is syntactic sugar for 'fromTo`{first=a,last=(2^^bits)-1}'.
|
||||
*/
|
||||
primitive fromTo : {first, last, bits} (fin last, fin bits, last >= first,
|
||||
bits >= width last) => [1 + (last - first)][bits]
|
||||
|
||||
/**
|
||||
* A finite arithmetic sequence starting with 'first' and 'next',
|
||||
* stopping when the values reach or would skip over 'last'.
|
||||
*
|
||||
* '[a,b..c]' is syntactic sugar for 'fromThenTo`{first=a,next=b,last=c}'.
|
||||
*/
|
||||
primitive fromThenTo : {first, next, last, bits, len} (fin first, fin next,
|
||||
fin last, fin bits, bits >= width first,
|
||||
bits >= width next, bits >= width last,
|
||||
lengthFromThenTo first next last == len) => [len][bits]
|
||||
|
||||
/**
|
||||
* An infinite sequence counting up from the given starting value.
|
||||
* '[x...]' is syntactic sugar for 'infFrom x'.
|
||||
*/
|
||||
primitive infFrom : {bits} (fin bits) => [bits] -> [inf][bits]
|
||||
|
||||
/**
|
||||
* An infinite arithmetic sequence starting with the given two values.
|
||||
* '[x,y...]' is syntactic sugar for 'infFromThen x y'.
|
||||
*/
|
||||
primitive infFromThen : {bits} (fin bits) => [bits] -> [bits] -> [inf][bits]
|
||||
|
||||
primitive error : {at, len} (fin len) => [len][8] -> at
|
||||
@ -284,7 +383,7 @@ primitive error : {at, len} (fin len) => [len][8] -> at
|
||||
/**
|
||||
* Performs multiplication of polynomials over GF(2).
|
||||
*/
|
||||
primitive pmult : {a, b} (fin a, fin b) => [a] -> [b] -> [max 1 (a + b) - 1]
|
||||
primitive pmult : {a, b} (fin a, fin b) => [1 + a] -> [1 + b] -> [1 + a + b]
|
||||
|
||||
/**
|
||||
* Performs division of polynomials over GF(2).
|
||||
@ -329,3 +428,30 @@ groupBy = split`{parts=parts}
|
||||
* Define the base 2 logarithm function in terms of width
|
||||
*/
|
||||
type lg2 n = width (max n 1 - 1)
|
||||
|
||||
/**
|
||||
* Debugging function for tracing. The first argument is a string,
|
||||
* which is prepended to the printed value of the second argument.
|
||||
* This combined string is then printed when the trace function is
|
||||
* evaluated. The return value is equal to the third argument.
|
||||
*
|
||||
* The exact timing and number of times the trace message is printed
|
||||
* depend on the internal details of the Cryptol evaluation order,
|
||||
* which are unspecified. Thus, the output produced by this
|
||||
* operation may be difficult to predict.
|
||||
*/
|
||||
primitive trace : {n, a, b} (fin n) => [n][8] -> a -> b -> b
|
||||
|
||||
/**
|
||||
* Debugging function for tracing values. The first argument is a string,
|
||||
* which is prepended to the printed value of the second argument.
|
||||
* This combined string is then printed when the trace function is
|
||||
* evaluated. The return value is equal to the second argument.
|
||||
*
|
||||
* The exact timing and number of times the trace message is printed
|
||||
* depend on the internal details of the Cryptol evaluation order,
|
||||
* which are unspecified. Thus, the output produced by this
|
||||
* operation may be difficult to predict.
|
||||
*/
|
||||
traceVal : {n, a} (fin n) => [n][8] -> a -> a
|
||||
traceVal msg x = trace msg x x
|
||||
|
@ -9,14 +9,6 @@
|
||||
|
||||
module Cryptol::Extras where
|
||||
|
||||
infixr 5 ==>
|
||||
|
||||
/**
|
||||
* Logical implication
|
||||
*/
|
||||
(==>) : Bit -> Bit -> Bit
|
||||
a ==> b = if a then b else True
|
||||
|
||||
/**
|
||||
* Logical negation
|
||||
*/
|
||||
@ -141,3 +133,10 @@ uncurry f = \(a,b) -> f a b
|
||||
*/
|
||||
curry : {a,b,c} ((a, b) -> c) -> a -> b -> c
|
||||
curry f = \a b -> f (a,b)
|
||||
|
||||
/**
|
||||
* Map a function iteratively over a seed value, producing an infinite
|
||||
* list of successive function applications.
|
||||
*/
|
||||
iterate : { a } (a -> a) -> a -> [inf]a
|
||||
iterate f x = [x] # [ f v | v <- iterate f x ]
|
||||
|
293
lib/CryptolTC.z3
Normal file
293
lib/CryptolTC.z3
Normal file
@ -0,0 +1,293 @@
|
||||
; ------------------------------------------------------------------------------
|
||||
; Basic datatypes
|
||||
|
||||
(declare-datatypes ()
|
||||
( (InfNat (mk-infnat (value Int) (isFin Bool) (isErr Bool)))
|
||||
)
|
||||
)
|
||||
|
||||
(declare-datatypes ()
|
||||
( (MaybeBool (mk-mb (prop Bool) (isErrorProp Bool)))
|
||||
)
|
||||
)
|
||||
|
||||
(define-fun cryBool ((x Bool)) MaybeBool
|
||||
(mk-mb x false)
|
||||
)
|
||||
|
||||
(define-fun cryErrProp () MaybeBool
|
||||
(mk-mb false true)
|
||||
)
|
||||
|
||||
(define-fun cryInf () InfNat
|
||||
(mk-infnat 0 false false)
|
||||
)
|
||||
|
||||
(define-fun cryNat ((x Int)) InfNat
|
||||
(mk-infnat x true false)
|
||||
)
|
||||
|
||||
(define-fun cryErr () InfNat
|
||||
(mk-infnat 0 false true)
|
||||
)
|
||||
|
||||
; ------------------------------------------------------------------------------
|
||||
; Cryptol version of logic
|
||||
|
||||
|
||||
(define-fun cryEq ((x InfNat) (y InfNat)) MaybeBool
|
||||
(ite (or (isErr x) (isErr y)) cryErrProp (cryBool
|
||||
(ite (isFin x)
|
||||
(ite (isFin y) (= (value x) (value y)) false)
|
||||
(not (isFin y))
|
||||
)))
|
||||
)
|
||||
|
||||
(define-fun cryFin ((x InfNat)) MaybeBool
|
||||
(ite (isErr x) cryErrProp (cryBool
|
||||
(isFin x)))
|
||||
)
|
||||
|
||||
(define-fun cryGeq ((x InfNat) (y InfNat)) MaybeBool
|
||||
(ite (or (isErr x) (isErr y)) cryErrProp (cryBool
|
||||
(ite (isFin x)
|
||||
(ite (isFin y) (>= (value x) (value y)) false)
|
||||
true
|
||||
)))
|
||||
)
|
||||
|
||||
(define-fun cryAnd ((x MaybeBool) (y MaybeBool)) MaybeBool
|
||||
(ite (or (isErrorProp x) (isErrorProp y)) cryErrProp
|
||||
(cryBool (and (prop x) (prop y)))
|
||||
)
|
||||
)
|
||||
|
||||
|
||||
(define-fun cryTrue () MaybeBool
|
||||
(cryBool true)
|
||||
)
|
||||
|
||||
; ------------------------------------------------------------------------------
|
||||
; Basic Cryptol assume/assert
|
||||
|
||||
|
||||
(define-fun cryVar ((x InfNat)) Bool
|
||||
(and (not (isErr x)) (>= (value x) 0))
|
||||
)
|
||||
|
||||
(define-fun cryAssume ((x MaybeBool)) Bool
|
||||
(ite (isErrorProp x) true (prop x))
|
||||
)
|
||||
|
||||
(declare-fun cryUnknown () Bool)
|
||||
|
||||
(define-fun cryProve ((x MaybeBool)) Bool
|
||||
(ite (isErrorProp x) cryUnknown (not (prop x)))
|
||||
)
|
||||
|
||||
|
||||
|
||||
; ------------------------------------------------------------------------------
|
||||
; Arithmetic
|
||||
|
||||
|
||||
(define-fun cryAdd ((x InfNat) (y InfNat)) InfNat
|
||||
(ite (or (isErr x) (isErr y)) cryErr
|
||||
(ite (isFin x)
|
||||
(ite (isFin y) (cryNat (+ (value x) (value y))) cryInf)
|
||||
cryInf
|
||||
))
|
||||
)
|
||||
|
||||
(define-fun crySub ((x InfNat) (y InfNat)) InfNat
|
||||
(ite (or (isErr x) (isErr y) (not (isFin y))) cryErr
|
||||
(ite (isFin x)
|
||||
(ite (>= (value x) (value y)) (cryNat (- (value x) (value y))) cryErr)
|
||||
cryInf
|
||||
))
|
||||
)
|
||||
|
||||
(define-fun cryMul ((x InfNat) (y InfNat)) InfNat
|
||||
(ite (or (isErr x) (isErr y)) cryErr
|
||||
(ite (isFin x)
|
||||
(ite (isFin y) (cryNat (* (value x) (value y)))
|
||||
(ite (= (value x) 0) (cryNat 0) cryInf))
|
||||
(ite (and (isFin y) (= (value y) 0)) (cryNat 0) cryInf)
|
||||
))
|
||||
)
|
||||
|
||||
(define-fun cryDiv ((x InfNat) (y InfNat)) InfNat
|
||||
(ite (or (isErr x) (isErr y) (not (isFin x))) cryErr
|
||||
(ite (isFin y)
|
||||
(ite (= (value y) 0) cryErr (cryNat (div (value x) (value y))))
|
||||
(cryNat 0)
|
||||
))
|
||||
)
|
||||
|
||||
(define-fun cryMod ((x InfNat) (y InfNat)) InfNat
|
||||
(ite (or (isErr x) (isErr y) (not (isFin x))) cryErr
|
||||
(ite (isFin y)
|
||||
(ite (= (value y) 0) cryErr (cryNat (mod (value x) (value y))))
|
||||
x
|
||||
))
|
||||
)
|
||||
|
||||
|
||||
|
||||
(define-fun cryMin ((x InfNat) (y InfNat)) InfNat
|
||||
(ite (or (isErr x) (isErr y)) cryErr
|
||||
(ite (isFin x)
|
||||
(ite (isFin y)
|
||||
(ite (<= (value x) (value y)) x y)
|
||||
x)
|
||||
y
|
||||
))
|
||||
)
|
||||
|
||||
(define-fun cryMax ((x InfNat) (y InfNat)) InfNat
|
||||
(ite (or (isErr x) (isErr y)) cryErr
|
||||
(ite (isFin x)
|
||||
(ite (isFin y)
|
||||
(ite (<= (value x) (value y)) y x)
|
||||
y)
|
||||
x
|
||||
))
|
||||
)
|
||||
|
||||
|
||||
(declare-fun cryWidthUnknown (Int) Int)
|
||||
|
||||
; Some axioms about cryWidthUnknown
|
||||
|
||||
(assert (forall ((x Int)) (> (cryWidthUnknown x) 64)))
|
||||
(assert (forall ((x Int)) (or (> x (cryWidthUnknown x))
|
||||
(< x 18446744073709551616))))
|
||||
(assert (forall ((x Int) (y Int))
|
||||
(=> (and (>= x y) (> y 64))
|
||||
(>= (cryWidthUnknown x) (cryWidthUnknown y)))))
|
||||
|
||||
|
||||
(define-fun cryWidthTable ((x Int)) Int
|
||||
(ite (< x 1) 0
|
||||
(ite (< x 2) 1
|
||||
(ite (< x 4) 2
|
||||
(ite (< x 8) 3
|
||||
(ite (< x 16) 4
|
||||
(ite (< x 32) 5
|
||||
(ite (< x 64) 6
|
||||
(ite (< x 128) 7
|
||||
(ite (< x 256) 8
|
||||
(ite (< x 512) 9
|
||||
(ite (< x 1024) 10
|
||||
(ite (< x 2048) 11
|
||||
(ite (< x 4096) 12
|
||||
(ite (< x 8192) 13
|
||||
(ite (< x 16384) 14
|
||||
(ite (< x 32768) 15
|
||||
(ite (< x 65536) 16
|
||||
(ite (< x 131072) 17
|
||||
(ite (< x 262144) 18
|
||||
(ite (< x 524288) 19
|
||||
(ite (< x 1048576) 20
|
||||
(ite (< x 2097152) 21
|
||||
(ite (< x 4194304) 22
|
||||
(ite (< x 8388608) 23
|
||||
(ite (< x 16777216) 24
|
||||
(ite (< x 33554432) 25
|
||||
(ite (< x 67108864) 26
|
||||
(ite (< x 134217728) 27
|
||||
(ite (< x 268435456) 28
|
||||
(ite (< x 536870912) 29
|
||||
(ite (< x 1073741824) 30
|
||||
(ite (< x 2147483648) 31
|
||||
(ite (< x 4294967296) 32
|
||||
(ite (< x 8589934592) 33
|
||||
(ite (< x 17179869184) 34
|
||||
(ite (< x 34359738368) 35
|
||||
(ite (< x 68719476736) 36
|
||||
(ite (< x 137438953472) 37
|
||||
(ite (< x 274877906944) 38
|
||||
(ite (< x 549755813888) 39
|
||||
(ite (< x 1099511627776) 40
|
||||
(ite (< x 2199023255552) 41
|
||||
(ite (< x 4398046511104) 42
|
||||
(ite (< x 8796093022208) 43
|
||||
(ite (< x 17592186044416) 44
|
||||
(ite (< x 35184372088832) 45
|
||||
(ite (< x 70368744177664) 46
|
||||
(ite (< x 140737488355328) 47
|
||||
(ite (< x 281474976710656) 48
|
||||
(ite (< x 562949953421312) 49
|
||||
(ite (< x 1125899906842624) 50
|
||||
(ite (< x 2251799813685248) 51
|
||||
(ite (< x 4503599627370496) 52
|
||||
(ite (< x 9007199254740992) 53
|
||||
(ite (< x 18014398509481984) 54
|
||||
(ite (< x 36028797018963968) 55
|
||||
(ite (< x 72057594037927936) 56
|
||||
(ite (< x 144115188075855872) 57
|
||||
(ite (< x 288230376151711744) 58
|
||||
(ite (< x 576460752303423488) 59
|
||||
(ite (< x 1152921504606846976) 60
|
||||
(ite (< x 2305843009213693952) 61
|
||||
(ite (< x 4611686018427387904) 62
|
||||
(ite (< x 9223372036854775808) 63
|
||||
(ite (< x 18446744073709551616) 64
|
||||
(cryWidthUnknown x))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))
|
||||
)
|
||||
|
||||
(define-fun cryWidth ((x InfNat)) InfNat
|
||||
(ite (isErr x) cryErr
|
||||
(ite (isFin x) (cryNat (cryWidthTable (value x)))
|
||||
cryInf
|
||||
))
|
||||
)
|
||||
|
||||
|
||||
|
||||
(declare-fun cryExpUnknown (Int Int) Int)
|
||||
|
||||
(define-fun cryExpTable ((x Int) (y Int)) Int
|
||||
(ite (= y 0) 1
|
||||
(ite (= y 1) x
|
||||
(ite (= x 0) 0
|
||||
(cryExpUnknown x y))))
|
||||
)
|
||||
|
||||
(define-fun cryExp ((x InfNat) (y InfNat)) InfNat
|
||||
(ite (or (isErr x) (isErr y)) cryErr
|
||||
(ite (isFin x)
|
||||
(ite (isFin y)
|
||||
(cryNat (cryExpTable (value x) (value y)))
|
||||
(ite (< (value x) 2) x cryInf))
|
||||
(ite (isFin y)
|
||||
(ite (= (value y) 0) (cryNat 1) cryInf)
|
||||
cryInf)
|
||||
))
|
||||
)
|
||||
|
||||
(define-fun cryLenFromThenTo ((x InfNat) (y InfNat) (z InfNat)) InfNat
|
||||
(ite (or (isErr x) (not (isFin x))
|
||||
(isErr y) (not (isFin y))
|
||||
(isErr z) (not (isFin z))
|
||||
(= (value x) (value y))) cryErr (cryNat
|
||||
(ite (> (value x) (value y))
|
||||
(ite (> (value z) (value x)) 0 (+ (div (- (value x) (value z))
|
||||
(- (value x) (value y))) 1))
|
||||
(ite (< (value z) (value x)) 0 (+ (div (- (value z) (value x))
|
||||
(- (value y) (value x))) 1))
|
||||
)))
|
||||
)
|
||||
|
||||
|
||||
(define-fun cryLenFromThen ((x InfNat) (y InfNat) (z InfNat)) InfNat
|
||||
(ite (or (isErr x) (not (isFin x))
|
||||
(isErr y) (not (isFin y))
|
||||
(isErr z) (not (isFin z))
|
||||
(= (value x) (value y))) cryErr
|
||||
(ite (< (value y) (value x)) (cryLenFromThenTo x y (cryNat 0))
|
||||
(cryLenFromThenTo x y (cryNat (- (cryExpTable 2 (value z)) 1))))
|
||||
)
|
||||
)
|
||||
|
||||
|
@ -6,105 +6,171 @@
|
||||
-- Stability : provisional
|
||||
-- Portability : portable
|
||||
|
||||
{-# LANGUAGE DoAndIfThenElse #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE ParallelListComp #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE Safe #-}
|
||||
{-# LANGUAGE PatternGuards #-}
|
||||
|
||||
module Cryptol.Eval (
|
||||
moduleEnv
|
||||
, EvalEnv()
|
||||
, runEval
|
||||
, Eval
|
||||
, EvalEnv
|
||||
, emptyEnv
|
||||
, evalExpr
|
||||
, evalDecls
|
||||
, EvalError(..)
|
||||
, WithBase(..)
|
||||
, forceValue
|
||||
) where
|
||||
|
||||
import Cryptol.Eval.Error
|
||||
import Cryptol.Eval.Env
|
||||
import Cryptol.Eval.Monad
|
||||
import Cryptol.Eval.Type
|
||||
import Cryptol.Eval.Value
|
||||
import Cryptol.ModuleSystem.Name
|
||||
import Cryptol.TypeCheck.AST
|
||||
import Cryptol.TypeCheck.Solver.InfNat (Nat')
|
||||
import Cryptol.TypeCheck.Solver.InfNat(Nat'(..))
|
||||
import Cryptol.Utils.Panic (panic)
|
||||
import Cryptol.Utils.PP
|
||||
import Cryptol.Prims.Eval
|
||||
|
||||
import qualified Data.Map as Map
|
||||
import Control.Monad
|
||||
import qualified Data.Sequence as Seq
|
||||
import Data.List
|
||||
import Data.Maybe
|
||||
import qualified Data.Map.Strict as Map
|
||||
|
||||
import Prelude ()
|
||||
import Prelude.Compat
|
||||
|
||||
type EvalEnv = GenEvalEnv Bool BV
|
||||
|
||||
-- Expression Evaluation -------------------------------------------------------
|
||||
|
||||
moduleEnv :: Module -> EvalEnv -> EvalEnv
|
||||
moduleEnv m env = evalDecls (mDecls m) (evalNewtypes (mNewtypes m) env)
|
||||
-- | Extend the given evaluation environment with all the declarations
|
||||
-- contained in the given module.
|
||||
moduleEnv :: EvalPrims b w
|
||||
=> Module -- ^ Module containing declarations to evaluate
|
||||
-> GenEvalEnv b w -- ^ Environment to extend
|
||||
-> Eval (GenEvalEnv b w)
|
||||
moduleEnv m env = evalDecls (mDecls m) =<< evalNewtypes (mNewtypes m) env
|
||||
|
||||
evalExpr :: EvalEnv -> Expr -> Value
|
||||
-- | Evaluate a Cryptol expression to a value. This evaluator is parameterized
|
||||
-- by the `EvalPrims` class, which defines the behavior of bits and words, in
|
||||
-- addition to providing implementations for all the primitives.
|
||||
evalExpr :: EvalPrims b w
|
||||
=> GenEvalEnv b w -- ^ Evaluation environment
|
||||
-> Expr -- ^ Expression to evaluate
|
||||
-> Eval (GenValue b w)
|
||||
evalExpr env expr = case expr of
|
||||
|
||||
EList es ty -> VSeq (isTBit (evalValType env ty)) (map (evalExpr env) es)
|
||||
-- Try to detect when the user has directly written a finite sequence of
|
||||
-- literal bit values and pack these into a word.
|
||||
EList es ty
|
||||
-- NB, even if the list cannot be packed, we must use `VWord`
|
||||
-- when the element type is `Bit`.
|
||||
| isTBit tyv -> {-# SCC "evalExpr->Elist/bit" #-}
|
||||
return $ VWord len $ return $
|
||||
case tryFromBits vs of
|
||||
Just w -> WordVal w
|
||||
Nothing -> BitsVal $ Seq.fromList $ map (fromVBit <$>) vs
|
||||
| otherwise -> {-# SCC "evalExpr->EList" #-}
|
||||
return $ VSeq len $ finiteSeqMap vs
|
||||
where
|
||||
tyv = evalValType (envTypes env) ty
|
||||
vs = map (evalExpr env) es
|
||||
len = genericLength es
|
||||
|
||||
ETuple es -> VTuple (map eval es)
|
||||
ETuple es -> {-# SCC "evalExpr->ETuple" #-} do
|
||||
let xs = map eval es
|
||||
return $ VTuple xs
|
||||
|
||||
ERec fields -> VRecord [ (f,eval e) | (f,e) <- fields ]
|
||||
ERec fields -> {-# SCC "evalExpr->ERec" #-} do
|
||||
let xs = [ (f, eval e)
|
||||
| (f,e) <- fields
|
||||
]
|
||||
return $ VRecord xs
|
||||
|
||||
ESel e sel -> evalSel env e sel
|
||||
ESel e sel -> {-# SCC "evalExpr->ESel" #-} do
|
||||
x <- eval e
|
||||
evalSel x sel
|
||||
|
||||
EIf c t f | fromVBit (eval c) -> eval t
|
||||
| otherwise -> eval f
|
||||
EIf c t f -> {-# SCC "evalExpr->EIf" #-} do
|
||||
b <- fromVBit <$> eval c
|
||||
iteValue b (eval t) (eval f)
|
||||
|
||||
EComp l h gs -> evalComp env (evalValType env l) h gs
|
||||
EComp n t h gs -> {-# SCC "evalExpr->EComp" #-} do
|
||||
let len = evalNumType (envTypes env) n
|
||||
let elty = evalValType (envTypes env) t
|
||||
evalComp env len elty h gs
|
||||
|
||||
EVar n -> case lookupVar n env of
|
||||
Just val -> val
|
||||
Nothing -> panic "[Eval] evalExpr"
|
||||
EVar n -> {-# SCC "evalExpr->EVar" #-} do
|
||||
case lookupVar n env of
|
||||
Just val -> val
|
||||
Nothing -> do
|
||||
envdoc <- ppEnv defaultPPOpts env
|
||||
panic "[Eval] evalExpr"
|
||||
["var `" ++ show (pp n) ++ "` is not defined"
|
||||
, pretty (WithBase defaultPPOpts env)
|
||||
, show envdoc
|
||||
]
|
||||
|
||||
ETAbs tv b -> case tpKind tv of
|
||||
KType -> VPoly $ \ty -> evalExpr (bindType (tpVar tv) (Right ty) env) b
|
||||
KNum -> VNumPoly $ \n -> evalExpr (bindType (tpVar tv) (Left n) env) b
|
||||
k -> panic "[Eval] evalExpr" ["invalid kind on type abstraction", show k]
|
||||
ETAbs tv b -> {-# SCC "evalExpr->ETAbs" #-}
|
||||
case tpKind tv of
|
||||
KType -> return $ VPoly $ \ty -> evalExpr (bindType (tpVar tv) (Right ty) env) b
|
||||
KNum -> return $ VNumPoly $ \n -> evalExpr (bindType (tpVar tv) (Left n) env) b
|
||||
k -> panic "[Eval] evalExpr" ["invalid kind on type abstraction", show k]
|
||||
|
||||
ETApp e ty -> case eval e of
|
||||
VPoly f -> f (evalValType env ty)
|
||||
VNumPoly f -> f (evalNumType env ty)
|
||||
val -> panic "[Eval] evalExpr"
|
||||
["expected a polymorphic value"
|
||||
, show (ppV val), show e, show ty
|
||||
]
|
||||
ETApp e ty -> {-# SCC "evalExpr->ETApp" #-} do
|
||||
eval e >>= \case
|
||||
VPoly f -> f $! (evalValType (envTypes env) ty)
|
||||
VNumPoly f -> f $! (evalNumType (envTypes env) ty)
|
||||
val -> do vdoc <- ppV val
|
||||
panic "[Eval] evalExpr"
|
||||
["expected a polymorphic value"
|
||||
, show vdoc, show e, show ty
|
||||
]
|
||||
|
||||
EApp f x -> case eval f of
|
||||
VFun f' -> f' (eval x)
|
||||
it -> panic "[Eval] evalExpr" ["not a function", show (ppV it) ]
|
||||
EApp f x -> {-# SCC "evalExpr->EApp" #-} do
|
||||
eval f >>= \case
|
||||
VFun f' -> f' (eval x)
|
||||
it -> do itdoc <- ppV it
|
||||
panic "[Eval] evalExpr" ["not a function", show itdoc ]
|
||||
|
||||
EAbs n _ty b -> VFun (\ val -> evalExpr (bindVar n val env) b )
|
||||
EAbs n _ty b -> {-# SCC "evalExpr->EAbs" #-}
|
||||
return $ VFun (\v -> do env' <- bindVar n v env
|
||||
evalExpr env' b)
|
||||
|
||||
-- XXX these will likely change once there is an evidence value
|
||||
EProofAbs _ e -> evalExpr env e
|
||||
EProofApp e -> evalExpr env e
|
||||
|
||||
ECast e _ty -> evalExpr env e
|
||||
|
||||
EWhere e ds -> evalExpr (evalDecls ds env) e
|
||||
EWhere e ds -> {-# SCC "evalExpr->EWhere" #-} do
|
||||
env' <- evalDecls ds env
|
||||
evalExpr env' e
|
||||
|
||||
where
|
||||
|
||||
{-# INLINE eval #-}
|
||||
eval = evalExpr env
|
||||
|
||||
ppV = ppValue defaultPPOpts
|
||||
|
||||
|
||||
-- Newtypes --------------------------------------------------------------------
|
||||
|
||||
evalNewtypes :: Map.Map Name Newtype -> EvalEnv -> EvalEnv
|
||||
evalNewtypes nts env = Map.foldl (flip evalNewtype) env nts
|
||||
evalNewtypes :: EvalPrims b w
|
||||
=> Map.Map Name Newtype
|
||||
-> GenEvalEnv b w
|
||||
-> Eval (GenEvalEnv b w)
|
||||
evalNewtypes nts env = foldM (flip evalNewtype) env $ Map.elems nts
|
||||
|
||||
-- | Introduce the constructor function for a newtype.
|
||||
evalNewtype :: Newtype -> EvalEnv -> EvalEnv
|
||||
evalNewtype nt = bindVar (ntName nt) (foldr tabs con (ntParams nt))
|
||||
evalNewtype :: EvalPrims b w
|
||||
=> Newtype
|
||||
-> GenEvalEnv b w
|
||||
-> Eval (GenEvalEnv b w)
|
||||
evalNewtype nt = bindVar (ntName nt) (return (foldr tabs con (ntParams nt)))
|
||||
where
|
||||
tabs _tp body = tlam (\ _ -> body)
|
||||
con = VFun id
|
||||
@ -112,169 +178,396 @@ evalNewtype nt = bindVar (ntName nt) (foldr tabs con (ntParams nt))
|
||||
|
||||
-- Declarations ----------------------------------------------------------------
|
||||
|
||||
evalDecls :: [DeclGroup] -> EvalEnv -> EvalEnv
|
||||
evalDecls dgs env = foldl (flip evalDeclGroup) env dgs
|
||||
-- | Extend the given evaluation environment with the result of evaluating the
|
||||
-- given collection of declaration groups.
|
||||
evalDecls :: EvalPrims b w
|
||||
=> [DeclGroup] -- ^ Declaration groups to evaluate
|
||||
-> GenEvalEnv b w -- ^ Environment to extend
|
||||
-> Eval (GenEvalEnv b w)
|
||||
evalDecls dgs env = foldM evalDeclGroup env dgs
|
||||
|
||||
evalDeclGroup :: DeclGroup -> EvalEnv -> EvalEnv
|
||||
evalDeclGroup dg env = env'
|
||||
evalDeclGroup :: EvalPrims b w
|
||||
=> GenEvalEnv b w
|
||||
-> DeclGroup
|
||||
-> Eval (GenEvalEnv b w)
|
||||
evalDeclGroup env dg = do
|
||||
case dg of
|
||||
Recursive ds -> do
|
||||
-- declare a "hole" for each declaration
|
||||
-- and extend the evaluation environment
|
||||
holes <- mapM declHole ds
|
||||
let holeEnv = Map.fromList $ [ (nm,h) | (nm,_,h,_) <- holes ]
|
||||
let env' = env `mappend` emptyEnv{ envVars = holeEnv }
|
||||
|
||||
-- evaluate the declaration bodies, building a new evaluation environment
|
||||
env'' <- foldM (evalDecl env') env ds
|
||||
|
||||
-- now backfill the holes we declared earlier using the definitions
|
||||
-- calculated in the previous step
|
||||
mapM_ (fillHole env'') holes
|
||||
|
||||
-- return the map containing the holes
|
||||
return env'
|
||||
|
||||
NonRecursive d -> do
|
||||
evalDecl env env d
|
||||
|
||||
|
||||
-- | This operation is used to complete the process of setting up recursive declaration
|
||||
-- groups. It 'backfills' previously-allocated thunk values with the actual evaluation
|
||||
-- procedure for the body of recursive definitions.
|
||||
--
|
||||
-- In order to faithfully evaluate the nonstrict semantics of Cryptol, we have to take some
|
||||
-- care in this process. In particular, we need to ensure that every recursive definition
|
||||
-- binding is indistinguishable from it's eta-expanded form. The straightforward solution
|
||||
-- to this is to force an eta-expansion procedure on all recursive definitions.
|
||||
-- However, for the so-called 'Value' types we can instead optimisticly use the 'delayFill'
|
||||
-- operation and only fall back on full eta expansion if the thunk is double-forced.
|
||||
fillHole :: BitWord b w
|
||||
=> GenEvalEnv b w
|
||||
-> (Name, Schema, Eval (GenValue b w), Eval (GenValue b w) -> Eval ())
|
||||
-> Eval ()
|
||||
fillHole env (nm, sch, _, fill) = do
|
||||
case lookupVar nm env of
|
||||
Nothing -> evalPanic "fillHole" ["Recursive definition not completed", show (ppLocName nm)]
|
||||
Just x
|
||||
| isValueType env sch -> fill =<< delayFill x (etaDelay (show (ppLocName nm)) env sch x)
|
||||
| otherwise -> fill (etaDelay (show (ppLocName nm)) env sch x)
|
||||
|
||||
|
||||
-- | 'Value' types are non-polymorphic types recursive constructed from
|
||||
-- bits, finite sequences, tuples and records. Types of this form can
|
||||
-- be implemented rather more efficently than general types because we can
|
||||
-- rely on the 'delayFill' operation to build a thunk that falls back on performing
|
||||
-- eta-expansion rather than doing it eagerly.
|
||||
isValueType :: GenEvalEnv b w -> Schema -> Bool
|
||||
isValueType env Forall{ sVars = [], sProps = [], sType = t0 }
|
||||
= go (evalValType (envTypes env) t0)
|
||||
where
|
||||
go TVBit = True
|
||||
go (TVSeq _ x) = go x
|
||||
go (TVTuple xs) = and (map go xs)
|
||||
go (TVRec xs) = and (map (go . snd) xs)
|
||||
go _ = False
|
||||
|
||||
isValueType _ _ = False
|
||||
|
||||
|
||||
-- | Eta-expand a word value. This forces an unpacked word representation.
|
||||
etaWord :: BitWord b w
|
||||
=> Integer
|
||||
-> Eval (GenValue b w)
|
||||
-> Eval (WordValue b w)
|
||||
etaWord n x = do
|
||||
w <- delay Nothing (fromWordVal "during eta-expansion" =<< x)
|
||||
return $ BitsVal $ Seq.fromFunction (fromInteger n) $ \i ->
|
||||
do w' <- w; indexWordValue w' (toInteger i)
|
||||
|
||||
|
||||
-- | Given a simulator value and it's type, fully eta-expand the value. This
|
||||
-- is a type-directed pass that always produces a canonical value of the
|
||||
-- expected shape. Eta expansion of values is sometimes necessary to ensure
|
||||
-- the correct evaluation semantics of recursive definitions. Otherwise,
|
||||
-- expressions that should be expected to produce well-defined values in the
|
||||
-- denotational semantics will fail to terminate instead.
|
||||
etaDelay :: BitWord b w
|
||||
=> String
|
||||
-> GenEvalEnv b w
|
||||
-> Schema
|
||||
-> Eval (GenValue b w)
|
||||
-> Eval (GenValue b w)
|
||||
etaDelay msg env0 Forall{ sVars = vs0, sType = tp0 } = goTpVars env0 vs0
|
||||
where
|
||||
-- the final environment is passed in for each declaration, to permit
|
||||
-- recursive values.
|
||||
env' = case dg of
|
||||
Recursive ds -> foldr (evalDecl env') env ds
|
||||
NonRecursive d -> evalDecl env d env
|
||||
goTpVars env [] x = go (evalValType (envTypes env) tp0) x
|
||||
goTpVars env (v:vs) x =
|
||||
case tpKind v of
|
||||
KType -> return $ VPoly $ \t ->
|
||||
goTpVars (bindType (tpVar v) (Right t) env) vs ( ($t) . fromVPoly =<< x )
|
||||
KNum -> return $ VNumPoly $ \n ->
|
||||
goTpVars (bindType (tpVar v) (Left n) env) vs ( ($n) . fromVNumPoly =<< x )
|
||||
k -> panic "[Eval] etaDelay" ["invalid kind on type abstraction", show k]
|
||||
|
||||
evalDecl :: ReadEnv -> Decl -> EvalEnv -> EvalEnv
|
||||
evalDecl renv d =
|
||||
bindVar (dName d) $
|
||||
case dDefinition d of
|
||||
DPrim -> evalPrim d
|
||||
DExpr e -> evalExpr renv e
|
||||
go tp (Ready x) =
|
||||
case x of
|
||||
VBit _ -> return x
|
||||
VWord _ _ -> return x
|
||||
VSeq n xs
|
||||
| TVSeq _nt el <- tp
|
||||
-> return $ VSeq n $ IndexSeqMap $ \i -> go el (lookupSeqMap xs i)
|
||||
|
||||
VStream xs
|
||||
| TVStream el <- tp
|
||||
-> return $ VStream $ IndexSeqMap $ \i -> go el (lookupSeqMap xs i)
|
||||
|
||||
VTuple xs
|
||||
| TVTuple ts <- tp
|
||||
-> return $ VTuple (zipWith go ts xs)
|
||||
|
||||
VRecord fs
|
||||
| TVRec fts <- tp
|
||||
-> return $ VRecord $
|
||||
let err f = evalPanic "expected record value with field" [show f] in
|
||||
[ (f, go (fromMaybe (err f) (lookup f fts)) y)
|
||||
| (f, y) <- fs
|
||||
]
|
||||
|
||||
VFun f
|
||||
| TVFun _t1 t2 <- tp
|
||||
-> return $ VFun $ \a -> go t2 (f a)
|
||||
|
||||
_ -> evalPanic "type mismatch during eta-expansion" []
|
||||
|
||||
go tp x =
|
||||
case tp of
|
||||
TVBit -> x
|
||||
|
||||
TVSeq n TVBit ->
|
||||
do w <- delayFill (fromWordVal "during eta-expansion" =<< x) (etaWord n x)
|
||||
return $ VWord n w
|
||||
|
||||
TVSeq n el ->
|
||||
do x' <- delay (Just msg) (fromSeq "during eta-expansion" =<< x)
|
||||
return $ VSeq n $ IndexSeqMap $ \i -> do
|
||||
go el (flip lookupSeqMap i =<< x')
|
||||
|
||||
TVStream el ->
|
||||
do x' <- delay (Just msg) (fromSeq "during eta-expansion" =<< x)
|
||||
return $ VStream $ IndexSeqMap $ \i ->
|
||||
go el (flip lookupSeqMap i =<< x')
|
||||
|
||||
TVFun _t1 t2 ->
|
||||
do x' <- delay (Just msg) (fromVFun <$> x)
|
||||
return $ VFun $ \a -> go t2 ( ($a) =<< x' )
|
||||
|
||||
TVTuple ts ->
|
||||
do let n = length ts
|
||||
x' <- delay (Just msg) (fromVTuple <$> x)
|
||||
return $ VTuple $
|
||||
[ go t =<< (flip genericIndex i <$> x')
|
||||
| i <- [0..(n-1)]
|
||||
| t <- ts
|
||||
]
|
||||
|
||||
TVRec fs ->
|
||||
do x' <- delay (Just msg) (fromVRecord <$> x)
|
||||
let err f = evalPanic "expected record value with field" [show f]
|
||||
return $ VRecord $
|
||||
[ (f, go t =<< (fromMaybe (err f) . lookup f <$> x'))
|
||||
| (f,t) <- fs
|
||||
]
|
||||
|
||||
|
||||
declHole :: Decl
|
||||
-> Eval (Name, Schema, Eval (GenValue b w), Eval (GenValue b w) -> Eval ())
|
||||
declHole d =
|
||||
case dDefinition d of
|
||||
DPrim -> evalPanic "Unexpected primitive declaration in recursive group"
|
||||
[show (ppLocName nm)]
|
||||
DExpr _ -> do
|
||||
(hole, fill) <- blackhole msg
|
||||
return (nm, sch, hole, fill)
|
||||
where
|
||||
nm = dName d
|
||||
sch = dSignature d
|
||||
msg = unwords ["<<loop>> while evaluating", show (pp nm)]
|
||||
|
||||
|
||||
-- | Evaluate a declaration, extending the evaluation environment.
|
||||
-- Two input environments are given: the first is an environment
|
||||
-- to use when evaluating the body of the declaration; the second
|
||||
-- is the environment to extend. There are two environments to
|
||||
-- handle the subtle name-binding issues that arise from recursive
|
||||
-- definitions. The 'read only' environment is used to bring recursive
|
||||
-- names into scope while we are still defining them.
|
||||
evalDecl :: EvalPrims b w
|
||||
=> GenEvalEnv b w -- ^ A 'read only' environment for use in declaration bodies
|
||||
-> GenEvalEnv b w -- ^ An evaluation environment to extend with the given declaration
|
||||
-> Decl -- ^ The declaration to evaluate
|
||||
-> Eval (GenEvalEnv b w)
|
||||
evalDecl renv env d =
|
||||
case dDefinition d of
|
||||
DPrim -> bindVarDirect (dName d) (evalPrim d) env
|
||||
DExpr e -> bindVar (dName d) (evalExpr renv e) env
|
||||
|
||||
|
||||
-- Selectors -------------------------------------------------------------------
|
||||
|
||||
evalSel :: ReadEnv -> Expr -> Selector -> Value
|
||||
evalSel env e sel = case sel of
|
||||
-- | Apply the the given "selector" form to the given value. This function pushes
|
||||
-- tuple and record selections pointwise down into other value constructs
|
||||
-- (e.g., streams and functions).
|
||||
evalSel :: forall b w
|
||||
. EvalPrims b w
|
||||
=> GenValue b w
|
||||
-> Selector
|
||||
-> Eval (GenValue b w)
|
||||
evalSel val sel = case sel of
|
||||
|
||||
TupleSel n _ -> tupleSel n val
|
||||
RecordSel n _ -> recordSel n val
|
||||
ListSel ix _ -> fromSeq val !! ix
|
||||
|
||||
ListSel ix _ -> listSel ix val
|
||||
where
|
||||
|
||||
val = evalExpr env e
|
||||
|
||||
tupleSel n v =
|
||||
case v of
|
||||
VTuple vs -> vs !! n
|
||||
VSeq False vs -> VSeq False [ tupleSel n v1 | v1 <- vs ]
|
||||
VStream vs -> VStream [ tupleSel n v1 | v1 <- vs ]
|
||||
VFun f -> VFun (\x -> tupleSel n (f x))
|
||||
_ -> evalPanic "Cryptol.Eval.evalSel"
|
||||
[ "Unexpected value in tuple selection"
|
||||
, show (ppValue defaultPPOpts v) ]
|
||||
VTuple vs -> vs !! n
|
||||
VSeq w vs -> VSeq w <$> mapSeqMap (tupleSel n) vs
|
||||
VStream vs -> VStream <$> mapSeqMap (tupleSel n) vs
|
||||
VFun f -> return $ VFun (\x -> tupleSel n =<< f x)
|
||||
_ -> do vdoc <- ppValue defaultPPOpts v
|
||||
evalPanic "Cryptol.Eval.evalSel"
|
||||
[ "Unexpected value in tuple selection"
|
||||
, show vdoc ]
|
||||
|
||||
recordSel n v =
|
||||
case v of
|
||||
VRecord {} -> lookupRecord n v
|
||||
VSeq False vs -> VSeq False [ recordSel n v1 | v1 <- vs ]
|
||||
VStream vs -> VStream [recordSel n v1 | v1 <- vs ]
|
||||
VFun f -> VFun (\x -> recordSel n (f x))
|
||||
_ -> evalPanic "Cryptol.Eval.evalSel"
|
||||
[ "Unexpected value in record selection"
|
||||
, show (ppValue defaultPPOpts v) ]
|
||||
VRecord {} -> lookupRecord n v
|
||||
VSeq w vs -> VSeq w <$> mapSeqMap (recordSel n) vs
|
||||
VStream vs -> VStream <$> mapSeqMap (recordSel n) vs
|
||||
VFun f -> return $ VFun (\x -> recordSel n =<< f x)
|
||||
_ -> do vdoc <- ppValue defaultPPOpts v
|
||||
evalPanic "Cryptol.Eval.evalSel"
|
||||
[ "Unexpected value in record selection"
|
||||
, show vdoc ]
|
||||
|
||||
listSel n v =
|
||||
case v of
|
||||
VSeq _ vs -> lookupSeqMap vs (toInteger n)
|
||||
VStream vs -> lookupSeqMap vs (toInteger n)
|
||||
VWord _ wv -> VBit <$> (flip indexWordValue (toInteger n) =<< wv)
|
||||
_ -> do vdoc <- ppValue defaultPPOpts val
|
||||
evalPanic "Cryptol.Eval.evalSel"
|
||||
[ "Unexpected value in list selection"
|
||||
, show vdoc ]
|
||||
|
||||
|
||||
|
||||
|
||||
-- List Comprehension Environments ---------------------------------------------
|
||||
|
||||
-- | A variation of the ZipList type from Control.Applicative, with a
|
||||
-- separate constructor for pure values. This datatype is used to
|
||||
-- represent the list of values that each variable takes on within a
|
||||
-- list comprehension. The @Zip@ constructor is for bindings that take
|
||||
-- different values at different positions in the list, while the
|
||||
-- @Pure@ constructor is for bindings originating outside the list
|
||||
-- comprehension, which have the same value for all list positions.
|
||||
data ZList a = Pure a | Zip [a]
|
||||
|
||||
getZList :: ZList a -> [a]
|
||||
getZList (Pure x) = repeat x
|
||||
getZList (Zip xs) = xs
|
||||
|
||||
instance Functor ZList where
|
||||
fmap f (Pure x) = Pure (f x)
|
||||
fmap f (Zip xs) = Zip (map f xs)
|
||||
|
||||
instance Applicative ZList where
|
||||
pure x = Pure x
|
||||
Pure f <*> Pure x = Pure (f x)
|
||||
Pure f <*> Zip xs = Zip (map f xs)
|
||||
Zip fs <*> Pure x = Zip (map ($ x) fs)
|
||||
Zip fs <*> Zip xs = Zip (zipWith ($) fs xs)
|
||||
|
||||
-- | Evaluation environments for list comprehensions: Each variable
|
||||
-- name is bound to a list of values, one for each element in the list
|
||||
-- comprehension.
|
||||
data ListEnv = ListEnv
|
||||
{ leVars :: Map.Map Name (ZList Value)
|
||||
, leTypes :: Map.Map TVar (Either Nat' TValue)
|
||||
data ListEnv b w = ListEnv
|
||||
{ leVars :: !(Map.Map Name (Integer -> Eval (GenValue b w)))
|
||||
-- ^ Bindings whose values vary by position
|
||||
, leStatic :: !(Map.Map Name (Eval (GenValue b w)))
|
||||
-- ^ Bindings whose values are constant
|
||||
, leTypes :: !TypeEnv
|
||||
}
|
||||
|
||||
instance Monoid ListEnv where
|
||||
instance Monoid (ListEnv b w) where
|
||||
mempty = ListEnv
|
||||
{ leVars = Map.empty
|
||||
, leTypes = Map.empty
|
||||
{ leVars = Map.empty
|
||||
, leStatic = Map.empty
|
||||
, leTypes = Map.empty
|
||||
}
|
||||
|
||||
mappend l r = ListEnv
|
||||
{ leVars = Map.union (leVars l) (leVars r)
|
||||
, leTypes = Map.union (leTypes l) (leTypes r)
|
||||
{ leVars = Map.union (leVars l) (leVars r)
|
||||
, leStatic = Map.union (leStatic l) (leStatic r)
|
||||
, leTypes = Map.union (leTypes l) (leTypes r)
|
||||
}
|
||||
|
||||
toListEnv :: EvalEnv -> ListEnv
|
||||
toListEnv :: GenEvalEnv b w -> ListEnv b w
|
||||
toListEnv e =
|
||||
ListEnv
|
||||
{ leVars = fmap Pure (envVars e)
|
||||
, leTypes = envTypes e
|
||||
{ leVars = mempty
|
||||
, leStatic = envVars e
|
||||
, leTypes = envTypes e
|
||||
}
|
||||
|
||||
-- | Take parallel slices of the list environment. If some names are
|
||||
-- bound to longer lists of values (e.g. if they come from a different
|
||||
-- parallel branch of a comprehension) then the last elements will be
|
||||
-- dropped as the lists are zipped together.
|
||||
zipListEnv :: ListEnv -> [EvalEnv]
|
||||
zipListEnv (ListEnv vm tm) =
|
||||
[ EvalEnv { envVars = v, envTypes = tm }
|
||||
| v <- getZList (sequenceA vm) ]
|
||||
|
||||
bindVarList :: Name -> [Value] -> ListEnv -> ListEnv
|
||||
bindVarList n vs lenv = lenv { leVars = Map.insert n (Zip vs) (leVars lenv) }
|
||||
-- | Evaluate a list environment at a position.
|
||||
-- This choses a particular value for the varying
|
||||
-- locations.
|
||||
evalListEnv :: ListEnv b w -> Integer -> GenEvalEnv b w
|
||||
evalListEnv (ListEnv vm st tm) i =
|
||||
let v = fmap ($i) vm
|
||||
in EvalEnv{ envVars = Map.union v st
|
||||
, envTypes = tm
|
||||
}
|
||||
|
||||
bindVarList :: Name
|
||||
-> (Integer -> Eval (GenValue b w))
|
||||
-> ListEnv b w
|
||||
-> ListEnv b w
|
||||
bindVarList n vs lenv = lenv { leVars = Map.insert n vs (leVars lenv) }
|
||||
|
||||
-- List Comprehensions ---------------------------------------------------------
|
||||
|
||||
-- | Evaluate a comprehension.
|
||||
evalComp :: ReadEnv -> TValue -> Expr -> [[Match]] -> Value
|
||||
evalComp env seqty body ms =
|
||||
case isTSeq seqty of
|
||||
Just (len, el) -> toSeq len el [ evalExpr e body | e <- envs ]
|
||||
_ -> evalPanic "Cryptol.Eval" ["evalComp given a non sequence", show seqty]
|
||||
|
||||
-- XXX we could potentially print this as a number if the type was available.
|
||||
where
|
||||
-- generate a new environment for each iteration of each parallel branch
|
||||
benvs :: [ListEnv]
|
||||
benvs = map (branchEnvs (toListEnv env)) ms
|
||||
|
||||
-- join environments to produce environments at each step through the process.
|
||||
envs :: [EvalEnv]
|
||||
envs = zipListEnv (mconcat benvs)
|
||||
evalComp :: EvalPrims b w
|
||||
=> GenEvalEnv b w -- ^ Starting evaluation environment
|
||||
-> Nat' -- ^ Length of the comprehension
|
||||
-> TValue -- ^ Type of the comprehension elements
|
||||
-> Expr -- ^ Head expression of the comprehension
|
||||
-> [[Match]] -- ^ List of parallel comprehension branches
|
||||
-> Eval (GenValue b w)
|
||||
evalComp env len elty body ms =
|
||||
do lenv <- mconcat <$> mapM (branchEnvs (toListEnv env)) ms
|
||||
mkSeq len elty <$> memoMap (IndexSeqMap $ \i -> do
|
||||
evalExpr (evalListEnv lenv i) body)
|
||||
|
||||
-- | Turn a list of matches into the final environments for each iteration of
|
||||
-- the branch.
|
||||
branchEnvs :: ListEnv -> [Match] -> ListEnv
|
||||
branchEnvs env matches = foldl evalMatch env matches
|
||||
branchEnvs :: EvalPrims b w
|
||||
=> ListEnv b w
|
||||
-> [Match]
|
||||
-> Eval (ListEnv b w)
|
||||
branchEnvs env matches = foldM evalMatch env matches
|
||||
|
||||
-- | Turn a match into the list of environments it represents.
|
||||
evalMatch :: ListEnv -> Match -> ListEnv
|
||||
evalMatch :: EvalPrims b w
|
||||
=> ListEnv b w
|
||||
-> Match
|
||||
-> Eval (ListEnv b w)
|
||||
evalMatch lenv m = case m of
|
||||
|
||||
-- many envs
|
||||
From n _ty expr -> bindVarList n (concat vss) lenv'
|
||||
From n l _ty expr ->
|
||||
case len of
|
||||
-- Select from a sequence of finite length. This causes us to 'stutter'
|
||||
-- through our previous choices `nLen` times.
|
||||
Nat nLen -> do
|
||||
vss <- memoMap $ IndexSeqMap $ \i -> evalExpr (evalListEnv lenv i) expr
|
||||
let stutter xs = \i -> xs (i `div` nLen)
|
||||
let lenv' = lenv { leVars = fmap stutter (leVars lenv) }
|
||||
let vs i = do let (q, r) = i `divMod` nLen
|
||||
lookupSeqMap vss q >>= \case
|
||||
VWord _ w -> VBit <$> (flip indexWordValue r =<< w)
|
||||
VSeq _ xs' -> lookupSeqMap xs' r
|
||||
VStream xs' -> lookupSeqMap xs' r
|
||||
_ -> evalPanic "evalMatch" ["Not a list value"]
|
||||
return $ bindVarList n vs lenv'
|
||||
|
||||
-- Select from a sequence of infinite length. Note that this means we
|
||||
-- will never need to backtrack into previous branches. Thus, we can convert
|
||||
-- `leVars` elements of the comprehension environment into `leStatic` elements
|
||||
-- by selecting out the 0th element.
|
||||
Inf -> do
|
||||
let allvars = Map.union (fmap ($0) (leVars lenv)) (leStatic lenv)
|
||||
let lenv' = lenv { leVars = Map.empty
|
||||
, leStatic = allvars
|
||||
}
|
||||
let env = EvalEnv allvars (leTypes lenv)
|
||||
xs <- evalExpr env expr
|
||||
let vs i = case xs of
|
||||
VWord _ w -> VBit <$> (flip indexWordValue i =<< w)
|
||||
VSeq _ xs' -> lookupSeqMap xs' i
|
||||
VStream xs' -> lookupSeqMap xs' i
|
||||
_ -> evalPanic "evalMatch" ["Not a list value"]
|
||||
return $ bindVarList n vs lenv'
|
||||
|
||||
where
|
||||
vss = [ fromSeq (evalExpr env expr) | env <- zipListEnv lenv ]
|
||||
stutter (Pure x) = Pure x
|
||||
stutter (Zip xs) = Zip [ x | (x, vs) <- zip xs vss, _ <- vs ]
|
||||
lenv' = lenv { leVars = fmap stutter (leVars lenv) }
|
||||
len = evalNumType (leTypes lenv) l
|
||||
|
||||
-- XXX we don't currently evaluate these as though they could be recursive, as
|
||||
-- they are typechecked that way; the read environment to evalExpr is the same
|
||||
-- as the environment to bind a new name in.
|
||||
Let d -> bindVarList (dName d) (map f (zipListEnv lenv)) lenv
|
||||
where f env =
|
||||
case dDefinition d of
|
||||
DPrim -> evalPrim d
|
||||
DExpr e -> evalExpr env e
|
||||
Let d -> return $ bindVarList (dName d) (\i -> f (evalListEnv lenv i)) lenv
|
||||
where
|
||||
f env =
|
||||
case dDefinition d of
|
||||
-- Primitives here should never happen, I think...
|
||||
-- perhaps this should be converted to an error.
|
||||
DPrim -> return $ evalPrim d
|
||||
DExpr e -> evalExpr env e
|
||||
|
@ -14,13 +14,16 @@
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
module Cryptol.Eval.Env where
|
||||
|
||||
import Cryptol.Eval.Monad( Eval, delay, ready )
|
||||
import Cryptol.Eval.Type
|
||||
import Cryptol.Eval.Value
|
||||
import Cryptol.ModuleSystem.Name
|
||||
import Cryptol.TypeCheck.AST
|
||||
import Cryptol.TypeCheck.Solver.InfNat (Nat'(..))
|
||||
import Cryptol.TypeCheck.Solver.InfNat
|
||||
import Cryptol.Utils.PP
|
||||
|
||||
import qualified Data.Map as Map
|
||||
|
||||
import qualified Data.Map.Strict as Map
|
||||
|
||||
import GHC.Generics (Generic)
|
||||
import Control.DeepSeq
|
||||
@ -30,14 +33,12 @@ import Prelude.Compat
|
||||
|
||||
-- Evaluation Environment ------------------------------------------------------
|
||||
|
||||
type ReadEnv = EvalEnv
|
||||
|
||||
data EvalEnv = EvalEnv
|
||||
{ envVars :: Map.Map Name Value
|
||||
, envTypes :: Map.Map TVar (Either Nat' TValue)
|
||||
data GenEvalEnv b w = EvalEnv
|
||||
{ envVars :: !(Map.Map Name (Eval (GenValue b w)))
|
||||
, envTypes :: !TypeEnv
|
||||
} deriving (Generic, NFData)
|
||||
|
||||
instance Monoid EvalEnv where
|
||||
instance Monoid (GenEvalEnv b w) where
|
||||
mempty = EvalEnv
|
||||
{ envVars = Map.empty
|
||||
, envTypes = Map.empty
|
||||
@ -48,26 +49,47 @@ instance Monoid EvalEnv where
|
||||
, envTypes = Map.union (envTypes l) (envTypes r)
|
||||
}
|
||||
|
||||
instance PP (WithBase EvalEnv) where
|
||||
ppPrec _ (WithBase opts env) = brackets (fsep (map bind (Map.toList (envVars env))))
|
||||
where
|
||||
bind (k,v) = pp k <+> text "->" <+> ppValue opts v
|
||||
ppEnv :: BitWord b w => PPOpts -> GenEvalEnv b w -> Eval Doc
|
||||
ppEnv opts env = brackets . fsep <$> mapM bind (Map.toList (envVars env))
|
||||
where
|
||||
bind (k,v) = do vdoc <- ppValue opts =<< v
|
||||
return (pp k <+> text "->" <+> vdoc)
|
||||
|
||||
emptyEnv :: EvalEnv
|
||||
-- | Evaluation environment with no bindings
|
||||
emptyEnv :: GenEvalEnv b w
|
||||
emptyEnv = mempty
|
||||
|
||||
-- | Bind a variable in the evaluation environment.
|
||||
bindVar :: Name -> Value -> EvalEnv -> EvalEnv
|
||||
bindVar n val env = env { envVars = Map.insert n val (envVars env) }
|
||||
bindVar :: Name
|
||||
-> Eval (GenValue b w)
|
||||
-> GenEvalEnv b w
|
||||
-> Eval (GenEvalEnv b w)
|
||||
bindVar n val env = do
|
||||
let nm = show $ ppLocName n
|
||||
val' <- delay (Just nm) val
|
||||
return $ env{ envVars = Map.insert n val' (envVars env) }
|
||||
|
||||
-- | Bind a variable to a value in the evaluation environment, without
|
||||
-- creating a thunk.
|
||||
bindVarDirect :: Name
|
||||
-> GenValue b w
|
||||
-> GenEvalEnv b w
|
||||
-> Eval (GenEvalEnv b w)
|
||||
bindVarDirect n val env = do
|
||||
return $ env{ envVars = Map.insert n (ready val) (envVars env) }
|
||||
|
||||
-- | Lookup a variable in the environment.
|
||||
lookupVar :: Name -> EvalEnv -> Maybe Value
|
||||
{-# INLINE lookupVar #-}
|
||||
lookupVar :: Name -> GenEvalEnv b w -> Maybe (Eval (GenValue b w))
|
||||
lookupVar n env = Map.lookup n (envVars env)
|
||||
|
||||
-- | Bind a type variable of kind # or *.
|
||||
bindType :: TVar -> Either Nat' TValue -> EvalEnv -> EvalEnv
|
||||
-- | Bind a type variable of kind *.
|
||||
{-# INLINE bindType #-}
|
||||
bindType :: TVar -> Either Nat' TValue -> GenEvalEnv b w -> GenEvalEnv b w
|
||||
bindType p ty env = env { envTypes = Map.insert p ty (envTypes env) }
|
||||
|
||||
-- | Lookup a type variable.
|
||||
lookupType :: TVar -> EvalEnv -> Maybe (Either Nat' TValue)
|
||||
{-# INLINE lookupType #-}
|
||||
lookupType :: TVar -> GenEvalEnv b w -> Maybe (Either Nat' TValue)
|
||||
lookupType p env = Map.lookup p (envTypes env)
|
||||
|
||||
|
@ -1,69 +0,0 @@
|
||||
-- |
|
||||
-- Module : $Header$
|
||||
-- Copyright : (c) 2013-2016 Galois, Inc.
|
||||
-- License : BSD3
|
||||
-- Maintainer : cryptol@galois.com
|
||||
-- Stability : provisional
|
||||
-- Portability : portable
|
||||
|
||||
{-# LANGUAGE Safe #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
|
||||
module Cryptol.Eval.Error where
|
||||
|
||||
import Cryptol.Utils.Panic
|
||||
import Cryptol.Utils.PP
|
||||
import Cryptol.TypeCheck.AST(Type)
|
||||
|
||||
import Data.Typeable (Typeable)
|
||||
import qualified Control.Exception as X
|
||||
|
||||
|
||||
-- Errors ----------------------------------------------------------------------
|
||||
|
||||
-- | Panic from an Eval context.
|
||||
evalPanic :: String -> [String] -> a
|
||||
evalPanic cxt = panic ("[Eval] " ++ cxt)
|
||||
|
||||
|
||||
data EvalError
|
||||
= InvalidIndex Integer
|
||||
| TypeCannotBeDemoted Type
|
||||
| DivideByZero
|
||||
| WordTooWide Integer
|
||||
| UserError String
|
||||
deriving (Typeable,Show)
|
||||
|
||||
instance PP EvalError where
|
||||
ppPrec _ e = case e of
|
||||
InvalidIndex i -> text "invalid sequence index:" <+> integer i
|
||||
TypeCannotBeDemoted t -> text "type cannot be demoted:" <+> pp t
|
||||
DivideByZero -> text "division by 0"
|
||||
WordTooWide w ->
|
||||
text "word too wide for memory:" <+> integer w <+> text "bits"
|
||||
UserError x -> text "Run-time error:" <+> text x
|
||||
|
||||
instance X.Exception EvalError
|
||||
|
||||
-- | A sequencing operation has gotten an invalid index.
|
||||
invalidIndex :: Integer -> a
|
||||
invalidIndex i = X.throw (InvalidIndex i)
|
||||
|
||||
-- | For things like `(inf) or `(0-1)
|
||||
typeCannotBeDemoted :: Type -> a
|
||||
typeCannotBeDemoted t = X.throw (TypeCannotBeDemoted t)
|
||||
|
||||
-- | For division by 0.
|
||||
divideByZero :: a
|
||||
divideByZero = X.throw DivideByZero
|
||||
|
||||
-- | For when we know that a word is too wide and will exceed gmp's
|
||||
-- limits (though words approaching this size will probably cause the
|
||||
-- system to crash anyway due to lack of memory)
|
||||
wordTooWide :: Integer -> a
|
||||
wordTooWide w = X.throw (WordTooWide w)
|
||||
|
||||
-- | For `error`
|
||||
cryUserError :: String -> a
|
||||
cryUserError msg = X.throw (UserError msg)
|
||||
|
210
src/Cryptol/Eval/Monad.hs
Normal file
210
src/Cryptol/Eval/Monad.hs
Normal file
@ -0,0 +1,210 @@
|
||||
-- |
|
||||
-- Module : $Header$
|
||||
-- Copyright : (c) 2013-2016 Galois, Inc.
|
||||
-- License : BSD3
|
||||
-- Maintainer : cryptol@galois.com
|
||||
-- Stability : provisional
|
||||
-- Portability : portable
|
||||
|
||||
{-# LANGUAGE Safe #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE DeriveFunctor #-}
|
||||
|
||||
module Cryptol.Eval.Monad
|
||||
( -- * Evaluation monad
|
||||
Eval(..)
|
||||
, runEval
|
||||
, io
|
||||
, delay
|
||||
, delayFill
|
||||
, ready
|
||||
, blackhole
|
||||
-- * Error reporting
|
||||
, EvalError(..)
|
||||
, evalPanic
|
||||
, typeCannotBeDemoted
|
||||
, divideByZero
|
||||
, wordTooWide
|
||||
, cryUserError
|
||||
, cryLoopError
|
||||
, invalidIndex
|
||||
) where
|
||||
|
||||
import Control.DeepSeq
|
||||
import Control.Monad
|
||||
import Control.Monad.Fix
|
||||
import Control.Monad.IO.Class
|
||||
import Data.IORef
|
||||
import Data.Typeable (Typeable)
|
||||
import qualified Control.Exception as X
|
||||
|
||||
|
||||
import Cryptol.Utils.Panic
|
||||
import Cryptol.Utils.PP
|
||||
import Cryptol.TypeCheck.AST(Type)
|
||||
|
||||
-- | A computation that returns an already-evaluated value.
|
||||
ready :: a -> Eval a
|
||||
ready a = Ready a
|
||||
|
||||
-- | The monad for Cryptol evaluation.
|
||||
data Eval a
|
||||
= Ready !a
|
||||
| Thunk !(IO a)
|
||||
|
||||
data ThunkState a
|
||||
= Unforced -- ^ This thunk has not yet been forced
|
||||
| BlackHole -- ^ This thunk is currently being evaluated
|
||||
| Forced !a -- ^ This thunk has previously been forced, and has the given value
|
||||
|
||||
{-# INLINE delay #-}
|
||||
-- | Delay the given evaluation computation, returning a thunk
|
||||
-- which will run the computation when forced. Raise a loop
|
||||
-- error if the resulting thunk is forced during its own evaluation.
|
||||
delay :: Maybe String -- ^ Optional name to print if a loop is detected
|
||||
-> Eval a -- ^ Computation to delay
|
||||
-> Eval (Eval a)
|
||||
delay _ (Ready a) = Ready (Ready a)
|
||||
delay msg (Thunk x) = Thunk $ do
|
||||
let msg' = maybe "" ("while evaluating "++) msg
|
||||
let retry = cryLoopError msg'
|
||||
r <- newIORef Unforced
|
||||
return $ unDelay retry r x
|
||||
|
||||
{-# INLINE delayFill #-}
|
||||
|
||||
-- | Delay the given evaluation computation, returning a thunk
|
||||
-- which will run the computation when forced. Run the 'retry'
|
||||
-- computation instead if the resulting thunk is forced during
|
||||
-- its own evaluation.
|
||||
delayFill :: Eval a -- ^ Computation to delay
|
||||
-> Eval a -- ^ Backup computation to run if a tight loop is detected
|
||||
-> Eval (Eval a)
|
||||
delayFill (Ready x) _ = Ready (Ready x)
|
||||
delayFill (Thunk x) retry = Thunk $ do
|
||||
r <- newIORef Unforced
|
||||
return $ unDelay retry r x
|
||||
|
||||
-- | Produce a thunk value which can be filled with its associated computation
|
||||
-- after the fact. A preallocated thunk is returned, along with an operation to
|
||||
-- fill the thunk with the associated computation.
|
||||
-- This is used to implement recursive declaration groups.
|
||||
blackhole :: String -- ^ A name to associate with this thunk.
|
||||
-> Eval (Eval a, Eval a -> Eval ())
|
||||
blackhole msg = do
|
||||
r <- io $ newIORef (fail msg)
|
||||
let get = join (io $ readIORef r)
|
||||
let set = io . writeIORef r
|
||||
return (get, set)
|
||||
|
||||
unDelay :: Eval a -> IORef (ThunkState a) -> IO a -> Eval a
|
||||
unDelay retry r x = do
|
||||
rval <- io $ readIORef r
|
||||
case rval of
|
||||
Forced val -> return val
|
||||
BlackHole ->
|
||||
retry
|
||||
Unforced -> io $ do
|
||||
writeIORef r BlackHole
|
||||
val <- x
|
||||
writeIORef r (Forced val)
|
||||
return val
|
||||
|
||||
-- | Execute the given evaluation action.
|
||||
runEval :: Eval a -> IO a
|
||||
runEval (Ready a) = return a
|
||||
runEval (Thunk x) = x
|
||||
|
||||
{-# INLINE evalBind #-}
|
||||
evalBind :: Eval a -> (a -> Eval b) -> Eval b
|
||||
evalBind (Ready a) f = f a
|
||||
evalBind (Thunk x) f = Thunk (x >>= runEval . f)
|
||||
|
||||
instance Functor Eval where
|
||||
fmap f (Ready x) = Ready (f x)
|
||||
fmap f (Thunk m) = Thunk (f <$> m)
|
||||
{-# INLINE fmap #-}
|
||||
|
||||
instance Applicative Eval where
|
||||
pure = return
|
||||
(<*>) = ap
|
||||
{-# INLINE pure #-}
|
||||
{-# INLINE (<*>) #-}
|
||||
|
||||
instance Monad Eval where
|
||||
return = Ready
|
||||
fail = Thunk . fail
|
||||
(>>=) = evalBind
|
||||
{-# INLINE return #-}
|
||||
{-# INLINE (>>=) #-}
|
||||
|
||||
instance MonadIO Eval where
|
||||
liftIO = io
|
||||
|
||||
instance NFData a => NFData (Eval a) where
|
||||
rnf (Ready a) = rnf a
|
||||
rnf (Thunk _) = ()
|
||||
|
||||
instance MonadFix Eval where
|
||||
mfix f = Thunk $ mfix (\x -> runEval (f x))
|
||||
|
||||
-- | Lift an 'IO' computation into the 'Eval' monad.
|
||||
io :: IO a -> Eval a
|
||||
io = Thunk
|
||||
{-# INLINE io #-}
|
||||
|
||||
|
||||
-- Errors ----------------------------------------------------------------------
|
||||
|
||||
-- | Panic from an @Eval@ context.
|
||||
evalPanic :: String -> [String] -> a
|
||||
evalPanic cxt = panic ("[Eval] " ++ cxt)
|
||||
|
||||
|
||||
-- | Data type describing errors that can occur during evaluation.
|
||||
data EvalError
|
||||
= InvalidIndex Integer -- ^ Out-of-bounds index
|
||||
| TypeCannotBeDemoted Type -- ^ Non-numeric type passed to demote function
|
||||
| DivideByZero -- ^ Division or modulus by 0
|
||||
| WordTooWide Integer -- ^ Bitvector too large
|
||||
| UserError String -- ^ Call to the Cryptol @error@ primitive
|
||||
| LoopError String -- ^ Detectable nontermination
|
||||
deriving (Typeable,Show)
|
||||
|
||||
instance PP EvalError where
|
||||
ppPrec _ e = case e of
|
||||
InvalidIndex i -> text "invalid sequence index:" <+> integer i
|
||||
TypeCannotBeDemoted t -> text "type cannot be demoted:" <+> pp t
|
||||
DivideByZero -> text "division by 0"
|
||||
WordTooWide w ->
|
||||
text "word too wide for memory:" <+> integer w <+> text "bits"
|
||||
UserError x -> text "Run-time error:" <+> text x
|
||||
LoopError x -> text "<<loop>>" <+> text x
|
||||
|
||||
instance X.Exception EvalError
|
||||
|
||||
-- | For things like @`(inf)@ or @`(0-1)@.
|
||||
typeCannotBeDemoted :: Type -> a
|
||||
typeCannotBeDemoted t = X.throw (TypeCannotBeDemoted t)
|
||||
|
||||
-- | For division by 0.
|
||||
divideByZero :: Eval a
|
||||
divideByZero = Thunk (X.throwIO DivideByZero)
|
||||
|
||||
-- | For when we know that a word is too wide and will exceed gmp's
|
||||
-- limits (though words approaching this size will probably cause the
|
||||
-- system to crash anyway due to lack of memory).
|
||||
wordTooWide :: Integer -> a
|
||||
wordTooWide w = X.throw (WordTooWide w)
|
||||
|
||||
-- | For the Cryptol @error@ function.
|
||||
cryUserError :: String -> Eval a
|
||||
cryUserError msg = Thunk (X.throwIO (UserError msg))
|
||||
|
||||
-- | For cases where we can detect tight loops.
|
||||
cryLoopError :: String -> Eval a
|
||||
cryLoopError msg = Thunk (X.throwIO (LoopError msg))
|
||||
|
||||
-- | A sequencing operation has gotten an invalid index.
|
||||
invalidIndex :: Integer -> Eval a
|
||||
invalidIndex i = Thunk (X.throwIO (InvalidIndex i))
|
1090
src/Cryptol/Eval/Reference.lhs
Normal file
1090
src/Cryptol/Eval/Reference.lhs
Normal file
File diff suppressed because it is too large
Load Diff
@ -7,26 +7,80 @@
|
||||
-- Portability : portable
|
||||
|
||||
{-# LANGUAGE Safe, PatternGuards #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
module Cryptol.Eval.Type where
|
||||
|
||||
module Cryptol.Eval.Type (evalType, evalValType, evalNumType, evalTF) where
|
||||
|
||||
import Cryptol.Eval.Env
|
||||
import Cryptol.Eval.Error
|
||||
import Cryptol.Eval.Value (TValue(..), tvSeq)
|
||||
import Cryptol.Eval.Monad
|
||||
import Cryptol.TypeCheck.AST
|
||||
import Cryptol.TypeCheck.PP(pp)
|
||||
import Cryptol.TypeCheck.Solver.InfNat
|
||||
import Cryptol.Utils.Panic (panic)
|
||||
import Cryptol.Utils.Ident (Ident)
|
||||
|
||||
import Data.Maybe(fromMaybe)
|
||||
import qualified Data.Map.Strict as Map
|
||||
import GHC.Generics (Generic)
|
||||
import Control.DeepSeq
|
||||
|
||||
-- | An evaluated type of kind *.
|
||||
-- These types do not contain type variables, type synonyms, or type functions.
|
||||
data TValue
|
||||
= TVBit -- ^ @ Bit @
|
||||
| TVSeq Integer TValue -- ^ @ [n]a @
|
||||
| TVStream TValue -- ^ @ [inf]t @
|
||||
| TVTuple [TValue] -- ^ @ (a, b, c )@
|
||||
| TVRec [(Ident, TValue)] -- ^ @ { x : a, y : b, z : c } @
|
||||
| TVFun TValue TValue -- ^ @ a -> b @
|
||||
deriving (Generic, NFData)
|
||||
|
||||
-- | Convert a type value back into a regular type
|
||||
tValTy :: TValue -> Type
|
||||
tValTy tv =
|
||||
case tv of
|
||||
TVBit -> tBit
|
||||
TVSeq n t -> tSeq (tNum n) (tValTy t)
|
||||
TVStream t -> tSeq tInf (tValTy t)
|
||||
TVTuple ts -> tTuple (map tValTy ts)
|
||||
TVRec fs -> tRec [ (f, tValTy t) | (f, t) <- fs ]
|
||||
TVFun t1 t2 -> tFun (tValTy t1) (tValTy t2)
|
||||
|
||||
instance Show TValue where
|
||||
showsPrec p v = showsPrec p (tValTy v)
|
||||
|
||||
|
||||
-- Utilities -------------------------------------------------------------------
|
||||
|
||||
-- | True if the evaluated value is @Bit@
|
||||
isTBit :: TValue -> Bool
|
||||
isTBit TVBit = True
|
||||
isTBit _ = False
|
||||
|
||||
-- | Produce a sequence type value
|
||||
tvSeq :: Nat' -> TValue -> TValue
|
||||
tvSeq (Nat n) t = TVSeq n t
|
||||
tvSeq Inf t = TVStream t
|
||||
|
||||
-- | Coerce an extended natural into an integer,
|
||||
-- for values known to be finite
|
||||
finNat' :: Nat' -> Integer
|
||||
finNat' n' =
|
||||
case n' of
|
||||
Nat x -> x
|
||||
Inf -> panic "Cryptol.Eval.Value.finNat'" [ "Unexpected `inf`" ]
|
||||
|
||||
|
||||
-- Type Evaluation -------------------------------------------------------------
|
||||
|
||||
type TypeEnv = Map.Map TVar (Either Nat' TValue)
|
||||
|
||||
|
||||
-- | Evaluation for types (kind * or #).
|
||||
evalType :: EvalEnv -> Type -> Either Nat' TValue
|
||||
evalType :: TypeEnv -> Type -> Either Nat' TValue
|
||||
evalType env ty =
|
||||
case ty of
|
||||
TVar tv ->
|
||||
case lookupType tv env of
|
||||
case Map.lookup tv env of
|
||||
Just v -> v
|
||||
Nothing -> evalPanic "evalType" ["type variable not bound", show tv]
|
||||
|
||||
@ -44,23 +98,27 @@ evalType env ty =
|
||||
_ -> evalPanic "evalType" ["not a value type", show ty]
|
||||
TCon (TF f) ts -> Left $ evalTF f (map num ts)
|
||||
TCon (PC p) _ -> evalPanic "evalType" ["invalid predicate symbol", show p]
|
||||
TCon (TError _ x) _ -> evalPanic "evalType"
|
||||
["Lingering typer error", show (pp x)]
|
||||
where
|
||||
val = evalValType env
|
||||
num = evalNumType env
|
||||
|
||||
-- | Evaluation for value types (kind *).
|
||||
evalValType :: EvalEnv -> Type -> TValue
|
||||
evalValType :: TypeEnv -> Type -> TValue
|
||||
evalValType env ty =
|
||||
case evalType env ty of
|
||||
Left _ -> evalPanic "evalValType" ["expected value type, found numeric type"]
|
||||
Right t -> t
|
||||
|
||||
evalNumType :: EvalEnv -> Type -> Nat'
|
||||
-- | Evaluation for number types (kind #).
|
||||
evalNumType :: TypeEnv -> Type -> Nat'
|
||||
evalNumType env ty =
|
||||
case evalType env ty of
|
||||
Left n -> n
|
||||
Right _ -> evalPanic "evalValType" ["expected numeric type, found value type"]
|
||||
|
||||
|
||||
-- | Reduce type functions, raising an exception for undefined values.
|
||||
evalTF :: TFun -> [Nat'] -> Nat'
|
||||
evalTF f vs
|
||||
|
@ -6,117 +6,250 @@
|
||||
-- Stability : provisional
|
||||
-- Portability : portable
|
||||
|
||||
{-# LANGUAGE Safe #-}
|
||||
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveFunctor #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DoAndIfThenElse #-}
|
||||
{-# LANGUAGE FunctionalDependencies #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE PatternGuards #-}
|
||||
{-# LANGUAGE Safe #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
|
||||
module Cryptol.Eval.Value where
|
||||
|
||||
import Data.Bits
|
||||
import Data.IORef
|
||||
import qualified Data.Sequence as Seq
|
||||
import qualified Data.Foldable as Fold
|
||||
import Data.Map.Strict (Map)
|
||||
import qualified Data.Map.Strict as Map
|
||||
import MonadLib
|
||||
|
||||
import qualified Cryptol.Eval.Arch as Arch
|
||||
import Cryptol.Eval.Error
|
||||
import Cryptol.Eval.Monad
|
||||
import Cryptol.Eval.Type
|
||||
|
||||
import Cryptol.TypeCheck.AST
|
||||
import Cryptol.TypeCheck.Solver.InfNat(Nat'(..))
|
||||
import Cryptol.Utils.Ident (Ident,mkIdent)
|
||||
import Cryptol.Utils.PP
|
||||
import Cryptol.Utils.Panic(panic)
|
||||
|
||||
import Control.Monad (guard, zipWithM)
|
||||
import Data.List(genericTake)
|
||||
import Data.Bits (setBit,testBit,(.&.),shiftL)
|
||||
import Data.List(genericLength, genericIndex)
|
||||
import qualified Data.Text as T
|
||||
import Numeric (showIntAtBase)
|
||||
|
||||
import GHC.Generics (Generic)
|
||||
import Control.DeepSeq
|
||||
|
||||
-- Utilities -------------------------------------------------------------------
|
||||
|
||||
isTBit :: TValue -> Bool
|
||||
isTBit TVBit = True
|
||||
isTBit _ = False
|
||||
|
||||
isTSeq :: TValue -> Maybe (Nat', TValue)
|
||||
isTSeq (TVSeq n t) = Just (Nat n, t)
|
||||
isTSeq (TVStream t) = Just (Inf, t)
|
||||
isTSeq _ = Nothing
|
||||
|
||||
isTFun :: TValue -> Maybe (TValue, TValue)
|
||||
isTFun (TVFun t1 t2) = Just (t1, t2)
|
||||
isTFun _ = Nothing
|
||||
|
||||
isTTuple :: TValue -> Maybe (Int,[TValue])
|
||||
isTTuple (TVTuple ts) = Just (length ts, ts)
|
||||
isTTuple _ = Nothing
|
||||
|
||||
isTRec :: TValue -> Maybe [(Ident, TValue)]
|
||||
isTRec (TVRec fs) = Just fs
|
||||
isTRec _ = Nothing
|
||||
|
||||
tvSeq :: Nat' -> TValue -> TValue
|
||||
tvSeq (Nat n) t = TVSeq n t
|
||||
tvSeq Inf t = TVStream t
|
||||
|
||||
finNat' :: Nat' -> Integer
|
||||
finNat' n' =
|
||||
case n' of
|
||||
Nat x -> x
|
||||
Inf -> panic "Cryptol.Eval.Value.finNat'" [ "Unexpected `inf`" ]
|
||||
|
||||
-- Values ----------------------------------------------------------------------
|
||||
|
||||
-- | width, value
|
||||
-- | Concrete bitvector values: width, value
|
||||
-- Invariant: The value must be within the range 0 .. 2^width-1
|
||||
data BV = BV !Integer !Integer deriving (Generic, NFData)
|
||||
|
||||
instance Show BV where
|
||||
show = show . bvVal
|
||||
|
||||
-- | Apply an integer function to the values of bitvectors.
|
||||
-- This function assumes both bitvectors are the same width.
|
||||
binBV :: (Integer -> Integer -> Integer) -> BV -> BV -> BV
|
||||
binBV f (BV w x) (BV _ y) = mkBv w (f x y)
|
||||
|
||||
-- | Apply an integer function to the values of a bitvector.
|
||||
-- This function assumes the function will not require masking.
|
||||
unaryBV :: (Integer -> Integer) -> BV -> BV
|
||||
unaryBV f (BV w x) = mkBv w $ f x
|
||||
|
||||
bvVal :: BV -> Integer
|
||||
bvVal (BV _w x) = x
|
||||
|
||||
-- | Smart constructor for 'BV's that checks for the width limit
|
||||
mkBv :: Integer -> Integer -> BV
|
||||
mkBv w i = BV w (mask w i)
|
||||
|
||||
-- | A sequence map represents a mapping from nonnegative integer indices
|
||||
-- to values. These are used to represent both finite and infinite sequences.
|
||||
data SeqMap b w
|
||||
= IndexSeqMap !(Integer -> Eval (GenValue b w))
|
||||
| UpdateSeqMap !(Map Integer (Eval (GenValue b w)))
|
||||
!(Integer -> Eval (GenValue b w))
|
||||
|
||||
lookupSeqMap :: SeqMap b w -> Integer -> Eval (GenValue b w)
|
||||
lookupSeqMap (IndexSeqMap f) i = f i
|
||||
lookupSeqMap (UpdateSeqMap m f) i =
|
||||
case Map.lookup i m of
|
||||
Just x -> x
|
||||
Nothing -> f i
|
||||
|
||||
type SeqValMap = SeqMap Bool BV
|
||||
|
||||
instance NFData (SeqMap b w) where
|
||||
rnf x = seq x ()
|
||||
|
||||
-- | Generate a finite sequence map from a list of values
|
||||
finiteSeqMap :: [Eval (GenValue b w)] -> SeqMap b w
|
||||
finiteSeqMap xs =
|
||||
UpdateSeqMap
|
||||
(Map.fromList (zip [0..] xs))
|
||||
invalidIndex
|
||||
|
||||
-- | Generate an infinite sequence map from a stream of values
|
||||
infiniteSeqMap :: [Eval (GenValue b w)] -> Eval (SeqMap b w)
|
||||
infiniteSeqMap xs =
|
||||
-- TODO: use an int-trie?
|
||||
memoMap (IndexSeqMap $ \i -> genericIndex xs i)
|
||||
|
||||
-- | Create a finite list of length `n` of the values from [0..n-1] in
|
||||
-- the given the sequence emap.
|
||||
enumerateSeqMap :: (Integral n) => n -> SeqMap b w -> [Eval (GenValue b w)]
|
||||
enumerateSeqMap n m = [ lookupSeqMap m i | i <- [0 .. (toInteger n)-1] ]
|
||||
|
||||
-- | Create an infinite stream of all the values in a sequence map
|
||||
streamSeqMap :: SeqMap b w -> [Eval (GenValue b w)]
|
||||
streamSeqMap m = [ lookupSeqMap m i | i <- [0..] ]
|
||||
|
||||
-- | Reverse the order of a finite sequence map
|
||||
reverseSeqMap :: Integer -- ^ Size of the sequence map
|
||||
-> SeqMap b w
|
||||
-> SeqMap b w
|
||||
reverseSeqMap n vals = IndexSeqMap $ \i -> lookupSeqMap vals (n - 1 - i)
|
||||
|
||||
updateSeqMap :: SeqMap b w -> Integer -> Eval (GenValue b w) -> SeqMap b w
|
||||
updateSeqMap (UpdateSeqMap m sm) i x = UpdateSeqMap (Map.insert i x m) sm
|
||||
updateSeqMap (IndexSeqMap f) i x = UpdateSeqMap (Map.singleton i x) f
|
||||
|
||||
-- | Given a number `n` and a sequence map, return two new sequence maps:
|
||||
-- the first containing the values from `[0..n-1]` and the next containing
|
||||
-- the values from `n` onward.
|
||||
splitSeqMap :: Integer -> SeqMap b w -> (SeqMap b w, SeqMap b w)
|
||||
splitSeqMap n xs = (hd,tl)
|
||||
where
|
||||
hd = xs
|
||||
tl = IndexSeqMap $ \i -> lookupSeqMap xs (i+n)
|
||||
|
||||
-- | Given a sequence map, return a new sequence map that is memoized using
|
||||
-- a finite map memo table.
|
||||
memoMap :: SeqMap b w -> Eval (SeqMap b w)
|
||||
memoMap x = do
|
||||
cache <- io $ newIORef $ Map.empty
|
||||
return $ IndexSeqMap (memo cache)
|
||||
|
||||
where
|
||||
memo cache i = do
|
||||
mz <- io (Map.lookup i <$> readIORef cache)
|
||||
case mz of
|
||||
Just z -> return z
|
||||
Nothing -> doEval cache i
|
||||
|
||||
doEval cache i = do
|
||||
v <- lookupSeqMap x i
|
||||
io $ modifyIORef' cache (Map.insert i v)
|
||||
return v
|
||||
|
||||
-- | Apply the given evaluation function pointwise to the two given
|
||||
-- sequence maps.
|
||||
zipSeqMap :: (GenValue b w -> GenValue b w -> Eval (GenValue b w))
|
||||
-> SeqMap b w
|
||||
-> SeqMap b w
|
||||
-> Eval (SeqMap b w)
|
||||
zipSeqMap f x y =
|
||||
memoMap (IndexSeqMap $ \i -> join (f <$> lookupSeqMap x i <*> lookupSeqMap y i))
|
||||
|
||||
-- | Apply the given function to each value in the given sequence map
|
||||
mapSeqMap :: (GenValue b w -> Eval (GenValue b w))
|
||||
-> SeqMap b w -> Eval (SeqMap b w)
|
||||
mapSeqMap f x =
|
||||
memoMap (IndexSeqMap $ \i -> f =<< lookupSeqMap x i)
|
||||
|
||||
-- | For efficency reasons, we handle finite sequences of bits as special cases
|
||||
-- in the evaluator. In cases where we know it is safe to do so, we prefer to
|
||||
-- used a "packed word" representation of bit sequences. This allows us to rely
|
||||
-- directly on Integer types (in the concrete evalautor) and SBV's Word types (in
|
||||
-- the symbolic simulator).
|
||||
--
|
||||
-- However, if we cannot be sure all the bits of the sequence
|
||||
-- will eventually be forced, we must instead rely on an explicit sequence of bits
|
||||
-- representation.
|
||||
data WordValue b w
|
||||
= WordVal !w -- ^ Packed word representation for bit sequences.
|
||||
| BitsVal !(Seq.Seq (Eval b)) -- ^ Sequence of thunks representing bits.
|
||||
deriving (Generic, NFData)
|
||||
|
||||
-- | Force a word value into packed word form
|
||||
asWordVal :: BitWord b w => WordValue b w -> Eval w
|
||||
asWordVal (WordVal w) = return w
|
||||
asWordVal (BitsVal bs) = packWord <$> sequence (Fold.toList bs)
|
||||
|
||||
-- | Force a word value into a sequence of bits
|
||||
asBitsVal :: BitWord b w => WordValue b w -> Seq.Seq (Eval b)
|
||||
asBitsVal (WordVal w) = Seq.fromList $ map ready $ unpackWord w
|
||||
asBitsVal (BitsVal bs) = bs
|
||||
|
||||
-- | Select an individual bit from a word value
|
||||
indexWordValue :: BitWord b w => WordValue b w -> Integer -> Eval b
|
||||
indexWordValue (WordVal w) idx = return $ genericIndex (unpackWord w) idx
|
||||
indexWordValue (BitsVal bs) idx = Seq.index bs (fromInteger idx)
|
||||
|
||||
|
||||
-- | Generic value type, parameterized by bit and word types.
|
||||
--
|
||||
-- NOTE: we maintain an important invariant regarding sequence types.
|
||||
-- `VSeq` must never be used for finite sequences of bits.
|
||||
-- Always use the `VWord` constructor instead! Infinite sequences of bits
|
||||
-- are handled by the `VStream` constructor, just as for other types.
|
||||
data GenValue b w
|
||||
= VRecord [(Ident, GenValue b w)] -- @ { .. } @
|
||||
| VTuple [GenValue b w] -- @ ( .. ) @
|
||||
| VBit b -- @ Bit @
|
||||
| VSeq Bool [GenValue b w] -- @ [n]a @
|
||||
-- The boolean parameter indicates whether or not
|
||||
-- this is a sequence of bits.
|
||||
| VWord w -- @ [n]Bit @
|
||||
| VStream [GenValue b w] -- @ [inf]a @
|
||||
| VFun (GenValue b w -> GenValue b w) -- functions
|
||||
| VPoly (TValue -> GenValue b w) -- polymorphic values (kind *)
|
||||
| VNumPoly (Nat' -> GenValue b w) -- polymorphic values (kind #)
|
||||
deriving (Generic, NFData)
|
||||
= VRecord ![(Ident, Eval (GenValue b w))] -- ^ @ { .. } @
|
||||
| VTuple ![Eval (GenValue b w)] -- ^ @ ( .. ) @
|
||||
| VBit !b -- ^ @ Bit @
|
||||
| VSeq !Integer !(SeqMap b w) -- ^ @ [n]a @
|
||||
-- Invariant: VSeq is never a sequence of bits
|
||||
| VWord !Integer !(Eval (WordValue b w)) -- ^ @ [n]Bit @
|
||||
| VStream !(SeqMap b w) -- ^ @ [inf]a @
|
||||
| VFun (Eval (GenValue b w) -> Eval (GenValue b w)) -- ^ functions
|
||||
| VPoly (TValue -> Eval (GenValue b w)) -- ^ polymorphic values (kind *)
|
||||
| VNumPoly (Nat' -> Eval (GenValue b w)) -- ^ polymorphic values (kind #)
|
||||
deriving (Generic, NFData)
|
||||
|
||||
|
||||
-- | Force the evaluation of a word value
|
||||
forceWordValue :: WordValue b w -> Eval ()
|
||||
forceWordValue (WordVal _w) = return ()
|
||||
forceWordValue (BitsVal bs) = mapM_ (\b -> const () <$> b) bs
|
||||
|
||||
-- | Force the evaluation of a value
|
||||
forceValue :: GenValue b w -> Eval ()
|
||||
forceValue v = case v of
|
||||
VRecord fs -> mapM_ (\x -> forceValue =<< snd x) fs
|
||||
VTuple xs -> mapM_ (forceValue =<<) xs
|
||||
VSeq n xs -> mapM_ (forceValue =<<) (enumerateSeqMap n xs)
|
||||
VBit _b -> return ()
|
||||
VWord _ wv -> forceWordValue =<< wv
|
||||
VStream _ -> return ()
|
||||
VFun _ -> return ()
|
||||
VPoly _ -> return ()
|
||||
VNumPoly _ -> return ()
|
||||
|
||||
|
||||
instance (Show b, Show w) => Show (GenValue b w) where
|
||||
show v = case v of
|
||||
VRecord fs -> "record:" ++ show (map fst fs)
|
||||
VTuple xs -> "tuple:" ++ show (length xs)
|
||||
VBit b -> show b
|
||||
VSeq n _ -> "seq:" ++ show n
|
||||
VWord n _ -> "word:" ++ show n
|
||||
VStream _ -> "stream"
|
||||
VFun _ -> "fun"
|
||||
VPoly _ -> "poly"
|
||||
VNumPoly _ -> "numpoly"
|
||||
|
||||
type Value = GenValue Bool BV
|
||||
|
||||
-- | An evaluated type of kind *.
|
||||
-- These types do not contain type variables, type synonyms, or type functions.
|
||||
data TValue
|
||||
= TVBit
|
||||
| TVSeq Integer TValue
|
||||
| TVStream TValue -- ^ [inf]t
|
||||
| TVTuple [TValue]
|
||||
| TVRec [(Ident, TValue)]
|
||||
| TVFun TValue TValue
|
||||
deriving (Generic, NFData)
|
||||
|
||||
tValTy :: TValue -> Type
|
||||
tValTy tv =
|
||||
case tv of
|
||||
TVBit -> tBit
|
||||
TVSeq n t -> tSeq (tNum n) (tValTy t)
|
||||
TVStream t -> tSeq tInf (tValTy t)
|
||||
TVTuple ts -> tTuple (map tValTy ts)
|
||||
TVRec fs -> tRec [ (f, tValTy t) | (f, t) <- fs ]
|
||||
TVFun t1 t2 -> tFun (tValTy t1) (tValTy t2)
|
||||
|
||||
instance Show TValue where
|
||||
showsPrec p v = showsPrec p (tValTy v)
|
||||
|
||||
|
||||
-- Pretty Printing -------------------------------------------------------------
|
||||
|
||||
@ -129,36 +262,55 @@ data PPOpts = PPOpts
|
||||
defaultPPOpts :: PPOpts
|
||||
defaultPPOpts = PPOpts { useAscii = False, useBase = 10, useInfLength = 5 }
|
||||
|
||||
ppValue :: PPOpts -> Value -> Doc
|
||||
atFst :: Functor f => (a -> f b) -> (a, c) -> f (b, c)
|
||||
atFst f (x,y) = fmap (,y) $ f x
|
||||
|
||||
atSnd :: Functor f => (a -> f b) -> (c, a) -> f (c, b)
|
||||
atSnd f (x,y) = fmap (x,) $ f y
|
||||
|
||||
ppValue :: forall b w
|
||||
. BitWord b w
|
||||
=> PPOpts
|
||||
-> GenValue b w
|
||||
-> Eval Doc
|
||||
ppValue opts = loop
|
||||
where
|
||||
loop :: GenValue b w -> Eval Doc
|
||||
loop val = case val of
|
||||
VRecord fs -> braces (sep (punctuate comma (map ppField fs)))
|
||||
VRecord fs -> do fs' <- traverse (atSnd (>>=loop)) $ fs
|
||||
return $ braces (sep (punctuate comma (map ppField fs')))
|
||||
where
|
||||
ppField (f,r) = pp f <+> char '=' <+> loop r
|
||||
VTuple vals -> parens (sep (punctuate comma (map loop vals)))
|
||||
VBit b | b -> text "True"
|
||||
| otherwise -> text "False"
|
||||
VSeq isWord vals
|
||||
| isWord -> ppWord opts (fromVWord val)
|
||||
| otherwise -> ppWordSeq vals
|
||||
VWord (BV w i) -> ppWord opts (BV w i)
|
||||
VStream vals -> brackets $ fsep
|
||||
ppField (f,r) = pp f <+> char '=' <+> r
|
||||
VTuple vals -> do vals' <- traverse (>>=loop) vals
|
||||
return $ parens (sep (punctuate comma vals'))
|
||||
VBit b -> return $ ppBit b
|
||||
VSeq sz vals -> ppWordSeq sz vals
|
||||
VWord _ wv -> ppWordVal =<< wv
|
||||
VStream vals -> do vals' <- traverse (>>=loop) $ enumerateSeqMap (useInfLength opts) vals
|
||||
return $ brackets $ fsep
|
||||
$ punctuate comma
|
||||
( take (useInfLength opts) (map loop vals)
|
||||
++ [text "..."]
|
||||
( vals' ++ [text "..."]
|
||||
)
|
||||
VFun _ -> text "<function>"
|
||||
VPoly _ -> text "<polymorphic value>"
|
||||
VNumPoly _ -> text "<polymorphic value>"
|
||||
VFun _ -> return $ text "<function>"
|
||||
VPoly _ -> return $ text "<polymorphic value>"
|
||||
VNumPoly _ -> return $ text "<polymorphic value>"
|
||||
|
||||
ppWordSeq ws =
|
||||
ppWordVal :: WordValue b w -> Eval Doc
|
||||
ppWordVal w = ppWord opts <$> asWordVal w
|
||||
|
||||
ppWordSeq :: Integer -> SeqMap b w -> Eval Doc
|
||||
ppWordSeq sz vals = do
|
||||
ws <- sequence (enumerateSeqMap sz vals)
|
||||
case ws of
|
||||
w : _
|
||||
| Just l <- vWordLen w, asciiMode opts l ->
|
||||
text $ show $ map (integerToChar . fromWord) ws
|
||||
_ -> brackets (fsep (punctuate comma (map loop ws)))
|
||||
|
||||
| Just l <- vWordLen w
|
||||
, asciiMode opts l
|
||||
-> do vs <- traverse (fromVWord "ppWordSeq") ws
|
||||
case traverse wordAsChar vs of
|
||||
Just str -> return $ text (show str)
|
||||
_ -> return $ brackets (fsep (punctuate comma $ map (ppWord opts) vs))
|
||||
_ -> do ws' <- traverse loop ws
|
||||
return $ brackets (fsep (punctuate comma ws'))
|
||||
|
||||
asciiMode :: PPOpts -> Integer -> Bool
|
||||
asciiMode opts width = useAscii opts && (width == 7 || width == 8)
|
||||
@ -166,14 +318,9 @@ asciiMode opts width = useAscii opts && (width == 7 || width == 8)
|
||||
integerToChar :: Integer -> Char
|
||||
integerToChar = toEnum . fromInteger
|
||||
|
||||
data WithBase a = WithBase PPOpts a
|
||||
deriving (Functor)
|
||||
|
||||
instance PP (WithBase Value) where
|
||||
ppPrec _ (WithBase opts v) = ppValue opts v
|
||||
|
||||
ppWord :: PPOpts -> BV -> Doc
|
||||
ppWord opts (BV width i)
|
||||
ppBV :: PPOpts -> BV -> Doc
|
||||
ppBV opts (BV width i)
|
||||
| base > 36 = integer i -- not sure how to rule this out
|
||||
| asciiMode opts width = text (show (toEnum (fromInteger i) :: Char))
|
||||
| otherwise = prefix <> text value
|
||||
@ -199,18 +346,97 @@ ppWord opts (BV width i)
|
||||
digits = "0123456789abcdefghijklmnopqrstuvwxyz"
|
||||
|
||||
|
||||
-- Big-endian Words ------------------------------------------------------------
|
||||
-- | This type class defines a collection of operations on bits and words that
|
||||
-- are necessary to define generic evaluator primitives that operate on both concrete
|
||||
-- and symbolic values uniformly.
|
||||
class BitWord b w | b -> w, w -> b where
|
||||
-- | Pretty-print an individual bit
|
||||
ppBit :: b -> Doc
|
||||
|
||||
class BitWord b w where
|
||||
-- | Pretty-print a word value
|
||||
ppWord :: PPOpts -> w -> Doc
|
||||
|
||||
-- | NOTE this assumes that the sequence of bits is big-endian and finite, so the
|
||||
-- first element of the list will be the most significant bit.
|
||||
-- | Attempt to render a word value as an ASCII character. Return `Nothing`
|
||||
-- if the character value is unknown (e.g., for symbolic values).
|
||||
wordAsChar :: w -> Maybe Char
|
||||
|
||||
-- | The number of bits in a word value.
|
||||
wordLen :: w -> Integer
|
||||
|
||||
-- | Construct a literal bit value from a boolean.
|
||||
bitLit :: Bool -> b
|
||||
|
||||
-- | Construct a literal word value given a bit width and a value.
|
||||
wordLit :: Integer -- ^ Width
|
||||
-> Integer -- ^ Value
|
||||
-> w
|
||||
|
||||
-- | Construct a word value from a finite sequence of bits.
|
||||
-- NOTE: this assumes that the sequence of bits is big-endian and finite, so the
|
||||
-- first element of the list will be the most significant bit.
|
||||
packWord :: [b] -> w
|
||||
|
||||
-- | NOTE this produces a list of bits that represent a big-endian word, so the
|
||||
-- most significant bit is the first element of the list.
|
||||
-- | Deconstruct a packed word value in to a finite sequence of bits.
|
||||
-- NOTE: this produces a list of bits that represent a big-endian word, so
|
||||
-- the most significant bit is the first element of the list.
|
||||
unpackWord :: w -> [b]
|
||||
|
||||
-- | Concatenate the two given word values.
|
||||
-- NOTE: the first argument represents the more-significant bits
|
||||
joinWord :: w -> w -> w
|
||||
|
||||
-- | Take the most-significant bits, and return
|
||||
-- those bits and the remainder. The first element
|
||||
-- of the pair is the most significant bits.
|
||||
-- The two integer sizes must sum to the length of the given word value.
|
||||
splitWord :: Integer -- ^ left width
|
||||
-> Integer -- ^ right width
|
||||
-> w
|
||||
-> (w, w)
|
||||
|
||||
-- | Extract a subsequence of bits from a packed word value.
|
||||
-- The first integer argument is the number of bits in the
|
||||
-- resulting word. The second integer argument is the
|
||||
-- number of less-significant digits to discard. Stated another
|
||||
-- way, the operation `extractWord n i w` is equivelant to
|
||||
-- first shifting `w` right by `i` bits, and then truncating to
|
||||
-- `n` bits.
|
||||
extractWord :: Integer -- ^ Number of bits to take
|
||||
-> Integer -- ^ starting bit
|
||||
-> w
|
||||
-> w
|
||||
|
||||
-- | 2's complement addition of packed words. The arguments must have
|
||||
-- equal bit width, and the result is of the same width. Overflow is silently
|
||||
-- discarded.
|
||||
wordPlus :: w -> w -> w
|
||||
|
||||
-- | 2's complement subtraction of packed words. The arguments must have
|
||||
-- equal bit width, and the result is of the same width. Overflow is silently
|
||||
-- discarded.
|
||||
wordMinus :: w -> w -> w
|
||||
|
||||
-- | 2's complement multiplication of packed words. The arguments must have
|
||||
-- equal bit width, and the result is of the same width. The high bits of the
|
||||
-- multiplication are silently discarded.
|
||||
wordMult :: w -> w -> w
|
||||
|
||||
|
||||
-- | This class defines additional operations necessary to define generic evaluation
|
||||
-- functions.
|
||||
class BitWord b w => EvalPrims b w where
|
||||
-- | Eval prim binds primitive declarations to the primitive values that implement them.
|
||||
evalPrim :: Decl -> GenValue b w
|
||||
|
||||
-- | if/then/else operation. Choose either the 'then' value or the 'else' value depending
|
||||
-- on the value of the test bit.
|
||||
iteValue :: b -- ^ Test bit
|
||||
-> Eval (GenValue b w) -- ^ 'then' value
|
||||
-> Eval (GenValue b w) -- ^ 'else' value
|
||||
-> Eval (GenValue b w)
|
||||
|
||||
|
||||
-- Concrete Big-endian Words ------------------------------------------------------------
|
||||
|
||||
mask :: Integer -- ^ Bit-width
|
||||
-> Integer -- ^ Value
|
||||
@ -218,74 +444,106 @@ mask :: Integer -- ^ Bit-width
|
||||
mask w i | w >= Arch.maxBigIntWidth = wordTooWide w
|
||||
| otherwise = i .&. ((1 `shiftL` fromInteger w) - 1)
|
||||
|
||||
|
||||
instance BitWord Bool BV where
|
||||
wordLen (BV w _) = w
|
||||
wordAsChar (BV _ x) = Just $ integerToChar x
|
||||
|
||||
ppBit b | b = text "True"
|
||||
| otherwise = text "False"
|
||||
|
||||
ppWord = ppBV
|
||||
|
||||
bitLit b = b
|
||||
wordLit = mkBv
|
||||
|
||||
packWord bits = BV (toInteger w) a
|
||||
where
|
||||
w = case length bits of
|
||||
len | toInteger len >= Arch.maxBigIntWidth -> wordTooWide (toInteger len)
|
||||
| otherwise -> len
|
||||
a = foldl set 0 (zip [w - 1, w - 2 .. 0] bits)
|
||||
set acc (n,b) | b = setBit acc n
|
||||
| otherwise = acc
|
||||
a = foldl setb 0 (zip [w - 1, w - 2 .. 0] bits)
|
||||
setb acc (n,b) | b = setBit acc n
|
||||
| otherwise = acc
|
||||
|
||||
unpackWord (BV w a) = [ testBit a n | n <- [w' - 1, w' - 2 .. 0] ]
|
||||
where
|
||||
w' = fromInteger w
|
||||
|
||||
joinWord (BV i x) (BV j y) =
|
||||
BV (i + j) (shiftL x (fromInteger j) + y)
|
||||
|
||||
splitWord leftW rightW (BV _ x) =
|
||||
( BV leftW (x `shiftR` (fromInteger rightW)), mkBv rightW x )
|
||||
|
||||
extractWord n i (BV _ x) = mkBv n (x `shiftR` (fromInteger i))
|
||||
|
||||
wordPlus (BV i x) (BV j y)
|
||||
| i == j = mkBv i (x+y)
|
||||
| otherwise = panic "Attempt to add words of different sizes: wordPlus" []
|
||||
|
||||
wordMinus (BV i x) (BV j y)
|
||||
| i == j = mkBv i (x-y)
|
||||
| otherwise = panic "Attempt to subtract words of different sizes: wordMinus" []
|
||||
|
||||
wordMult (BV i x) (BV j y)
|
||||
| i == j = mkBv i (x*y)
|
||||
| otherwise = panic "Attempt to multiply words of different sizes: wordMult" []
|
||||
|
||||
|
||||
-- Value Constructors ----------------------------------------------------------
|
||||
|
||||
-- | Create a packed word of n bits.
|
||||
word :: Integer -> Integer -> Value
|
||||
word n i = VWord (mkBv n i)
|
||||
word :: BitWord b w => Integer -> Integer -> GenValue b w
|
||||
word n i = VWord n $ ready $ WordVal $ wordLit n i
|
||||
|
||||
lam :: (GenValue b w -> GenValue b w) -> GenValue b w
|
||||
lam :: (Eval (GenValue b w) -> Eval (GenValue b w)) -> GenValue b w
|
||||
lam = VFun
|
||||
|
||||
-- | A type lambda that expects a @Type@ of kind *.
|
||||
-- | Functions that assume word inputs
|
||||
wlam :: BitWord b w => (w -> Eval (GenValue b w)) -> GenValue b w
|
||||
wlam f = VFun (\x -> x >>= fromVWord "wlam" >>= f)
|
||||
|
||||
-- | A type lambda that expects a @Type@.
|
||||
tlam :: (TValue -> GenValue b w) -> GenValue b w
|
||||
tlam = VPoly
|
||||
tlam f = VPoly (return . f)
|
||||
|
||||
-- | A type lambda that expects a @Type@ of kind #.
|
||||
nlam :: (Nat' -> GenValue b w) -> GenValue b w
|
||||
nlam = VNumPoly
|
||||
nlam f = VNumPoly (return . f)
|
||||
|
||||
-- | Generate a stream.
|
||||
toStream :: [GenValue b w] -> GenValue b w
|
||||
toStream = VStream
|
||||
toStream :: [GenValue b w] -> Eval (GenValue b w)
|
||||
toStream vs =
|
||||
VStream <$> infiniteSeqMap (map ready vs)
|
||||
|
||||
toFinSeq :: TValue -> [GenValue b w] -> GenValue b w
|
||||
toFinSeq elty = VSeq (isTBit elty)
|
||||
toFinSeq :: BitWord b w
|
||||
=> Integer -> TValue -> [GenValue b w] -> GenValue b w
|
||||
toFinSeq len elty vs
|
||||
| isTBit elty = VWord len $ ready $ WordVal $ packWord $ map fromVBit vs
|
||||
| otherwise = VSeq len $ finiteSeqMap (map ready vs)
|
||||
|
||||
-- | This is strict!
|
||||
boolToWord :: [Bool] -> Value
|
||||
boolToWord = VWord . packWord
|
||||
boolToWord bs = VWord (genericLength bs) $ ready $ WordVal $ packWord bs
|
||||
|
||||
-- | Construct either a finite sequence, or a stream. In the finite case,
|
||||
-- record whether or not the elements were bits, to aid pretty-printing.
|
||||
toSeq :: Nat' -> TValue -> [GenValue b w] -> GenValue b w
|
||||
toSeq :: BitWord b w
|
||||
=> Nat' -> TValue -> [GenValue b w] -> Eval (GenValue b w)
|
||||
toSeq len elty vals = case len of
|
||||
Nat n -> toFinSeq elty (genericTake n vals)
|
||||
Nat n -> return $ toFinSeq n elty vals
|
||||
Inf -> toStream vals
|
||||
|
||||
-- | Construct one of:
|
||||
-- * a word, when the sequence is finite and the elements are bits
|
||||
-- * a sequence, when the sequence is finite but the elements aren't bits
|
||||
-- * a stream, when the sequence is not finite
|
||||
--
|
||||
-- NOTE: do not use this constructor in the case where the thing may be a
|
||||
-- finite, but recursive, sequence.
|
||||
toPackedSeq :: Nat' -> TValue -> [Value] -> Value
|
||||
toPackedSeq len elty vals = case len of
|
||||
|
||||
-- finite sequence, pack a word if the elements are bits.
|
||||
Nat _ | isTBit elty -> boolToWord (map fromVBit vals)
|
||||
| otherwise -> VSeq False vals
|
||||
|
||||
-- infinite sequence, construct a stream
|
||||
Inf -> VStream vals
|
||||
-- | Construct either a finite sequence, or a stream. In the finite case,
|
||||
-- record whether or not the elements were bits, to aid pretty-printing.
|
||||
mkSeq :: Nat' -> TValue -> SeqMap b w -> GenValue b w
|
||||
mkSeq len elty vals = case len of
|
||||
Nat n
|
||||
| isTBit elty -> VWord n $ return $ BitsVal $ Seq.fromFunction (fromInteger n) $ \i ->
|
||||
fromVBit <$> lookupSeqMap vals (toInteger i)
|
||||
| otherwise -> VSeq n vals
|
||||
Inf -> VStream vals
|
||||
|
||||
|
||||
-- Value Destructors -----------------------------------------------------------
|
||||
@ -296,68 +554,84 @@ fromVBit val = case val of
|
||||
VBit b -> b
|
||||
_ -> evalPanic "fromVBit" ["not a Bit"]
|
||||
|
||||
-- | Extract a sequence.
|
||||
fromSeq :: BitWord b w => GenValue b w -> [GenValue b w]
|
||||
fromSeq val = case val of
|
||||
VSeq _ vs -> vs
|
||||
VWord bv -> map VBit (unpackWord bv)
|
||||
VStream vs -> vs
|
||||
_ -> evalPanic "fromSeq" ["not a sequence"]
|
||||
bitsSeq :: BitWord b w => WordValue b w -> Integer -> Eval b
|
||||
bitsSeq (WordVal w) =
|
||||
let bs = unpackWord w
|
||||
in \i -> return $ genericIndex bs i
|
||||
bitsSeq (BitsVal bs) = \i -> Seq.index bs (fromInteger i)
|
||||
|
||||
fromStr :: Value -> String
|
||||
fromStr = map (toEnum . fromInteger . fromWord) . fromSeq
|
||||
-- | Extract a sequence.
|
||||
fromSeq :: forall b w. BitWord b w => String -> GenValue b w -> Eval (SeqMap b w)
|
||||
fromSeq msg val = case val of
|
||||
VSeq _ vs -> return vs
|
||||
VStream vs -> return vs
|
||||
_ -> evalPanic "fromSeq" ["not a sequence", msg]
|
||||
|
||||
fromStr :: Value -> Eval String
|
||||
fromStr (VSeq n vals) =
|
||||
traverse (\x -> toEnum . fromInteger <$> (fromWord "fromStr" =<< x)) (enumerateSeqMap n vals)
|
||||
fromStr _ = evalPanic "fromStr" ["Not a finite sequence"]
|
||||
|
||||
fromWordVal :: String -> GenValue b w -> Eval (WordValue b w)
|
||||
fromWordVal _msg (VWord _ wval) = wval
|
||||
fromWordVal msg _ = evalPanic "fromWordVal" ["not a word value", msg]
|
||||
|
||||
-- | Extract a packed word.
|
||||
fromVWord :: BitWord b w => GenValue b w -> w
|
||||
fromVWord val = case val of
|
||||
VWord bv -> bv -- this should always mask
|
||||
VSeq isWord bs | isWord -> packWord (map fromVBit bs)
|
||||
_ -> evalPanic "fromVWord" ["not a word"]
|
||||
fromVWord :: BitWord b w => String -> GenValue b w -> Eval w
|
||||
fromVWord _msg (VWord _ wval) = wval >>= asWordVal
|
||||
fromVWord msg _ = evalPanic "fromVWord" ["not a word", msg]
|
||||
|
||||
vWordLen :: Value -> Maybe Integer
|
||||
vWordLen :: BitWord b w => GenValue b w -> Maybe Integer
|
||||
vWordLen val = case val of
|
||||
VWord (BV w _) -> Just w
|
||||
VSeq isWord bs | isWord -> Just (toInteger (length bs))
|
||||
_ -> Nothing
|
||||
VWord n _wv -> Just n
|
||||
_ -> Nothing
|
||||
|
||||
-- | If the given list of values are all fully-evaluated thunks
|
||||
-- containing bits, return a packed word built from the same bits.
|
||||
-- However, if any value is not a fully-evaluated bit, return `Nothing`.
|
||||
tryFromBits :: BitWord b w => [Eval (GenValue b w)] -> Maybe w
|
||||
tryFromBits = go id
|
||||
where
|
||||
go f [] = Just (packWord (f []))
|
||||
go f (Ready (VBit b) : vs) = go (f . (b :)) vs
|
||||
go _ (_ : _) = Nothing
|
||||
|
||||
-- | Turn a value into an integer represented by w bits.
|
||||
fromWord :: Value -> Integer
|
||||
fromWord val = a
|
||||
where BV _ a = fromVWord val
|
||||
fromWord :: String -> Value -> Eval Integer
|
||||
fromWord msg val = bvVal <$> fromVWord msg val
|
||||
|
||||
-- | Extract a function from a value.
|
||||
fromVFun :: GenValue b w -> (GenValue b w -> GenValue b w)
|
||||
fromVFun :: GenValue b w -> (Eval (GenValue b w) -> Eval (GenValue b w))
|
||||
fromVFun val = case val of
|
||||
VFun f -> f
|
||||
_ -> evalPanic "fromVFun" ["not a function"]
|
||||
|
||||
-- | Extract a polymorphic function from a value.
|
||||
fromVPoly :: GenValue b w -> (TValue -> GenValue b w)
|
||||
fromVPoly :: GenValue b w -> (TValue -> Eval (GenValue b w))
|
||||
fromVPoly val = case val of
|
||||
VPoly f -> f
|
||||
_ -> evalPanic "fromVPoly" ["not a polymorphic value"]
|
||||
|
||||
-- | Extract a polymorphic function from a value.
|
||||
fromVNumPoly :: GenValue b w -> (Nat' -> GenValue b w)
|
||||
fromVNumPoly :: GenValue b w -> (Nat' -> Eval (GenValue b w))
|
||||
fromVNumPoly val = case val of
|
||||
VNumPoly f -> f
|
||||
_ -> evalPanic "fromVNumPoly" ["not a polymorphic value"]
|
||||
|
||||
-- | Extract a tuple from a value.
|
||||
fromVTuple :: GenValue b w -> [GenValue b w]
|
||||
fromVTuple :: GenValue b w -> [Eval (GenValue b w)]
|
||||
fromVTuple val = case val of
|
||||
VTuple vs -> vs
|
||||
_ -> evalPanic "fromVTuple" ["not a tuple"]
|
||||
|
||||
-- | Extract a record from a value.
|
||||
fromVRecord :: GenValue b w -> [(Ident, GenValue b w)]
|
||||
fromVRecord :: GenValue b w -> [(Ident, Eval (GenValue b w))]
|
||||
fromVRecord val = case val of
|
||||
VRecord fs -> fs
|
||||
_ -> evalPanic "fromVRecord" ["not a record"]
|
||||
|
||||
-- | Lookup a field in a record.
|
||||
lookupRecord :: Ident -> GenValue b w -> GenValue b w
|
||||
lookupRecord :: Ident -> GenValue b w -> Eval (GenValue b w)
|
||||
lookupRecord f rec = case lookup f (fromVRecord rec) of
|
||||
Just val -> val
|
||||
Nothing -> evalPanic "lookupRecord" ["malformed record"]
|
||||
@ -368,38 +642,41 @@ lookupRecord f rec = case lookup f (fromVRecord rec) of
|
||||
-- this value, if we can determine it.
|
||||
--
|
||||
-- XXX: View patterns would probably clean up this definition a lot.
|
||||
toExpr :: PrimMap -> Type -> Value -> Maybe Expr
|
||||
toExpr prims = go
|
||||
toExpr :: PrimMap -> Type -> Value -> Eval (Maybe Expr)
|
||||
toExpr prims t0 v0 = findOne (go t0 v0)
|
||||
where
|
||||
|
||||
prim n = ePrim prims (mkIdent (T.pack n))
|
||||
|
||||
go :: Type -> Value -> ChoiceT Eval Expr
|
||||
go ty val = case (ty, val) of
|
||||
(TRec tfs, VRecord vfs) -> do
|
||||
let fns = map fst vfs
|
||||
guard (map fst tfs == fns)
|
||||
fes <- zipWithM go (map snd tfs) (map snd vfs)
|
||||
fes <- zipWithM go (map snd tfs) =<< lift (traverse snd vfs)
|
||||
return $ ERec (zip fns fes)
|
||||
(TCon (TC (TCTuple tl)) ts, VTuple tvs) -> do
|
||||
guard (tl == (length tvs))
|
||||
ETuple `fmap` zipWithM go ts tvs
|
||||
ETuple `fmap` (zipWithM go ts =<< lift (sequence tvs))
|
||||
(TCon (TC TCBit) [], VBit True ) -> return (prim "True")
|
||||
(TCon (TC TCBit) [], VBit False) -> return (prim "False")
|
||||
(TCon (TC TCSeq) [a,b], VSeq _ []) -> do
|
||||
(TCon (TC TCSeq) [a,b], VSeq 0 _) -> do
|
||||
guard (a == tZero)
|
||||
return $ EList [] b
|
||||
(TCon (TC TCSeq) [a,b], VSeq _ svs) -> do
|
||||
guard (a == tNum (length svs))
|
||||
ses <- mapM (go b) svs
|
||||
(TCon (TC TCSeq) [a,b], VSeq n svs) -> do
|
||||
guard (a == tNum n)
|
||||
ses <- mapM (go b) =<< lift (sequence (enumerateSeqMap n svs))
|
||||
return $ EList ses b
|
||||
(TCon (TC TCSeq) [a,(TCon (TC TCBit) [])], VWord (BV w v)) -> do
|
||||
(TCon (TC TCSeq) [a,(TCon (TC TCBit) [])], VWord _ wval) -> do
|
||||
BV w v <- lift (asWordVal =<< wval)
|
||||
guard (a == tNum w)
|
||||
return $ ETApp (ETApp (prim "demote") (tNum v)) (tNum w)
|
||||
(_, VStream _) -> fail "cannot construct infinite expressions"
|
||||
(_, VFun _) -> fail "cannot convert function values to expressions"
|
||||
(_, VPoly _) -> fail "cannot convert polymorphic values to expressions"
|
||||
_ -> panic "Cryptol.Eval.Value.toExpr"
|
||||
["type mismatch:"
|
||||
, pretty ty
|
||||
, render (ppValue defaultPPOpts val)
|
||||
]
|
||||
_ -> do doc <- lift (ppValue defaultPPOpts val)
|
||||
panic "Cryptol.Eval.Value.toExpr"
|
||||
["type mismatch:"
|
||||
, pretty ty
|
||||
, render doc
|
||||
]
|
||||
|
@ -19,6 +19,7 @@ import Cryptol.ModuleSystem.Env (lookupModule, LoadedModule(..)
|
||||
, meCoreLint, CoreLint(..))
|
||||
import qualified Cryptol.Eval as E
|
||||
import qualified Cryptol.Eval.Value as E
|
||||
import Cryptol.Prims.Eval ()
|
||||
import qualified Cryptol.ModuleSystem.NamingEnv as R
|
||||
import qualified Cryptol.ModuleSystem.Renamer as R
|
||||
import qualified Cryptol.Parser as P
|
||||
@ -31,11 +32,11 @@ import qualified Cryptol.TypeCheck as T
|
||||
import qualified Cryptol.TypeCheck.AST as T
|
||||
import qualified Cryptol.TypeCheck.PP as T
|
||||
import qualified Cryptol.TypeCheck.Sanity as TcSanity
|
||||
import Cryptol.Utils.Ident (preludeName,interactiveName,unpackModName)
|
||||
import Cryptol.Utils.Ident (preludeName, preludeExtrasName, interactiveName,unpackModName)
|
||||
import Cryptol.Utils.PP (pretty)
|
||||
import Cryptol.Utils.Panic (panic)
|
||||
|
||||
import Cryptol.Prelude (writePreludeContents)
|
||||
import Cryptol.Prelude (writePreludeContents, writePreludeExtrasContents)
|
||||
|
||||
import Cryptol.Transform.MonoValues (rewModule)
|
||||
|
||||
@ -48,7 +49,7 @@ import Data.Maybe (fromMaybe)
|
||||
import Data.Monoid ((<>))
|
||||
import Data.Text.Lazy (Text)
|
||||
import qualified Data.Text.Lazy.IO as T
|
||||
import System.Directory (doesFileExist)
|
||||
import System.Directory (doesFileExist, canonicalizePath)
|
||||
import System.FilePath ( addExtension
|
||||
, isAbsolute
|
||||
, joinPath
|
||||
@ -124,20 +125,22 @@ parseModule path = do
|
||||
loadModuleByPath :: FilePath -> ModuleM T.Module
|
||||
loadModuleByPath path = withPrependedSearchPath [ takeDirectory path ] $ do
|
||||
let fileName = takeFileName path
|
||||
-- path' is the resolved, absolute path
|
||||
path' <- findFile fileName
|
||||
pm <- parseModule path'
|
||||
foundPath <- findFile fileName
|
||||
pm <- parseModule foundPath
|
||||
let n = thing (P.mName pm)
|
||||
|
||||
-- Check whether this module name has already been loaded from a different file
|
||||
env <- getModuleEnv
|
||||
-- path' is the resolved, absolute path, used only for checking
|
||||
-- whether it's already been loaded
|
||||
path' <- io $ canonicalizePath foundPath
|
||||
case lookupModule n env of
|
||||
Nothing -> loadingModule n (loadModule path' pm)
|
||||
-- loadModule will calculate the canonical path again
|
||||
Nothing -> loadingModule n (loadModule foundPath pm)
|
||||
Just lm
|
||||
| path' == loaded -> return (lmModule lm)
|
||||
| otherwise -> duplicateModuleName n path' loaded
|
||||
where loaded = lmFilePath lm
|
||||
|
||||
| path' == loaded -> return (lmModule lm)
|
||||
| otherwise -> duplicateModuleName n path' loaded
|
||||
where loaded = lmCanonicalPath lm
|
||||
|
||||
-- | Load the module specified by an import.
|
||||
loadImport :: Located P.Import -> ModuleM ()
|
||||
@ -173,7 +176,9 @@ loadModule path pm = do
|
||||
-- extend the eval env
|
||||
modifyEvalEnv (E.moduleEnv tcm)
|
||||
|
||||
loadedModule path tcm
|
||||
canonicalPath <- io (canonicalizePath path)
|
||||
|
||||
loadedModule path canonicalPath tcm
|
||||
|
||||
return tcm
|
||||
|
||||
@ -214,7 +219,8 @@ findModule n = do
|
||||
|
||||
handleNotFound =
|
||||
case n of
|
||||
m | m == preludeName -> writePreludeContents
|
||||
m | m == preludeName -> io writePreludeContents
|
||||
m | m == preludeExtrasName -> io writePreludeExtrasContents
|
||||
_ -> moduleNotFound n =<< getSearchPath
|
||||
|
||||
-- generate all possible search paths
|
||||
@ -433,6 +439,7 @@ genInferInput r prims env = do
|
||||
monoBinds <- getMonoBinds
|
||||
cfg <- getSolverConfig
|
||||
supply <- getSupply
|
||||
searchPath <- getSearchPath
|
||||
|
||||
-- TODO: include the environment needed by the module
|
||||
return T.InferInput
|
||||
@ -443,6 +450,7 @@ genInferInput r prims env = do
|
||||
, T.inpNameSeeds = seeds
|
||||
, T.inpMonoBinds = monoBinds
|
||||
, T.inpSolverConfig = cfg
|
||||
, T.inpSearchPath = searchPath
|
||||
, T.inpSupply = supply
|
||||
, T.inpPrimNames = prims
|
||||
}
|
||||
@ -454,14 +462,15 @@ evalExpr :: T.Expr -> ModuleM E.Value
|
||||
evalExpr e = do
|
||||
env <- getEvalEnv
|
||||
denv <- getDynEnv
|
||||
return (E.evalExpr (env <> deEnv denv) e)
|
||||
io $ E.runEval $ (E.evalExpr (env <> deEnv denv) e)
|
||||
|
||||
evalDecls :: [T.DeclGroup] -> ModuleM ()
|
||||
evalDecls dgs = do
|
||||
env <- getEvalEnv
|
||||
denv <- getDynEnv
|
||||
let env' = env <> deEnv denv
|
||||
denv' = denv { deDecls = deDecls denv ++ dgs
|
||||
, deEnv = E.evalDecls dgs env'
|
||||
deEnv' <- io $ E.runEval $ E.evalDecls dgs env'
|
||||
let denv' = denv { deDecls = deDecls denv ++ dgs
|
||||
, deEnv = deEnv'
|
||||
}
|
||||
setDynEnv denv'
|
||||
|
@ -192,7 +192,8 @@ instance Monoid LoadedModules where
|
||||
|
||||
data LoadedModule = LoadedModule
|
||||
{ lmName :: ModName
|
||||
, lmFilePath :: FilePath
|
||||
, lmFilePath :: FilePath -- ^ The file path used to load this module (may not be canonical)
|
||||
, lmCanonicalPath :: FilePath -- ^ The canonical version of the path of this module
|
||||
, lmInterface :: Iface
|
||||
, lmModule :: T.Module
|
||||
} deriving (Show, Generic, NFData)
|
||||
@ -203,14 +204,15 @@ isLoaded mn lm = any ((mn ==) . lmName) (getLoadedModules lm)
|
||||
lookupModule :: ModName -> ModuleEnv -> Maybe LoadedModule
|
||||
lookupModule mn env = List.find ((mn ==) . lmName) (getLoadedModules (meLoadedModules env))
|
||||
|
||||
addLoadedModule :: FilePath -> T.Module -> LoadedModules -> LoadedModules
|
||||
addLoadedModule path tm lm
|
||||
addLoadedModule :: FilePath -> FilePath -> T.Module -> LoadedModules -> LoadedModules
|
||||
addLoadedModule path canonicalPath tm lm
|
||||
| isLoaded (T.mName tm) lm = lm
|
||||
| otherwise = LoadedModules (getLoadedModules lm ++ [loaded])
|
||||
where
|
||||
loaded = LoadedModule
|
||||
{ lmName = T.mName tm
|
||||
, lmFilePath = path
|
||||
, lmCanonicalPath = canonicalPath
|
||||
, lmInterface = genIface tm
|
||||
, lmModule = tm
|
||||
}
|
||||
|
@ -11,7 +11,9 @@
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
module Cryptol.ModuleSystem.Monad where
|
||||
|
||||
import Cryptol.Eval.Env (EvalEnv)
|
||||
import Cryptol.Eval (EvalEnv)
|
||||
|
||||
import qualified Cryptol.Eval.Monad as E
|
||||
import Cryptol.ModuleSystem.Env
|
||||
import Cryptol.ModuleSystem.Interface
|
||||
import Cryptol.ModuleSystem.Name (FreshM(..),Supply)
|
||||
@ -26,9 +28,10 @@ import qualified Cryptol.Parser.NoInclude as NoInc
|
||||
import qualified Cryptol.TypeCheck as T
|
||||
import qualified Cryptol.TypeCheck.AST as T
|
||||
import Cryptol.Parser.Position (Range)
|
||||
import Cryptol.Utils.Ident (interactiveName)
|
||||
import Cryptol.Utils.Ident (interactiveName, packModName)
|
||||
import Cryptol.Utils.PP
|
||||
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Exception (IOException)
|
||||
import Data.Function (on)
|
||||
import Data.Maybe (isJust)
|
||||
@ -273,6 +276,9 @@ instance Monad m => FreshM (ModuleT m) where
|
||||
set $! me { meSupply = s' }
|
||||
return a
|
||||
|
||||
instance MonadIO m => MonadIO (ModuleT m) where
|
||||
liftIO m = lift $ liftIO m
|
||||
|
||||
runModuleT :: Monad m
|
||||
=> ModuleEnv
|
||||
-> ModuleT m a
|
||||
@ -340,8 +346,7 @@ getImportSource = ModuleT $ do
|
||||
ro <- ask
|
||||
case roLoading ro of
|
||||
is : _ -> return is
|
||||
_ -> panic "ModuleSystem: getImportSource" ["Import stack is empty"]
|
||||
|
||||
_ -> return (FromModule (packModName ["<none>"])) -- panic "ModuleSystem: getImportSource" ["Import stack is empty"]
|
||||
|
||||
getIface :: P.ModName -> ModuleM Iface
|
||||
getIface mn = ModuleT $ do
|
||||
@ -380,15 +385,17 @@ unloadModule path = ModuleT $ do
|
||||
env <- get
|
||||
set $! env { meLoadedModules = removeLoadedModule path (meLoadedModules env) }
|
||||
|
||||
loadedModule :: FilePath -> T.Module -> ModuleM ()
|
||||
loadedModule path m = ModuleT $ do
|
||||
loadedModule :: FilePath -> FilePath -> T.Module -> ModuleM ()
|
||||
loadedModule path canonicalPath m = ModuleT $ do
|
||||
env <- get
|
||||
set $! env { meLoadedModules = addLoadedModule path m (meLoadedModules env) }
|
||||
set $! env { meLoadedModules = addLoadedModule path canonicalPath m (meLoadedModules env) }
|
||||
|
||||
modifyEvalEnv :: (EvalEnv -> EvalEnv) -> ModuleM ()
|
||||
modifyEvalEnv :: (EvalEnv -> E.Eval EvalEnv) -> ModuleM ()
|
||||
modifyEvalEnv f = ModuleT $ do
|
||||
env <- get
|
||||
set $! env { meEvalEnv = f (meEvalEnv env) }
|
||||
let evalEnv = meEvalEnv env
|
||||
evalEnv' <- inBase $ E.runEval (f evalEnv)
|
||||
set $! env { meEvalEnv = evalEnv' }
|
||||
|
||||
getEvalEnv :: ModuleM EvalEnv
|
||||
getEvalEnv = ModuleT (meEvalEnv `fmap` get)
|
||||
|
@ -300,12 +300,14 @@ instance BindsNames (InModule (TopDecl PName)) where
|
||||
TDNewtype d -> namingEnv (InModule ns (tlValue d))
|
||||
Include _ -> mempty
|
||||
|
||||
-- NOTE: we use the same name at the type and expression level, as there's only
|
||||
-- ever one name introduced in the declaration. The names are only ever used in
|
||||
-- different namespaces, so there's no ambiguity.
|
||||
instance BindsNames (InModule (Newtype PName)) where
|
||||
namingEnv (InModule ns Newtype { .. }) = BuildNamingEnv $
|
||||
do let Located { .. } = nName
|
||||
tyName <- liftSupply (mkDeclared ns (getIdent thing) Nothing srcRange)
|
||||
eName <- liftSupply (mkDeclared ns (getIdent thing) Nothing srcRange)
|
||||
return (singletonT thing tyName `mappend` singletonE thing eName)
|
||||
ntName <- liftSupply (mkDeclared ns (getIdent thing) Nothing srcRange)
|
||||
return (singletonT thing ntName `mappend` singletonE thing ntName)
|
||||
|
||||
-- | The naming environment for a single declaration.
|
||||
instance BindsNames (InModule (Decl PName)) where
|
||||
|
@ -13,6 +13,7 @@
|
||||
{-# LANGUAGE MultiWayIf #-}
|
||||
{-# LANGUAGE PatternGuards #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
module Cryptol.ModuleSystem.Renamer (
|
||||
NamingEnv(), shadowing
|
||||
, BindsNames(..), InModule(..), namingEnv'
|
||||
@ -38,6 +39,7 @@ import Cryptol.Utils.PP
|
||||
import qualified Data.Foldable as F
|
||||
import qualified Data.Map.Strict as Map
|
||||
import qualified Data.Sequence as Seq
|
||||
import Data.String (IsString(..))
|
||||
import MonadLib hiding (mapM, mapM_)
|
||||
|
||||
import GHC.Generics (Generic)
|
||||
@ -138,6 +140,10 @@ instance PP RenamerError where
|
||||
|
||||
data RenamerWarning
|
||||
= SymbolShadowed Name [Name] NameDisp
|
||||
|
||||
-- Warn when fixity is used to resolve parses, and the relative
|
||||
-- fixity is planned to change. See https://github.com/GaloisInc/cryptol/issues/241
|
||||
| DangerousFixity (Located Name) (Located Name) NameDisp
|
||||
deriving (Show, Generic, NFData)
|
||||
|
||||
instance PP RenamerWarning where
|
||||
@ -154,6 +160,12 @@ instance PP RenamerWarning where
|
||||
loc = pp (nameLoc new)
|
||||
sym = pp new
|
||||
|
||||
ppPrec _ (DangerousFixity o1 o2 disp) = fixNameDisp disp $
|
||||
hang (text "[warning] at" <+> pp (srcRange o1))
|
||||
4 $ fsep [ text "Using fixity to resolve the parsing of operators" <+> pp (thing o1) <+> text "and" <+> pp (thing o2) <> text ";"
|
||||
, text "the relative fixity of these operators is planned to change in a future Cryptol release."
|
||||
, text "Use parentheses to disambiguate this parse, or consider replacing (&&) with (/\\), or (||) with (\\/)."
|
||||
]
|
||||
|
||||
-- Renaming Monad --------------------------------------------------------------
|
||||
|
||||
@ -232,6 +244,12 @@ record f = RenameM $
|
||||
RW { .. } <- get
|
||||
set RW { rwErrors = rwErrors Seq.|> f roDisp, .. }
|
||||
|
||||
recordW :: (NameDisp -> RenamerWarning) -> RenameM ()
|
||||
recordW f = RenameM $
|
||||
do RO { .. } <- ask
|
||||
RW { .. } <- get
|
||||
set RW { rwWarnings = rwWarnings Seq.|> f roDisp, .. }
|
||||
|
||||
curLoc :: RenameM Range
|
||||
curLoc = RenameM (roLoc `fmap` ask)
|
||||
|
||||
@ -712,20 +730,61 @@ instance Rename Expr where
|
||||
z' <- rename z
|
||||
mkEInfix x' op z'
|
||||
|
||||
-- | Check if we are resolving operators whose precedence will change in the
|
||||
-- future, and issue a warning in that event.
|
||||
--
|
||||
-- (&&) is scheduled to have higher precedence than the comparisons and (^)
|
||||
-- (||) is scheduled to have higher precedence than the comparisons
|
||||
--
|
||||
-- See https://github.com/GaloisInc/cryptol/issues/241
|
||||
isDangerousFixity :: Name -> Name -> Bool
|
||||
isDangerousFixity (asPrim -> Just x) (asPrim -> Just y) = test x y || test y x
|
||||
where
|
||||
test n m
|
||||
| n == mkInfix (fromString "&&")
|
||||
, (m `elem` comparisons) || (m == mkInfix (fromString "^"))
|
||||
= True
|
||||
|
||||
| n == mkInfix (fromString "||")
|
||||
, m `elem` comparisons
|
||||
= True
|
||||
|
||||
| otherwise
|
||||
= False
|
||||
|
||||
comparisons =
|
||||
[ mkInfix $ fromString "=="
|
||||
, mkInfix $ fromString "==="
|
||||
, mkInfix $ fromString "!="
|
||||
, mkInfix $ fromString "!=="
|
||||
, mkInfix $ fromString ">"
|
||||
, mkInfix $ fromString ">="
|
||||
, mkInfix $ fromString "<"
|
||||
, mkInfix $ fromString "<="
|
||||
]
|
||||
isDangerousFixity _ _ = False
|
||||
|
||||
|
||||
|
||||
mkEInfix :: Expr Name -- ^ May contain infix expressions
|
||||
-> (Located Name,Fixity) -- ^ The operator to use
|
||||
-> Expr Name -- ^ Will not contain infix expressions
|
||||
-> RenameM (Expr Name)
|
||||
|
||||
mkEInfix e@(EInfix x o1 f1 y) op@(o2,f2) z =
|
||||
case compareFixity f1 f2 of
|
||||
FCLeft -> return (EInfix e o2 f2 z)
|
||||
-- Temporary warning while we transition the fixity of && and || relative
|
||||
-- to comparisons and xor. See https://github.com/GaloisInc/cryptol/issues/241
|
||||
do when (isDangerousFixity (thing o1) (thing o2))
|
||||
(recordW (DangerousFixity o1 o2))
|
||||
|
||||
FCRight -> do r <- mkEInfix y op z
|
||||
return (EInfix x o1 f1 r)
|
||||
case compareFixity f1 f2 of
|
||||
FCLeft -> return (EInfix e o2 f2 z)
|
||||
|
||||
FCError -> do record (FixityError o1 o2)
|
||||
return (EInfix e o2 f2 z)
|
||||
FCRight -> do r <- mkEInfix y op z
|
||||
return (EInfix x o1 f1 r)
|
||||
|
||||
FCError -> do record (FixityError o1 o2)
|
||||
return (EInfix e o2 f2 z)
|
||||
|
||||
mkEInfix (ELocated e' _) op z =
|
||||
mkEInfix e' op z
|
||||
|
@ -280,7 +280,7 @@ decl :: { Decl PName }
|
||||
, bDoc = Nothing
|
||||
} }
|
||||
|
||||
| apat other_op apat '=' expr
|
||||
| apat pat_op apat '=' expr
|
||||
{ at ($1,$5) $
|
||||
DBind $ Bind { bName = $2
|
||||
, bParams = [$1,$3]
|
||||
@ -401,6 +401,10 @@ qop :: { LPName }
|
||||
in mkQual (mkModName ns) (mkInfix (T.toStrict i)) A.<$ $1 }
|
||||
|
||||
op :: { LPName }
|
||||
: pat_op { $1 }
|
||||
| '#' { Located $1 $ mkUnqual $ mkInfix "#" }
|
||||
|
||||
pat_op :: { LPName }
|
||||
: other_op { $1 }
|
||||
|
||||
-- special cases for operators that are re-used elsewhere
|
||||
@ -409,10 +413,9 @@ op :: { LPName }
|
||||
| '-' { Located $1 $ mkUnqual $ mkInfix "-" }
|
||||
| '~' { Located $1 $ mkUnqual $ mkInfix "~" }
|
||||
| '^^' { Located $1 $ mkUnqual $ mkInfix "^^" }
|
||||
| '#' { Located $1 $ mkUnqual $ mkInfix "#" }
|
||||
|
||||
|
||||
other_op :: { LPName }
|
||||
other_op :: { LPName }
|
||||
: OP { let Token (Op (Other [] str)) _ = thing $1
|
||||
in mkUnqual (mkInfix (T.toStrict str)) A.<$ $1 }
|
||||
|
||||
|
@ -39,7 +39,7 @@ $unitick = \x7
|
||||
@id_next = [a-zA-Z0-9_'] | $unilower | $uniupper | $unidigit | $unitick
|
||||
|
||||
@id = @id_first @id_next*
|
||||
@op = ([\!\@\#\$\%\^\&\*\~\>\<\?\+\=\|\/\\\-] | $unisymbol)+
|
||||
@op = ([\!\#\$\%\&\*\+\-\.\/\:\<\=\>\?\@\\\^\|\~] | $unisymbol)+
|
||||
|
||||
@qual = (@id $white* :: $white*)+
|
||||
@qual_id = @qual @id
|
||||
@ -62,7 +62,7 @@ $unitick = \x7
|
||||
}
|
||||
|
||||
<comment> {
|
||||
\*+\/ { endComent }
|
||||
\*+\/ { endComment }
|
||||
[^\*\/]+ { addToComment }
|
||||
\* { addToComment }
|
||||
\/ { addToComment }
|
||||
|
@ -62,8 +62,8 @@ startComment isDoc _ p txt s = (Nothing, InComment d p stack chunks)
|
||||
InComment doc q qs cs -> (doc, q : qs, txt : cs)
|
||||
_ -> panic "[Lexer] startComment" ["in a string"]
|
||||
|
||||
endComent :: Action
|
||||
endComent cfg p txt s =
|
||||
endComment :: Action
|
||||
endComment cfg p txt s =
|
||||
case s of
|
||||
InComment d f [] cs -> (Just (mkToken d f cs), Normal)
|
||||
InComment d _ (q:qs) cs -> (Nothing, InComment d q qs (txt : cs))
|
||||
@ -216,20 +216,14 @@ splitQual t =
|
||||
numToken :: Integer -> Text -> TokenT
|
||||
numToken rad ds = Num (toVal ds) (fromInteger rad) (fromIntegral (T.length ds))
|
||||
where
|
||||
toVal = T.foldl' (\x c -> rad * x + toDig c) 0
|
||||
toDig = if rad == 16 then fromHexDigit else fromDecDigit
|
||||
toVal = T.foldl' (\x c -> rad * x + fromDigit c) 0
|
||||
|
||||
fromDecDigit :: Char -> Integer
|
||||
fromDecDigit x = read [x]
|
||||
|
||||
fromHexDigit :: Char -> Integer
|
||||
fromHexDigit x'
|
||||
| 'a' <= x && x <= 'f' = fromIntegral (10 + fromEnum x - fromEnum 'a')
|
||||
| otherwise = fromDecDigit x
|
||||
fromDigit :: Char -> Integer
|
||||
fromDigit x'
|
||||
| 'a' <= x && x <= 'z' = fromIntegral (10 + fromEnum x - fromEnum 'a')
|
||||
| otherwise = fromIntegral (fromEnum x - fromEnum '0')
|
||||
where x = toLower x'
|
||||
|
||||
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
|
||||
data AlexInput = Inp { alexPos :: !Position
|
||||
@ -354,7 +348,7 @@ virt cfg pos x = Located { srcRange = Range
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data Token = Token { tokenType :: TokenT, tokenText :: Text }
|
||||
data Token = Token { tokenType :: !TokenT, tokenText :: !Text }
|
||||
deriving (Show, Generic, NFData)
|
||||
|
||||
-- | Virtual tokens, inserted by layout processing.
|
||||
@ -432,16 +426,16 @@ data TokenErr = UnterminatedComment
|
||||
| LexicalError
|
||||
deriving (Eq, Show, Generic, NFData)
|
||||
|
||||
data TokenT = Num Integer Int Int -- ^ value, base, number of digits
|
||||
| ChrLit Char -- ^ character literal
|
||||
| Ident [T.Text] T.Text -- ^ (qualified) identifier
|
||||
| StrLit String -- ^ string literal
|
||||
| KW TokenKW -- ^ keyword
|
||||
| Op TokenOp -- ^ operator
|
||||
| Sym TokenSym -- ^ symbol
|
||||
| Virt TokenV -- ^ virtual token (for layout)
|
||||
| White TokenW -- ^ white space token
|
||||
| Err TokenErr -- ^ error token
|
||||
data TokenT = Num !Integer !Int !Int -- ^ value, base, number of digits
|
||||
| ChrLit !Char -- ^ character literal
|
||||
| Ident ![T.Text] !T.Text -- ^ (qualified) identifier
|
||||
| StrLit !String -- ^ string literal
|
||||
| KW !TokenKW -- ^ keyword
|
||||
| Op !TokenOp -- ^ operator
|
||||
| Sym !TokenSym -- ^ symbol
|
||||
| Virt !TokenV -- ^ virtual token (for layout)
|
||||
| White !TokenW -- ^ white space token
|
||||
| Err !TokenErr -- ^ error token
|
||||
| EOF
|
||||
deriving (Eq, Show, Generic, NFData)
|
||||
|
||||
|
@ -157,7 +157,7 @@ mkFixity :: Assoc -> Located Token -> [LPName] -> ParseM (Decl PName)
|
||||
mkFixity assoc tok qns =
|
||||
do l <- intVal tok
|
||||
unless (l >= 1 && l <= 100)
|
||||
(errorMessage (srcRange tok) "Fixity levels must be between 0 and 20")
|
||||
(errorMessage (srcRange tok) "Fixity levels must be between 1 and 100")
|
||||
return (DFixity (Fixity assoc (fromInteger l)) qns)
|
||||
|
||||
mkTupleSel :: Range -> Integer -> ParseM (Located Selector)
|
||||
|
@ -21,7 +21,7 @@ import Control.DeepSeq
|
||||
|
||||
import Cryptol.Utils.PP
|
||||
|
||||
data Located a = Located { srcRange :: !Range, thing :: a }
|
||||
data Located a = Located { srcRange :: !Range, thing :: !a }
|
||||
deriving (Eq, Show, Generic, NFData)
|
||||
|
||||
data Position = Position { line :: !Int, col :: !Int }
|
||||
|
@ -38,7 +38,8 @@ translateExprToNumT expr =
|
||||
e2 <- translateExprToNumT b
|
||||
return (TInfix e1 o f e2)
|
||||
|
||||
EParens e -> translateExprToNumT e
|
||||
EParens e -> do t <- translateExprToNumT e
|
||||
return (TParens t)
|
||||
|
||||
_ -> Nothing
|
||||
|
||||
|
@ -8,13 +8,17 @@
|
||||
--
|
||||
-- Compile the prelude into the executable as a last resort
|
||||
|
||||
{-# LANGUAGE Trustworthy #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Cryptol.Prelude (writePreludeContents) where
|
||||
module Cryptol.Prelude (
|
||||
writePreludeContents,
|
||||
writePreludeExtrasContents,
|
||||
writeTcPreludeContents,
|
||||
) where
|
||||
|
||||
import Cryptol.ModuleSystem.Monad
|
||||
|
||||
import System.Directory (getTemporaryDirectory)
|
||||
import System.IO (hClose, hPutStr, openTempFile)
|
||||
@ -25,10 +29,34 @@ preludeContents = [there|lib/Cryptol.cry|]
|
||||
|
||||
-- | Write the contents of the Prelude to a temporary file so that
|
||||
-- Cryptol can load the module.
|
||||
writePreludeContents :: ModuleM FilePath
|
||||
writePreludeContents = io $ do
|
||||
writePreludeContents :: IO FilePath
|
||||
writePreludeContents = do
|
||||
tmpdir <- getTemporaryDirectory
|
||||
(path, h) <- openTempFile tmpdir "Cryptol.cry"
|
||||
hPutStr h preludeContents
|
||||
hClose h
|
||||
return path
|
||||
|
||||
preludeExtrasContents :: String
|
||||
preludeExtrasContents = [there|lib/Cryptol/Extras.cry|]
|
||||
|
||||
writePreludeExtrasContents :: IO FilePath
|
||||
writePreludeExtrasContents = do
|
||||
tmpdir <- getTemporaryDirectory
|
||||
(path, h) <- openTempFile tmpdir "CryptolExtras.cry"
|
||||
hPutStr h preludeExtrasContents
|
||||
hClose h
|
||||
return path
|
||||
|
||||
cryptolTcContents :: String
|
||||
cryptolTcContents = [there|lib/CryptolTC.z3|]
|
||||
|
||||
-- | Write the contents of the Prelude to a temporary file so that
|
||||
-- Cryptol can load the module.
|
||||
writeTcPreludeContents :: IO FilePath
|
||||
writeTcPreludeContents = do
|
||||
tmpdir <- getTemporaryDirectory
|
||||
(path, h) <- openTempFile tmpdir "CryptolTC.z3"
|
||||
hPutStr h cryptolTcContents
|
||||
hClose h
|
||||
return path
|
||||
|
File diff suppressed because it is too large
Load Diff
@ -12,7 +12,7 @@
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
module Cryptol.REPL.Command (
|
||||
-- * Commands
|
||||
Command(..), CommandDescr(..), CommandBody(..)
|
||||
Command(..), CommandDescr(..), CommandBody(..), CommandExitCode(..)
|
||||
, parseCommand
|
||||
, runCommand
|
||||
, splitCommand
|
||||
@ -56,7 +56,9 @@ import qualified Cryptol.ModuleSystem.NamingEnv as M
|
||||
import qualified Cryptol.ModuleSystem.Renamer as M (RenamerWarning(SymbolShadowed))
|
||||
import qualified Cryptol.Utils.Ident as M
|
||||
|
||||
import qualified Cryptol.Eval.Monad as E
|
||||
import qualified Cryptol.Eval.Value as E
|
||||
import qualified Cryptol.Eval.Reference as R
|
||||
import Cryptol.Testing.Concrete
|
||||
import qualified Cryptol.Testing.Random as TestR
|
||||
import Cryptol.Parser
|
||||
@ -72,10 +74,9 @@ import Cryptol.Utils.PP
|
||||
import Cryptol.Utils.Panic(panic)
|
||||
import qualified Cryptol.Parser.AST as P
|
||||
import qualified Cryptol.Transform.Specialize as S
|
||||
import Cryptol.Symbolic (ProverCommand(..), QueryType(..), SatNum(..))
|
||||
import Cryptol.Symbolic (ProverCommand(..), QueryType(..), SatNum(..),ProverStats)
|
||||
import qualified Cryptol.Symbolic as Symbolic
|
||||
|
||||
import Control.DeepSeq
|
||||
import qualified Control.Exception as X
|
||||
import Control.Monad hiding (mapM, mapM_)
|
||||
import qualified Data.ByteString as BS
|
||||
@ -98,10 +99,14 @@ import System.Random.TF(newTFGen)
|
||||
import Numeric (showFFloat)
|
||||
import qualified Data.Text as ST
|
||||
import qualified Data.Text.Lazy as T
|
||||
import Data.IORef(newIORef,readIORef)
|
||||
|
||||
import Prelude ()
|
||||
import Prelude.Compat
|
||||
|
||||
import qualified Data.SBV as SBV (Solver)
|
||||
import qualified Data.SBV.Internals as SBV (showTDiff)
|
||||
|
||||
-- Commands --------------------------------------------------------------------
|
||||
|
||||
-- | Commands.
|
||||
@ -113,9 +118,9 @@ data Command
|
||||
|
||||
-- | Command builder.
|
||||
data CommandDescr = CommandDescr
|
||||
{ cNames :: [String]
|
||||
, cBody :: CommandBody
|
||||
, cHelp :: String
|
||||
{ cNames :: [String]
|
||||
, cBody :: CommandBody
|
||||
, cHelp :: String
|
||||
}
|
||||
|
||||
instance Show CommandDescr where
|
||||
@ -138,6 +143,10 @@ data CommandBody
|
||||
| NoArg (REPL ())
|
||||
|
||||
|
||||
data CommandExitCode = CommandOk
|
||||
| CommandError -- XXX: More?
|
||||
|
||||
|
||||
-- | REPL command parsing.
|
||||
commands :: CommandMap
|
||||
commands = foldl insert emptyTrie commandList
|
||||
@ -173,6 +182,8 @@ nbCommandList =
|
||||
"use a solver to find a satisfying assignment for which the argument returns true (if no argument, find an assignment for all properties)"
|
||||
, CommandDescr [ ":debug_specialize" ] (ExprArg specializeCmd)
|
||||
"do type specialization on a closed expression"
|
||||
, CommandDescr [ ":eval" ] (ExprArg refEvalCmd)
|
||||
"evaluate an expression with the reference evaluator"
|
||||
]
|
||||
|
||||
commandList :: [CommandDescr]
|
||||
@ -210,18 +221,20 @@ genHelp cs = map cmdHelp cs
|
||||
-- Command Evaluation ----------------------------------------------------------
|
||||
|
||||
-- | Run a command.
|
||||
runCommand :: Command -> REPL ()
|
||||
runCommand :: Command -> REPL CommandExitCode
|
||||
runCommand c = case c of
|
||||
|
||||
Command cmd -> cmd `Cryptol.REPL.Monad.catch` handler
|
||||
Command cmd -> (cmd >> return CommandOk) `Cryptol.REPL.Monad.catch` handler
|
||||
where
|
||||
handler re = rPutStrLn "" >> rPrint (pp re)
|
||||
handler re = rPutStrLn "" >> rPrint (pp re) >> return CommandError
|
||||
|
||||
Unknown cmd -> rPutStrLn ("Unknown command: " ++ cmd)
|
||||
Unknown cmd -> do rPutStrLn ("Unknown command: " ++ cmd)
|
||||
return CommandError
|
||||
|
||||
Ambiguous cmd cmds -> do
|
||||
rPutStrLn (cmd ++ " is ambiguous, it could mean one of:")
|
||||
rPutStrLn ("\t" ++ intercalate ", " cmds)
|
||||
return CommandError
|
||||
|
||||
|
||||
-- Get the setting we should use for displaying values.
|
||||
@ -245,13 +258,16 @@ evalCmd str = do
|
||||
P.ExprInput expr -> do
|
||||
(val,_ty) <- replEvalExpr expr
|
||||
ppOpts <- getPPValOpts
|
||||
valDoc <- io $ rethrowEvalError $ E.runEval $ E.ppValue ppOpts val
|
||||
|
||||
-- This is the point where the value gets forced. We deepseq the
|
||||
-- pretty-printed representation of it, rather than the value
|
||||
-- itself, leaving it up to the pretty-printer to determine how
|
||||
-- much of the value to force
|
||||
out <- io $ rethrowEvalError
|
||||
$ return $!! show $ pp $ E.WithBase ppOpts val
|
||||
rPutStrLn out
|
||||
--out <- io $ rethrowEvalError
|
||||
-- $ return $!! show $ pp $ E.WithBase ppOpts val
|
||||
|
||||
rPutStrLn (show valDoc)
|
||||
P.LetInput decl -> do
|
||||
-- explicitly make this a top-level declaration, so that it will
|
||||
-- be generalized if mono-binds is enabled
|
||||
@ -367,13 +383,13 @@ qcCmd qcMode str =
|
||||
prtLn "FAILED"
|
||||
FailFalse vs -> do
|
||||
prtLn "FAILED for the following inputs:"
|
||||
mapM_ (rPrint . pp . E.WithBase opts) vs
|
||||
mapM_ (\v -> rPrint =<< (io $ E.runEval $ E.ppValue opts v)) vs
|
||||
FailError err [] -> do
|
||||
prtLn "ERROR"
|
||||
rPrint (pp err)
|
||||
FailError err vs -> do
|
||||
prtLn "ERROR for the following inputs:"
|
||||
mapM_ (rPrint . pp . E.WithBase opts) vs
|
||||
mapM_ (\v -> rPrint =<< (io $ E.runEval $ E.ppValue opts v)) vs
|
||||
rPrint (pp err)
|
||||
Pass -> panic "Cryptol.REPL.Command" ["unexpected Test.Pass"]
|
||||
|
||||
@ -381,6 +397,13 @@ satCmd, proveCmd :: String -> REPL ()
|
||||
satCmd = cmdProveSat True
|
||||
proveCmd = cmdProveSat False
|
||||
|
||||
showProverStats :: Maybe SBV.Solver -> ProverStats -> REPL ()
|
||||
showProverStats mprover stat = rPutStrLn msg
|
||||
where
|
||||
|
||||
msg = "(Total Elapsed Time: " ++ SBV.showTDiff stat ++
|
||||
maybe "" (\p -> ", using " ++ show p) mprover ++ ")"
|
||||
|
||||
-- | Console-specific version of 'proveSat'. Prints output to the
|
||||
-- console, and binds the @it@ variable to a record whose form depends
|
||||
-- on the expression given. See ticket #66 for a discussion of this
|
||||
@ -421,7 +444,7 @@ cmdProveSat isSat str = do
|
||||
Just path -> io $ writeFile path smtlib
|
||||
Nothing -> rPutStr smtlib
|
||||
_ -> do
|
||||
result <- onlineProveSat isSat str mfile
|
||||
(firstProver,result,stats) <- onlineProveSat isSat str mfile
|
||||
ppOpts <- getPPValOpts
|
||||
case result of
|
||||
Symbolic.EmptyResult ->
|
||||
@ -436,8 +459,8 @@ cmdProveSat isSat str = do
|
||||
vss = map (map $ \(_,_,v) -> v) tevss
|
||||
ppvs vs = do
|
||||
parseExpr <- replParseExpr str
|
||||
let docs = map (pp . E.WithBase ppOpts) vs
|
||||
-- function application has precedence 3
|
||||
docs <- mapM (io . E.runEval . E.ppValue ppOpts) vs
|
||||
let -- function application has precedence 3
|
||||
doc = ppPrec 3 parseExpr
|
||||
rPrint $ hang doc 2 (sep docs) <+>
|
||||
text (if isSat then "= True" else "= False")
|
||||
@ -460,8 +483,12 @@ cmdProveSat isSat str = do
|
||||
(t, [e]) -> bindItVariable t e
|
||||
(t, es ) -> bindItVariables t es
|
||||
|
||||
seeStats <- getUserShowProverStats
|
||||
when seeStats (showProverStats firstProver stats)
|
||||
|
||||
onlineProveSat :: Bool
|
||||
-> String -> Maybe FilePath -> REPL Symbolic.ProverResult
|
||||
-> String -> Maybe FilePath
|
||||
-> REPL (Maybe SBV.Solver,Symbolic.ProverResult,ProverStats)
|
||||
onlineProveSat isSat str mfile = do
|
||||
EnvString proverName <- getUser "prover"
|
||||
EnvBool verbose <- getUser "debug"
|
||||
@ -469,16 +496,20 @@ onlineProveSat isSat str mfile = do
|
||||
parseExpr <- replParseExpr str
|
||||
(_, expr, schema) <- replCheckExpr parseExpr
|
||||
decls <- fmap M.deDecls getDynEnv
|
||||
timing <- io (newIORef 0)
|
||||
let cmd = Symbolic.ProverCommand {
|
||||
pcQueryType = if isSat then SatQuery satNum else ProveQuery
|
||||
, pcProverName = proverName
|
||||
, pcVerbose = verbose
|
||||
, pcProverStats = timing
|
||||
, pcExtraDecls = decls
|
||||
, pcSmtFile = mfile
|
||||
, pcExpr = expr
|
||||
, pcSchema = schema
|
||||
}
|
||||
liftModuleCmd $ Symbolic.satProve cmd
|
||||
(firstProver, res) <- liftModuleCmd $ Symbolic.satProve cmd
|
||||
stas <- io (readIORef timing)
|
||||
return (firstProver,res,stas)
|
||||
|
||||
offlineProveSat :: Bool -> String -> Maybe FilePath -> REPL (Either String String)
|
||||
offlineProveSat isSat str mfile = do
|
||||
@ -486,10 +517,12 @@ offlineProveSat isSat str mfile = do
|
||||
parseExpr <- replParseExpr str
|
||||
(_, expr, schema) <- replCheckExpr parseExpr
|
||||
decls <- fmap M.deDecls getDynEnv
|
||||
timing <- io (newIORef 0)
|
||||
let cmd = Symbolic.ProverCommand {
|
||||
pcQueryType = if isSat then SatQuery (SomeSat 0) else ProveQuery
|
||||
, pcProverName = "offline"
|
||||
, pcVerbose = verbose
|
||||
, pcProverStats = timing
|
||||
, pcExtraDecls = decls
|
||||
, pcSmtFile = mfile
|
||||
, pcExpr = expr
|
||||
@ -541,6 +574,13 @@ specializeCmd str = do
|
||||
rPutStrLn "Specialized expression:"
|
||||
rPutStrLn $ dump spexpr
|
||||
|
||||
refEvalCmd :: String -> REPL ()
|
||||
refEvalCmd str = do
|
||||
parseExpr <- replParseExpr str
|
||||
(_, expr, _schema) <- replCheckExpr parseExpr
|
||||
val <- liftModuleCmd (rethrowEvalError . R.evaluate expr)
|
||||
rPrint $ R.ppValue val
|
||||
|
||||
typeOfCmd :: String -> REPL ()
|
||||
typeOfCmd str = do
|
||||
|
||||
@ -581,8 +621,9 @@ writeFileCmd file str = do
|
||||
tIsByte x = maybe False
|
||||
(\(n,b) -> T.tIsBit b && T.tIsNum n == Just 8)
|
||||
(T.tIsSeq x)
|
||||
serializeValue (E.VSeq _ vs) =
|
||||
return $ BS.pack $ map (serializeByte . E.fromVWord) vs
|
||||
serializeValue (E.VSeq n vs) = do
|
||||
ws <- io $ E.runEval (mapM (>>=E.fromVWord "serializeValue") $ E.enumerateSeqMap n vs)
|
||||
return $ BS.pack $ map serializeByte ws
|
||||
serializeValue _ =
|
||||
panic "Cryptol.REPL.Command.writeFileCmd"
|
||||
["Impossible: Non-VSeq value of type [n][8]."]
|
||||
@ -760,6 +801,19 @@ helpCmd cmd
|
||||
<+> colon
|
||||
<+> pp (ifDeclSig)
|
||||
|
||||
let mbFix = ifDeclFixity `mplus`
|
||||
(guard ifDeclInfix >> return P.defaultFixity)
|
||||
case mbFix of
|
||||
Just f ->
|
||||
let msg = "Precedence " ++ show (P.fLevel f) ++ ", " ++
|
||||
(case P.fAssoc f of
|
||||
P.LeftAssoc -> "associates to the left."
|
||||
P.RightAssoc -> "associates to the right."
|
||||
P.NonAssoc -> "does not associate.")
|
||||
|
||||
in rPutStrLn ('\n' : msg)
|
||||
Nothing -> return ()
|
||||
|
||||
case ifDeclDoc of
|
||||
Just str -> rPutStrLn ('\n' : str)
|
||||
Nothing -> return ()
|
||||
@ -787,8 +841,9 @@ cdCmd f | null f = rPutStrLn $ "[error] :cd requires a path argument"
|
||||
-- C-c Handlings ---------------------------------------------------------------
|
||||
|
||||
-- XXX this should probably do something a bit more specific.
|
||||
handleCtrlC :: REPL ()
|
||||
handleCtrlC = rPutStrLn "Ctrl-C"
|
||||
handleCtrlC :: a -> REPL a
|
||||
handleCtrlC a = do rPutStrLn "Ctrl-C"
|
||||
return a
|
||||
|
||||
|
||||
-- Utilities -------------------------------------------------------------------
|
||||
@ -846,6 +901,7 @@ moduleCmdResult (res,ws0) = do
|
||||
filterDefaults w = Just w
|
||||
|
||||
isShadowWarn (M.SymbolShadowed {}) = True
|
||||
isShadowWarn _ = False
|
||||
|
||||
filterShadowing w | warnShadowing = Just w
|
||||
filterShadowing (M.RenamerWarnings xs) =
|
||||
@ -902,8 +958,7 @@ replEvalExpr expr =
|
||||
let su = T.listSubst [ (T.tpVar a, t) | (a,t) <- tys ]
|
||||
return (def1, T.apSubst su (T.sType sig))
|
||||
|
||||
val <- liftModuleCmd (M.evalExpr def1)
|
||||
_ <- io $ rethrowEvalError $ X.evaluate val
|
||||
val <- liftModuleCmd (rethrowEvalError . M.evalExpr def1)
|
||||
whenDebug (rPutStrLn (dump def1))
|
||||
-- add "it" to the namespace
|
||||
bindItVariable ty def1
|
||||
|
@ -57,6 +57,7 @@ module Cryptol.REPL.Monad (
|
||||
, setUser, getUser, tryGetUser
|
||||
, userOptions
|
||||
, getUserSatNum
|
||||
, getUserShowProverStats
|
||||
|
||||
-- ** Configurable Output
|
||||
, getPutStr
|
||||
@ -304,12 +305,13 @@ unlessBatch body = do
|
||||
|
||||
-- | Run a computation in batch mode, restoring the previous isBatch
|
||||
-- flag afterwards
|
||||
asBatch :: REPL () -> REPL ()
|
||||
asBatch :: REPL a -> REPL a
|
||||
asBatch body = do
|
||||
wasBatch <- eIsBatch `fmap` getRW
|
||||
modifyRW_ $ (\ rw -> rw { eIsBatch = True })
|
||||
body
|
||||
a <- body
|
||||
modifyRW_ $ (\ rw -> rw { eIsBatch = wasBatch })
|
||||
return a
|
||||
|
||||
disableLet :: REPL ()
|
||||
disableLet = modifyRW_ (\ rw -> rw { eLetEnabled = False })
|
||||
@ -487,7 +489,7 @@ mkUserEnv opts = Map.fromList $ do
|
||||
|
||||
-- | Set a user option.
|
||||
setUser :: String -> String -> REPL ()
|
||||
setUser name val = case lookupTrie name userOptions of
|
||||
setUser name val = case lookupTrieExact name userOptions of
|
||||
|
||||
[opt] -> setUserOpt opt
|
||||
[] -> io (putStrLn ("Unknown env value `" ++ name ++ "`"))
|
||||
@ -565,6 +567,11 @@ getUser name = do
|
||||
Just ev -> return ev
|
||||
Nothing -> panic "[REPL] getUser" ["option `" ++ name ++ "` does not exist"]
|
||||
|
||||
getUserShowProverStats :: REPL Bool
|
||||
getUserShowProverStats =
|
||||
do EnvBool yes <- getUser "prover-stats"
|
||||
return yes
|
||||
|
||||
-- Environment Options ---------------------------------------------------------
|
||||
|
||||
type OptionMap = Trie OptionDescr
|
||||
@ -640,8 +647,12 @@ userOptions = mkOptionMap
|
||||
in \case EnvBool True -> setIt M.CoreLint
|
||||
EnvBool False -> setIt M.NoCoreLint
|
||||
_ -> return ()
|
||||
|
||||
, simpleOpt "prover-stats" (EnvBool True) (const (return Nothing))
|
||||
"Enable prover timing statistics."
|
||||
]
|
||||
|
||||
|
||||
-- | Check the value to the `base` option.
|
||||
checkBase :: EnvVal -> IO (Maybe String)
|
||||
checkBase val = case val of
|
||||
|
@ -16,12 +16,15 @@
|
||||
|
||||
module Cryptol.Symbolic where
|
||||
|
||||
import Control.Monad (replicateM, when, zipWithM)
|
||||
import Data.List (transpose, intercalate)
|
||||
import qualified Data.Map as Map
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad (replicateM, when, zipWithM, foldM)
|
||||
import Data.List (intercalate, genericLength)
|
||||
import Data.IORef(IORef)
|
||||
import qualified Control.Exception as X
|
||||
|
||||
import qualified Data.SBV.Dynamic as SBV
|
||||
import Data.SBV (Timing(SaveTiming))
|
||||
import Data.SBV.Internals (showTDiff)
|
||||
|
||||
import qualified Cryptol.ModuleSystem as M hiding (getPrimMap)
|
||||
import qualified Cryptol.ModuleSystem.Env as M
|
||||
@ -31,11 +34,12 @@ import qualified Cryptol.ModuleSystem.Monad as M
|
||||
import Cryptol.Symbolic.Prims
|
||||
import Cryptol.Symbolic.Value
|
||||
|
||||
import qualified Cryptol.Eval as Eval
|
||||
import qualified Cryptol.Eval.Monad as Eval
|
||||
import qualified Cryptol.Eval.Type as Eval
|
||||
import qualified Cryptol.Eval.Value as Eval
|
||||
import qualified Cryptol.Eval.Type (evalValType, evalNumType)
|
||||
import qualified Cryptol.Eval.Env (EvalEnv(..))
|
||||
import Cryptol.Eval.Env (GenEvalEnv(..))
|
||||
import Cryptol.TypeCheck.AST
|
||||
import Cryptol.TypeCheck.Solver.InfNat (Nat'(..))
|
||||
import Cryptol.Utils.Ident (Ident)
|
||||
import Cryptol.Utils.PP
|
||||
import Cryptol.Utils.Panic(panic)
|
||||
@ -43,6 +47,11 @@ import Cryptol.Utils.Panic(panic)
|
||||
import Prelude ()
|
||||
import Prelude.Compat
|
||||
|
||||
import Data.Time (NominalDiffTime)
|
||||
|
||||
type EvalEnv = GenEvalEnv SBool SWord
|
||||
|
||||
|
||||
-- External interface ----------------------------------------------------------
|
||||
|
||||
proverConfigs :: [(String, SBV.SMTConfig)]
|
||||
@ -82,6 +91,8 @@ data ProverCommand = ProverCommand {
|
||||
-- ^ Which prover to use (one of the strings in 'proverConfigs')
|
||||
, pcVerbose :: Bool
|
||||
-- ^ Verbosity flag passed to SBV
|
||||
, pcProverStats :: !(IORef ProverStats)
|
||||
-- ^ Record timing information here
|
||||
, pcExtraDecls :: [DeclGroup]
|
||||
-- ^ Extra declarations to bring into scope for symbolic
|
||||
-- simulation
|
||||
@ -93,6 +104,8 @@ data ProverCommand = ProverCommand {
|
||||
-- ^ The 'Schema' of @pcExpr@
|
||||
}
|
||||
|
||||
type ProverStats = NominalDiffTime
|
||||
|
||||
-- | A prover result is either an error message, an empty result (eg
|
||||
-- for the offline prover), a counterexample or a lazy list of
|
||||
-- satisfying assignments.
|
||||
@ -105,16 +118,18 @@ satSMTResults :: SBV.SatResult -> [SBV.SMTResult]
|
||||
satSMTResults (SBV.SatResult r) = [r]
|
||||
|
||||
allSatSMTResults :: SBV.AllSatResult -> [SBV.SMTResult]
|
||||
allSatSMTResults (SBV.AllSatResult (_, rs)) = rs
|
||||
allSatSMTResults (SBV.AllSatResult (_, _, rs)) = rs
|
||||
|
||||
thmSMTResults :: SBV.ThmResult -> [SBV.SMTResult]
|
||||
thmSMTResults (SBV.ThmResult r) = [r]
|
||||
|
||||
proverError :: String -> M.ModuleCmd ProverResult
|
||||
proverError msg modEnv = return (Right (ProverError msg, modEnv), [])
|
||||
proverError :: String -> M.ModuleCmd (Maybe SBV.Solver, ProverResult)
|
||||
proverError msg modEnv =
|
||||
return (Right ((Nothing, ProverError msg), modEnv), [])
|
||||
|
||||
satProve :: ProverCommand -> M.ModuleCmd ProverResult
|
||||
satProve ProverCommand {..} = protectStack proverError $ \modEnv ->
|
||||
satProve :: ProverCommand -> M.ModuleCmd (Maybe SBV.Solver, ProverResult)
|
||||
satProve ProverCommand {..} =
|
||||
protectStack proverError $ \modEnv ->
|
||||
M.runModuleM modEnv $ do
|
||||
let (isSat, mSatNum) = case pcQueryType of
|
||||
ProveQuery -> (False, Nothing)
|
||||
@ -125,47 +140,54 @@ satProve ProverCommand {..} = protectStack proverError $ \modEnv ->
|
||||
provers <-
|
||||
case pcProverName of
|
||||
"any" -> M.io SBV.sbvAvailableSolvers
|
||||
_ -> return [(lookupProver pcProverName) { SBV.smtFile = pcSmtFile }]
|
||||
let provers' = [ p { SBV.timing = pcVerbose, SBV.verbose = pcVerbose } | p <- provers ]
|
||||
_ -> return [(lookupProver pcProverName) { SBV.transcript = pcSmtFile }]
|
||||
|
||||
|
||||
let provers' = [ p { SBV.timing = SaveTiming pcProverStats, SBV.verbose = pcVerbose } | p <- provers ]
|
||||
let tyFn = if isSat then existsFinType else forallFinType
|
||||
let runProver fn tag e = do
|
||||
case provers of
|
||||
[prover] -> do
|
||||
when pcVerbose $ M.io $
|
||||
putStrLn $ "Trying proof with " ++ show prover
|
||||
putStrLn $ "Trying proof with " ++ show (SBV.name (SBV.solver prover))
|
||||
res <- M.io (fn prover e)
|
||||
when pcVerbose $ M.io $
|
||||
putStrLn $ "Got result from " ++ show prover
|
||||
return (tag res)
|
||||
putStrLn $ "Got result from " ++ show (SBV.name (SBV.solver prover))
|
||||
return (Just (SBV.name (SBV.solver prover)), tag res)
|
||||
_ ->
|
||||
return [ SBV.ProofError
|
||||
prover
|
||||
[":sat with option prover=any requires option satNum=1"]
|
||||
| prover <- provers ]
|
||||
return ( Nothing
|
||||
, [ SBV.ProofError
|
||||
prover
|
||||
[":sat with option prover=any requires option satNum=1"]
|
||||
| prover <- provers ]
|
||||
)
|
||||
runProvers fn tag e = do
|
||||
when pcVerbose $ M.io $
|
||||
putStrLn $ "Trying proof with " ++
|
||||
intercalate ", " (map show provers)
|
||||
(firstProver, res) <- M.io (fn provers' e)
|
||||
intercalate ", " (map (show . SBV.name . SBV.solver) provers)
|
||||
(firstProver, timeElapsed, res) <- M.io (fn provers' e)
|
||||
when pcVerbose $ M.io $
|
||||
putStrLn $ "Got result from " ++ show firstProver
|
||||
return (tag res)
|
||||
putStrLn $ "Got result from " ++ show firstProver ++ ", time: " ++ showTDiff timeElapsed
|
||||
return (Just firstProver, tag res)
|
||||
let runFn = case pcQueryType of
|
||||
ProveQuery -> runProvers SBV.proveWithAny thmSMTResults
|
||||
SatQuery sn -> case sn of
|
||||
SomeSat 1 -> runProvers SBV.satWithAny satSMTResults
|
||||
_ -> runProver SBV.allSatWith allSatSMTResults
|
||||
case predArgTypes pcSchema of
|
||||
Left msg -> return (ProverError msg)
|
||||
Left msg -> return (Nothing, ProverError msg)
|
||||
Right ts -> do when pcVerbose $ M.io $ putStrLn "Simulating..."
|
||||
let env = evalDecls mempty extDgs
|
||||
let v = evalExpr env pcExpr
|
||||
v <- M.io $ Eval.runEval $ do
|
||||
env <- Eval.evalDecls extDgs mempty
|
||||
Eval.evalExpr env pcExpr
|
||||
prims <- M.getPrimMap
|
||||
results' <- runFn $ do
|
||||
args <- mapM tyFn ts
|
||||
b <- return $! fromVBit (foldl fromVFun v args)
|
||||
return b
|
||||
let results = maybe results' (\n -> take n results') mSatNum
|
||||
runRes <- runFn $ do
|
||||
args <- mapM tyFn ts
|
||||
b <- liftIO $ Eval.runEval
|
||||
(fromVBit <$> foldM fromVFun v (map Eval.ready args))
|
||||
return b
|
||||
let (firstProver, results') = runRes
|
||||
results = maybe results' (\n -> take n results') mSatNum
|
||||
esatexprs <- case results of
|
||||
-- allSat can return more than one as long as
|
||||
-- they're satisfiable
|
||||
@ -173,12 +195,13 @@ satProve ProverCommand {..} = protectStack proverError $ \modEnv ->
|
||||
tevss <- mapM mkTevs results
|
||||
return $ AllSatResult tevss
|
||||
where
|
||||
mkTevs result =
|
||||
let Right (_, cws) = SBV.getModel result
|
||||
mkTevs result = do
|
||||
let Right (_, cws) = SBV.getModelAssignment result
|
||||
(vs, _) = parseValues ts cws
|
||||
sattys = unFinType <$> ts
|
||||
satexprs = zipWithM (Eval.toExpr prims) sattys vs
|
||||
in case zip3 sattys <$> satexprs <*> pure vs of
|
||||
satexprs <- liftIO $ Eval.runEval
|
||||
(zipWithM (Eval.toExpr prims) sattys vs)
|
||||
case zip3 sattys <$> (sequence satexprs) <*> pure vs of
|
||||
Nothing ->
|
||||
panic "Cryptol.Symbolic.sat"
|
||||
[ "unable to make assignment into expression" ]
|
||||
@ -190,11 +213,11 @@ satProve ProverCommand {..} = protectStack proverError $ \modEnv ->
|
||||
[] -> return $ ThmResult (unFinType <$> ts)
|
||||
-- otherwise something is wrong
|
||||
_ -> return $ ProverError (rshow results)
|
||||
where rshow | isSat = show . SBV.AllSatResult . (boom,)
|
||||
where rshow | isSat = show . SBV.AllSatResult . (False,boom,)
|
||||
| otherwise = show . SBV.ThmResult . head
|
||||
boom = panic "Cryptol.Symbolic.sat"
|
||||
[ "attempted to evaluate bogus boolean for pretty-printing" ]
|
||||
return esatexprs
|
||||
return (firstProver, esatexprs)
|
||||
|
||||
satProveOffline :: ProverCommand -> M.ModuleCmd (Either String String)
|
||||
satProveOffline ProverCommand {..} =
|
||||
@ -208,12 +231,13 @@ satProveOffline ProverCommand {..} =
|
||||
Left msg -> return (Right (Left msg, modEnv), [])
|
||||
Right ts ->
|
||||
do when pcVerbose $ putStrLn "Simulating..."
|
||||
let env = evalDecls mempty extDgs
|
||||
let v = evalExpr env pcExpr
|
||||
smtlib <- SBV.compileToSMTLib SBV.SMTLib2 isSat $ do
|
||||
v <- liftIO $ Eval.runEval $
|
||||
do env <- Eval.evalDecls extDgs mempty
|
||||
Eval.evalExpr env pcExpr
|
||||
smtlib <- SBV.generateSMTBenchmark isSat $ do
|
||||
args <- mapM tyFn ts
|
||||
b <- return $! fromVBit (foldl fromVFun v args)
|
||||
return b
|
||||
liftIO $ Eval.runEval
|
||||
(fromVBit <$> foldM fromVFun v (map Eval.ready args))
|
||||
return (Right (Right smtlib, modEnv), [])
|
||||
|
||||
protectStack :: (String -> M.ModuleCmd a)
|
||||
@ -235,17 +259,21 @@ parseValues (t : ts) cws = (v : vs, cws'')
|
||||
parseValue :: FinType -> [SBV.CW] -> (Eval.Value, [SBV.CW])
|
||||
parseValue FTBit [] = panic "Cryptol.Symbolic.parseValue" [ "empty FTBit" ]
|
||||
parseValue FTBit (cw : cws) = (Eval.VBit (SBV.cwToBool cw), cws)
|
||||
parseValue (FTSeq 0 FTBit) cws = (Eval.VWord (Eval.BV 0 0), cws)
|
||||
parseValue (FTSeq 0 FTBit) cws = (Eval.word 0 0, cws)
|
||||
parseValue (FTSeq n FTBit) cws =
|
||||
case SBV.genParse (SBV.KBounded False n) cws of
|
||||
Just (x, cws') -> (Eval.VWord (Eval.BV (toInteger n) x), cws')
|
||||
Nothing -> (Eval.VSeq True vs, cws')
|
||||
Just (x, cws') -> (Eval.word (toInteger n) x, cws')
|
||||
Nothing -> (VWord (genericLength vs) $ return $ Eval.WordVal $
|
||||
Eval.packWord (map fromVBit vs), cws')
|
||||
where (vs, cws') = parseValues (replicate n FTBit) cws
|
||||
parseValue (FTSeq n t) cws = (Eval.VSeq False vs, cws')
|
||||
parseValue (FTSeq n t) cws =
|
||||
(Eval.VSeq (toInteger n) $ Eval.finiteSeqMap (map Eval.ready vs)
|
||||
, cws'
|
||||
)
|
||||
where (vs, cws') = parseValues (replicate n t) cws
|
||||
parseValue (FTTuple ts) cws = (Eval.VTuple vs, cws')
|
||||
parseValue (FTTuple ts) cws = (Eval.VTuple (map Eval.ready vs), cws')
|
||||
where (vs, cws') = parseValues ts cws
|
||||
parseValue (FTRecord fs) cws = (Eval.VRecord (zip ns vs), cws')
|
||||
parseValue (FTRecord fs) cws = (Eval.VRecord (zip ns (map Eval.ready vs)), cws')
|
||||
where (ns, ts) = unzip fs
|
||||
(vs, cws') = parseValues ts cws
|
||||
|
||||
@ -266,11 +294,11 @@ numType n
|
||||
finType :: TValue -> Maybe FinType
|
||||
finType ty =
|
||||
case ty of
|
||||
TVBit -> Just FTBit
|
||||
TVSeq n t -> FTSeq <$> numType n <*> finType t
|
||||
TVTuple ts -> FTTuple <$> traverse finType ts
|
||||
TVRec fields -> FTRecord <$> traverse (traverseSnd finType) fields
|
||||
_ -> Nothing
|
||||
Eval.TVBit -> Just FTBit
|
||||
Eval.TVSeq n t -> FTSeq <$> numType n <*> finType t
|
||||
Eval.TVTuple ts -> FTTuple <$> traverse finType ts
|
||||
Eval.TVRec fields -> FTRecord <$> traverse (traverseSnd finType) fields
|
||||
_ -> Nothing
|
||||
|
||||
unFinType :: FinType -> Type
|
||||
unFinType fty =
|
||||
@ -286,218 +314,34 @@ unFinType fty =
|
||||
predArgTypes :: Schema -> Either String [FinType]
|
||||
predArgTypes schema@(Forall ts ps ty)
|
||||
| null ts && null ps =
|
||||
case go (Cryptol.Eval.Type.evalValType mempty ty) of
|
||||
Just fts -> Right fts
|
||||
Nothing -> Left $ "Not a valid predicate type:\n" ++ show (pp schema)
|
||||
case go <$> (Eval.evalType mempty ty) of
|
||||
Right (Just fts) -> Right fts
|
||||
_ -> Left $ "Not a valid predicate type:\n" ++ show (pp schema)
|
||||
| otherwise = Left $ "Not a monomorphic type:\n" ++ show (pp schema)
|
||||
where
|
||||
go :: TValue -> Maybe [FinType]
|
||||
go TVBit = Just []
|
||||
go (TVFun ty1 ty2) = (:) <$> finType ty1 <*> go ty2
|
||||
go _ = Nothing
|
||||
go Eval.TVBit = Just []
|
||||
go (Eval.TVFun ty1 ty2) = (:) <$> finType ty1 <*> go ty2
|
||||
go _ = Nothing
|
||||
|
||||
forallFinType :: FinType -> SBV.Symbolic Value
|
||||
forallFinType ty =
|
||||
case ty of
|
||||
FTBit -> VBit <$> forallSBool_
|
||||
FTSeq 0 FTBit -> return $ VWord (literalSWord 0 0)
|
||||
FTSeq n FTBit -> VWord <$> (forallBV_ n)
|
||||
FTSeq n t -> VSeq False <$> replicateM n (forallFinType t)
|
||||
FTTuple ts -> VTuple <$> mapM forallFinType ts
|
||||
FTRecord fs -> VRecord <$> mapM (traverseSnd forallFinType) fs
|
||||
FTSeq 0 FTBit -> return $ Eval.word 0 0
|
||||
FTSeq n FTBit -> VWord (toInteger n) . return . Eval.WordVal <$> (forallBV_ n)
|
||||
FTSeq n t -> do vs <- replicateM n (forallFinType t)
|
||||
return $ VSeq (toInteger n) $ Eval.finiteSeqMap (map Eval.ready vs)
|
||||
FTTuple ts -> VTuple <$> mapM (fmap Eval.ready . forallFinType) ts
|
||||
FTRecord fs -> VRecord <$> mapM (traverseSnd (fmap Eval.ready . forallFinType)) fs
|
||||
|
||||
existsFinType :: FinType -> SBV.Symbolic Value
|
||||
existsFinType ty =
|
||||
case ty of
|
||||
FTBit -> VBit <$> existsSBool_
|
||||
FTSeq 0 FTBit -> return $ VWord (literalSWord 0 0)
|
||||
FTSeq n FTBit -> VWord <$> existsBV_ n
|
||||
FTSeq n t -> VSeq False <$> replicateM n (existsFinType t)
|
||||
FTTuple ts -> VTuple <$> mapM existsFinType ts
|
||||
FTRecord fs -> VRecord <$> mapM (traverseSnd existsFinType) fs
|
||||
|
||||
-- Simulation environment ------------------------------------------------------
|
||||
|
||||
data Env = Env
|
||||
{ envVars :: Map.Map Name Value
|
||||
, envTypes :: Map.Map TVar (Either Nat' TValue)
|
||||
}
|
||||
|
||||
instance Monoid Env where
|
||||
mempty = Env
|
||||
{ envVars = Map.empty
|
||||
, envTypes = Map.empty
|
||||
}
|
||||
|
||||
mappend l r = Env
|
||||
{ envVars = Map.union (envVars l) (envVars r)
|
||||
, envTypes = Map.union (envTypes l) (envTypes r)
|
||||
}
|
||||
|
||||
-- | Bind a variable in the evaluation environment.
|
||||
bindVar :: (Name, Value) -> Env -> Env
|
||||
bindVar (n, thunk) env = env { envVars = Map.insert n thunk (envVars env) }
|
||||
|
||||
-- | Lookup a variable in the environment.
|
||||
lookupVar :: Name -> Env -> Maybe Value
|
||||
lookupVar n env = Map.lookup n (envVars env)
|
||||
|
||||
-- | Bind a type variable of kind *.
|
||||
bindType :: TVar -> (Either Nat' TValue) -> Env -> Env
|
||||
bindType p ty env = env { envTypes = Map.insert p ty (envTypes env) }
|
||||
|
||||
-- | Lookup a type variable.
|
||||
lookupType :: TVar -> Env -> Maybe (Either Nat' TValue)
|
||||
lookupType p env = Map.lookup p (envTypes env)
|
||||
|
||||
-- Expressions -----------------------------------------------------------------
|
||||
|
||||
evalExpr :: Env -> Expr -> Value
|
||||
evalExpr env expr =
|
||||
case expr of
|
||||
EList es ty -> VSeq (tIsBit ty) (map eval es)
|
||||
ETuple es -> VTuple (map eval es)
|
||||
ERec fields -> VRecord [ (f, eval e) | (f, e) <- fields ]
|
||||
ESel e sel -> evalSel sel (eval e)
|
||||
EIf b e1 e2 -> iteValue (fromVBit (eval b)) (eval e1) (eval e2)
|
||||
EComp ty e mss -> evalComp env (evalValType env ty) e mss
|
||||
EVar n -> case lookupVar n env of
|
||||
Just x -> x
|
||||
_ -> panic "Cryptol.Symbolic.evalExpr" [ "Variable " ++ show n ++ " not found" ]
|
||||
-- TODO: how to deal with uninterpreted functions?
|
||||
ETAbs tv e -> case tpKind tv of
|
||||
KType -> VPoly $ \ty -> evalExpr (bindType (tpVar tv) (Right ty) env) e
|
||||
KNum -> VNumPoly $ \n -> evalExpr (bindType (tpVar tv) (Left n) env) e
|
||||
k -> panic "[Symbolic] evalExpr" ["invalid kind on type abstraction", show k]
|
||||
ETApp e ty -> case eval e of
|
||||
VPoly f -> f (evalValType env ty)
|
||||
VNumPoly f -> f (evalNumType env ty)
|
||||
_ -> panic "[Symbolic] evalExpr"
|
||||
[ "expected a polymorphic value"
|
||||
, show e, show ty
|
||||
]
|
||||
EApp e1 e2 -> fromVFun (eval e1) (eval e2)
|
||||
EAbs n _ty e -> VFun $ \x -> evalExpr (bindVar (n, x) env) e
|
||||
EProofAbs _prop e -> eval e
|
||||
EProofApp e -> eval e
|
||||
ECast e _ty -> eval e
|
||||
EWhere e ds -> evalExpr (evalDecls env ds) e
|
||||
where
|
||||
eval e = evalExpr env e
|
||||
|
||||
evalValType :: Env -> Type -> TValue
|
||||
evalValType env ty = Cryptol.Eval.Type.evalValType env' ty
|
||||
where env' = Cryptol.Eval.Env.EvalEnv Map.empty (envTypes env)
|
||||
|
||||
evalNumType :: Env -> Type -> Nat'
|
||||
evalNumType env ty = Cryptol.Eval.Type.evalNumType env' ty
|
||||
where env' = Cryptol.Eval.Env.EvalEnv Map.empty (envTypes env)
|
||||
|
||||
evalSel :: Selector -> Value -> Value
|
||||
evalSel sel v =
|
||||
case sel of
|
||||
TupleSel n _ ->
|
||||
case v of
|
||||
VTuple xs -> xs !! n -- 0-based indexing
|
||||
VSeq b xs -> VSeq b (map (evalSel sel) xs)
|
||||
VStream xs -> VStream (map (evalSel sel) xs)
|
||||
VFun f -> VFun (\x -> evalSel sel (f x))
|
||||
_ -> panic "Cryptol.Symbolic.evalSel" [ "Tuple selector applied to incompatible type" ]
|
||||
|
||||
RecordSel n _ ->
|
||||
case v of
|
||||
VRecord bs -> case lookup n bs of
|
||||
Just x -> x
|
||||
_ -> panic "Cryptol.Symbolic.evalSel" [ "Selector " ++ show n ++ " not found" ]
|
||||
VSeq b xs -> VSeq b (map (evalSel sel) xs)
|
||||
VStream xs -> VStream (map (evalSel sel) xs)
|
||||
VFun f -> VFun (\x -> evalSel sel (f x))
|
||||
_ -> panic "Cryptol.Symbolic.evalSel" [ "Record selector applied to non-record" ]
|
||||
|
||||
ListSel n _ -> case v of
|
||||
VWord s -> VBit (SBV.svTestBit s i)
|
||||
where i = SBV.intSizeOf s - 1 - n
|
||||
_ -> fromSeq v !! n -- 0-based indexing
|
||||
|
||||
-- Declarations ----------------------------------------------------------------
|
||||
|
||||
evalDecls :: Env -> [DeclGroup] -> Env
|
||||
evalDecls = foldl evalDeclGroup
|
||||
|
||||
evalDeclGroup :: Env -> DeclGroup -> Env
|
||||
evalDeclGroup env dg =
|
||||
case dg of
|
||||
NonRecursive d -> bindVar (evalDecl env d) env
|
||||
Recursive ds -> let env' = foldr bindVar env lazyBindings
|
||||
bindings = map (evalDecl env') ds
|
||||
lazyBindings = [ (qname, copyBySchema env (dSignature d) v)
|
||||
| (d, (qname, v)) <- zip ds bindings ]
|
||||
in env'
|
||||
|
||||
evalDecl :: Env -> Decl -> (Name, Value)
|
||||
evalDecl env d = (dName d, body)
|
||||
where
|
||||
body = case dDefinition d of
|
||||
DExpr e -> evalExpr env e
|
||||
DPrim -> evalPrim d
|
||||
|
||||
-- | Make a copy of the given value, building the spine based only on
|
||||
-- the type without forcing the value argument. This lets us avoid
|
||||
-- strictness problems when evaluating recursive definitions.
|
||||
copyBySchema :: Env -> Schema -> Value -> Value
|
||||
copyBySchema env0 (Forall params _props ty) = go params env0
|
||||
where
|
||||
go [] env v = copyByType env (evalValType env ty) v
|
||||
go (p : ps) env v =
|
||||
case tpKind p of
|
||||
KType -> VPoly (\t -> go ps (bindType (tpVar p) (Right t) env) (fromVPoly v t))
|
||||
KNum -> VNumPoly (\t -> go ps (bindType (tpVar p) (Left t) env) (fromVNumPoly v t))
|
||||
k -> panic "[Eval] copyBySchema" ["invalid kind on type abstraction", show k]
|
||||
|
||||
copyByType :: Env -> TValue -> Value -> Value
|
||||
copyByType env ty v =
|
||||
case ty of
|
||||
TVBit -> VBit (fromVBit v)
|
||||
TVSeq _ ety -> VSeq (isTBit ety) (fromSeq v)
|
||||
TVStream _ -> VStream (fromSeq v)
|
||||
TVFun _ bty -> VFun (\x -> copyByType env bty (fromVFun v x))
|
||||
TVTuple tys -> VTuple (zipWith (copyByType env) tys (fromVTuple v))
|
||||
TVRec fs -> VRecord [ (f, copyByType env t (lookupRecord f v)) | (f, t) <- fs ]
|
||||
-- copyByType env ty v = logicUnary id id (evalValType env ty) v
|
||||
|
||||
-- List Comprehensions ---------------------------------------------------------
|
||||
|
||||
-- | Evaluate a comprehension.
|
||||
evalComp :: Env -> TValue -> Expr -> [[Match]] -> Value
|
||||
evalComp env seqty body ms =
|
||||
case Eval.isTSeq seqty of
|
||||
Just (len, el) -> toSeq len el [ evalExpr e body | e <- envs ]
|
||||
Nothing -> evalPanic "Cryptol.Eval" ["evalComp given a non sequence", show seqty]
|
||||
|
||||
-- XXX we could potentially print this as a number if the type was available.
|
||||
where
|
||||
-- generate a new environment for each iteration of each parallel branch
|
||||
benvs = map (branchEnvs env) ms
|
||||
|
||||
-- take parallel slices of each environment. when the length of the list
|
||||
-- drops below the number of branches, one branch has terminated.
|
||||
allBranches es = length es == length ms
|
||||
slices = takeWhile allBranches (transpose benvs)
|
||||
|
||||
-- join environments to produce environments at each step through the process.
|
||||
envs = map mconcat slices
|
||||
|
||||
-- | Turn a list of matches into the final environments for each iteration of
|
||||
-- the branch.
|
||||
branchEnvs :: Env -> [Match] -> [Env]
|
||||
branchEnvs env matches =
|
||||
case matches of
|
||||
[] -> [env]
|
||||
m : ms -> do env' <- evalMatch env m
|
||||
branchEnvs env' ms
|
||||
|
||||
-- | Turn a match into the list of environments it represents.
|
||||
evalMatch :: Env -> Match -> [Env]
|
||||
evalMatch env m = case m of
|
||||
From n _ty expr -> [ bindVar (n, v) env | v <- fromSeq (evalExpr env expr) ]
|
||||
Let d -> [ bindVar (evalDecl env d) env ]
|
||||
FTSeq 0 FTBit -> return $ Eval.word 0 0
|
||||
FTSeq n FTBit -> VWord (toInteger n) . return . Eval.WordVal <$> (existsBV_ n)
|
||||
FTSeq n t -> do vs <- replicateM n (existsFinType t)
|
||||
return $ VSeq (toInteger n) $ Eval.finiteSeqMap (map Eval.ready vs)
|
||||
FTTuple ts -> VTuple <$> mapM (fmap Eval.ready . existsFinType) ts
|
||||
FTRecord fs -> VRecord <$> mapM (traverseSnd (fmap Eval.ready . existsFinType)) fs
|
||||
|
File diff suppressed because it is too large
Load Diff
@ -9,6 +9,7 @@
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE PatternGuards #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
module Cryptol.Symbolic.Value
|
||||
@ -18,25 +19,33 @@ module Cryptol.Symbolic.Value
|
||||
, forallBV_, existsBV_
|
||||
, forallSBool_, existsSBool_
|
||||
, Value
|
||||
, TValue(..), isTBit, tvSeq
|
||||
, GenValue(..), lam, tlam, nlam, toStream, toFinSeq, toSeq, finNat'
|
||||
, fromVBit, fromVFun, fromVPoly, fromVNumPoly, fromVTuple, fromVRecord
|
||||
, lookupRecord
|
||||
, TValue, isTBit, tvSeq
|
||||
, GenValue(..), lam, tlam, toStream, toFinSeq, toSeq
|
||||
, fromVBit, fromVFun, fromVPoly, fromVTuple, fromVRecord, lookupRecord
|
||||
, fromSeq, fromVWord
|
||||
, evalPanic
|
||||
, iteValue, mergeValue
|
||||
, iteSValue, mergeValue, mergeWord, mergeBit, mergeBits, mergeSeqMap
|
||||
)
|
||||
where
|
||||
|
||||
import Data.List (foldl')
|
||||
import qualified Data.Sequence as Seq
|
||||
|
||||
import Data.SBV.Dynamic
|
||||
|
||||
import Cryptol.Eval.Value (TValue(..), isTBit, tvSeq, finNat', GenValue(..),
|
||||
BitWord(..), lam, tlam, nlam, toStream, toFinSeq, toSeq,
|
||||
--import Cryptol.Eval.Monad
|
||||
import Cryptol.Eval.Type (TValue(..), isTBit, tvSeq)
|
||||
import Cryptol.Eval.Monad (Eval)
|
||||
import Cryptol.Eval.Value ( GenValue(..), BitWord(..), lam, tlam, toStream,
|
||||
toFinSeq, toSeq, WordValue(..), asBitsVal,
|
||||
fromSeq, fromVBit, fromVWord, fromVFun, fromVPoly,
|
||||
fromVNumPoly, fromVTuple, fromVRecord, lookupRecord)
|
||||
fromVTuple, fromVRecord, lookupRecord, SeqMap(..),
|
||||
ppBV,BV(..),integerToChar, lookupSeqMap )
|
||||
import Cryptol.Utils.Panic (panic)
|
||||
import Cryptol.Utils.PP
|
||||
|
||||
import Control.Monad.Reader (ask)
|
||||
import Control.Monad.Trans (liftIO)
|
||||
|
||||
-- SBool and SWord -------------------------------------------------------------
|
||||
|
||||
@ -51,16 +60,16 @@ literalSWord :: Int -> Integer -> SWord
|
||||
literalSWord w i = svInteger (KBounded False w) i
|
||||
|
||||
forallBV_ :: Int -> Symbolic SWord
|
||||
forallBV_ w = svMkSymVar (Just ALL) (KBounded False w) Nothing
|
||||
forallBV_ w = ask >>= liftIO . svMkSymVar (Just ALL) (KBounded False w) Nothing
|
||||
|
||||
existsBV_ :: Int -> Symbolic SWord
|
||||
existsBV_ w = svMkSymVar (Just EX) (KBounded False w) Nothing
|
||||
existsBV_ w = ask >>= liftIO . svMkSymVar (Just EX) (KBounded False w) Nothing
|
||||
|
||||
forallSBool_ :: Symbolic SBool
|
||||
forallSBool_ = svMkSymVar (Just ALL) KBool Nothing
|
||||
forallSBool_ = ask >>= liftIO . svMkSymVar (Just ALL) KBool Nothing
|
||||
|
||||
existsSBool_ :: Symbolic SBool
|
||||
existsSBool_ = svMkSymVar (Just EX) KBool Nothing
|
||||
existsSBool_ = ask >>= liftIO . svMkSymVar (Just EX) KBool Nothing
|
||||
|
||||
-- Values ----------------------------------------------------------------------
|
||||
|
||||
@ -68,44 +77,94 @@ type Value = GenValue SBool SWord
|
||||
|
||||
-- Symbolic Conditionals -------------------------------------------------------
|
||||
|
||||
iteValue :: SBool -> Value -> Value -> Value
|
||||
iteValue c x y =
|
||||
iteSValue :: SBool -> Value -> Value -> Value
|
||||
iteSValue c x y =
|
||||
case svAsBool c of
|
||||
Just True -> x
|
||||
Just False -> y
|
||||
Nothing -> mergeValue True c x y
|
||||
|
||||
mergeBit :: Bool
|
||||
-> SBool
|
||||
-> SBool
|
||||
-> SBool
|
||||
-> SBool
|
||||
mergeBit f c b1 b2 = svSymbolicMerge KBool f c b1 b2
|
||||
|
||||
mergeWord :: Bool
|
||||
-> SBool
|
||||
-> WordValue SBool SWord
|
||||
-> WordValue SBool SWord
|
||||
-> WordValue SBool SWord
|
||||
mergeWord f c (WordVal w1) (WordVal w2) =
|
||||
WordVal $ svSymbolicMerge (kindOf w1) f c w1 w2
|
||||
mergeWord f c w1 w2 = BitsVal $ mergeBits f c (asBitsVal w1) (asBitsVal w2)
|
||||
|
||||
mergeBits :: Bool
|
||||
-> SBool
|
||||
-> Seq.Seq (Eval SBool)
|
||||
-> Seq.Seq (Eval SBool)
|
||||
-> Seq.Seq (Eval SBool)
|
||||
mergeBits f c bs1 bs2 = Seq.zipWith mergeBit' bs1 bs2
|
||||
where mergeBit' b1 b2 = mergeBit f c <$> b1 <*> b2
|
||||
|
||||
mergeValue :: Bool -> SBool -> Value -> Value -> Value
|
||||
mergeValue f c v1 v2 =
|
||||
case (v1, v2) of
|
||||
(VRecord fs1, VRecord fs2) -> VRecord $ zipWith mergeField fs1 fs2
|
||||
(VTuple vs1 , VTuple vs2 ) -> VTuple $ zipWith (mergeValue f c) vs1 vs2
|
||||
(VBit b1 , VBit b2 ) -> VBit $ mergeBit b1 b2
|
||||
(VWord w1 , VWord w2 ) -> VWord $ mergeWord w1 w2
|
||||
(VSeq b1 vs1, VSeq _ vs2 ) -> VSeq b1 $ zipWith (mergeValue f c) vs1 vs2
|
||||
(VStream vs1, VStream vs2) -> VStream $ mergeStream vs1 vs2
|
||||
(VFun f1 , VFun f2 ) -> VFun $ \x -> mergeValue f c (f1 x) (f2 x)
|
||||
(VPoly f1 , VPoly f2 ) -> VPoly $ \x -> mergeValue f c (f1 x) (f2 x)
|
||||
(VWord w1 , _ ) -> VWord $ mergeWord w1 (fromVWord v2)
|
||||
(_ , VWord w2 ) -> VWord $ mergeWord (fromVWord v1) w2
|
||||
(VTuple vs1 , VTuple vs2 ) -> VTuple $ zipWith (\x y -> mergeValue f c <$> x <*> y) vs1 vs2
|
||||
(VBit b1 , VBit b2 ) -> VBit $ mergeBit f c b1 b2
|
||||
(VWord n1 w1, VWord n2 w2 ) | n1 == n2 -> VWord n1 (mergeWord f c <$> w1 <*> w2)
|
||||
(VSeq n1 vs1, VSeq n2 vs2 ) | n1 == n2 -> VSeq n1 $ mergeSeqMap f c vs1 vs2
|
||||
(VStream vs1, VStream vs2) -> VStream $ mergeSeqMap f c vs1 vs2
|
||||
(VFun f1 , VFun f2 ) -> VFun $ \x -> mergeValue f c <$> (f1 x) <*> (f2 x)
|
||||
(VPoly f1 , VPoly f2 ) -> VPoly $ \x -> mergeValue f c <$> (f1 x) <*> (f2 x)
|
||||
(_ , _ ) -> panic "Cryptol.Symbolic.Value"
|
||||
[ "mergeValue: incompatible values" ]
|
||||
where
|
||||
mergeBit b1 b2 = svSymbolicMerge KBool f c b1 b2
|
||||
mergeWord w1 w2 = svSymbolicMerge (kindOf w1) f c w1 w2
|
||||
mergeField (n1, x1) (n2, x2)
|
||||
| n1 == n2 = (n1, mergeValue f c x1 x2)
|
||||
| n1 == n2 = (n1, mergeValue f c <$> x1 <*> x2)
|
||||
| otherwise = panic "Cryptol.Symbolic.Value"
|
||||
[ "mergeValue.mergeField: incompatible values" ]
|
||||
mergeStream xs ys =
|
||||
mergeValue f c (head xs) (head ys) : mergeStream (tail xs) (tail ys)
|
||||
|
||||
-- Big-endian Words ------------------------------------------------------------
|
||||
|
||||
mergeSeqMap :: Bool -> SBool -> SeqMap SBool SWord -> SeqMap SBool SWord -> SeqMap SBool SWord
|
||||
mergeSeqMap f c x y =
|
||||
IndexSeqMap $ \i -> mergeValue f c <$> lookupSeqMap x i <*> lookupSeqMap y i
|
||||
|
||||
-- Symbolic Big-endian Words -------------------------------------------------------
|
||||
|
||||
instance BitWord SBool SWord where
|
||||
wordLen v = toInteger (intSizeOf v)
|
||||
wordAsChar v = integerToChar <$> svAsInteger v
|
||||
|
||||
ppBit v
|
||||
| Just b <- svAsBool v = text $! if b then "True" else "False"
|
||||
| otherwise = text "?"
|
||||
ppWord opts v
|
||||
| Just x <- svAsInteger v = ppBV opts (BV (wordLen v) x)
|
||||
| otherwise = text "[?]"
|
||||
|
||||
bitLit b = svBool b
|
||||
wordLit n x = svInteger (KBounded False (fromInteger n)) x
|
||||
|
||||
packWord bs = fromBitsLE (reverse bs)
|
||||
unpackWord x = [ svTestBit x i | i <- reverse [0 .. intSizeOf x - 1] ]
|
||||
|
||||
joinWord x y = svJoin x y
|
||||
|
||||
splitWord _leftW rightW w =
|
||||
( svExtract (intSizeOf w - 1) (fromInteger rightW) w
|
||||
, svExtract (fromInteger rightW - 1) 0 w
|
||||
)
|
||||
|
||||
extractWord len start w =
|
||||
svExtract (fromInteger start + fromInteger len - 1) (fromInteger start) w
|
||||
|
||||
wordPlus = svPlus
|
||||
wordMinus = svMinus
|
||||
wordMult = svTimes
|
||||
|
||||
-- Errors ----------------------------------------------------------------------
|
||||
|
||||
evalPanic :: String -> [String] -> a
|
||||
|
@ -9,7 +9,9 @@
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
module Cryptol.Testing.Concrete where
|
||||
|
||||
import Cryptol.Eval.Error
|
||||
import Control.Monad (join)
|
||||
|
||||
import Cryptol.Eval.Monad
|
||||
import Cryptol.Eval.Value
|
||||
import Cryptol.TypeCheck.AST
|
||||
import Cryptol.Utils.Panic (panic)
|
||||
@ -39,22 +41,24 @@ runOneTest :: Value -> [Value] -> IO TestResult
|
||||
runOneTest v0 vs0 = run `X.catch` handle
|
||||
where
|
||||
run = do
|
||||
result <- X.evaluate (go v0 vs0)
|
||||
result <- runEval (go v0 vs0)
|
||||
if result
|
||||
then return Pass
|
||||
else return (FailFalse vs0)
|
||||
handle e = return (FailError e vs0)
|
||||
|
||||
go :: Value -> [Value] -> Bool
|
||||
go (VFun f) (v : vs) = go (f v) vs
|
||||
go :: Value -> [Value] -> Eval Bool
|
||||
go (VFun f) (v : vs) = join (go <$> (f (ready v)) <*> return vs)
|
||||
go (VFun _) [] = panic "Not enough arguments while applying function"
|
||||
[]
|
||||
go (VBit b) [] = b
|
||||
go v vs = panic "Type error while running test" $
|
||||
[ "Function:"
|
||||
, show $ ppValue defaultPPOpts v
|
||||
, "Arguments:"
|
||||
] ++ map (show . ppValue defaultPPOpts) vs
|
||||
go (VBit b) [] = return b
|
||||
go v vs = do vdoc <- ppValue defaultPPOpts v
|
||||
vsdocs <- mapM (ppValue defaultPPOpts) vs
|
||||
panic "Type error while running test" $
|
||||
[ "Function:"
|
||||
, show vdoc
|
||||
, "Arguments:"
|
||||
] ++ map show vsdocs
|
||||
|
||||
{- | Given a (function) type, compute all possible inputs for it.
|
||||
We also return the total number of test (i.e., the length of the outer list. -}
|
||||
@ -102,7 +106,7 @@ typeValues ty =
|
||||
TVar _ -> []
|
||||
TUser _ _ t -> typeValues t
|
||||
TRec fs -> [ VRecord xs
|
||||
| xs <- sequence [ [ (f,v) | v <- typeValues t ]
|
||||
| xs <- sequence [ [ (f,ready v) | v <- typeValues t ]
|
||||
| (f,t) <- fs ]
|
||||
]
|
||||
TCon (TC tc) ts ->
|
||||
@ -113,16 +117,19 @@ typeValues ty =
|
||||
(TCSeq, ts1) ->
|
||||
case map tNoUser ts1 of
|
||||
[ TCon (TC (TCNum n)) _, TCon (TC TCBit) [] ] ->
|
||||
[ VWord (BV n x) | x <- [ 0 .. 2^n - 1 ] ]
|
||||
[ VWord n (ready (WordVal (BV n x))) | x <- [ 0 .. 2^n - 1 ] ]
|
||||
|
||||
[ TCon (TC (TCNum n)) _, t ] ->
|
||||
[ VSeq False xs | xs <- sequence $ genericReplicate n
|
||||
$ typeValues t ]
|
||||
[ VSeq n (finiteSeqMap (map ready xs))
|
||||
| xs <- sequence $ genericReplicate n
|
||||
$ typeValues t ]
|
||||
_ -> []
|
||||
|
||||
|
||||
(TCFun, _) -> [] -- We don't generate function values.
|
||||
(TCTuple _, els) -> [ VTuple xs | xs <- sequence (map typeValues els)]
|
||||
(TCTuple _, els) -> [ VTuple (map ready xs)
|
||||
| xs <- sequence (map typeValues els)
|
||||
]
|
||||
(TCNewtype _, _) -> []
|
||||
|
||||
TCon _ _ -> []
|
||||
|
@ -11,16 +11,18 @@
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
module Cryptol.Testing.Random where
|
||||
|
||||
import Cryptol.Eval.Value (BV(..),Value,GenValue(..))
|
||||
import Cryptol.Eval.Monad (ready)
|
||||
import Cryptol.Eval.Value (BV(..),Value,GenValue(..),SeqMap(..), WordValue(..))
|
||||
import qualified Cryptol.Testing.Concrete as Conc
|
||||
import Cryptol.TypeCheck.AST (Type(..),TCon(..),TC(..),tNoUser)
|
||||
import Cryptol.TypeCheck.Solve(simpType)
|
||||
import Cryptol.TypeCheck.SimpType(tRebuild')
|
||||
|
||||
import Cryptol.Utils.Ident (Ident)
|
||||
|
||||
import Control.Monad (forM)
|
||||
import Data.List (unfoldr, genericTake)
|
||||
import Data.List (unfoldr, genericTake, genericIndex)
|
||||
import System.Random (RandomGen, split, random, randomR)
|
||||
import qualified Data.Sequence as Seq
|
||||
|
||||
type Gen g = Integer -> g -> (Value, g)
|
||||
|
||||
@ -64,7 +66,7 @@ randomValue :: RandomGen g => Type -> Maybe (Gen g)
|
||||
randomValue ty =
|
||||
case ty of
|
||||
TCon tc ts ->
|
||||
case (tc, map (simpType . tNoUser) ts) of
|
||||
case (tc, map (tRebuild' False) ts) of
|
||||
(TC TCBit, []) -> Just randomBit
|
||||
|
||||
(TC TCSeq, [TCon (TC TCInf) [], el]) ->
|
||||
@ -102,21 +104,23 @@ randomBit _ g =
|
||||
randomWord :: RandomGen g => Integer -> Gen g
|
||||
randomWord w _sz g =
|
||||
let (val, g1) = randomR (0,2^w-1) g
|
||||
in (VWord (BV w val), g1)
|
||||
in (VWord w (ready (WordVal (BV w val))), g1)
|
||||
|
||||
-- | Generate a random infinite stream value.
|
||||
randomStream :: RandomGen g => Gen g -> Gen g
|
||||
randomStream mkElem sz g =
|
||||
let (g1,g2) = split g
|
||||
in (VStream (unfoldr (Just . mkElem sz) g1), g2)
|
||||
in (VStream $ IndexSeqMap $ genericIndex (map ready (unfoldr (Just . mkElem sz) g1)), g2)
|
||||
|
||||
{- | Generate a random sequence. Generally, this should be used for sequences
|
||||
other than bits. For sequences of bits use "randomWord". The difference
|
||||
is mostly about how the results will be displayed. -}
|
||||
{- | Generate a random sequence. This should be used for sequences
|
||||
other than bits. For sequences of bits use "randomWord". -}
|
||||
randomSequence :: RandomGen g => Integer -> Gen g -> Gen g
|
||||
randomSequence w mkElem sz g =
|
||||
let (g1,g2) = split g
|
||||
in (VSeq False $ genericTake w $ unfoldr (Just . mkElem sz) g1 , g2)
|
||||
randomSequence w mkElem sz g0 = do
|
||||
let (g1,g2) = split g0
|
||||
let f g = let (x,g') = mkElem sz g
|
||||
in seq x (Just (ready x, g'))
|
||||
let xs = Seq.fromList $ genericTake w $ unfoldr f g1
|
||||
seq xs (VSeq w $ IndexSeqMap $ (Seq.index xs . fromInteger), g2)
|
||||
|
||||
-- | Generate a random tuple value.
|
||||
randomTuple :: RandomGen g => [Gen g] -> Gen g
|
||||
@ -125,7 +129,7 @@ randomTuple gens sz = go [] gens
|
||||
go els [] g = (VTuple (reverse els), g)
|
||||
go els (mkElem : more) g =
|
||||
let (v, g1) = mkElem sz g
|
||||
in go (v : els) more g1
|
||||
in seq v (go (ready v : els) more g1)
|
||||
|
||||
-- | Generate a random record value.
|
||||
randomRecord :: RandomGen g => [(Ident, Gen g)] -> Gen g
|
||||
@ -134,7 +138,7 @@ randomRecord gens sz = go [] gens
|
||||
go els [] g = (VRecord (reverse els), g)
|
||||
go els ((l,mkElem) : more) g =
|
||||
let (v, g1) = mkElem sz g
|
||||
in go ((l,v) : els) more g1
|
||||
in seq v (go ((l,ready v) : els) more g1)
|
||||
|
||||
{-
|
||||
test = do
|
||||
|
@ -185,7 +185,7 @@ rewE rews = go
|
||||
ESel e s -> ESel <$> go e <*> return s
|
||||
EIf e1 e2 e3 -> EIf <$> go e1 <*> go e2 <*> go e3
|
||||
|
||||
EComp t e mss -> EComp t <$> go e <*> mapM (mapM (rewM rews)) mss
|
||||
EComp len t e mss -> EComp len t <$> go e <*> mapM (mapM (rewM rews)) mss
|
||||
EVar _ -> return expr
|
||||
|
||||
ETAbs x e -> ETAbs x <$> go e
|
||||
@ -195,7 +195,6 @@ rewE rews = go
|
||||
|
||||
EProofAbs x e -> EProofAbs x <$> go e
|
||||
|
||||
ECast e t -> ECast <$> go e <*> return t
|
||||
EWhere e dgs -> EWhere <$> go e <*> inLocal
|
||||
(mapM (rewDeclGroup rews) dgs)
|
||||
|
||||
@ -203,7 +202,7 @@ rewE rews = go
|
||||
rewM :: RewMap -> Match -> M Match
|
||||
rewM rews ma =
|
||||
case ma of
|
||||
From x t e -> From x t <$> rewE rews e
|
||||
From x len t e -> From x len t <$> rewE rews e
|
||||
|
||||
-- These are not recursive.
|
||||
Let d -> Let <$> rewD rews d
|
||||
|
@ -78,7 +78,7 @@ specializeExpr expr =
|
||||
ERec fs -> ERec <$> traverse (traverseSnd specializeExpr) fs
|
||||
ESel e s -> ESel <$> specializeExpr e <*> pure s
|
||||
EIf e1 e2 e3 -> EIf <$> specializeExpr e1 <*> specializeExpr e2 <*> specializeExpr e3
|
||||
EComp t e mss -> EComp t <$> specializeExpr e <*> traverse (traverse specializeMatch) mss
|
||||
EComp len t e mss -> EComp len t <$> specializeExpr e <*> traverse (traverse specializeMatch) mss
|
||||
-- Bindings within list comprehensions always have monomorphic types.
|
||||
EVar {} -> specializeConst expr
|
||||
ETAbs t e -> do
|
||||
@ -99,12 +99,10 @@ specializeExpr expr =
|
||||
EAbs qn t e -> EAbs qn t <$> specializeExpr e
|
||||
EProofAbs p e -> EProofAbs p <$> specializeExpr e
|
||||
EProofApp {} -> specializeConst expr
|
||||
ECast e t -> ECast <$> specializeExpr e <*> pure t
|
||||
-- TODO: if typeOf e == t, then drop the coercion.
|
||||
EWhere e dgs -> specializeEWhere e dgs
|
||||
|
||||
specializeMatch :: Match -> SpecM Match
|
||||
specializeMatch (From qn t e) = From qn t <$> specializeExpr e
|
||||
specializeMatch (From qn l t e) = From qn l t <$> specializeExpr e
|
||||
specializeMatch (Let decl)
|
||||
| null (sVars (dSignature decl)) = return (Let decl)
|
||||
| otherwise = fail "unimplemented: specializeMatch Let unimplemented"
|
||||
|
@ -24,29 +24,27 @@ module Cryptol.TypeCheck.AST
|
||||
, Pragma(..)
|
||||
, Fixity(..)
|
||||
, PrimMap(..)
|
||||
, TCErrorMessage(..)
|
||||
, module Cryptol.TypeCheck.Type
|
||||
) where
|
||||
|
||||
import Cryptol.ModuleSystem.Name
|
||||
import Cryptol.Prims.Syntax
|
||||
import Cryptol.Parser.AST ( Selector(..),Pragma(..), ppSelector
|
||||
import Cryptol.Parser.AST ( Selector(..),Pragma(..)
|
||||
, Import(..), ImportSpec(..), ExportType(..)
|
||||
, ExportSpec(..), isExportedBind
|
||||
, isExportedType, Fixity(..) )
|
||||
import Cryptol.Utils.Ident (Ident,isInfixIdent,ModName,packIdent)
|
||||
import Cryptol.Utils.Panic(panic)
|
||||
import Cryptol.TypeCheck.PP
|
||||
import Cryptol.TypeCheck.Solver.InfNat
|
||||
import Cryptol.TypeCheck.Type
|
||||
|
||||
import GHC.Generics (Generic)
|
||||
import Control.DeepSeq
|
||||
|
||||
import Data.Map (Map)
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.IntMap as IntMap
|
||||
import Data.Set (Set)
|
||||
|
||||
{- | A Cryptol module.
|
||||
-}
|
||||
-- | A Cryptol module.
|
||||
data Module = Module { mName :: !ModName
|
||||
, mExports :: ExportSpec Name
|
||||
, mImports :: [Import]
|
||||
@ -55,135 +53,6 @@ data Module = Module { mName :: !ModName
|
||||
, mDecls :: [DeclGroup]
|
||||
} deriving (Show, Generic, NFData)
|
||||
|
||||
-- | Kinds, classify types.
|
||||
data Kind = KType
|
||||
| KNum
|
||||
| KProp
|
||||
| Kind :-> Kind
|
||||
deriving (Eq, Show, Generic, NFData)
|
||||
infixr 5 :->
|
||||
|
||||
|
||||
-- | The types of polymorphic values.
|
||||
data Schema = Forall { sVars :: [TParam], sProps :: [Prop], sType :: Type }
|
||||
deriving (Eq, Show, Generic, NFData)
|
||||
|
||||
-- | Type synonym.
|
||||
data TySyn = TySyn { tsName :: Name -- ^ Name
|
||||
, tsParams :: [TParam] -- ^ Parameters
|
||||
, tsConstraints :: [Prop] -- ^ Ensure body is OK
|
||||
, tsDef :: Type -- ^ Definition
|
||||
}
|
||||
deriving (Eq, Show, Generic, NFData)
|
||||
|
||||
-- | Named records
|
||||
data Newtype = Newtype { ntName :: Name
|
||||
, ntParams :: [TParam]
|
||||
, ntConstraints :: [Prop]
|
||||
, ntFields :: [(Ident,Type)]
|
||||
} deriving (Show, Generic, NFData)
|
||||
|
||||
-- | Type parameters.
|
||||
data TParam = TParam { tpUnique :: !Int -- ^ Parameter identifier
|
||||
, tpKind :: Kind -- ^ Kind of parameter
|
||||
, tpName :: Maybe Name -- ^ Name from source, if any.
|
||||
}
|
||||
deriving (Show, Generic, NFData)
|
||||
|
||||
instance Eq TParam where
|
||||
x == y = tpUnique x == tpUnique y
|
||||
|
||||
instance Ord TParam where
|
||||
compare x y = compare (tpUnique x) (tpUnique y)
|
||||
|
||||
tpVar :: TParam -> TVar
|
||||
tpVar p = TVBound (tpUnique p) (tpKind p)
|
||||
|
||||
-- | The internal representation of types.
|
||||
-- These are assumed to be kind correct.
|
||||
data Type = TCon TCon [Type]
|
||||
-- ^ Type constant with args
|
||||
|
||||
| TVar TVar
|
||||
-- ^ Type variable (free or bound)
|
||||
|
||||
| TUser Name [Type] Type
|
||||
{- ^ This is just a type annotation, for a type that
|
||||
was written as a type synonym. It is useful so that we
|
||||
can use it to report nicer errors.
|
||||
Example: `TUser T ts t` is really just the type `t` that
|
||||
was written as `T ts` by the user. -}
|
||||
|
||||
| TRec [(Ident,Type)]
|
||||
-- ^ Record type
|
||||
|
||||
deriving (Show, Eq, Ord, Generic, NFData)
|
||||
|
||||
-- | The type is supposed to be of kind `KProp`
|
||||
type Prop = Type
|
||||
|
||||
-- | The type is "simple" (i.e., it contains no type functions).
|
||||
type SType = Type
|
||||
|
||||
|
||||
-- | Type variables.
|
||||
data TVar = TVFree !Int Kind (Set TVar) Doc
|
||||
-- ^ Unique, kind, ids of bound type variables that are in scope
|
||||
-- The `Doc` is a description of how this type came to be.
|
||||
|
||||
|
||||
| TVBound !Int Kind
|
||||
deriving (Show, Generic, NFData)
|
||||
|
||||
-- | Type constants.
|
||||
data TCon = TC TC | PC PC | TF TFun
|
||||
deriving (Show, Eq, Ord, Generic, NFData)
|
||||
|
||||
-- | Built-in type constants.
|
||||
|
||||
-- | Predicate symbols.
|
||||
data PC = PEqual -- ^ @_ == _@
|
||||
| PNeq -- ^ @_ /= _@
|
||||
| PGeq -- ^ @_ >= _@
|
||||
| PFin -- ^ @fin _@
|
||||
|
||||
-- classes
|
||||
| PHas Selector -- ^ @Has sel type field@ does not appear in schemas
|
||||
| PArith -- ^ @Arith _@
|
||||
| PCmp -- ^ @Cmp _@
|
||||
deriving (Show, Eq, Ord, Generic, NFData)
|
||||
|
||||
-- | 1-1 constants.
|
||||
data TC = TCNum Integer -- ^ Numbers
|
||||
| TCInf -- ^ Inf
|
||||
| TCBit -- ^ Bit
|
||||
| TCSeq -- ^ @[_] _@
|
||||
| TCFun -- ^ @_ -> _@
|
||||
| TCTuple Int -- ^ @(_, _, _)@
|
||||
| TCNewtype UserTC -- ^ user-defined, @T@
|
||||
deriving (Show, Eq, Ord, Generic, NFData)
|
||||
|
||||
data UserTC = UserTC Name Kind
|
||||
deriving (Show, Generic, NFData)
|
||||
|
||||
instance Eq UserTC where
|
||||
UserTC x _ == UserTC y _ = x == y
|
||||
|
||||
instance Ord UserTC where
|
||||
compare (UserTC x _) (UserTC y _) = compare x y
|
||||
|
||||
instance Eq TVar where
|
||||
TVBound x _ == TVBound y _ = x == y
|
||||
TVFree x _ _ _ == TVFree y _ _ _ = x == y
|
||||
_ == _ = False
|
||||
|
||||
instance Ord TVar where
|
||||
compare (TVFree x _ _ _) (TVFree y _ _ _) = compare x y
|
||||
compare (TVFree _ _ _ _) _ = LT
|
||||
compare _ (TVFree _ _ _ _) = GT
|
||||
|
||||
compare (TVBound x _) (TVBound y _) = compare x y
|
||||
|
||||
|
||||
|
||||
data Expr = EList [Expr] Type -- ^ List value (with type of elements)
|
||||
@ -192,9 +61,10 @@ data Expr = EList [Expr] Type -- ^ List value (with type of elements)
|
||||
| ESel Expr Selector -- ^ Elimination for tuple/record/list
|
||||
|
||||
| EIf Expr Expr Expr -- ^ If-then-else
|
||||
| EComp Type Expr [[Match]] -- ^ List comprehensions
|
||||
-- The type caches the type of the
|
||||
-- expr.
|
||||
| EComp Type Type Expr [[Match]]
|
||||
-- ^ List comprehensions
|
||||
-- The types cache the length of the
|
||||
-- sequence and its element type.
|
||||
|
||||
| EVar Name -- ^ Use of a bound variable
|
||||
|
||||
@ -222,30 +92,14 @@ data Expr = EList [Expr] Type -- ^ List value (with type of elements)
|
||||
|
||||
| EProofApp Expr {- proof -}
|
||||
|
||||
{- | if e : t1, then cast e : t2
|
||||
as long as we can prove that 't1 = t2'.
|
||||
We could express this in terms of a built-in constant.
|
||||
`cast :: {a,b} (a =*= b) => a -> b`
|
||||
|
||||
Using the constant is a bit verbose though, because we
|
||||
end up with both the source and target type. So, instead
|
||||
we use this language construct, which only stores the
|
||||
target type, and the source type can be reconstructed
|
||||
from the expression.
|
||||
|
||||
Another way to think of this is simply as an expression
|
||||
with an explicit type annotation.
|
||||
-}
|
||||
| ECast Expr Type
|
||||
|
||||
|
||||
| EWhere Expr [DeclGroup]
|
||||
|
||||
deriving (Show, Generic, NFData)
|
||||
|
||||
|
||||
data Match = From Name Type Expr -- ^ do we need this type? it seems like it
|
||||
-- can be computed from the expr
|
||||
data Match = From Name Type Type Expr
|
||||
-- ^ Type arguments are the length and element
|
||||
-- type of the sequence expression
|
||||
| Let Decl
|
||||
deriving (Show, Generic, NFData)
|
||||
|
||||
@ -274,241 +128,6 @@ data DeclDef = DPrim
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
|
||||
isFreeTV :: TVar -> Bool
|
||||
isFreeTV (TVFree {}) = True
|
||||
isFreeTV _ = False
|
||||
|
||||
isBoundTV :: TVar -> Bool
|
||||
isBoundTV (TVBound {}) = True
|
||||
isBoundTV _ = False
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
tIsNat' :: Type -> Maybe Nat'
|
||||
tIsNat' ty =
|
||||
case tNoUser ty of
|
||||
TCon (TC (TCNum x)) [] -> Just (Nat x)
|
||||
TCon (TC TCInf) [] -> Just Inf
|
||||
_ -> Nothing
|
||||
|
||||
tIsNum :: Type -> Maybe Integer
|
||||
tIsNum ty = do Nat x <- tIsNat' ty
|
||||
return x
|
||||
|
||||
tIsInf :: Type -> Bool
|
||||
tIsInf ty = tIsNat' ty == Just Inf
|
||||
|
||||
tIsVar :: Type -> Maybe TVar
|
||||
tIsVar ty = case tNoUser ty of
|
||||
TVar x -> Just x
|
||||
_ -> Nothing
|
||||
|
||||
tIsFun :: Type -> Maybe (Type, Type)
|
||||
tIsFun ty = case tNoUser ty of
|
||||
TCon (TC TCFun) [a, b] -> Just (a, b)
|
||||
_ -> Nothing
|
||||
|
||||
tIsSeq :: Type -> Maybe (Type, Type)
|
||||
tIsSeq ty = case tNoUser ty of
|
||||
TCon (TC TCSeq) [n, a] -> Just (n, a)
|
||||
_ -> Nothing
|
||||
|
||||
tIsBit :: Type -> Bool
|
||||
tIsBit ty = case tNoUser ty of
|
||||
TCon (TC TCBit) [] -> True
|
||||
_ -> False
|
||||
|
||||
tIsTuple :: Type -> Maybe [Type]
|
||||
tIsTuple ty = case tNoUser ty of
|
||||
TCon (TC (TCTuple _)) ts -> Just ts
|
||||
_ -> Nothing
|
||||
|
||||
tIsBinFun :: TFun -> Type -> Maybe (Type,Type)
|
||||
tIsBinFun f ty = case tNoUser ty of
|
||||
TCon (TF g) [a,b] | f == g -> Just (a,b)
|
||||
_ -> Nothing
|
||||
|
||||
-- | Split up repeated occurances of the given binary type-level function.
|
||||
tSplitFun :: TFun -> Type -> [Type]
|
||||
tSplitFun f t0 = go t0 []
|
||||
where go ty xs = case tIsBinFun f ty of
|
||||
Just (a,b) -> go a (go b xs)
|
||||
Nothing -> ty : xs
|
||||
|
||||
|
||||
pIsFin :: Prop -> Maybe Type
|
||||
pIsFin ty = case tNoUser ty of
|
||||
TCon (PC PFin) [t1] -> Just t1
|
||||
_ -> Nothing
|
||||
|
||||
pIsGeq :: Prop -> Maybe (Type,Type)
|
||||
pIsGeq ty = case tNoUser ty of
|
||||
TCon (PC PGeq) [t1,t2] -> Just (t1,t2)
|
||||
_ -> Nothing
|
||||
|
||||
pIsEq :: Prop -> Maybe (Type,Type)
|
||||
pIsEq ty = case tNoUser ty of
|
||||
TCon (PC PEqual) [t1,t2] -> Just (t1,t2)
|
||||
_ -> Nothing
|
||||
|
||||
pIsArith :: Prop -> Maybe Type
|
||||
pIsArith ty = case tNoUser ty of
|
||||
TCon (PC PArith) [t1] -> Just t1
|
||||
_ -> Nothing
|
||||
|
||||
pIsCmp :: Prop -> Maybe Type
|
||||
pIsCmp ty = case tNoUser ty of
|
||||
TCon (PC PCmp) [t1] -> Just t1
|
||||
_ -> Nothing
|
||||
|
||||
|
||||
|
||||
pIsNumeric :: Prop -> Bool
|
||||
pIsNumeric (TCon (PC PEqual) _) = True
|
||||
pIsNumeric (TCon (PC PNeq) _) = True
|
||||
pIsNumeric (TCon (PC PGeq) _) = True
|
||||
pIsNumeric (TCon (PC PFin) _) = True
|
||||
pIsNumeric (TUser _ _ t) = pIsNumeric t
|
||||
pIsNumeric _ = False
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
tNum :: Integral a => a -> Type
|
||||
tNum n = TCon (TC (TCNum (fromIntegral n))) []
|
||||
|
||||
tZero :: Type
|
||||
tZero = tNum (0 :: Int)
|
||||
|
||||
tOne :: Type
|
||||
tOne = tNum (1 :: Int)
|
||||
|
||||
tTwo :: Type
|
||||
tTwo = tNum (2 :: Int)
|
||||
|
||||
tInf :: Type
|
||||
tInf = TCon (TC TCInf) []
|
||||
|
||||
tNat' :: Nat' -> Type
|
||||
tNat' n' = case n' of
|
||||
Inf -> tInf
|
||||
Nat n -> tNum n
|
||||
|
||||
tBit :: Type
|
||||
tBit = TCon (TC TCBit) []
|
||||
|
||||
tWord :: Type -> Type
|
||||
tWord a = tSeq a tBit
|
||||
|
||||
tSeq :: Type -> Type -> Type
|
||||
tSeq a b = TCon (TC TCSeq) [a,b]
|
||||
|
||||
tChar :: Type
|
||||
tChar = tWord (tNum (8 :: Int))
|
||||
|
||||
tString :: Int -> Type
|
||||
tString len = tSeq (tNum len) tChar
|
||||
|
||||
tRec :: [(Ident,Type)] -> Type
|
||||
tRec = TRec
|
||||
|
||||
tTuple :: [Type] -> Type
|
||||
tTuple ts = TCon (TC (TCTuple (length ts))) ts
|
||||
|
||||
|
||||
infixr 5 `tFun`
|
||||
|
||||
-- | Make a function type.
|
||||
tFun :: Type -> Type -> Type
|
||||
tFun a b = TCon (TC TCFun) [a,b]
|
||||
|
||||
-- | Eliminate outermost type synonyms.
|
||||
tNoUser :: Type -> Type
|
||||
tNoUser t = case t of
|
||||
TUser _ _ a -> tNoUser a
|
||||
_ -> t
|
||||
|
||||
tWidth :: Type -> Type
|
||||
tWidth t = TCon (TF TCWidth) [t]
|
||||
|
||||
tLenFromThen :: Type -> Type -> Type -> Type
|
||||
tLenFromThen t1 t2 t3 = TCon (TF TCLenFromThen) [t1,t2,t3]
|
||||
|
||||
tLenFromThenTo :: Type -> Type -> Type -> Type
|
||||
tLenFromThenTo t1 t2 t3 = TCon (TF TCLenFromThenTo) [t1,t2,t3]
|
||||
|
||||
tMax :: Type -> Type -> Type
|
||||
tMax t1 t2 = TCon (TF TCMax) [t1,t2]
|
||||
|
||||
infix 4 =#=, >==
|
||||
infixl 6 .+.
|
||||
infixl 7 .*.
|
||||
|
||||
-- | Equality for numeric types.
|
||||
(=#=) :: Type -> Type -> Prop
|
||||
x =#= y = TCon (PC PEqual) [x,y]
|
||||
|
||||
(=/=) :: Type -> Type -> Prop
|
||||
x =/= y = TCon (PC PNeq) [x,y]
|
||||
|
||||
pArith :: Type -> Prop
|
||||
pArith t = TCon (PC PArith) [t]
|
||||
|
||||
pCmp :: Type -> Prop
|
||||
pCmp t = TCon (PC PCmp) [t]
|
||||
|
||||
-- | Make a greater-than-or-equal-to constraint.
|
||||
(>==) :: Type -> Type -> Prop
|
||||
x >== y = TCon (PC PGeq) [x,y]
|
||||
|
||||
-- | A `Has` constraint, used for tuple and record selection.
|
||||
pHas :: Selector -> Type -> Type -> Prop
|
||||
pHas l ty fi = TCon (PC (PHas l)) [ty,fi]
|
||||
|
||||
pFin :: Type -> Prop
|
||||
pFin ty = TCon (PC PFin) [ty]
|
||||
|
||||
|
||||
|
||||
-- | Make multiplication type.
|
||||
(.*.) :: Type -> Type -> Type
|
||||
x .*. y = TCon (TF TCMul) [x,y]
|
||||
|
||||
-- | Make addition type.
|
||||
(.+.) :: Type -> Type -> Type
|
||||
x .+. y = TCon (TF TCAdd) [x,y]
|
||||
|
||||
(.-.) :: Type -> Type -> Type
|
||||
x .-. y = TCon (TF TCSub) [x,y]
|
||||
|
||||
(.^.) :: Type -> Type -> Type
|
||||
x .^. y = TCon (TF TCExp) [x,y]
|
||||
|
||||
tDiv :: Type -> Type -> Type
|
||||
tDiv x y = TCon (TF TCDiv) [x,y]
|
||||
|
||||
tMod :: Type -> Type -> Type
|
||||
tMod x y = TCon (TF TCMod) [x,y]
|
||||
|
||||
-- | Make a @min@ type.
|
||||
tMin :: Type -> Type -> Type
|
||||
tMin x y = TCon (TF TCMin) [x,y]
|
||||
|
||||
|
||||
newtypeTyCon :: Newtype -> TCon
|
||||
newtypeTyCon nt = TC $ TCNewtype $ UserTC (ntName nt) (kindOf nt)
|
||||
|
||||
newtypeConType :: Newtype -> Schema
|
||||
newtypeConType nt =
|
||||
Forall as (ntConstraints nt)
|
||||
$ TRec (ntFields nt) `tFun` TCon (newtypeTyCon nt) (map (TVar . tpVar) as)
|
||||
where
|
||||
as = ntParams nt
|
||||
|
||||
|
||||
|
||||
-- | Construct a primitive, given a map to the unique names of the Cryptol
|
||||
-- module.
|
||||
@ -530,248 +149,6 @@ eChar prims c = ETApp (ETApp (ePrim prims (packIdent "demote")) (tNum v)) (tNum
|
||||
w = 8 :: Int
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
class HasKind t where
|
||||
kindOf :: t -> Kind
|
||||
|
||||
instance HasKind TVar where
|
||||
kindOf (TVFree _ k _ _) = k
|
||||
kindOf (TVBound _ k) = k
|
||||
|
||||
instance HasKind TCon where
|
||||
kindOf (TC tc) = kindOf tc
|
||||
kindOf (PC pc) = kindOf pc
|
||||
kindOf (TF tf) = kindOf tf
|
||||
|
||||
instance HasKind UserTC where
|
||||
kindOf (UserTC _ k) = k
|
||||
|
||||
instance HasKind TC where
|
||||
kindOf tcon =
|
||||
case tcon of
|
||||
TCNum _ -> KNum
|
||||
TCInf -> KNum
|
||||
TCBit -> KType
|
||||
TCSeq -> KNum :-> KType :-> KType
|
||||
TCFun -> KType :-> KType :-> KType
|
||||
TCTuple n -> foldr (:->) KType (replicate n KType)
|
||||
TCNewtype x -> kindOf x
|
||||
|
||||
instance HasKind PC where
|
||||
kindOf pc =
|
||||
case pc of
|
||||
PEqual -> KNum :-> KNum :-> KProp
|
||||
PNeq -> KNum :-> KNum :-> KProp
|
||||
PGeq -> KNum :-> KNum :-> KProp
|
||||
PFin -> KNum :-> KProp
|
||||
PHas _ -> KType :-> KType :-> KProp
|
||||
PArith -> KType :-> KProp
|
||||
PCmp -> KType :-> KProp
|
||||
|
||||
instance HasKind TFun where
|
||||
kindOf tfun =
|
||||
case tfun of
|
||||
TCWidth -> KNum :-> KNum
|
||||
|
||||
TCAdd -> KNum :-> KNum :-> KNum
|
||||
TCSub -> KNum :-> KNum :-> KNum
|
||||
TCMul -> KNum :-> KNum :-> KNum
|
||||
TCDiv -> KNum :-> KNum :-> KNum
|
||||
TCMod -> KNum :-> KNum :-> KNum
|
||||
TCExp -> KNum :-> KNum :-> KNum
|
||||
TCMin -> KNum :-> KNum :-> KNum
|
||||
TCMax -> KNum :-> KNum :-> KNum
|
||||
|
||||
TCLenFromThen -> KNum :-> KNum :-> KNum :-> KNum
|
||||
TCLenFromThenTo -> KNum :-> KNum :-> KNum :-> KNum
|
||||
|
||||
instance HasKind Type where
|
||||
kindOf ty =
|
||||
case ty of
|
||||
TVar a -> kindOf a
|
||||
TCon c ts -> quickApply (kindOf c) ts
|
||||
TUser _ _ t -> kindOf t
|
||||
TRec {} -> KType
|
||||
|
||||
instance HasKind TySyn where
|
||||
kindOf (TySyn _ as _ t) = foldr (:->) (kindOf t) (map kindOf as)
|
||||
|
||||
instance HasKind Newtype where
|
||||
kindOf nt = foldr (:->) KType (map kindOf (ntParams nt))
|
||||
|
||||
instance HasKind TParam where
|
||||
kindOf p = tpKind p
|
||||
|
||||
quickApply :: Kind -> [a] -> Kind
|
||||
quickApply k [] = k
|
||||
quickApply (_ :-> k) (_ : ts) = quickApply k ts
|
||||
quickApply k _ = panic "Cryptol.TypeCheck.AST.quickApply"
|
||||
[ "Applying a non-function kind:", show k ]
|
||||
|
||||
-- Pretty Printing -------------------------------------------------------------
|
||||
|
||||
instance PP Kind where
|
||||
ppPrec p k = case k of
|
||||
KType -> char '*'
|
||||
KNum -> char '#'
|
||||
KProp -> text "Prop"
|
||||
l :-> r -> optParens (p >= 1) (sep [ppPrec 1 l, text "->", ppPrec 0 r])
|
||||
|
||||
instance PP (WithNames TVar) where
|
||||
|
||||
ppPrec _ (WithNames (TVBound x _) mp) =
|
||||
case IntMap.lookup x mp of
|
||||
Just a -> text a
|
||||
Nothing -> text ("a`" ++ show x)
|
||||
|
||||
ppPrec _ (WithNames (TVFree x _ _ _) _) =
|
||||
char '?' <> text (intToName x)
|
||||
|
||||
instance PP TVar where
|
||||
ppPrec = ppWithNamesPrec IntMap.empty
|
||||
|
||||
instance PP TParam where
|
||||
ppPrec = ppWithNamesPrec IntMap.empty
|
||||
|
||||
instance PP (WithNames TParam) where
|
||||
ppPrec _ (WithNames p mp) = ppWithNames mp (tpVar p)
|
||||
|
||||
instance PP (WithNames Type) where
|
||||
ppPrec prec ty0@(WithNames ty nmMap) =
|
||||
case ty of
|
||||
TVar a -> ppWithNames nmMap a
|
||||
TRec fs -> braces $ fsep $ punctuate comma
|
||||
[ pp l <+> text ":" <+> go 0 t | (l,t) <- fs ]
|
||||
TUser c ts _ -> optParens (prec > 3) $ pp c <+> fsep (map (go 4) ts)
|
||||
|
||||
TCon (TC tc) ts ->
|
||||
case (tc,ts) of
|
||||
(TCNum n, []) -> integer n
|
||||
(TCInf, []) -> text "inf"
|
||||
(TCBit, []) -> text "Bit"
|
||||
|
||||
(TCSeq, [t1,TCon (TC TCBit) []]) -> brackets (go 0 t1)
|
||||
(TCSeq, [t1,t2]) -> optParens (prec > 3)
|
||||
$ brackets (go 0 t1) <> go 3 t2
|
||||
|
||||
(TCFun, [t1,t2]) -> optParens (prec > 1)
|
||||
$ go 2 t1 <+> text "->" <+> go 1 t2
|
||||
|
||||
(TCTuple _, fs) -> parens $ fsep $ punctuate comma $ map (go 0) fs
|
||||
|
||||
(_, _) -> pp tc <+> fsep (map (go 4) ts)
|
||||
|
||||
TCon (PC pc) ts ->
|
||||
case (pc,ts) of
|
||||
(PEqual, [t1,t2]) -> go 0 t1 <+> text "==" <+> go 0 t2
|
||||
(PNeq , [t1,t2]) -> go 0 t1 <+> text "/=" <+> go 0 t2
|
||||
(PGeq, [t1,t2]) -> go 0 t1 <+> text ">=" <+> go 0 t2
|
||||
(PFin, [t1]) -> text "fin" <+> (go 4 t1)
|
||||
(PHas x, [t1,t2]) -> ppSelector x <+> text "of"
|
||||
<+> go 0 t1 <+> text "is" <+> go 0 t2
|
||||
|
||||
(PArith, [t1]) -> pp pc <+> go 4 t1
|
||||
(PCmp, [t1]) -> pp pc <+> go 4 t1
|
||||
|
||||
(_, _) -> pp pc <+> fsep (map (go 4) ts)
|
||||
|
||||
_ | Just tinf <- isTInfix ty0 -> optParens (prec > 2)
|
||||
$ ppInfix 2 isTInfix tinf
|
||||
|
||||
TCon f ts -> optParens (prec > 3)
|
||||
$ pp f <+> fsep (map (go 4) ts)
|
||||
|
||||
where
|
||||
go p t = ppWithNamesPrec nmMap p t
|
||||
|
||||
isTInfix (WithNames (TCon (TF ieOp) [ieLeft',ieRight']) _) =
|
||||
do let ieLeft = WithNames ieLeft' nmMap
|
||||
ieRight = WithNames ieRight' nmMap
|
||||
(ieAssoc,iePrec) <- Map.lookup ieOp tBinOpPrec
|
||||
return Infix { .. }
|
||||
isTInfix _ = Nothing
|
||||
|
||||
addTNames :: [TParam] -> NameMap -> NameMap
|
||||
addTNames as ns = foldr (uncurry IntMap.insert) ns
|
||||
$ named ++ zip unnamed avail
|
||||
|
||||
where avail = filter (`notElem` used) (nameList [])
|
||||
named = [ (u,show (pp n))
|
||||
| TParam { tpUnique = u, tpName = Just n } <- as ]
|
||||
unnamed = [ u | TParam { tpUnique = u, tpName = Nothing } <- as ]
|
||||
|
||||
used = map snd named ++ IntMap.elems ns
|
||||
|
||||
ppNewtypeShort :: Newtype -> Doc
|
||||
ppNewtypeShort nt =
|
||||
text "newtype" <+> pp (ntName nt) <+> hsep (map (ppWithNamesPrec nm 9) ps)
|
||||
where
|
||||
ps = ntParams nt
|
||||
nm = addTNames ps emptyNameMap
|
||||
|
||||
|
||||
instance PP Schema where
|
||||
ppPrec = ppWithNamesPrec IntMap.empty
|
||||
|
||||
instance PP (WithNames Schema) where
|
||||
ppPrec _ (WithNames s ns) = vars <+> props <+> ppWithNames ns1 (sType s)
|
||||
where
|
||||
vars = case sVars s of
|
||||
[] -> empty
|
||||
vs -> braces $ commaSep $ map (ppWithNames ns1) vs
|
||||
|
||||
props = case sProps s of
|
||||
[] -> empty
|
||||
ps -> parens (commaSep (map (ppWithNames ns1) ps)) <+> text "=>"
|
||||
|
||||
ns1 = addTNames (sVars s) ns
|
||||
|
||||
instance PP TySyn where
|
||||
ppPrec = ppWithNamesPrec IntMap.empty
|
||||
|
||||
instance PP (WithNames TySyn) where
|
||||
ppPrec _ (WithNames (TySyn n ps _ ty) ns) =
|
||||
text "type" <+> pp n <+> sep (map (ppWithNames ns1) ps) <+> char '='
|
||||
<+> ppWithNames ns1 ty
|
||||
where ns1 = addTNames ps ns
|
||||
|
||||
instance PP Type where
|
||||
ppPrec n t = ppWithNamesPrec IntMap.empty n t
|
||||
|
||||
|
||||
instance PP TCon where
|
||||
ppPrec _ (TC tc) = pp tc
|
||||
ppPrec _ (PC tc) = pp tc
|
||||
ppPrec _ (TF tc) = pp tc
|
||||
|
||||
instance PP PC where
|
||||
ppPrec _ x =
|
||||
case x of
|
||||
PEqual -> text "(==)"
|
||||
PNeq -> text "(/=)"
|
||||
PGeq -> text "(>=)"
|
||||
PFin -> text "fin"
|
||||
PHas sel -> parens (ppSelector sel)
|
||||
PArith -> text "Arith"
|
||||
PCmp -> text "Cmp"
|
||||
|
||||
instance PP TC where
|
||||
ppPrec _ x =
|
||||
case x of
|
||||
TCNum n -> integer n
|
||||
TCInf -> text "inf"
|
||||
TCBit -> text "Bit"
|
||||
TCSeq -> text "[]"
|
||||
TCFun -> text "(->)"
|
||||
TCTuple 0 -> text "()"
|
||||
TCTuple 1 -> text "(one tuple?)"
|
||||
TCTuple n -> parens $ hcat $ replicate (n-1) comma
|
||||
TCNewtype u -> pp u
|
||||
|
||||
instance PP UserTC where
|
||||
ppPrec p (UserTC x _) = ppPrec p x
|
||||
|
||||
instance PP (WithNames Expr) where
|
||||
ppPrec prec (WithNames expr nm) =
|
||||
case expr of
|
||||
@ -792,8 +169,8 @@ instance PP (WithNames Expr) where
|
||||
, text "then" <+> ppW e2
|
||||
, text "else" <+> ppW e3 ]
|
||||
|
||||
EComp _ e mss -> let arm ms = text "|" <+> commaSep (map ppW ms)
|
||||
in brackets $ ppW e <+> vcat (map arm mss)
|
||||
EComp _ _ e mss -> let arm ms = text "|" <+> commaSep (map ppW ms)
|
||||
in brackets $ ppW e <+> vcat (map arm mss)
|
||||
|
||||
EVar x -> ppPrefixName x
|
||||
|
||||
@ -826,9 +203,6 @@ instance PP (WithNames Expr) where
|
||||
ETApp e t -> optParens (prec > 3)
|
||||
$ ppWP 3 e <+> ppWP 4 t
|
||||
|
||||
ECast e t -> optParens (prec > 0)
|
||||
( ppWP 2 e <+> text ":" <+> ppW t )
|
||||
|
||||
EWhere e ds -> optParens (prec > 0)
|
||||
( ppW e $$ text "where"
|
||||
$$ nest 2 (vcat (map ppW ds))
|
||||
@ -882,7 +256,7 @@ instance PP Expr where
|
||||
instance PP (WithNames Match) where
|
||||
ppPrec _ (WithNames mat nm) =
|
||||
case mat of
|
||||
From x _ e -> pp x <+> text "<-" <+> ppWithNames nm e
|
||||
From x _ _ e -> pp x <+> text "<-" <+> ppWithNames nm e
|
||||
Let d -> text "let" <+> ppWithNames nm d
|
||||
|
||||
instance PP Match where
|
||||
|
@ -19,14 +19,15 @@ import Cryptol.ModuleSystem.Name (asPrim,lookupPrimDecl)
|
||||
import Cryptol.Parser.Position
|
||||
import qualified Cryptol.Parser.AST as P
|
||||
import qualified Cryptol.Parser.Names as P
|
||||
import Cryptol.TypeCheck.AST
|
||||
import Cryptol.TypeCheck.AST hiding (tSub,tMul,tExp)
|
||||
import Cryptol.TypeCheck.Monad
|
||||
import Cryptol.TypeCheck.Solve
|
||||
import Cryptol.TypeCheck.SimpType(tSub,tMul,tExp)
|
||||
import Cryptol.TypeCheck.Kind(checkType,checkSchema,checkTySyn,
|
||||
checkNewtype)
|
||||
import Cryptol.TypeCheck.Instantiate
|
||||
import Cryptol.TypeCheck.Depends
|
||||
import Cryptol.TypeCheck.Subst (listSubst,apSubst,fvs,(@@))
|
||||
import Cryptol.TypeCheck.Subst (listSubst,apSubst,(@@),emptySubst)
|
||||
import Cryptol.TypeCheck.Solver.InfNat(genLog)
|
||||
import Cryptol.Utils.Ident
|
||||
import Cryptol.Utils.Panic(panic)
|
||||
@ -107,7 +108,8 @@ appTys expr ts tGoal =
|
||||
ExtVar s -> instantiateWith (EVar x) s ts
|
||||
CurSCC e t -> instantiateWith e (Forall [] [] t) ts
|
||||
|
||||
checkHasType e' t tGoal
|
||||
checkHasType t tGoal
|
||||
return e'
|
||||
|
||||
P.ELit l -> do e <- desugarLiteral False l
|
||||
appTys e ts tGoal
|
||||
@ -146,7 +148,8 @@ appTys expr ts tGoal =
|
||||
(ie,t) <- instantiateWith e' (Forall [] [] tGoal) ts
|
||||
-- XXX seems weird to need to do this, as t should be the same
|
||||
-- as tGoal
|
||||
checkHasType ie t tGoal
|
||||
checkHasType t tGoal
|
||||
return ie
|
||||
|
||||
|
||||
inferTyParam :: P.TypeInst Name -> InferM (Located (Maybe Ident, Type))
|
||||
@ -185,7 +188,8 @@ checkE expr tGoal =
|
||||
ExtVar s -> instantiateWith (EVar x) s []
|
||||
CurSCC e t -> return (e, t)
|
||||
|
||||
checkHasType e' t tGoal
|
||||
checkHasType t tGoal
|
||||
return e'
|
||||
|
||||
P.ELit l -> (`checkE` tGoal) =<< desugarLiteral False l
|
||||
|
||||
@ -223,8 +227,8 @@ checkE expr tGoal =
|
||||
do rng <- curRange
|
||||
bit <- newType (text "bit-width of enumeration sequnce") KNum
|
||||
fstT <- checkTypeOfKind t1 KNum
|
||||
let totLen = tNum (2::Int) .^. bit
|
||||
lstT = totLen .-. tNum (1::Int)
|
||||
let totLen = tExp (tNum (2::Int)) bit
|
||||
lstT = tSub totLen (tNum (1::Int))
|
||||
|
||||
fromToPrim <- mkPrim "fromTo"
|
||||
appTys fromToPrim
|
||||
@ -266,13 +270,13 @@ checkE expr tGoal =
|
||||
|
||||
P.EComp e mss ->
|
||||
do (mss', dss, ts) <- unzip3 `fmap` zipWithM inferCArm [ 1 .. ] mss
|
||||
(len,a)<- expectSeq tGoal
|
||||
(len,a) <- expectSeq tGoal
|
||||
|
||||
newGoals CtComprehension =<< unify len =<< smallest ts
|
||||
|
||||
ds <- combineMaps dss
|
||||
e' <- withMonoTypes ds (checkE e a)
|
||||
return (EComp tGoal e' mss')
|
||||
return (EComp len a e' mss')
|
||||
|
||||
P.EAppT e fs ->
|
||||
do ts <- mapM inferTyParam fs
|
||||
@ -307,7 +311,8 @@ checkE expr tGoal =
|
||||
P.ETyped e t ->
|
||||
do tSig <- checkTypeOfKind t KType
|
||||
e' <- checkE e tSig
|
||||
checkHasType e' tSig tGoal
|
||||
checkHasType tSig tGoal
|
||||
return e'
|
||||
|
||||
P.ETypeVal t ->
|
||||
do l <- curRange
|
||||
@ -337,12 +342,12 @@ expectSeq ty =
|
||||
|
||||
TVar _ ->
|
||||
do tys@(a,b) <- genTys
|
||||
newGoals CtExactType =<< unify (tSeq a b) ty
|
||||
newGoals CtExactType =<< unify ty (tSeq a b)
|
||||
return tys
|
||||
|
||||
_ ->
|
||||
do tys@(a,b) <- genTys
|
||||
recordError (TypeMismatch (tSeq a b) ty)
|
||||
recordError (TypeMismatch ty (tSeq a b))
|
||||
return tys
|
||||
where
|
||||
genTys =
|
||||
@ -363,12 +368,12 @@ expectTuple n ty =
|
||||
|
||||
TVar _ ->
|
||||
do tys <- genTys
|
||||
newGoals CtExactType =<< unify (tTuple tys) ty
|
||||
newGoals CtExactType =<< unify ty (tTuple tys)
|
||||
return tys
|
||||
|
||||
_ ->
|
||||
do tys <- genTys
|
||||
recordError (TypeMismatch (tTuple tys) ty)
|
||||
recordError (TypeMismatch ty (tTuple tys))
|
||||
return tys
|
||||
|
||||
where
|
||||
@ -391,9 +396,9 @@ expectRec fs ty =
|
||||
_ ->
|
||||
do (tys,res) <- genTys
|
||||
case ty of
|
||||
TVar TVFree{} -> do ps <- unify (TRec tys) ty
|
||||
TVar TVFree{} -> do ps <- unify ty (TRec tys)
|
||||
newGoals CtExactType ps
|
||||
_ -> recordError (TypeMismatch (TRec tys) ty)
|
||||
_ -> recordError (TypeMismatch ty (TRec tys))
|
||||
return res
|
||||
|
||||
where
|
||||
@ -422,7 +427,7 @@ expectFin n ty =
|
||||
return ()
|
||||
|
||||
_ ->
|
||||
do newGoals CtExactType =<< unify (tNum n) ty
|
||||
do newGoals CtExactType =<< unify ty (tNum n)
|
||||
|
||||
expectFun :: Int -> Type -> InferM ([Type],Type)
|
||||
expectFun = go []
|
||||
@ -442,9 +447,9 @@ expectFun = go []
|
||||
do args <- genArgs arity
|
||||
res <- newType (text "result of function") KType
|
||||
case ty of
|
||||
TVar TVFree{} -> do ps <- unify (foldr tFun res args) ty
|
||||
TVar TVFree{} -> do ps <- unify ty (foldr tFun res args)
|
||||
newGoals CtExactType ps
|
||||
_ -> recordError (TypeMismatch (foldr tFun res args) ty)
|
||||
_ -> recordError (TypeMismatch ty (foldr tFun res args))
|
||||
return (reverse tys ++ args, res)
|
||||
|
||||
| otherwise =
|
||||
@ -454,12 +459,12 @@ expectFun = go []
|
||||
newType (text "argument" <+> ordinal ix) KType
|
||||
|
||||
|
||||
checkHasType :: Expr -> Type -> Type -> InferM Expr
|
||||
checkHasType e inferredType givenType =
|
||||
checkHasType :: Type -> Type -> InferM ()
|
||||
checkHasType inferredType givenType =
|
||||
do ps <- unify givenType inferredType
|
||||
case ps of
|
||||
[] -> return e
|
||||
_ -> newGoals CtExactType ps >> return (ECast e givenType)
|
||||
[] -> return ()
|
||||
_ -> newGoals CtExactType ps
|
||||
|
||||
|
||||
checkFun :: Doc -> [P.Pattern Name] -> P.Expr Name -> Type -> InferM Expr
|
||||
@ -491,7 +496,8 @@ checkP desc p tGoal =
|
||||
do (x, t) <- inferP desc p
|
||||
ps <- unify tGoal (thing t)
|
||||
let rng = fromMaybe emptyRange $ getLoc p
|
||||
let mkErr = recordError . UnsolvedGoal False . Goal (CtPattern desc) rng
|
||||
let mkErr = recordError . UnsolvedGoals False . (:[])
|
||||
. Goal (CtPattern desc) rng
|
||||
mapM_ mkErr ps
|
||||
return (Located (srcRange t) x)
|
||||
|
||||
@ -517,10 +523,10 @@ inferP desc pat =
|
||||
-- | Infer the type of one match in a list comprehension.
|
||||
inferMatch :: P.Match Name -> InferM (Match, Name, Located Type, Type)
|
||||
inferMatch (P.Match p e) =
|
||||
do (x,t) <- inferP (text "XXX:MATCH") p
|
||||
n <- newType (text "sequence length of comprehension match") KNum
|
||||
do (x,t) <- inferP (text "a value bound by a generator in a comprehension") p
|
||||
n <- newType (text "the length of a generator in a comprehension") KNum
|
||||
e' <- checkE e (tSeq n (thing t))
|
||||
return (From x (thing t) e', x, t, n)
|
||||
return (From x n (thing t) e', x, t, n)
|
||||
|
||||
inferMatch (P.MatchLet b)
|
||||
| P.bMono b =
|
||||
@ -552,7 +558,7 @@ inferCArm armNum (m : ms) =
|
||||
let src = text "length of" <+> ordinal armNum <+>
|
||||
text "arm of list comprehension"
|
||||
sz <- newType src KNum
|
||||
newGoals CtComprehension [ sz =#= (n .*. n') ]
|
||||
newGoals CtComprehension [ sz =#= tMul n n' ]
|
||||
return (m1 : ms', Map.insertWith (\_ old -> old) x t ds, sz)
|
||||
|
||||
-- | @inferBinds isTopLevel isRec binds@ performs inference for a
|
||||
@ -623,7 +629,7 @@ guessType exprMap b@(P.Bind { .. }) =
|
||||
|
||||
Nothing
|
||||
| bMono ->
|
||||
do t <- newType (text "defintion of" <+> quotes (pp name)) KType
|
||||
do t <- newType (text "definition of" <+> quotes (pp name)) KType
|
||||
let schema = Forall [] [] t
|
||||
return ((name, ExtVar schema), Left (checkMonoB b t))
|
||||
|
||||
@ -638,26 +644,6 @@ guessType exprMap b@(P.Bind { .. }) =
|
||||
where
|
||||
name = thing bName
|
||||
|
||||
-- | Try to evaluate the inferred type in a binding.
|
||||
simpBind :: Decl -> Decl
|
||||
simpBind d =
|
||||
case dSignature d of
|
||||
Forall as qs t ->
|
||||
case simpTypeMaybe t of
|
||||
Nothing -> d
|
||||
Just t1 -> d { dSignature = Forall as qs t1
|
||||
, dDefinition = case dDefinition d of
|
||||
DPrim -> DPrim
|
||||
DExpr e -> DExpr (castUnder t1 e)
|
||||
}
|
||||
where
|
||||
-- Assumes the quantifiers match
|
||||
castUnder t (ETAbs a e) = ETAbs a (castUnder t e)
|
||||
castUnder t (EProofAbs p e) = EProofAbs p (castUnder t e)
|
||||
castUnder t e = ECast e t
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
-- | The inputs should be declarations with monomorphic types
|
||||
@ -676,11 +662,9 @@ generalize bs0 gs0 =
|
||||
do gs <- forM gs0 $ \g -> applySubst g
|
||||
|
||||
-- XXX: Why would these bindings have signatures??
|
||||
bs1 <- forM bs0 $ \b -> do s <- applySubst (dSignature b)
|
||||
bs <- forM bs0 $ \b -> do s <- applySubst (dSignature b)
|
||||
return b { dSignature = s }
|
||||
|
||||
let bs = map simpBind bs1
|
||||
|
||||
let goalFVS g = Set.filter isFreeTV $ fvs $ goal g
|
||||
inGoals = Set.unions $ map goalFVS gs
|
||||
inSigs = Set.filter isFreeTV $ fvs $ map dSignature bs
|
||||
@ -703,7 +687,14 @@ generalize bs0 gs0 =
|
||||
|
||||
|
||||
solver <- getSolver
|
||||
(as0,here1,defSu,ws) <- io $ improveByDefaultingWith solver maybeAmbig here0
|
||||
(as0,here1,mb_defSu,ws) <- io $ improveByDefaultingWith solver maybeAmbig here0
|
||||
defSu <- case mb_defSu of
|
||||
Nothing -> do recordError $ UnsolvedGoals True here0
|
||||
return emptySubst
|
||||
Just s -> return s
|
||||
|
||||
|
||||
|
||||
mapM_ recordWarning ws
|
||||
let here = map goal here1
|
||||
|
||||
@ -724,7 +715,7 @@ generalize bs0 gs0 =
|
||||
}
|
||||
|
||||
addGoals later
|
||||
return (map (simpBind . genB) bs)
|
||||
return (map genB bs)
|
||||
|
||||
|
||||
|
||||
@ -775,7 +766,8 @@ checkSigB b (Forall as asmps0 t0, validSchema) = case thing (P.bDef b) of
|
||||
withTParams as $
|
||||
do (e1,cs0) <- collectGoals $
|
||||
do e1 <- checkFun (pp (thing (P.bName b))) (P.bParams b) e0 t0
|
||||
() <- simplifyAllConstraints -- XXX: using `asmps` also...
|
||||
addGoals validSchema
|
||||
() <- simplifyAllConstraints -- XXX: using `asmps` also?
|
||||
return e1
|
||||
cs <- applySubst cs0
|
||||
|
||||
@ -791,7 +783,7 @@ checkSigB b (Forall as asmps0 t0, validSchema) = case thing (P.bDef b) of
|
||||
|
||||
asmps1 <- applySubst asmps0
|
||||
|
||||
defSu1 <- proveImplication (thing (P.bName b)) as asmps1 (validSchema ++ now)
|
||||
defSu1 <- proveImplication (thing (P.bName b)) as asmps1 now
|
||||
let later = apSubst defSu1 later0
|
||||
asmps = apSubst defSu1 asmps1
|
||||
|
||||
@ -807,7 +799,12 @@ checkSigB b (Forall as asmps0 t0, validSchema) = case thing (P.bDef b) of
|
||||
$ AmbiguousType [ thing (P.bName b) ]
|
||||
|
||||
solver <- getSolver
|
||||
(_,_,defSu2,ws) <- io $ improveByDefaultingWith solver maybeAmbig later
|
||||
(_,_,mb_defSu2,ws) <-
|
||||
io $ improveByDefaultingWith solver maybeAmbig later
|
||||
defSu2 <- case mb_defSu2 of
|
||||
Nothing -> do recordError $ UnsolvedGoals True later
|
||||
return emptySubst
|
||||
Just s -> return s
|
||||
mapM_ recordWarning ws
|
||||
extendSubst defSu2
|
||||
|
||||
|
@ -20,7 +20,6 @@ module Cryptol.TypeCheck.InferTypes where
|
||||
|
||||
import Cryptol.TypeCheck.AST
|
||||
import Cryptol.TypeCheck.Subst
|
||||
import Cryptol.TypeCheck.TypeMap
|
||||
import Cryptol.Parser.Position
|
||||
import qualified Cryptol.Parser.AST as P
|
||||
import Cryptol.Utils.PP
|
||||
@ -28,13 +27,15 @@ import Cryptol.ModuleSystem.Name (asPrim,nameLoc)
|
||||
import Cryptol.TypeCheck.PP
|
||||
import Cryptol.Utils.Ident (Ident,identText)
|
||||
import Cryptol.Utils.Panic(panic)
|
||||
import Cryptol.Utils.Misc(anyJust)
|
||||
|
||||
import Data.Set ( Set )
|
||||
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
|
||||
import Data.List ((\\))
|
||||
|
||||
data SolverConfig = SolverConfig
|
||||
{ solverPath :: FilePath -- ^ The SMT solver to invoke
|
||||
@ -46,20 +47,24 @@ data SolverConfig = SolverConfig
|
||||
data VarType = ExtVar Schema -- ^ Known type
|
||||
| CurSCC Expr Type -- ^ Part of current SCC
|
||||
|
||||
newtype Goals = Goals (TypeMap Goal)
|
||||
-- XXX: Temporary, until we figure out:
|
||||
-- 1. How to apply substitutions with normalization to the type Map
|
||||
-- 2. What are the strictness requirements
|
||||
-- (e.g., using Set results in a black hole)
|
||||
newtype Goals = Goals (Set Goal) -- Goals (TypeMap Goal)
|
||||
deriving (Show)
|
||||
|
||||
emptyGoals :: Goals
|
||||
emptyGoals = Goals emptyTM
|
||||
emptyGoals = Goals Set.empty -- emptyTM
|
||||
|
||||
nullGoals :: Goals -> Bool
|
||||
nullGoals (Goals tm) = nullTM tm
|
||||
nullGoals (Goals tm) = Set.null tm -- nullTM tm
|
||||
|
||||
fromGoals :: Goals -> [Goal]
|
||||
fromGoals (Goals tm) = membersTM tm
|
||||
fromGoals (Goals tm) = Set.toList tm -- membersTM tm
|
||||
|
||||
insertGoal :: Goal -> Goals -> Goals
|
||||
insertGoal g (Goals tm) = Goals (insertTM (goal g) g tm)
|
||||
insertGoal g (Goals tm) = Goals (Set.insert g tm) -- (insertTM (goal g) g tm)
|
||||
|
||||
-- | Something that we need to find evidence for.
|
||||
data Goal = Goal
|
||||
@ -68,6 +73,12 @@ data Goal = Goal
|
||||
, goal :: Prop -- ^ What needs to be proved
|
||||
} deriving (Show, Generic, NFData)
|
||||
|
||||
instance Eq Goal where
|
||||
x == y = goal x == goal y
|
||||
|
||||
instance Ord Goal where
|
||||
compare x y = compare (goal x) (goal y)
|
||||
|
||||
data HasGoal = HasGoal
|
||||
{ hasName :: !Int
|
||||
, hasGoal :: Goal
|
||||
@ -81,11 +92,6 @@ data DelayedCt = DelayedCt
|
||||
, dctGoals :: [Goal]
|
||||
} deriving (Show, Generic, NFData)
|
||||
|
||||
data Solved = Solved (Maybe Subst) [Goal] -- ^ Solved, assuming the sub-goals.
|
||||
| Unsolved -- ^ We could not solve the goal.
|
||||
| Unsolvable -- ^ The goal can never be solved.
|
||||
deriving (Show)
|
||||
|
||||
data Warning = DefaultingKind (P.TParam Name) P.Kind
|
||||
| DefaultingWildType P.Kind
|
||||
| DefaultingTo Doc Type
|
||||
@ -135,7 +141,7 @@ data Error = ErrorMsg Doc
|
||||
| RecursiveType Type Type
|
||||
-- ^ Unification results in a recursive type
|
||||
|
||||
| UnsolvedGoal Bool Goal
|
||||
| UnsolvedGoals Bool [Goal]
|
||||
-- ^ A constraint that we could not solve
|
||||
-- The boolean indicates if we know that this constraint
|
||||
-- is impossible.
|
||||
@ -240,7 +246,7 @@ instance TVars Error where
|
||||
MultipleTypeParamDefs {} -> err
|
||||
TypeMismatch t1 t2 -> TypeMismatch (apSubst su t1) (apSubst su t2)
|
||||
RecursiveType t1 t2 -> RecursiveType (apSubst su t1) (apSubst su t2)
|
||||
UnsolvedGoal x g -> UnsolvedGoal x (apSubst su g)
|
||||
UnsolvedGoals x gs -> UnsolvedGoals x (apSubst su gs)
|
||||
UnsolvedDelayedCt g -> UnsolvedDelayedCt (apSubst su g)
|
||||
UnexpectedTypeWildCard -> err
|
||||
TypeVariableEscaped t xs -> TypeVariableEscaped (apSubst su t) xs
|
||||
@ -267,7 +273,7 @@ instance FVS Error where
|
||||
MultipleTypeParamDefs {} -> Set.empty
|
||||
TypeMismatch t1 t2 -> fvs (t1,t2)
|
||||
RecursiveType t1 t2 -> fvs (t1,t2)
|
||||
UnsolvedGoal _ g -> fvs g
|
||||
UnsolvedGoals _ gs -> fvs gs
|
||||
UnsolvedDelayedCt g -> fvs g
|
||||
UnexpectedTypeWildCard -> Set.empty
|
||||
TypeVariableEscaped t _ -> fvs t
|
||||
@ -289,6 +295,18 @@ instance FVS DelayedCt where
|
||||
-- values that remain, as applying the substitution to the keys will only ever
|
||||
-- reduce the number of values that remain.
|
||||
instance TVars Goals where
|
||||
apSubst su (Goals gs) = case anyJust apG (Set.toList gs) of
|
||||
Nothing -> Goals gs
|
||||
Just gs1 -> Goals $ Set.fromList
|
||||
$ concatMap norm gs1
|
||||
where
|
||||
norm g = [ g { goal = p } | p <- pSplitAnd (goal g) ]
|
||||
apG g = mk g <$> apSubstMaybe su (goal g)
|
||||
mk g p = g { goal = p }
|
||||
|
||||
{-
|
||||
apSubst su (Goals gs) = Goals (Set.fromList . mapAp
|
||||
|
||||
apSubst su (Goals goals) =
|
||||
Goals (mapWithKeyTM setGoal (apSubstTypeMapKeys su goals))
|
||||
where
|
||||
@ -298,6 +316,7 @@ instance TVars Goals where
|
||||
setGoal key g = g { goalSource = apSubst su (goalSource g)
|
||||
, goal = key
|
||||
}
|
||||
-}
|
||||
|
||||
instance TVars Goal where
|
||||
apSubst su g = Goal { goalSource = apSubst su (goalSource g)
|
||||
@ -313,26 +332,26 @@ instance TVars DelayedCt where
|
||||
| Set.null captured =
|
||||
DelayedCt { dctSource = dctSource g
|
||||
, dctForall = dctForall g
|
||||
, dctAsmps = apSubst su1 (dctAsmps g)
|
||||
, dctGoals = apSubst su1 (dctGoals g)
|
||||
, dctAsmps = apSubst su (dctAsmps g)
|
||||
, dctGoals = apSubst su (dctGoals g)
|
||||
}
|
||||
|
||||
| otherwise = panic "Cryptol.TypeCheck.Subst.apSubst (DelayedCt)"
|
||||
[ "Captured quantified variables:"
|
||||
, "Substitution: " ++ show m1
|
||||
, "Substitution: " ++ show su
|
||||
, "Variables: " ++ show captured
|
||||
, "Constraint: " ++ show g
|
||||
]
|
||||
|
||||
where
|
||||
used = fvs (dctAsmps g, map goal (dctGoals g)) `Set.difference`
|
||||
Set.fromList (map tpVar (dctForall g))
|
||||
m1 = Map.filterWithKey (\k _ -> k `Set.member` used) (suMap su)
|
||||
su1 = S { suMap = m1, suDefaulting = suDefaulting su }
|
||||
|
||||
captured = Set.fromList (map tpVar (dctForall g)) `Set.intersection`
|
||||
fvs (Map.elems m1)
|
||||
|
||||
|
||||
captured = Set.fromList (map tpVar (dctForall g))
|
||||
`Set.intersection`
|
||||
subVars
|
||||
subVars = Set.unions
|
||||
$ map (fvs . applySubstToVar su)
|
||||
$ Set.toList used
|
||||
used = fvs (dctAsmps g, map goal (dctGoals g)) `Set.difference`
|
||||
Set.fromList (map tpVar (dctForall g))
|
||||
|
||||
-- | For use in error messages
|
||||
cppKind :: Kind -> Doc
|
||||
@ -442,10 +461,12 @@ instance PP (WithNames Error) where
|
||||
TypeMismatch t1 t2 ->
|
||||
nested (text "Type mismatch:")
|
||||
(text "Expected type:" <+> ppWithNames names t1 $$
|
||||
text "Inferred type:" <+> ppWithNames names t2)
|
||||
text "Inferred type:" <+> ppWithNames names t2 $$
|
||||
mismatchHint t1 t2)
|
||||
|
||||
UnsolvedGoal imp g ->
|
||||
nested (word <+> text "constraint:") (ppWithNames names g)
|
||||
UnsolvedGoals imp gs ->
|
||||
nested (word <+> text "constraints:")
|
||||
$ vcat $ map (ppWithNames names) gs
|
||||
where word = if imp then text "Unsolvable" else text "Unsolved"
|
||||
|
||||
UnsolvedDelayedCt g ->
|
||||
@ -494,6 +515,15 @@ instance PP (WithNames Error) where
|
||||
multi [x,y] = [x <> text ", and", y <> text "." ]
|
||||
multi (x : xs) = x <> text "," : multi xs
|
||||
|
||||
mismatchHint (TRec fs1) (TRec fs2) =
|
||||
hint "Missing" missing $$ hint "Unexpected" extra
|
||||
where
|
||||
missing = map fst fs1 \\ map fst fs2
|
||||
extra = map fst fs2 \\ map fst fs1
|
||||
hint _ [] = mempty
|
||||
hint s [x] = text s <+> text "field" <+> pp x
|
||||
hint s xs = text s <+> text "fields" <+> commaSep (map pp xs)
|
||||
mismatchHint _ _ = mempty
|
||||
|
||||
|
||||
instance PP ConstraintSource where
|
||||
@ -549,10 +579,4 @@ instance PP (WithNames DelayedCt) where
|
||||
ns1 = addTNames (dctForall d) names
|
||||
|
||||
|
||||
instance PP Solved where
|
||||
ppPrec _ res =
|
||||
case res of
|
||||
Solved mb gs -> text "solved" $$ nest 2 (suDoc $$ vcat (map (pp . goal) gs))
|
||||
where suDoc = maybe empty pp mb
|
||||
Unsolved -> text "unsolved"
|
||||
Unsolvable -> text "unsolvable"
|
||||
|
||||
|
@ -75,15 +75,11 @@ instantiateWithPos e (Forall as ps t) ts =
|
||||
The arguments that are provided will be instantiated as requested,
|
||||
the rest will be instantiated with fresh type variables.
|
||||
|
||||
Note that we assume that type parameters are not normalized.
|
||||
Generally, the resulting expression will look something like this:
|
||||
|
||||
ECast (EProofApp (ETApp e t)) t1
|
||||
EProofApp (ETApp e t)
|
||||
|
||||
where
|
||||
- There will be one `ETApp t` for each insantiated type parameter;
|
||||
- there will be one `EProofApp` for each constraint on the schema;
|
||||
- there will be `ECast` if we had equality constraints from normalization.
|
||||
-}
|
||||
instantiateWithNames :: Expr -> Schema -> [Located (Ident,Type)]
|
||||
-> InferM (Expr,Type)
|
||||
|
@ -20,6 +20,7 @@ import Cryptol.Parser.AST (Named(..))
|
||||
import Cryptol.Parser.Position
|
||||
import Cryptol.TypeCheck.AST
|
||||
import Cryptol.TypeCheck.Monad hiding (withTParams)
|
||||
import Cryptol.TypeCheck.SimpType(tRebuild)
|
||||
import Cryptol.TypeCheck.Solve (simplifyAllConstraints
|
||||
,wfTypeFunction)
|
||||
import Cryptol.Utils.PP
|
||||
@ -42,7 +43,9 @@ checkSchema (P.Forall xs ps t mb) =
|
||||
do ps1 <- mapM checkProp ps
|
||||
t1 <- doCheckType t (Just KType)
|
||||
return (ps1,t1)
|
||||
return (Forall xs1 ps1 t1, gs)
|
||||
return ( Forall xs1 (map tRebuild ps1) (tRebuild t1)
|
||||
, [ g { goal = tRebuild (goal g) } | g <- gs ]
|
||||
)
|
||||
|
||||
where
|
||||
rng = case mb of
|
||||
@ -59,8 +62,8 @@ checkTySyn (P.TySyn x as t) =
|
||||
return r
|
||||
return TySyn { tsName = thing x
|
||||
, tsParams = as1
|
||||
, tsConstraints = map goal gs
|
||||
, tsDef = t1
|
||||
, tsConstraints = map (tRebuild . goal) gs
|
||||
, tsDef = tRebuild t1
|
||||
}
|
||||
|
||||
-- | Check a newtype declaration.
|
||||
@ -89,7 +92,7 @@ checkNewtype (P.Newtype x as fs) =
|
||||
checkType :: P.Type Name -> Maybe Kind -> InferM Type
|
||||
checkType t k =
|
||||
do (_, t1) <- withTParams True [] $ doCheckType t k
|
||||
return t1
|
||||
return (tRebuild t1)
|
||||
|
||||
{- | Check something with type parameters.
|
||||
|
||||
@ -122,10 +125,14 @@ There are two reasons for this choice:
|
||||
|
||||
withTParams :: Bool -> [P.TParam Name] -> KindM a -> InferM ([TParam], a)
|
||||
withTParams allowWildCards xs m =
|
||||
mdo mapM_ recordError duplicates
|
||||
(a, vars) <- runKindM allowWildCards (zip' xs ts) m
|
||||
(as, ts) <- unzip `fmap` mapM (newTP vars) xs
|
||||
return (as,a)
|
||||
do (as,a,ctrs) <-
|
||||
mdo mapM_ recordError duplicates
|
||||
(a, vars,ctrs) <- runKindM allowWildCards (zip' xs ts) m
|
||||
(as, ts) <- unzip `fmap` mapM (newTP vars) xs
|
||||
return (as,a,ctrs)
|
||||
mapM_ (uncurry newGoals) ctrs
|
||||
return (as,a)
|
||||
|
||||
where
|
||||
getKind vs tp =
|
||||
case Map.lookup (P.tpName tp) vs of
|
||||
|
@ -6,11 +6,11 @@
|
||||
-- Stability : provisional
|
||||
-- Portability : portable
|
||||
{-# LANGUAGE Safe #-}
|
||||
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE RecursiveDo #-}
|
||||
{-# LANGUAGE PatternGuards #-}
|
||||
module Cryptol.TypeCheck.Monad
|
||||
( module Cryptol.TypeCheck.Monad
|
||||
, module Cryptol.TypeCheck.InferTypes
|
||||
@ -19,10 +19,12 @@ module Cryptol.TypeCheck.Monad
|
||||
import Cryptol.ModuleSystem.Name (FreshM(..),Supply)
|
||||
import Cryptol.Parser.Position
|
||||
import qualified Cryptol.Parser.AST as P
|
||||
import Cryptol.Prelude (writeTcPreludeContents)
|
||||
import Cryptol.TypeCheck.AST
|
||||
import Cryptol.TypeCheck.Subst
|
||||
import Cryptol.TypeCheck.Unify(mgu, Result(..), UnificationError(..))
|
||||
import Cryptol.TypeCheck.InferTypes
|
||||
import qualified Cryptol.TypeCheck.SimpleSolver as Simple
|
||||
import qualified Cryptol.TypeCheck.Solver.CrySAT as CrySAT
|
||||
import Cryptol.Utils.PP(pp, (<+>), Doc, text, quotes)
|
||||
import Cryptol.Utils.Panic(panic)
|
||||
@ -33,11 +35,17 @@ import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
import Data.Map (Map)
|
||||
import Data.Set (Set)
|
||||
import Data.List(find, minimumBy, groupBy, sortBy)
|
||||
import Data.List(find, minimumBy, groupBy, sortBy, foldl')
|
||||
import Data.Maybe(mapMaybe)
|
||||
import Data.Function(on)
|
||||
import MonadLib hiding (mapM)
|
||||
|
||||
import Data.IORef
|
||||
|
||||
import System.FilePath((</>))
|
||||
import System.Directory(doesFileExist)
|
||||
|
||||
|
||||
import GHC.Generics (Generic)
|
||||
import Control.DeepSeq
|
||||
|
||||
@ -56,6 +64,8 @@ data InferInput = InferInput
|
||||
-- signatures be monomorphized?
|
||||
|
||||
, inpSolverConfig :: SolverConfig -- ^ Options for the constraint solver
|
||||
, inpSearchPath :: [FilePath]
|
||||
-- ^ Where to look for Cryptol theory file.
|
||||
|
||||
, inpPrimNames :: !PrimMap -- ^ The mapping from 'Ident' to 'Name',
|
||||
-- for names that the typechecker
|
||||
@ -87,9 +97,15 @@ data InferOutput a
|
||||
|
||||
deriving Show
|
||||
|
||||
bumpCounter :: InferM ()
|
||||
bumpCounter = do RO { .. } <- IM ask
|
||||
io $ modifyIORef' iSolveCounter (+1)
|
||||
|
||||
runInferM :: TVars a => InferInput -> InferM a -> IO (InferOutput a)
|
||||
runInferM info (IM m) = CrySAT.withSolver (inpSolverConfig info) $ \solver ->
|
||||
do rec ro <- return RO { iRange = inpRange info
|
||||
do loadCryTCPrel solver (inpSearchPath info)
|
||||
coutner <- newIORef 0
|
||||
rec ro <- return RO { iRange = inpRange info
|
||||
, iVars = Map.map ExtVar (inpVars info)
|
||||
, iTVars = []
|
||||
, iTSyns = fmap mkExternal (inpTSyns info)
|
||||
@ -98,6 +114,7 @@ runInferM info (IM m) = CrySAT.withSolver (inpSolverConfig info) $ \solver ->
|
||||
, iMonoBinds = inpMonoBinds info
|
||||
, iSolver = solver
|
||||
, iPrimNames = inpPrimNames info
|
||||
, iSolveCounter = coutner
|
||||
}
|
||||
|
||||
(result, finalRW) <- runStateT rw
|
||||
@ -119,7 +136,7 @@ runInferM info (IM m) = CrySAT.withSolver (inpSolverConfig info) $ \solver ->
|
||||
(cts,has) -> return $ InferFailed warns
|
||||
$ dropErrorsFromSameLoc
|
||||
[ ( goalRange g
|
||||
, UnsolvedGoal False (apSubst theSu g)
|
||||
, UnsolvedGoals False [apSubst theSu g]
|
||||
) | g <- fromGoals cts ++ map hasGoal has
|
||||
]
|
||||
errs -> return $ InferFailed warns
|
||||
@ -151,6 +168,17 @@ runInferM info (IM m) = CrySAT.withSolver (inpSolverConfig info) $ \solver ->
|
||||
-- The actual order does not matter
|
||||
cmpRange (Range x y z) (Range a b c) = compare (x,y,z) (a,b,c)
|
||||
|
||||
loadCryTCPrel s [] =
|
||||
do file <- writeTcPreludeContents
|
||||
CrySAT.loadFile s file
|
||||
|
||||
loadCryTCPrel s (p : ps) =
|
||||
do let file = p </> "CryptolTC.z3"
|
||||
yes <- doesFileExist file
|
||||
if yes then CrySAT.loadFile s file
|
||||
else loadCryTCPrel s ps
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
@ -193,6 +221,8 @@ data RO = RO
|
||||
, iSolver :: CrySAT.Solver
|
||||
|
||||
, iPrimNames :: !PrimMap
|
||||
|
||||
, iSolveCounter :: !(IORef Int)
|
||||
}
|
||||
|
||||
-- | Read-write component of the monad.
|
||||
@ -311,7 +341,11 @@ getGoals =
|
||||
|
||||
-- | Add a bunch of goals that need solving.
|
||||
addGoals :: [Goal] -> InferM ()
|
||||
addGoals gs = IM $ sets_ $ \s -> s { iCts = foldl (flip insertGoal) (iCts s) gs }
|
||||
addGoals gs0 = doAdd =<< simpGoals gs0
|
||||
where
|
||||
doAdd [] = return ()
|
||||
doAdd gs = IM $ sets_ $ \s -> s { iCts = foldl' (flip insertGoal) (iCts s) gs }
|
||||
|
||||
|
||||
-- | Collect the goals emitted by the given sub-computation.
|
||||
-- Does not emit any new goals.
|
||||
@ -331,6 +365,17 @@ collectGoals m =
|
||||
-- set the type map directly
|
||||
setGoals' gs = IM $ sets $ \ RW { .. } -> ((), RW { iCts = gs, .. })
|
||||
|
||||
simpGoal :: Goal -> InferM [Goal]
|
||||
simpGoal g =
|
||||
case Simple.simplify Map.empty (goal g) of
|
||||
p | Just e <- tIsError p ->
|
||||
do recordError $ ErrorMsg $ text $ tcErrorMessage e
|
||||
return []
|
||||
| ps <- pSplitAnd p -> return [ g { goal = pr } | pr <- ps ]
|
||||
|
||||
simpGoals :: [Goal] -> InferM [Goal]
|
||||
simpGoals gs = concat <$> mapM simpGoal gs
|
||||
|
||||
|
||||
|
||||
{- | Record a constraint that when we select from the first type,
|
||||
@ -644,6 +689,7 @@ data KRO = KRO { lazyTVars :: Map Name Type -- ^ lazy map, with tyvars.
|
||||
}
|
||||
|
||||
data KRW = KRW { typeParams :: Map Name Kind -- ^ kinds of (known) vars.
|
||||
, kCtrs :: [(ConstraintSource,[Prop])]
|
||||
}
|
||||
|
||||
instance Functor KindM where
|
||||
@ -670,14 +716,16 @@ As a result we return the value of the sub-computation and the computed
|
||||
kinds of the type parameters. -}
|
||||
runKindM :: Bool -- Are type-wild cards allowed?
|
||||
-> [(Name, Maybe Kind, Type)] -- ^ See comment
|
||||
-> KindM a -> InferM (a, Map Name Kind)
|
||||
-> KindM a -> InferM (a, Map Name Kind, [(ConstraintSource,[Prop])])
|
||||
runKindM wildOK vs (KM m) =
|
||||
do (a,kw) <- runStateT krw (runReaderT kro m)
|
||||
return (a, typeParams kw)
|
||||
return (a, typeParams kw, kCtrs kw)
|
||||
where
|
||||
tys = Map.fromList [ (x,t) | (x,_,t) <- vs ]
|
||||
kro = KRO { allowWild = wildOK, lazyTVars = tys }
|
||||
krw = KRW { typeParams = Map.fromList [ (x,k) | (x,Just k,_) <- vs ] }
|
||||
krw = KRW { typeParams = Map.fromList [ (x,k) | (x,Just k,_) <- vs ]
|
||||
, kCtrs = []
|
||||
}
|
||||
|
||||
-- | This is what's returned when we lookup variables during kind checking.
|
||||
data LkpTyVar = TLocalVar Type (Maybe Kind) -- ^ Locally bound variable.
|
||||
@ -705,6 +753,9 @@ kRecordWarning :: Warning -> KindM ()
|
||||
kRecordWarning w = kInInferM $ recordWarning w
|
||||
|
||||
-- | Generate a fresh unification variable of the given kind.
|
||||
-- NOTE: We do not simplify these, because we end up with bottom.
|
||||
-- See `Kind.hs`
|
||||
-- XXX: Perhaps we can avoid the recursion?
|
||||
kNewType :: Doc -> Kind -> KindM Type
|
||||
kNewType src k =
|
||||
do tps <- KM $ do vs <- asks lazyTVars
|
||||
@ -743,7 +794,8 @@ kInRange r (KM m) = KM $
|
||||
return a
|
||||
|
||||
kNewGoals :: ConstraintSource -> [Prop] -> KindM ()
|
||||
kNewGoals c ps = kInInferM $ newGoals c ps
|
||||
kNewGoals _ [] = return ()
|
||||
kNewGoals c ps = KM $ sets_ $ \s -> s { kCtrs = (c,ps) : kCtrs s }
|
||||
|
||||
kInInferM :: InferM a -> KindM a
|
||||
kInInferM m = KM $ lift $ lift m
|
||||
|
@ -16,11 +16,11 @@ module Cryptol.TypeCheck.Sanity
|
||||
|
||||
|
||||
import Cryptol.TypeCheck.AST
|
||||
import Cryptol.TypeCheck.Subst(apSubst, fvs, singleSubst)
|
||||
import Cryptol.TypeCheck.Subst (apSubst, singleSubst)
|
||||
import Cryptol.Utils.Ident
|
||||
|
||||
import qualified Data.Set as Set
|
||||
import Data.List(sort, sortBy)
|
||||
import Data.List (sort, sortBy)
|
||||
import Data.Function (on)
|
||||
import MonadLib
|
||||
import qualified Control.Applicative as A
|
||||
@ -160,8 +160,11 @@ exprSchema expr =
|
||||
return (f,t)
|
||||
return $ tMono $ TRec fs1
|
||||
|
||||
ESel e sel ->
|
||||
do t <- exprType e
|
||||
ESel e sel -> do ty <- exprType e
|
||||
ty1 <- check ty
|
||||
return (tMono ty1)
|
||||
where
|
||||
check t =
|
||||
case sel of
|
||||
|
||||
TupleSel n mb ->
|
||||
@ -176,7 +179,13 @@ exprSchema expr =
|
||||
unless (n < sz) $
|
||||
reportError (TupleSelectorOutOfRange n sz)
|
||||
|
||||
return $ tMono $ ts !! n
|
||||
return $ ts !! n
|
||||
|
||||
TCon (TC TCSeq) [s,elT] -> do res <- check elT
|
||||
return (TCon (TC TCSeq) [s,res])
|
||||
|
||||
TCon (TC TCFun) [a,b] -> do res <- check b
|
||||
return (TCon (TC TCFun) [a,res])
|
||||
|
||||
_ -> reportError $ BadSelector sel t
|
||||
|
||||
@ -195,11 +204,19 @@ exprSchema expr =
|
||||
|
||||
case lookup f fs of
|
||||
Nothing -> reportError $ MissingField f $ map fst fs
|
||||
Just ft -> return $ tMono ft
|
||||
Just ft -> return ft
|
||||
|
||||
TCon (TC TCSeq) [s,elT] -> do res <- check elT
|
||||
return (TCon (TC TCSeq) [s,res])
|
||||
|
||||
TCon (TC TCFun) [a,b] -> do res <- check b
|
||||
return (TCon (TC TCFun) [a,res])
|
||||
|
||||
|
||||
_ -> reportError $ BadSelector sel t
|
||||
|
||||
|
||||
-- XXX: Remove this?
|
||||
ListSel _ mb ->
|
||||
case tNoUser t of
|
||||
TCon (TC TCSeq) [ n, elT ] ->
|
||||
@ -212,7 +229,7 @@ exprSchema expr =
|
||||
| m == fromIntegral len -> return ()
|
||||
_ -> reportError $ UnexpectedSequenceShape len n
|
||||
|
||||
return $ tMono elT
|
||||
return elT
|
||||
|
||||
_ -> reportError $ BadSelector sel t
|
||||
|
||||
@ -229,8 +246,9 @@ exprSchema expr =
|
||||
|
||||
return $ tMono t1
|
||||
|
||||
EComp t e mss ->
|
||||
do checkTypeIs KType t
|
||||
EComp len t e mss ->
|
||||
do checkTypeIs KNum len
|
||||
checkTypeIs KType t
|
||||
|
||||
(xs,ls) <- unzip `fmap` mapM checkArm mss
|
||||
-- XXX: check no duplicates
|
||||
@ -238,9 +256,9 @@ exprSchema expr =
|
||||
|
||||
case ls of
|
||||
[] -> return ()
|
||||
_ -> convertible t (tSeq (foldr1 tMin ls) elT)
|
||||
_ -> convertible (tSeq len t) (tSeq (foldr1 tMin ls) elT)
|
||||
|
||||
return (tMono t)
|
||||
return (tMono (tSeq len t))
|
||||
|
||||
|
||||
EVar x -> lookupVar x
|
||||
@ -300,12 +318,6 @@ exprSchema expr =
|
||||
(_,_) -> reportError (BadProofTyVars as)
|
||||
|
||||
|
||||
ECast e t ->
|
||||
do checkTypeIs KType t
|
||||
t1 <- exprType e
|
||||
convertible t t1
|
||||
return (tMono t)
|
||||
|
||||
-- XXX: Check that defined things are disitnct?
|
||||
EWhere e dgs ->
|
||||
let go [] = exprSchema e
|
||||
@ -390,13 +402,14 @@ checkDeclGroup dg =
|
||||
checkMatch :: Match -> TcM ((Name, Schema), Type)
|
||||
checkMatch ma =
|
||||
case ma of
|
||||
From x t e ->
|
||||
do checkTypeIs KType t
|
||||
From x len elt e ->
|
||||
do checkTypeIs KNum len
|
||||
checkTypeIs KType elt
|
||||
t1 <- exprType e
|
||||
case tNoUser t1 of
|
||||
TCon (TC TCSeq) [ l, el ]
|
||||
| same t el -> return ((x, tMono t), l)
|
||||
| otherwise -> reportError $ TypeMismatch (tMono t) (tMono el)
|
||||
| same elt el -> return ((x, tMono elt), l)
|
||||
| otherwise -> reportError $ TypeMismatch (tMono elt) (tMono el)
|
||||
|
||||
|
||||
_ -> reportError $ BadMatch t1
|
||||
@ -411,7 +424,7 @@ checkArm [m] = do (x,l) <- checkMatch m
|
||||
checkArm (m : ms) =
|
||||
do (x, l) <- checkMatch m
|
||||
(xs, l1) <- withVars [x] $ checkArm ms
|
||||
let newLen = l .*. l1
|
||||
let newLen = tMul l l1
|
||||
return $ if fst x `elem` map fst xs
|
||||
then (xs, newLen)
|
||||
else (x : xs, newLen)
|
||||
|
304
src/Cryptol/TypeCheck/SimpType.hs
Normal file
304
src/Cryptol/TypeCheck/SimpType.hs
Normal file
@ -0,0 +1,304 @@
|
||||
{-# LANGUAGE PatternGuards #-}
|
||||
module Cryptol.TypeCheck.SimpType where
|
||||
|
||||
import Control.Applicative((<|>))
|
||||
import Cryptol.TypeCheck.Type hiding
|
||||
(tSub,tMul,tDiv,tMod,tExp,tMin,tWidth,tLenFromThen,tLenFromThenTo)
|
||||
import Cryptol.TypeCheck.TypePat
|
||||
import Cryptol.TypeCheck.Solver.InfNat
|
||||
import Control.Monad(msum,guard)
|
||||
import Cryptol.TypeCheck.PP(pp)
|
||||
|
||||
|
||||
tRebuild' :: Bool -> Type -> Type
|
||||
tRebuild' withUser = go
|
||||
where
|
||||
go ty =
|
||||
case ty of
|
||||
TUser x xs t
|
||||
| withUser -> TUser x xs (go t)
|
||||
| otherwise -> go t
|
||||
TVar _ -> ty
|
||||
TRec xs -> TRec [ (x,go y) | (x,y) <- xs ]
|
||||
TCon tc ts ->
|
||||
case (tc, map go ts) of
|
||||
(TF f, ts') ->
|
||||
case (f,ts') of
|
||||
(TCAdd,[x,y]) -> tAdd x y
|
||||
(TCSub,[x,y]) -> tSub x y
|
||||
(TCMul,[x,y]) -> tMul x y
|
||||
(TCExp,[x,y]) -> tExp x y
|
||||
(TCDiv,[x,y]) -> tDiv x y
|
||||
(TCMod,[x,y]) -> tMod x y
|
||||
(TCMin,[x,y]) -> tMin x y
|
||||
(TCMax,[x,y]) -> tMax x y
|
||||
(TCWidth,[x]) -> tWidth x
|
||||
(TCLenFromThen,[x,y,z]) -> tLenFromThen x y z
|
||||
(TCLenFromThenTo,[x,y,z]) -> tLenFromThenTo x y z
|
||||
_ -> TCon tc ts
|
||||
(_,ts') -> TCon tc ts'
|
||||
|
||||
tRebuild :: Type -> Type
|
||||
tRebuild = tRebuild' True
|
||||
|
||||
-- Normal: constants to the left
|
||||
tAdd :: Type -> Type -> Type
|
||||
tAdd x y
|
||||
| Just t <- tOp TCAdd (total (op2 nAdd)) [x,y] = t
|
||||
| tIsInf x = tInf
|
||||
| tIsInf y = tInf
|
||||
| Just n <- tIsNum x = addK n y
|
||||
| Just n <- tIsNum y = addK n x
|
||||
| Just (n,x1) <- isSumK x = addK n (tAdd x1 y)
|
||||
| Just (n,y1) <- isSumK y = addK n (tAdd x y1)
|
||||
| Just v <- matchMaybe (do (a,b) <- (|-|) y
|
||||
guard (x == b)
|
||||
return a) = v
|
||||
| Just v <- matchMaybe (do (a,b) <- (|-|) x
|
||||
guard (b == y)
|
||||
return a) = v
|
||||
|
||||
| Just v <- matchMaybe (factor <|> same <|> swapVars) = v
|
||||
|
||||
| otherwise = tf2 TCAdd x y
|
||||
where
|
||||
isSumK t = case tNoUser t of
|
||||
TCon (TF TCAdd) [ l, r ] ->
|
||||
do n <- tIsNum l
|
||||
return (n, r)
|
||||
_ -> Nothing
|
||||
|
||||
addK 0 t = t
|
||||
addK n t | Just (m,b) <- isSumK t = tf2 TCAdd (tNum (n + m)) b
|
||||
| Just v <- matchMaybe
|
||||
$ do (a,b) <- (|-|) t
|
||||
(do m <- aNat b
|
||||
return $ case compare n m of
|
||||
GT -> tAdd (tNum (n-m)) a
|
||||
EQ -> a
|
||||
LT -> tSub a (tNum (m-n)))
|
||||
<|>
|
||||
(do m <- aNat a
|
||||
return (tSub (tNum (m+n)) b))
|
||||
= v
|
||||
-- K + min a b ~> min (K + a) (K + b)
|
||||
| Just v <- matchMaybe
|
||||
$ do (a,b) <- aMin t
|
||||
return $ tMin (tAdd (tNum n) a) (tAdd (tNum n) b)
|
||||
= v
|
||||
|
||||
| otherwise = tf2 TCAdd (tNum n) t
|
||||
|
||||
factor = do (a,b1) <- aMul x
|
||||
(a',b2) <- aMul y
|
||||
guard (a == a')
|
||||
return (tMul a (tAdd b1 b2))
|
||||
|
||||
same = do guard (x == y)
|
||||
return (tMul (tNum (2 :: Int)) x)
|
||||
|
||||
swapVars = do a <- aTVar x
|
||||
b <- aTVar y
|
||||
guard (b < a)
|
||||
return (tf2 TCAdd y x)
|
||||
|
||||
tSub :: Type -> Type -> Type
|
||||
tSub x y
|
||||
| Just t <- tOp TCSub (op2 nSub) [x,y] = t
|
||||
| tIsInf y = tBadNumber $ TCErrorMessage "Subtraction of `inf`."
|
||||
| Just 0 <- yNum = x
|
||||
| Just k <- yNum
|
||||
, TCon (TF TCAdd) [a,b] <- tNoUser x
|
||||
, Just n <- tIsNum a = case compare k n of
|
||||
EQ -> b
|
||||
LT -> tf2 TCAdd (tNum (n - k)) b
|
||||
GT -> tSub b (tNum (k - n))
|
||||
|
||||
| Just v <- matchMaybe (do (a,b) <- anAdd x
|
||||
(guard (a == y) >> return b)
|
||||
<|> (guard (b == y) >> return a))
|
||||
= v
|
||||
|
||||
| Just v <- matchMaybe (do (a,b) <- (|-|) y
|
||||
return (tSub (tAdd x b) a)) = v
|
||||
|
||||
| otherwise = tf2 TCSub x y
|
||||
where
|
||||
yNum = tIsNum y
|
||||
|
||||
|
||||
|
||||
-- Normal: constants to the left
|
||||
tMul :: Type -> Type -> Type
|
||||
tMul x y
|
||||
| Just t <- tOp TCMul (total (op2 nMul)) [x,y] = t
|
||||
| Just n <- tIsNum x = mulK n y
|
||||
| Just n <- tIsNum y = mulK n x
|
||||
| Just v <- matchMaybe swapVars = v
|
||||
| otherwise = tf2 TCMul x y
|
||||
where
|
||||
mulK 0 _ = tNum (0 :: Int)
|
||||
mulK 1 t = t
|
||||
mulK n t | TCon (TF TCMul) [a,b] <- t'
|
||||
, Just a' <- tIsNat' a = case a' of
|
||||
Inf -> t
|
||||
Nat m -> tf2 TCMul (tNum (n * m)) b
|
||||
| TCon (TF TCDiv) [a,b] <- t'
|
||||
, Just b' <- tIsNum b
|
||||
-- XXX: similar for a = b * k?
|
||||
, n == b' = tSub a (tMod a b)
|
||||
|
||||
|
||||
| otherwise = tf2 TCMul (tNum n) t
|
||||
where t' = tNoUser t
|
||||
|
||||
swapVars = do a <- aTVar x
|
||||
b <- aTVar y
|
||||
guard (b < a)
|
||||
return (tf2 TCMul y x)
|
||||
|
||||
|
||||
|
||||
tDiv :: Type -> Type -> Type
|
||||
tDiv x y
|
||||
| Just t <- tOp TCDiv (op2 nDiv) [x,y] = t
|
||||
| tIsInf x = tBadNumber $ TCErrorMessage "Division of `inf`."
|
||||
| Just 0 <- tIsNum y = tBadNumber $ TCErrorMessage "Division by 0."
|
||||
| otherwise = tf2 TCDiv x y
|
||||
|
||||
|
||||
tMod :: Type -> Type -> Type
|
||||
tMod x y
|
||||
| Just t <- tOp TCMod (op2 nMod) [x,y] = t
|
||||
| tIsInf x = tBadNumber $ TCErrorMessage "Modulus of `inf`."
|
||||
| Just 0 <- tIsNum x = tBadNumber $ TCErrorMessage "Modulus by 0."
|
||||
| otherwise = tf2 TCMod x y
|
||||
|
||||
tExp :: Type -> Type -> Type
|
||||
tExp x y
|
||||
| Just t <- tOp TCExp (total (op2 nExp)) [x,y] = t
|
||||
| Just 0 <- tIsNum y = tNum (1 :: Int)
|
||||
| TCon (TF TCExp) [a,b] <- tNoUser y = tExp x (tMul a b)
|
||||
| otherwise = tf2 TCExp x y
|
||||
|
||||
|
||||
-- Normal: constants to the left
|
||||
tMin :: Type -> Type -> Type
|
||||
tMin x y
|
||||
| Just t <- tOp TCMin (total (op2 nMin)) [x,y] = t
|
||||
| Just n <- tIsNat' x = minK n y
|
||||
| Just n <- tIsNat' y = minK n x
|
||||
| Just n <- matchMaybe (minPlusK x y <|> minPlusK y x) = n
|
||||
| Just n <- matchMaybe $ do (k,a) <- isMinK x
|
||||
return $ minK k (tMin a y)
|
||||
<|>
|
||||
do (k,a) <- isMinK y
|
||||
return $ minK k (tMin x a)
|
||||
= n
|
||||
|
||||
| Just n <- matchMaybe $ do (k1,a) <- isAddK x
|
||||
(k2,b) <- isAddK y
|
||||
guard (a == b)
|
||||
return $ tAdd (tNum (min k1 k2)) a
|
||||
= n
|
||||
|
||||
| x == y = x
|
||||
-- XXX: min (k + t) t -> t
|
||||
| otherwise = tf2 TCMin x y
|
||||
where
|
||||
isAddK ty = do (a,b) <- anAdd ty
|
||||
k <- aNat a
|
||||
return (k,b)
|
||||
|
||||
isMinK ty = do (a,b) <- aMin ty
|
||||
k <- aNat' a
|
||||
return (k,b)
|
||||
|
||||
minPlusK a b = do (k,r) <- isAddK a
|
||||
guard (k >= 1 && b == r)
|
||||
return b
|
||||
|
||||
|
||||
minK Inf t = t
|
||||
minK (Nat 0) _ = tNum (0 :: Int)
|
||||
minK (Nat k) t
|
||||
| TCon (TF TCMin) [a,b] <- t'
|
||||
, Just n <- tIsNum a = tf2 TCMin (tNum (min k n)) b
|
||||
|
||||
| otherwise = tf2 TCMin (tNum k) t
|
||||
where t' = tNoUser t
|
||||
|
||||
-- Normal: constants to the left
|
||||
tMax :: Type -> Type -> Type
|
||||
tMax x y
|
||||
| Just t <- tOp TCMax (total (op2 nMax)) [x,y] = t
|
||||
| Just n <- tIsNat' x = maxK n y
|
||||
| Just n <- tIsNat' y = maxK n x
|
||||
| otherwise = tf2 TCMax x y
|
||||
where
|
||||
maxK Inf _ = tInf
|
||||
maxK (Nat 0) t = t
|
||||
maxK (Nat k) t
|
||||
|
||||
| TCon (TF TCAdd) [a,b] <- t'
|
||||
, Just n <- tIsNum a = if k <= n
|
||||
then t
|
||||
else tMax (tNum (k - n)) b
|
||||
|
||||
| TCon (TF TCSub) [a,b] <- t'
|
||||
, Just n <- tIsNat' a =
|
||||
case n of
|
||||
Inf -> t
|
||||
Nat m -> if k >= m then tNum k else tSub a (tMin (tNum (m - k)) b)
|
||||
|
||||
| TCon (TF TCMax) [a,b] <- t'
|
||||
, Just n <- tIsNum a = tf2 TCMax (tNum (max k n)) b
|
||||
|
||||
| otherwise = tf2 TCMax (tNum k) t
|
||||
where t' = tNoUser t
|
||||
|
||||
|
||||
tWidth :: Type -> Type
|
||||
tWidth x
|
||||
| Just t <- tOp TCWidth (total (op1 nWidth)) [x] = t
|
||||
| otherwise = tf1 TCWidth x
|
||||
|
||||
tLenFromThen :: Type -> Type -> Type -> Type
|
||||
tLenFromThen x y z
|
||||
| Just t <- tOp TCLenFromThen (op3 nLenFromThen) [x,y,z] = t
|
||||
-- XXX: rules?
|
||||
| otherwise = tf3 TCLenFromThen x y z
|
||||
|
||||
tLenFromThenTo :: Type -> Type -> Type -> Type
|
||||
tLenFromThenTo x y z
|
||||
| Just t <- tOp TCLenFromThenTo (op3 nLenFromThenTo) [x,y,z] = t
|
||||
| otherwise = tf3 TCLenFromThenTo x y z
|
||||
|
||||
total :: ([Nat'] -> Nat') -> ([Nat'] -> Maybe Nat')
|
||||
total f xs = Just (f xs)
|
||||
|
||||
op1 :: (a -> b) -> [a] -> b
|
||||
op1 f ~[x] = f x
|
||||
|
||||
op2 :: (a -> a -> b) -> [a] -> b
|
||||
op2 f ~[x,y] = f x y
|
||||
|
||||
op3 :: (a -> a -> a -> b) -> [a] -> b
|
||||
op3 f ~[x,y,z] = f x y z
|
||||
|
||||
-- | Common checks: check for error, or simple full evaluation.
|
||||
tOp :: TFun -> ([Nat'] -> Maybe Nat') -> [Type] -> Maybe Type
|
||||
tOp tf f ts
|
||||
| Just e <- msum (map tIsError ts) = Just (tBadNumber e)
|
||||
| Just xs <- mapM tIsNat' ts =
|
||||
Just $ case f xs of
|
||||
Nothing -> tBadNumber (err xs)
|
||||
Just n -> tNat' n
|
||||
| otherwise = Nothing
|
||||
where
|
||||
err xs = TCErrorMessage $
|
||||
"Invalid type: " ++ show (pp (TCon (TF tf) (map tNat' xs)))
|
||||
|
||||
|
||||
|
||||
|
50
src/Cryptol/TypeCheck/SimpleSolver.hs
Normal file
50
src/Cryptol/TypeCheck/SimpleSolver.hs
Normal file
@ -0,0 +1,50 @@
|
||||
{-# LANGUAGE PatternGuards, Trustworthy #-}
|
||||
module Cryptol.TypeCheck.SimpleSolver ( simplify , simplifyStep) where
|
||||
|
||||
import Cryptol.TypeCheck.Type hiding
|
||||
( tSub, tMul, tDiv, tMod, tExp, tMin, tWidth
|
||||
, tLenFromThen, tLenFromThenTo)
|
||||
import Cryptol.TypeCheck.Solver.Types
|
||||
import Cryptol.TypeCheck.Solver.Numeric.Fin(cryIsFinType)
|
||||
import Cryptol.TypeCheck.Solver.Numeric(cryIsEqual, cryIsNotEqual, cryIsGeq)
|
||||
import Cryptol.TypeCheck.Solver.Class(solveArithInst,solveCmpInst)
|
||||
|
||||
import Cryptol.Utils.Debug(ppTrace)
|
||||
import Cryptol.TypeCheck.PP
|
||||
|
||||
simplify :: Ctxt -> Prop -> Prop
|
||||
simplify ctxt p =
|
||||
case simplifyStep ctxt p of
|
||||
Unsolvable e -> pError e
|
||||
Unsolved -> dbg msg p
|
||||
where msg = text "unsolved:" <+> pp p
|
||||
SolvedIf ps -> dbg msg $ pAnd (map (simplify ctxt) ps)
|
||||
where msg = case ps of
|
||||
[] -> text "solved:" <+> pp p
|
||||
_ -> pp p <+> text "~~~>" <+>
|
||||
vcat (punctuate comma (map pp ps))
|
||||
|
||||
where
|
||||
dbg msg x
|
||||
| False = ppTrace msg x
|
||||
| otherwise = x
|
||||
|
||||
|
||||
simplifyStep :: Ctxt -> Prop -> Solved
|
||||
simplifyStep ctxt prop =
|
||||
case tNoUser prop of
|
||||
TCon (PC PTrue) [] -> SolvedIf []
|
||||
TCon (PC PAnd) [l,r] -> SolvedIf [l,r]
|
||||
|
||||
TCon (PC PArith) [ty] -> solveArithInst ty
|
||||
TCon (PC PCmp) [ty] -> solveCmpInst ty
|
||||
|
||||
TCon (PC PFin) [ty] -> cryIsFinType ctxt ty
|
||||
|
||||
TCon (PC PEqual) [t1,t2] -> cryIsEqual ctxt t1 t2
|
||||
TCon (PC PNeq) [t1,t2] -> cryIsNotEqual ctxt t1 t2
|
||||
TCon (PC PGeq) [t1,t2] -> cryIsGeq ctxt t1 t2
|
||||
|
||||
_ -> Unsolved
|
||||
|
||||
|
@ -15,35 +15,36 @@ module Cryptol.TypeCheck.Solve
|
||||
, wfTypeFunction
|
||||
, improveByDefaultingWith
|
||||
, defaultReplExpr
|
||||
, simpType
|
||||
, simpTypeMaybe
|
||||
) where
|
||||
|
||||
import Cryptol.Parser.Position (emptyRange)
|
||||
import Cryptol.TypeCheck.PP(pp)
|
||||
import Cryptol.TypeCheck.AST
|
||||
import Cryptol.TypeCheck.Monad
|
||||
import Cryptol.TypeCheck.Subst
|
||||
(apSubst,fvs,singleSubst,substToList, isEmptySubst,
|
||||
(apSubst, singleSubst, isEmptySubst, substToList,
|
||||
emptySubst,Subst,listSubst, (@@), Subst,
|
||||
apSubstMaybe)
|
||||
import Cryptol.TypeCheck.Solver.Class
|
||||
apSubstMaybe, substBinds)
|
||||
import qualified Cryptol.TypeCheck.SimpleSolver as Simplify
|
||||
import Cryptol.TypeCheck.Solver.Types
|
||||
import Cryptol.TypeCheck.Solver.Selector(tryHasGoal)
|
||||
import Cryptol.TypeCheck.SimpType(tMax)
|
||||
|
||||
|
||||
import Cryptol.TypeCheck.Solver.SMT(proveImp,checkUnsolvable)
|
||||
import Cryptol.TypeCheck.Solver.Improve(improveProp,improveProps)
|
||||
import Cryptol.TypeCheck.Solver.Numeric.Interval
|
||||
import qualified Cryptol.TypeCheck.Solver.Numeric.AST as Num
|
||||
import qualified Cryptol.TypeCheck.Solver.Numeric.ImportExport as Num
|
||||
import Cryptol.TypeCheck.Solver.Numeric.Interval (Interval)
|
||||
import qualified Cryptol.TypeCheck.Solver.Numeric.Simplify1 as Num
|
||||
import qualified Cryptol.TypeCheck.Solver.Numeric.SimplifyExpr as Num
|
||||
import qualified Cryptol.TypeCheck.Solver.CrySAT as Num
|
||||
import Cryptol.TypeCheck.Solver.CrySAT (debugBlock, DebugLog(..))
|
||||
import Cryptol.TypeCheck.Solver.Simplify (tryRewritePropAsSubst)
|
||||
import Cryptol.Utils.PP (text)
|
||||
import Cryptol.TypeCheck.Solver.CrySAT
|
||||
import Cryptol.Utils.PP (text,vcat,(<+>))
|
||||
import Cryptol.Utils.Panic(panic)
|
||||
import Cryptol.Utils.Misc(anyJust)
|
||||
import Cryptol.Utils.Patterns(matchMaybe)
|
||||
|
||||
import Control.Monad (unless, guard)
|
||||
import Control.Monad (guard, mzero)
|
||||
import Control.Applicative ((<|>))
|
||||
import Data.Either(partitionEithers)
|
||||
import Data.Maybe(catMaybes, fromMaybe, mapMaybe)
|
||||
import Data.Maybe(catMaybes)
|
||||
import Data.Map ( Map )
|
||||
import qualified Data.Map as Map
|
||||
import Data.Set ( Set )
|
||||
@ -80,18 +81,97 @@ wfType t =
|
||||
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
|
||||
quickSolverIO :: Ctxt -> [Goal] -> IO (Either Goal (Subst,[Goal]))
|
||||
quickSolverIO _ [] = return (Right (emptySubst, []))
|
||||
quickSolverIO ctxt gs =
|
||||
case quickSolver ctxt gs of
|
||||
Left err ->
|
||||
do msg (text "Contradiction:" <+> pp (goal err))
|
||||
return (Left err)
|
||||
Right (su,gs') ->
|
||||
do msg (vcat (map (pp . goal) gs' ++ [pp su]))
|
||||
return (Right (su,gs'))
|
||||
where
|
||||
msg _ = return ()
|
||||
{-
|
||||
shAsmps = case [ pp x <+> text "in" <+> ppInterval i |
|
||||
(x,i) <- Map.toList ctxt ] of
|
||||
[] -> text ""
|
||||
xs -> text "ASMPS:" $$ nest 2 (vcat xs $$ text "===")
|
||||
msg d = putStrLn $ show (
|
||||
text "quickSolver:" $$ nest 2 (vcat
|
||||
[ shAsmps
|
||||
, vcat (map (pp.goal) gs)
|
||||
, text "==>"
|
||||
, d
|
||||
])) -- -}
|
||||
|
||||
quickSolver :: Ctxt -- ^ Facts we can know
|
||||
-> [Goal] -- ^ Need to solve these
|
||||
-> Either Goal (Subst,[Goal])
|
||||
-- ^ Left: contradicting goals,
|
||||
-- Right: inferred types, unsolved goals.
|
||||
quickSolver ctxt gs0 = go emptySubst [] gs0
|
||||
where
|
||||
go su [] [] = Right (su,[])
|
||||
|
||||
go su unsolved [] =
|
||||
case matchMaybe (findImprovement unsolved) of
|
||||
Nothing -> Right (su,unsolved)
|
||||
Just (newSu, subs) -> go (newSu @@ su) [] (subs ++ apSubst newSu unsolved)
|
||||
|
||||
go su unsolved (g : gs) =
|
||||
case Simplify.simplifyStep ctxt (goal g) of
|
||||
Unsolvable _ -> Left g
|
||||
Unsolved -> go su (g : unsolved) gs
|
||||
SolvedIf subs ->
|
||||
let cvt x = g { goal = x }
|
||||
in go su unsolved (map cvt subs ++ gs)
|
||||
|
||||
-- Probably better to find more than one.
|
||||
findImprovement [] = mzero
|
||||
findImprovement (g : gs) =
|
||||
do (su,ps) <- improveProp False ctxt (goal g)
|
||||
return (su, [ g { goal = p } | p <- ps ])
|
||||
<|> findImprovement gs
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
simplifyAllConstraints :: InferM ()
|
||||
simplifyAllConstraints =
|
||||
do mapM_ tryHasGoal =<< getHasGoals
|
||||
do simpHasGoals
|
||||
gs <- getGoals
|
||||
solver <- getSolver
|
||||
(mb,su) <- io (simpGoals' solver gs)
|
||||
extendSubst su
|
||||
case mb of
|
||||
Right gs1 -> addGoals gs1
|
||||
Left badGs -> mapM_ (recordError . UnsolvedGoal True) badGs
|
||||
case gs of
|
||||
[] -> return ()
|
||||
_ ->
|
||||
case quickSolver Map.empty gs of
|
||||
Left badG -> recordError (UnsolvedGoals True [badG])
|
||||
Right (su,gs1) ->
|
||||
do extendSubst su
|
||||
addGoals gs1
|
||||
|
||||
-- | Simplify @Has@ constraints as much as possible.
|
||||
simpHasGoals :: InferM ()
|
||||
simpHasGoals = go False [] =<< getHasGoals
|
||||
where
|
||||
go _ [] [] = return ()
|
||||
go True unsolved [] = go False [] unsolved
|
||||
go False unsolved [] = mapM_ addHasGoal unsolved
|
||||
|
||||
go changes unsolved (g : todo) =
|
||||
do (ch,solved) <- tryHasGoal g
|
||||
let changes' = ch || changes
|
||||
unsolved' = if solved then unsolved else g : unsolved
|
||||
changes' `seq` unsolved `seq` go changes' unsolved' todo
|
||||
|
||||
|
||||
|
||||
|
||||
proveImplication :: Name -> [TParam] -> [Prop] -> [Goal] -> InferM Subst
|
||||
@ -114,115 +194,80 @@ proveImplicationIO :: Num.Solver
|
||||
-> [Goal] -- ^ Collected constraints
|
||||
-> IO (Either Error [Warning], Subst)
|
||||
proveImplicationIO _ _ _ _ [] [] = return (Right [], emptySubst)
|
||||
proveImplicationIO s lname varsInEnv as ps gs =
|
||||
debugBlock s "proveImplicationIO" $
|
||||
|
||||
do debugBlock s "assumes" (debugLog s ps)
|
||||
debugBlock s "shows" (debugLog s gs)
|
||||
debugLog s "1. ------------------"
|
||||
|
||||
|
||||
_simpPs <- Num.assumeProps s ps
|
||||
|
||||
mbImps <- Num.check s
|
||||
debugLog s "2. ------------------"
|
||||
|
||||
|
||||
case mbImps of
|
||||
|
||||
Nothing ->
|
||||
do debugLog s "(contradiction in assumptions)"
|
||||
return (Left $ UnusableFunction lname ps, emptySubst)
|
||||
|
||||
Just (imps,extra) ->
|
||||
do let su = importImps imps
|
||||
gs0 = apSubst su gs
|
||||
|
||||
debugBlock s "improvement from assumptions:" $ debugLog s su
|
||||
|
||||
let (scs,invalid) = importSideConds extra
|
||||
unless (null invalid) $
|
||||
panic "proveImplicationIO" ( "Unable to import all side conditions:"
|
||||
: map (show . Num.ppProp) invalid )
|
||||
|
||||
let gs1 = filter ((`notElem` ps) . goal) gs0
|
||||
|
||||
debugLog s "3. ---------------------"
|
||||
(mb,su1) <- simpGoals' s (scs ++ gs1)
|
||||
|
||||
case mb of
|
||||
Left badGs -> reportUnsolved badGs (su1 @@ su)
|
||||
Right [] -> return (Right [], su1 @@ su)
|
||||
|
||||
Right us ->
|
||||
-- Last hope: try to default stuff
|
||||
do let vs = Set.filter isFreeTV $ fvs $ map goal us
|
||||
dVars = Set.toList (vs `Set.difference` varsInEnv)
|
||||
(_,us1,su2,ws) <- improveByDefaultingWith s dVars us
|
||||
case us1 of
|
||||
[] -> return (Right ws, su2 @@ su1 @@ su)
|
||||
_ -> reportUnsolved us1 (su2 @@ su1 @@ su)
|
||||
proveImplicationIO s f varsInEnv ps asmps0 gs0 =
|
||||
do let ctxt = assumptionIntervals Map.empty asmps
|
||||
res <- quickSolverIO ctxt gs
|
||||
case res of
|
||||
Left bad -> return (Left (UnsolvedGoals True [bad]), emptySubst)
|
||||
Right (su,[]) -> return (Right [], su)
|
||||
Right (su,gs1) ->
|
||||
do gs2 <- proveImp s asmps gs1
|
||||
case gs2 of
|
||||
[] -> return (Right [], su)
|
||||
gs3 ->
|
||||
do let free = Set.toList
|
||||
$ Set.difference (fvs (map goal gs3)) varsInEnv
|
||||
case improveByDefaultingWithPure free gs3 of
|
||||
(_,_,newSu,_)
|
||||
| isEmptySubst newSu -> return (err gs3, su) -- XXX: Old?
|
||||
(_,newGs,newSu,ws) ->
|
||||
do let su1 = newSu @@ su
|
||||
(res1,su2) <- proveImplicationIO s f varsInEnv ps
|
||||
(apSubst su1 asmps0) newGs
|
||||
let su3 = su2 @@ su1
|
||||
case res1 of
|
||||
Left bad -> return (Left bad, su3)
|
||||
Right ws1 -> return (Right (ws++ws1),su3)
|
||||
where
|
||||
reportUnsolved us su =
|
||||
return ( Left $ UnsolvedDelayedCt
|
||||
$ DelayedCt { dctSource = lname
|
||||
, dctForall = as
|
||||
, dctAsmps = ps
|
||||
err us = Left $ cleanupError
|
||||
$ UnsolvedDelayedCt
|
||||
$ DelayedCt { dctSource = f
|
||||
, dctForall = ps
|
||||
, dctAsmps = asmps0
|
||||
, dctGoals = us
|
||||
}, su)
|
||||
}
|
||||
|
||||
|
||||
|
||||
(asmps,gs) =
|
||||
let gs1 = [ g { goal = p } | g <- gs0, p <- pSplitAnd (goal g)
|
||||
, notElem p asmps0 ]
|
||||
in case matchMaybe (improveProps True Map.empty asmps0) of
|
||||
Nothing -> (asmps0,gs1)
|
||||
Just (newSu,newAsmps) ->
|
||||
( [ TVar x =#= t | (x,t) <- substToList newSu ]
|
||||
++ newAsmps
|
||||
, [ g { goal = apSubst newSu (goal g) } | g <- gs1 ]
|
||||
)
|
||||
|
||||
|
||||
|
||||
|
||||
cleanupError :: Error -> Error
|
||||
cleanupError err =
|
||||
case err of
|
||||
UnsolvedDelayedCt d ->
|
||||
let noInferVars = Set.null . Set.filter isFreeTV . fvs . goal
|
||||
without = filter noInferVars (dctGoals d)
|
||||
in UnsolvedDelayedCt $
|
||||
if not (null without) then d { dctGoals = without } else d
|
||||
|
||||
_ -> err
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
{- Constraints and satisfiability:
|
||||
|
||||
1. [Satisfiable] A collection of constraints is _satisfiable_, if there is an
|
||||
assignment for the variables that make all constraints true.
|
||||
|
||||
2. [Valid] If a constraint is satisfiable for any assignment of its free
|
||||
variables, then it is _valid_, and may be ommited.
|
||||
|
||||
3. [Partial] A constraint may _partial_, which means that under some
|
||||
assignment it is neither true nor false. For example:
|
||||
`x - y > 5` is true for `{ x = 15, y = 3 }`, it is false for
|
||||
`{ x = 5, y = 4 }`, and it is neither for `{ x = 1, y = 2 }`.
|
||||
|
||||
Note that constraints that are always true or undefined are NOT
|
||||
valid, as there are assignemntes for which they are not true.
|
||||
An example of such constraint is `x - y >= 0`.
|
||||
|
||||
4. [Provability] Instead of thinking of three possible values for
|
||||
satisfiability (i.e., true, false, and unknown), we could instead
|
||||
think of asking: "Is constraint C provable". This essentailly
|
||||
maps "true" to "true", and "false,unknown" to "false", if we
|
||||
treat constraints with malformed parameters as unprovable.
|
||||
-}
|
||||
|
||||
|
||||
{-
|
||||
The plan:
|
||||
1. Start with a set of constraints, CS
|
||||
2. Compute its well-defined closure, DS.
|
||||
3. Simplify constraints: evaluate terms in constraints as much as possible
|
||||
4. Solve: eliminate constraints that are true
|
||||
5. Check for consistency
|
||||
6. Compute improvements
|
||||
7. For each type in the improvements, add well-defined constraints
|
||||
8. Instantiate constraints with substitution
|
||||
9. Goto 3
|
||||
-}
|
||||
|
||||
simpGoals' :: Num.Solver -> [Goal] -> IO (Either [Goal] [Goal], Subst)
|
||||
simpGoals' s gs0 = go emptySubst [] (wellFormed gs0 ++ gs0)
|
||||
simpGoals' :: Num.Solver -> Ctxt -> [Goal] -> IO (Either [Goal] [Goal], Subst)
|
||||
simpGoals' s asmps gs0 = go emptySubst [] (wellFormed gs0 ++ gs0)
|
||||
where
|
||||
-- Assumes that the well-formed constraints are themselves well-formed.
|
||||
wellFormed gs = [ g { goal = p } | g <- gs, p <- wfType (goal g) ]
|
||||
|
||||
go su old [] = return (Right old, su)
|
||||
go su old gs =
|
||||
do gs1 <- simplifyConstraintTerms s gs
|
||||
res <- solveConstraints s old gs1
|
||||
do res <- solveConstraints s asmps old gs
|
||||
case res of
|
||||
Left err -> return (Left err, su)
|
||||
Right gs2 ->
|
||||
@ -257,14 +302,20 @@ However, we should be careful to avoid circular reasoning, as we wouldn't
|
||||
want to use the fact that `x >= 1` to simplify `x >= 1` to true.
|
||||
-}
|
||||
|
||||
-- XXX: currently simplify individually
|
||||
simplifyConstraintTerms :: Num.Solver -> [Goal] -> IO [Goal]
|
||||
simplifyConstraintTerms s gs =
|
||||
debugBlock s "Simplifying terms" $ return (map simpGoal gs)
|
||||
where simpGoal g = g { goal = simpProp (goal g) }
|
||||
|
||||
|
||||
|
||||
assumptionIntervals :: Ctxt -> [Prop] -> Ctxt
|
||||
assumptionIntervals as ps =
|
||||
case computePropIntervals as ps of
|
||||
NoChange -> as
|
||||
InvalidInterval {} -> as -- XXX: say something
|
||||
NewIntervals bs -> Map.union bs as
|
||||
|
||||
|
||||
|
||||
solveConstraints :: Num.Solver ->
|
||||
Ctxt ->
|
||||
[Goal] {- We may use these, but don't try to solve,
|
||||
we already tried and failed. -} ->
|
||||
[Goal] {- Need to solve these -} ->
|
||||
@ -272,32 +323,37 @@ solveConstraints :: Num.Solver ->
|
||||
-- ^ Left: contradiciting goals,
|
||||
-- Right: goals that were not solved, or sub-goals
|
||||
-- for solved goals. Does not include "old"
|
||||
solveConstraints s otherGs gs0 =
|
||||
debugBlock s "Solving constraints" $ solveClassCts [] [] gs0
|
||||
solveConstraints s asmps otherGs gs0 =
|
||||
debugBlock s "Solving constraints" $ go ctxt0 [] gs0
|
||||
|
||||
where
|
||||
ctxt0 = assumptionIntervals asmps (map goal otherGs)
|
||||
|
||||
|
||||
go _ unsolved [] =
|
||||
do let (cs,nums) = partitionEithers (map Num.numericRight unsolved)
|
||||
nums' <- solveNumerics s otherNumerics nums
|
||||
return (Right (cs ++ nums'))
|
||||
|
||||
go ctxt unsolved (g : gs) =
|
||||
case Simplify.simplifyStep ctxt (goal g) of
|
||||
Unsolvable _x -> return (Left [g]) -- maybe give error?
|
||||
Unsolved -> go ctxt (g : unsolved) gs
|
||||
SolvedIf subs ->
|
||||
let cvt x = g { goal = x }
|
||||
in go ctxt unsolved (map cvt subs ++ gs)
|
||||
|
||||
|
||||
otherNumerics = [ g | Right g <- map Num.numericRight otherGs ]
|
||||
|
||||
solveClassCts unsolvedClass numerics [] =
|
||||
do unsolvedNum <- solveNumerics s otherNumerics numerics
|
||||
return (Right (unsolvedClass ++ unsolvedNum))
|
||||
|
||||
solveClassCts unsolved numerics (g : gs) =
|
||||
case Num.numericRight g of
|
||||
Right n -> solveClassCts unsolved (n : numerics) gs
|
||||
Left c ->
|
||||
case classStep c of
|
||||
Unsolvable -> return (Left [g])
|
||||
Unsolved -> solveClassCts (g : unsolved) numerics gs
|
||||
Solved Nothing subs -> solveClassCts unsolved numerics (subs ++ gs)
|
||||
Solved (Just su) _ -> panic "solveClassCts"
|
||||
[ "Unexpected substituion", show su ]
|
||||
|
||||
|
||||
solveNumerics :: Num.Solver ->
|
||||
[(Goal,Num.Prop)] {- ^ Consult these -} ->
|
||||
[(Goal,Num.Prop)] {- ^ Solve these -} ->
|
||||
IO [Goal]
|
||||
solveNumerics _ _ [] = return []
|
||||
solveNumerics s consultGs solveGs =
|
||||
Num.withScope s $
|
||||
do _ <- Num.assumeProps s (map (goal . fst) consultGs)
|
||||
@ -320,25 +376,21 @@ computeImprovements s gs =
|
||||
Right ints <- Num.getIntervals s
|
||||
return (Just (ints,su))
|
||||
case res of
|
||||
Just (ints,su)
|
||||
Just (_ints, su) -> return (Right su) -- ?
|
||||
{-
|
||||
| isEmptySubst su
|
||||
, (x,t) : _ <- mapMaybe (improveByDefn ints) gs ->
|
||||
do let su' = singleSubst x t
|
||||
debugLog s ("Improve by definition: " ++ show (pp su'))
|
||||
return (Right su')
|
||||
|
||||
| otherwise -> return (Right su)
|
||||
|
||||
-}
|
||||
Nothing ->
|
||||
do bad <- Num.minimizeContradictionSimpDef s
|
||||
(map Num.knownDefined nums)
|
||||
return (Left bad)
|
||||
|
||||
|
||||
improveByDefn :: Map TVar Interval -> Goal -> Maybe (TVar,Type)
|
||||
improveByDefn ints Goal { .. } =
|
||||
do (var,ty) <- tryRewritePropAsSubst ints goal
|
||||
return (var,simpType ty)
|
||||
|
||||
|
||||
|
||||
@ -367,29 +419,6 @@ importSplitImps = mk . partitionEithers . map imp . Map.toList
|
||||
|
||||
|
||||
|
||||
-- | Import an improving substitution into a Cryptol substitution.
|
||||
-- The substitution will contain both unification and skolem variables,
|
||||
-- so this should be used when processing *givens*.
|
||||
importImps :: Map Num.Name Num.Expr -> Subst
|
||||
importImps = listSubst . map imp . Map.toList
|
||||
where
|
||||
imp (x,e) = case (x, Num.importType e) of
|
||||
(Num.UserName tv, Just ty) -> (tv,ty)
|
||||
_ -> panic "importImps" [ "Failed to import:", show x, show e ]
|
||||
|
||||
|
||||
|
||||
importSideConds :: [Num.Prop] -> ([Goal],[Num.Prop])
|
||||
importSideConds = go [] []
|
||||
where
|
||||
go ok bad [] = ([ Goal CtImprovement emptyRange g | g <- ok], bad)
|
||||
go ok bad (p:ps) = case Num.importProp p of
|
||||
Just p' -> go (p' ++ ok) bad ps
|
||||
Nothing -> go ok (p:bad) ps
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
@ -424,10 +453,50 @@ improveByDefaultingWith ::
|
||||
[Goal] -> -- constraints
|
||||
IO ( [TVar] -- non-defaulted
|
||||
, [Goal] -- new constraints
|
||||
, Subst -- improvements from defaulting
|
||||
, Maybe Subst -- Nothing: improve to False
|
||||
-- Just: improvements from defaulting
|
||||
, [Warning] -- warnings about defaulting
|
||||
)
|
||||
improveByDefaultingWith s as ps =
|
||||
-- XXX: Remove this
|
||||
-- improveByDefaultingWith s as gs = return (as,gs,emptySubst,[])
|
||||
improveByDefaultingWith s as gs =
|
||||
do bad <- checkUnsolvable s gs
|
||||
if bad
|
||||
then return (as, gs, Nothing, [])
|
||||
else tryImp
|
||||
|
||||
where
|
||||
tryImp =
|
||||
case improveByDefaultingWithPure as gs of
|
||||
(xs,gs',su,ws) ->
|
||||
do (res,su1) <- simpGoals' s Map.empty gs'
|
||||
case res of
|
||||
Left err ->
|
||||
panic "improveByDefaultingWith"
|
||||
$ [ "Defaulting resulted in unsolvable constraints."
|
||||
, "Before:"
|
||||
] ++ [ " " ++ show (pp (goal g)) | g <- gs ] ++
|
||||
[ "After:"
|
||||
] ++ [ " " ++ show (pp (goal g)) | g <- gs' ] ++
|
||||
[ "Contradiction:" ] ++
|
||||
[ " " ++ show (pp (goal g)) | g <- err ]
|
||||
Right gs'' ->
|
||||
do let su2 = su1 @@ su
|
||||
isDef x = x `Set.member` substBinds su2
|
||||
return ( filter (not . isDef) xs
|
||||
, gs''
|
||||
, Just su2
|
||||
, ws
|
||||
)
|
||||
|
||||
|
||||
improveByDefaultingWithPure :: [TVar] -> [Goal] ->
|
||||
( [TVar] -- non-defaulted
|
||||
, [Goal] -- new constraints
|
||||
, Subst -- improvements from defaulting
|
||||
, [Warning] -- warnings about defaulting
|
||||
)
|
||||
improveByDefaultingWithPure as ps =
|
||||
classify (Map.fromList [ (a,([],Set.empty)) | a <- as ]) [] [] ps
|
||||
|
||||
where
|
||||
@ -436,34 +505,23 @@ improveByDefaultingWith s as ps =
|
||||
-- fins: all `fin` constraints
|
||||
-- others: any other constraints
|
||||
classify leqs fins others [] =
|
||||
do let -- First, we use the `leqs` to choose some definitions.
|
||||
(defs, newOthers) = select [] [] (fvs others) (Map.toList leqs)
|
||||
su = listSubst defs
|
||||
let -- First, we use the `leqs` to choose some definitions.
|
||||
(defs, newOthers) = select [] [] (fvs others) (Map.toList leqs)
|
||||
su = listSubst defs
|
||||
warn (x,t) =
|
||||
case x of
|
||||
TVFree _ _ _ d -> DefaultingTo d t
|
||||
TVBound {} -> panic "Crypto.TypeCheck.Infer"
|
||||
[ "tryDefault attempted to default a quantified variable."
|
||||
]
|
||||
|
||||
-- Do this to simplify the instantiated "fin" constraints.
|
||||
(mb,su1) <- simpGoals' s (newOthers ++ others ++ apSubst su fins)
|
||||
case mb of
|
||||
Right gs1 ->
|
||||
let warn (x,t) =
|
||||
case x of
|
||||
TVFree _ _ _ d -> DefaultingTo d t
|
||||
TVBound {} -> panic "Crypto.TypeCheck.Infer"
|
||||
[ "tryDefault attempted to default a quantified variable."
|
||||
]
|
||||
names = substBinds su
|
||||
|
||||
newSu = su1 @@ su -- XXX: is that right?
|
||||
names = Set.fromList $ map fst $ fromMaybe [] $ substToList newSu
|
||||
|
||||
in return ( [ a | a <- as, not (a `Set.member` names) ]
|
||||
, gs1
|
||||
, newSu
|
||||
, map warn defs
|
||||
)
|
||||
|
||||
|
||||
|
||||
-- Something went wrong, don't default.
|
||||
Left _ -> return (as,ps,su1 @@ su,[])
|
||||
in ( [ a | a <- as, not (a `Set.member` names) ]
|
||||
, newOthers ++ others ++ apSubst su fins
|
||||
, su
|
||||
, map warn defs
|
||||
)
|
||||
|
||||
|
||||
classify leqs fins others (prop : more) =
|
||||
@ -532,13 +590,14 @@ improveByDefaultingWith s as ps =
|
||||
-- The resulting types should satisfy the constraints of the schema.
|
||||
defaultReplExpr :: Num.Solver -> Expr -> Schema
|
||||
-> IO (Maybe ([(TParam,Type)], Expr))
|
||||
-- defaultReplExpr _ _ _ = return Nothing
|
||||
defaultReplExpr so e s =
|
||||
if all (\v -> kindOf v == KNum) (sVars s)
|
||||
then do let params = map tpVar (sVars s)
|
||||
mbSubst <- tryGetModel so params (sProps s)
|
||||
case mbSubst of
|
||||
Just su ->
|
||||
do (res,su1) <- simpGoals' so (map (makeGoal su) (sProps s))
|
||||
do (res,su1) <- simpGoals' so Map.empty (map (makeGoal su) (sProps s))
|
||||
return $
|
||||
case res of
|
||||
Right [] | isEmptySubst su1 ->
|
||||
@ -575,78 +634,4 @@ tryGetModel s xs ps =
|
||||
-- We are only interested in finite instantiations
|
||||
Num.getModel s (map (pFin . TVar) xs ++ ps)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
simpType :: Type -> Type
|
||||
simpType ty = fromMaybe ty (simpTypeMaybe ty)
|
||||
|
||||
simpProp :: Prop -> Prop
|
||||
simpProp p = case p of
|
||||
TUser f ts q -> TUser f (map simpType ts) (simpProp q)
|
||||
TCon c ts -> TCon c (map simpType ts)
|
||||
TVar {} -> panic "simpProp" ["variable", show p]
|
||||
TRec {} -> panic "simpProp" ["record", show p]
|
||||
|
||||
|
||||
|
||||
|
||||
simpTypeMaybe :: Type -> Maybe Type
|
||||
simpTypeMaybe ty =
|
||||
case ty of
|
||||
TCon c ts ->
|
||||
case c of
|
||||
TF {} -> do e <- Num.exportType ty
|
||||
e1 <- Num.crySimpExprMaybe e
|
||||
Num.importType e1
|
||||
|
||||
_ -> TCon c `fmap` anyJust simpTypeMaybe ts
|
||||
|
||||
TVar _ -> Nothing
|
||||
TUser x ts t -> TUser x ts `fmap` simpTypeMaybe t
|
||||
TRec fs ->
|
||||
do let (ls,ts) = unzip fs
|
||||
ts' <- anyJust simpTypeMaybe ts
|
||||
return (TRec (zip ls ts'))
|
||||
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
_testSimpGoals :: IO ()
|
||||
_testSimpGoals = Num.withSolver cfg $ \s ->
|
||||
do mapM_ dump asmps
|
||||
mapM_ (dump .goal) gs
|
||||
|
||||
_ <- Num.assumeProps s asmps
|
||||
_mbImps <- Num.check s
|
||||
|
||||
|
||||
(mb,_) <- simpGoals' s gs
|
||||
case mb of
|
||||
Right _ -> debugLog s "End of test"
|
||||
Left _ -> debugLog s "Impossible"
|
||||
where
|
||||
cfg = SolverConfig { solverPath = "z3"
|
||||
, solverArgs = [ "-smt2", "-in" ]
|
||||
, solverVerbose = 1
|
||||
}
|
||||
|
||||
asmps = []
|
||||
|
||||
gs = map fakeGoal [ tv 0 =#= tMin (num 10) (tv 1)
|
||||
, tv 1 =#= num 10
|
||||
]
|
||||
|
||||
|
||||
fakeGoal p = Goal { goalSource = undefined, goalRange = undefined, goal = p }
|
||||
tv n = TVar (TVFree n KNum Set.empty (text "test var"))
|
||||
_btv n = TVar (TVBound n KNum)
|
||||
num x = tNum (x :: Int)
|
||||
|
||||
dump a = do putStrLn "-------------------_"
|
||||
case Num.exportProp a of
|
||||
Just b -> do print $ Num.ppProp' $ Num.propToProp' b
|
||||
putStrLn "-------------------"
|
||||
Nothing -> print "can't export"
|
||||
|
||||
|
||||
|
||||
|
@ -11,79 +11,85 @@
|
||||
{-# LANGUAGE PatternGuards #-}
|
||||
module Cryptol.TypeCheck.Solver.Class
|
||||
( classStep
|
||||
, solveArithInst
|
||||
, solveCmpInst
|
||||
, expandProp
|
||||
) where
|
||||
|
||||
import Cryptol.TypeCheck.AST
|
||||
import Cryptol.TypeCheck.InferTypes(Goal(..), Solved(..))
|
||||
import Cryptol.TypeCheck.Type
|
||||
import Cryptol.TypeCheck.Solver.Types
|
||||
|
||||
-- | Solve class constraints.
|
||||
-- If not, then we return 'Nothing'.
|
||||
-- If solved, ther we return 'Just' a list of sub-goals.
|
||||
classStep :: Goal -> Solved
|
||||
classStep g = case goal g of
|
||||
TCon (PC PArith) [ty] -> solveArithInst g (tNoUser ty)
|
||||
TCon (PC PCmp) [ty] -> solveCmpInst g (tNoUser ty)
|
||||
classStep :: Prop -> Solved
|
||||
classStep p = case tNoUser p of
|
||||
TCon (PC PArith) [ty] -> solveArithInst (tNoUser ty)
|
||||
TCon (PC PCmp) [ty] -> solveCmpInst (tNoUser ty)
|
||||
_ -> Unsolved
|
||||
|
||||
-- | Solve an original goal in terms of the give sub-goals.
|
||||
solved :: Goal -> [Prop] -> Solved
|
||||
solved g ps = Solved Nothing [ g { goal = p } | p <- ps ]
|
||||
|
||||
-- | Solve an Arith constraint by instance, if possible.
|
||||
solveArithInst :: Goal -> Type -> Solved
|
||||
solveArithInst g ty = case ty of
|
||||
solveArithInst :: Type -> Solved
|
||||
solveArithInst ty = case tNoUser ty of
|
||||
|
||||
-- Arith Error -> fails
|
||||
TCon (TError _ e) _ -> Unsolvable e
|
||||
|
||||
-- Arith [n]e
|
||||
TCon (TC TCSeq) [n, e] -> solveArithSeq g n e
|
||||
TCon (TC TCSeq) [n, e] -> solveArithSeq n e
|
||||
|
||||
-- Arith b => Arith (a -> b)
|
||||
TCon (TC TCFun) [_,b] -> solved g [ pArith b ]
|
||||
TCon (TC TCFun) [_,b] -> SolvedIf [ pArith b ]
|
||||
|
||||
-- (Arith a, Arith b) => Arith (a,b)
|
||||
TCon (TC (TCTuple _)) es -> solved g [ pArith e | e <- es ]
|
||||
TCon (TC (TCTuple _)) es -> SolvedIf [ pArith e | e <- es ]
|
||||
|
||||
-- Arith Bit fails
|
||||
TCon (TC TCBit) [] -> Unsolvable
|
||||
TCon (TC TCBit) [] ->
|
||||
Unsolvable $ TCErrorMessage "Arithmetic cannot be done on individual bits."
|
||||
|
||||
-- (Arith a, Arith b) => Arith { x1 : a, x2 : b }
|
||||
TRec fs -> solved g [ pArith ety | (_,ety) <- fs ]
|
||||
TRec fs -> SolvedIf [ pArith ety | (_,ety) <- fs ]
|
||||
|
||||
_ -> Unsolved
|
||||
|
||||
-- | Solve an Arith constraint for a sequence. The type passed here is the
|
||||
-- element type of the sequence.
|
||||
solveArithSeq :: Goal -> Type -> Type -> Solved
|
||||
solveArithSeq g n ty = case ty of
|
||||
solveArithSeq :: Type -> Type -> Solved
|
||||
solveArithSeq n ty = case tNoUser ty of
|
||||
|
||||
-- fin n => Arith [n]Bit
|
||||
TCon (TC TCBit) [] -> solved g [ pFin n ]
|
||||
TCon (TC TCBit) [] -> SolvedIf [ pFin n ]
|
||||
|
||||
-- variables are not solvable.
|
||||
TVar {} -> Unsolved
|
||||
|
||||
-- Arith ty => Arith [n]ty
|
||||
_ -> solved g [ pArith ty ]
|
||||
_ -> SolvedIf [ pArith ty ]
|
||||
|
||||
|
||||
-- | Solve Cmp constraints.
|
||||
solveCmpInst :: Goal -> Type -> Solved
|
||||
solveCmpInst g ty = case ty of
|
||||
solveCmpInst :: Type -> Solved
|
||||
solveCmpInst ty = case tNoUser ty of
|
||||
|
||||
-- Cmp Error -> fails
|
||||
TCon (TError _ e) _ -> Unsolvable e
|
||||
|
||||
-- Cmp Bit
|
||||
TCon (TC TCBit) [] -> solved g []
|
||||
TCon (TC TCBit) [] -> SolvedIf []
|
||||
|
||||
-- (fin n, Cmp a) => Cmp [n]a
|
||||
TCon (TC TCSeq) [n,a] -> solved g [ pFin n, pCmp a ]
|
||||
TCon (TC TCSeq) [n,a] -> SolvedIf [ pFin n, pCmp a ]
|
||||
|
||||
-- (Cmp a, Cmp b) => Cmp (a,b)
|
||||
TCon (TC (TCTuple _)) es -> solved g (map pCmp es)
|
||||
TCon (TC (TCTuple _)) es -> SolvedIf (map pCmp es)
|
||||
|
||||
-- Cmp (a -> b) fails
|
||||
TCon (TC TCFun) [_,_] -> Unsolvable
|
||||
TCon (TC TCFun) [_,_] ->
|
||||
Unsolvable $ TCErrorMessage "Comparisons may not be performed on functions."
|
||||
|
||||
-- (Cmp a, Cmp b) => Cmp { x:a, y:b }
|
||||
TRec fs -> solved g [ pCmp e | (_,e) <- fs ]
|
||||
TRec fs -> SolvedIf [ pCmp e | (_,e) <- fs ]
|
||||
|
||||
_ -> Unsolved
|
||||
|
||||
|
@ -21,12 +21,15 @@ module Cryptol.TypeCheck.Solver.CrySAT
|
||||
, DebugLog(..)
|
||||
, knownDefined, numericRight
|
||||
, minimizeContradictionSimpDef
|
||||
, loadFile
|
||||
, rawSolver
|
||||
) where
|
||||
|
||||
import qualified Cryptol.TypeCheck.AST as Cry
|
||||
import Cryptol.TypeCheck.InferTypes(Goal(..), SolverConfig(..), Solved(..))
|
||||
import Cryptol.TypeCheck.InferTypes(Goal(..), SolverConfig(..))
|
||||
import qualified Cryptol.TypeCheck.Subst as Cry
|
||||
|
||||
import Cryptol.TypeCheck.Solver.Types
|
||||
import Cryptol.TypeCheck.Solver.Numeric.AST
|
||||
import Cryptol.TypeCheck.Solver.Numeric.Fin
|
||||
import Cryptol.TypeCheck.Solver.Numeric.ImportExport
|
||||
@ -42,6 +45,7 @@ import MonadLib
|
||||
import Data.Maybe ( fromMaybe )
|
||||
import Data.Map (Map)
|
||||
import qualified Data.Map as Map
|
||||
import Data.Char(isSpace)
|
||||
import Data.Foldable ( any, all )
|
||||
import qualified Data.Set as Set
|
||||
import Data.IORef ( IORef, newIORef, readIORef, modifyIORef',
|
||||
@ -124,9 +128,11 @@ simplifyProps s props =
|
||||
|
||||
Just (ints,False) ->
|
||||
debugLog s ("Using the fin solver:" ++ show (pp (goal (dpData p)))) >>
|
||||
case cryIsFin ints (dpData p) of
|
||||
Solved _ gs' ->
|
||||
case cryIsFin ints (goal (dpData p)) of
|
||||
SolvedIf ps' ->
|
||||
do debugLog s "solved"
|
||||
let gg = dpData p
|
||||
gs' = [ gg { goal = pr } | pr <- ps' ]
|
||||
let more' = [ knownDefined g | Right g <- map numericRight gs' ]
|
||||
go survived (more' ++ more)
|
||||
Unsolved ->
|
||||
@ -134,8 +140,8 @@ simplifyProps s props =
|
||||
assert s p
|
||||
go (dpData p : survived) more
|
||||
|
||||
Unsolvable ->
|
||||
do debugLog s "unsolvable"
|
||||
x@(Unsolvable {}) ->
|
||||
do debugLog s (show (pp x))
|
||||
go (dpData p:survived) more
|
||||
|
||||
Nothing -> go (dpData p:survived) more
|
||||
@ -279,6 +285,28 @@ data Solver = Solver
|
||||
-- ^ For debugging
|
||||
}
|
||||
|
||||
loadFile :: Solver -> FilePath -> IO ()
|
||||
loadFile s file = do -- txt <- readFile file
|
||||
-- mapM_ putStrLn (lines txt)
|
||||
go . dropComments =<< readFile file
|
||||
where
|
||||
go txt
|
||||
| all isSpace txt = return ()
|
||||
| otherwise = case SMT.readSExpr txt of
|
||||
Just (e,rest) -> SMT.command (solver s) e >> go rest
|
||||
Nothing -> panic "loadFile" [ "Failed to parse SMT file."
|
||||
, txt
|
||||
]
|
||||
|
||||
dropComments = unlines . map dropComment . lines
|
||||
dropComment xs = case break (== ';') xs of
|
||||
(as,_:_) -> as
|
||||
_ -> xs
|
||||
|
||||
rawSolver :: Solver -> SMT.Solver
|
||||
rawSolver = solver
|
||||
|
||||
|
||||
|
||||
-- | Keeps track of declared variables and non-linear terms.
|
||||
data VarInfo = VarInfo
|
||||
@ -415,7 +443,7 @@ withSolver SolverConfig { .. } k =
|
||||
let smtDbg = if solverVerbose > 1 then Just logger else Nothing
|
||||
solver <- SMT.newSolver solverPath solverArgs smtDbg
|
||||
_ <- SMT.setOptionMaybe solver ":global-decls" "false"
|
||||
SMT.setLogic solver "QF_LIA"
|
||||
-- SMT.setLogic solver "QF_LIA"
|
||||
declared <- newIORef viEmpty
|
||||
a <- k Solver { .. }
|
||||
_ <- SMT.stop solver
|
||||
|
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue
Block a user