GaloisInc/cryptol
1
1
Fork 0
mirror of https://github.com/GaloisInc/cryptol.git synced 2024-08-16 17:30:27 +03:00
Code Issues Projects Releases Wiki Activity

Merge branch 'release/2.5.0' into releases

Browse Source
This commit is contained in:
Aaron Tomb 2017-07-25 08:54:01 -07:00
commit 78fa3f2c5f
174 changed files with 12433 additions and 5623 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
.appveyor.yml Normal file
View 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
View File

@ -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
View File

@ -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
View File

@ -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
View File

@ -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

85
bench/Main.hs
View File

@ -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)

14
bench/data/AES.cry
View File

@ -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
View 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 ]

5
bench/data/SHA512.cry
View File

@ -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
View File

File diff suppressed because it is too large Load Diff

2000
cabal.GHC80.config
View File

File diff suppressed because it is too large Load Diff

107
cryptol.cabal
View File

@ -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

81
cryptol/Main.hs
View File

@ -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."

139
cryptol/REPL/Haskeline.hs
View File

@ -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.

2
cryptol/REPL/Logo.hs
View File

@ -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)))

15
docs/CryptolPrims.md
View File

@ -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

BIN
docs/CryptolPrims.pdf
View File

Binary file not shown.

5
docs/Makefile
View File

@ -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}

BIN
docs/ProgrammingCryptol.pdf
View File

Binary file not shown.

5
docs/ProgrammingCryptol/aes/AES.cry
View File

@ -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]

105
docs/ProgrammingCryptol/aes/AES.tex
View File

@ -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

2
docs/ProgrammingCryptol/aes/AESCode.tex
View File

@ -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.

28
docs/ProgrammingCryptol/appendices/Syntax.tex
View File

@ -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}

32
docs/ProgrammingCryptol/classic/Classic.tex
View File

@ -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}

316
docs/ProgrammingCryptol/crashCourse/CrashCourse.tex
View File

@ -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))

14
docs/ProgrammingCryptol/enigma/Enigma.tex
View File

@ -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,

68
docs/ProgrammingCryptol/highAssurance/HighAssurance.tex
View File

@ -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.
%%

38
docs/ProgrammingCryptol/prims/Primitives.tex
View File

@ -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.}

10
docs/ProgrammingCryptol/technicalities/Install.tex
View File

@ -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

52
docs/ProgrammingCryptol/technicalities/TechAppendix.tex
View File

@ -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
View File

Binary file not shown.

16
docs/Syntax.md
View File

@ -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
View File

Binary file not shown.

236
examples/AES.cry Normal file
View 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

116
examples/ChaChaPolyCryptolIETF.md
View File

@ -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
```

6
examples/DEStest.cry
View File

@ -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) ]

2
examples/MiniLock/File.md
View File

@ -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
```

2
examples/MiniLock/Keys.cry
View File

@ -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

6
examples/MiniLock/prim/Base64.cry
View File

@ -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

2
examples/MiniLock/prim/Blake2s.cry
View File

@ -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)

8
examples/MiniLock/prim/CryptoBox.cry
View File

@ -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

8
examples/MiniLock/prim/PBKDF2.cry
View File

@ -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

8
examples/MiniLock/prim/Poly1305.md
View File

@ -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 =

27
examples/MiniLock/prim/SCrypt.cry
View File

@ -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

28
examples/MiniLock/prim/Salsa20.cry
View File

@ -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]))]

8
examples/SHA1.cry
View File

@ -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]

6
examples/SIV-rfc5297.md
View File

@ -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
```

26
examples/Salsa20.cry
View File

@ -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,

2
examples/ZUC.cry
View File

@ -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]

2
examples/contrib/EvenMansour.cry
View File

@ -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
View 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

2
examples/contrib/mkrand.cry
View File

@ -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

6
examples/funstuff/Coins.cry
View File

@ -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

2
examples/funstuff/NQueens.cry
View File

@ -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)]]

30
examples/funstuff/marble.cry
View File

@ -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]

9
examples/maliciousSHA/malicious_SHA1.cry
View File

@ -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
View File

@ -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

15
lib/Cryptol/Extras.cry
View File

@ -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
View 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))))
)
)

597
src/Cryptol/Eval.hs
View File

@ -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

60
src/Cryptol/Eval/Env.hs
View File

@ -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)

69
src/Cryptol/Eval/Error.hs
View File

@ -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
View 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
View File

File diff suppressed because it is too large Load Diff

76
src/Cryptol/Eval/Type.hs
View File

@ -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

643
src/Cryptol/Eval/Value.hs
View File

@ -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
]

41
src/Cryptol/ModuleSystem/Base.hs
View File

@ -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'

8
src/Cryptol/ModuleSystem/Env.hs
View File

@ -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
}

25
src/Cryptol/ModuleSystem/Monad.hs
View File

@ -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)

8
src/Cryptol/ModuleSystem/NamingEnv.hs
View File

@ -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

71
src/Cryptol/ModuleSystem/Renamer.hs
View File

@ -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

9
src/Cryptol/Parser.y
View File

@ -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 }

4
src/Cryptol/Parser/Lexer.x
View File

@ -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 }

42
src/Cryptol/Parser/LexerUtils.hs
View File

@ -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)

2
src/Cryptol/Parser/ParserUtils.hs
View File

@ -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)

2
src/Cryptol/Parser/Position.hs
View File

@ -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 }

3
src/Cryptol/Parser/Utils.hs
View File

@ -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

36
src/Cryptol/Prelude.hs
View File

@ -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

1202
src/Cryptol/Prims/Eval.hs
View File

File diff suppressed because it is too large Load Diff

107
src/Cryptol/REPL/Command.hs
View File

@ -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

17
src/Cryptol/REPL/Monad.hs
View File

@ -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

356
src/Cryptol/Symbolic.hs
View File

@ -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

960
src/Cryptol/Symbolic/Prims.hs
View File

File diff suppressed because it is too large Load Diff

117
src/Cryptol/Symbolic/Value.hs
View File

@ -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

37
src/Cryptol/Testing/Concrete.hs
View File

@ -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 _ _ -> []

32
src/Cryptol/Testing/Random.hs
View File

@ -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

5
src/Cryptol/Transform/MonoValues.hs
View File

@ -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

6
src/Cryptol/Transform/Specialize.hs
View File

@ -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"

656
src/Cryptol/TypeCheck/AST.hs
View File

@ -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

111
src/Cryptol/TypeCheck/Infer.hs
View File

@ -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

98
src/Cryptol/TypeCheck/InferTypes.hs
View File

@ -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"

6
src/Cryptol/TypeCheck/Instantiate.hs
View File

@ -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)

23
src/Cryptol/TypeCheck/Kind.hs
View File

@ -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

70
src/Cryptol/TypeCheck/Monad.hs
View File

@ -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

57
src/Cryptol/TypeCheck/Sanity.hs
View File

@ -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
View 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
View 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

525
src/Cryptol/TypeCheck/Solve.hs
View File

@ -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"

62
src/Cryptol/TypeCheck/Solver/Class.hs
View File

@ -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

40
src/Cryptol/TypeCheck/Solver/CrySAT.hs
View File

@ -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