diff --git a/CHANGES.md b/CHANGES.md
--- a/CHANGES.md
+++ b/CHANGES.md
@@ -1,3 +1,61 @@
+# 2.10.0
+
+## Language changes
+
+* Cryptol now supports primality checking at the type level. The
+ type-level predicate `prime` is true when its parameter passes the
+ Miller-Rabin probabilistic primality test implemented in the GMP
+ library.
+
+* The `Z p` type is now a `Field` when `p` is prime, allowing additional
+ operations on `Z p` values.
+
+* The literals `0` and `1` can now be used at type `Bit`, as
+ alternatives for `False` and `True`, respectively.
+
+## New features
+
+* The interpreter now includes a number of primitive functions that
+ allow faster execution of a number of common cryptographic functions,
+ including the core operations of AES and SHA-2, operations on GF(2)
+ polynomials (the existing `pmod`, `pdiv`, and `pmult` functions), and
+ some operations on prime field elliptic curves. These functions are
+ useful for implementing higher-level algorithms, such as many
+ post-quantum schemes, with more acceptable performance than possible
+ when running a top-to-bottom Cryptol implementation in the
+ interpreter.
+
+ For a full list of the new primitives, see the new Cryptol
+ [`SuiteB`](https://github.com/GaloisInc/cryptol/blob/master/lib/SuiteB.cry)
+ and
+ [`PrimeEC`](https://github.com/GaloisInc/cryptol/blob/master/lib/PrimeEC.cry)
+ modules.
+
+* The REPL now allows lines containing only comments, making it easier
+ to copy and paste examples.
+
+* The interpreter has generally improved performance overall.
+
+* Several error messages are more comprehensible and less verbose.
+
+* Cryptol releases and nightly builds now include an RPC server
+ alongside the REPL. This provides an alternative interface to the same
+ interpreter and proof engine available from the REPL, but is
+ better-suited to programmatic use. Details on the protocol used by the
+ server are available
+ [here](https://github.com/GaloisInc/argo/blob/master/docs/Protocol.rst).
+ A Python client for this protocol is available
+ [here](https://github.com/GaloisInc/argo/tree/master/python).
+
+* Windows builds are now distributed as both `.tar.gz` and `.msi` files.
+
+## Bug Fixes
+
+* Closed issues #98, #485, #713, #744, #746, #787, #796, #803, #818,
+ #826, #838, #856, #873, #875, #876, #877, #879, #880, #881, #883,
+ #886, #887, #888, #892, #894, #901, #910, #913, #924, #926, #931,
+ #933, #937, #939, #946, #948, #953, #956, #958, and #969.
+
# 2.9.1
## Language changes
diff --git a/cryptol.cabal b/cryptol.cabal
--- a/cryptol.cabal
+++ b/cryptol.cabal
@@ -1,8 +1,9 @@
+Cabal-version: 2.4
Name: cryptol
-Version: 2.9.1
+Version: 2.10.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 .
-License: BSD3
+License: BSD-3-Clause
License-file: LICENSE
Author: Galois, Inc.
Maintainer: cryptol@galois.com
@@ -11,11 +12,10 @@
Copyright: 2013-2020 Galois Inc.
Category: Language
Build-type: Simple
-Cabal-version: 1.18
extra-source-files: bench/data/*.cry
CHANGES.md
-data-files: *.cry *.z3
+data-files: **/*.cry **/*.z3
data-dir: lib
source-repository head
@@ -25,8 +25,9 @@
source-repository this
type: git
location: https://github.com/GaloisInc/cryptol.git
- tag: 2.9.1
+ tag: 2.10.0
+
flag static
default: False
description: Create a statically-linked binary
@@ -35,11 +36,6 @@
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.
--- 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:
Haskell2010
@@ -56,17 +52,21 @@
exceptions,
filepath >= 1.3,
gitrev >= 1.0,
+ ghc-prim,
GraphSCC >= 1.0.4,
heredoc >= 0.2,
+ integer-gmp >= 1.0 && < 1.1,
libBF >= 0.5.1,
+ MemoTrie >= 0.6 && < 0.7,
monad-control >= 1.0,
monadLib >= 3.7.2,
parameterized-utils >= 2.0.2,
pretty >= 1.1,
process >= 1.2,
random >= 1.0.1,
- sbv >= 8.6,
+ sbv >= 8.6 && < 8.8,
simple-smt >= 0.7.1,
+ stm >= 2.4,
strict,
text >= 1.1,
tf-random >= 0.5,
@@ -76,7 +76,7 @@
panic >= 0.3,
what4 >= 1.0 && < 1.1
- Build-tools: alex, happy
+ Build-tool-depends: alex:alex, happy:happy
hs-source-dirs: src
Exposed-modules: Cryptol.Parser,
@@ -157,25 +157,30 @@
Cryptol.IR.FreeVars,
+ Cryptol.Backend,
+ Cryptol.Backend.Arch,
+ Cryptol.Backend.Concrete,
+ Cryptol.Backend.FloatHelpers,
+ Cryptol.Backend.Monad,
+ Cryptol.Backend.SBV,
+ Cryptol.Backend.What4,
+ Cryptol.Backend.What4.SFloat,
+
Cryptol.Eval,
- Cryptol.Eval.Arch,
- Cryptol.Eval.Backend,
Cryptol.Eval.Concrete,
- Cryptol.Eval.Concrete.Float,
- Cryptol.Eval.Concrete.FloatHelpers,
- Cryptol.Eval.Concrete.Value,
Cryptol.Eval.Env,
Cryptol.Eval.Generic,
- Cryptol.Eval.Monad,
Cryptol.Eval.Reference,
Cryptol.Eval.SBV,
Cryptol.Eval.Type,
Cryptol.Eval.Value,
Cryptol.Eval.What4,
- Cryptol.Eval.What4.Value,
- Cryptol.Eval.What4.Float,
- Cryptol.Eval.What4.SFloat,
+ Cryptol.AES,
+ Cryptol.F2,
+ Cryptol.SHA,
+ Cryptol.PrimeEC,
+
Cryptol.Testing.Random,
Cryptol.Symbolic,
@@ -196,8 +201,6 @@
if impl(ghc >= 8.0.1)
ghc-options: -Wno-redundant-constraints
- ghc-prof-options: -O2 -fprof-auto-top
-
if flag(relocatable)
cpp-options: -DRELOCATABLE
@@ -206,10 +209,13 @@
Haskell2010
Main-is: Main.hs
hs-source-dirs: cryptol
+ Autogen-modules: Paths_cryptol
+
Other-modules: OptParser,
REPL.Haskeline,
REPL.Logo,
Paths_cryptol
+
build-depends: ansi-terminal
, base
, base-compat
@@ -225,8 +231,6 @@
if impl(ghc >= 8.0.1)
ghc-options: -Wno-redundant-constraints
- ghc-prof-options: -O2 -fprof-auto-top
-
if os(linux) && flag(static)
ld-options: -static -pthread
@@ -237,37 +241,6 @@
hs-source-dirs: utils
build-depends: base, text, cryptol, blaze-html
GHC-options: -Wall
-
--- 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 -threaded -rtsopts "-with-rtsopts=-N1 -A64m"
--- if impl(ghc >= 8.0.1)
--- ghc-options: -Wno-redundant-constraints
--- 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
diff --git a/lib/Cryptol.cry b/lib/Cryptol.cry
--- a/lib/Cryptol.cry
+++ b/lib/Cryptol.cry
@@ -44,6 +44,9 @@
* of the equivalance class. In other words, 'fromZ' computes
* the (unique) integer value 'i' where '0 <= i < n' and
* 'i' is in the given equivalance class.
+ *
+ * If the modulus 'n' is prime, 'Z n' also
+ * supports computing inverses and forms a field.
*/
primitive type {n : #} (fin n, n >= 1) => Z n : *
@@ -80,6 +83,9 @@
/** Assert that a numeric type is a proper natural number (not 'inf'). */
primitive type fin : # -> Prop
+/** Assert that a numeric type is a prime number. */
+primitive type prime : # -> Prop
+
/** Add numeric types. */
primitive type (+) : # -> # -> #
@@ -111,7 +117,8 @@
primitive type width : # -> #
/**
- * Define the base 2 logarithm function in terms of width
+ * The ceiling of the base-2 logarithm of a numeric type.
+ * We define 'lg2 n = width (n - 1)' for nonzero n, and 'lg2 0 = 0'.
*/
type lg2 n = width (max n 1 - 1)
@@ -656,10 +663,8 @@
primitive (>>$) : {n, ix} (fin n, n >= 1, Integral ix) => [n] -> ix -> [n]
/**
- * Log base two.
- *
- * For words, computes the ceiling of log, base 2, of a number.
- * We set 'lg2 0 = 0'
+ * The ceiling of the base-2 logarithm of an unsigned bitvector.
+ * We set 'lg2 0 = 0'.
*/
primitive lg2 : {n} (fin n) => [n] -> [n]
@@ -883,60 +888,56 @@
/**
* Performs multiplication of polynomials over GF(2).
*/
-pmult : {u, v} (fin u, fin v) => [1 + u] -> [1 + v] -> [1 + u + v]
-pmult x y = last zs
- where
- zs = [0] # [ (z << 1) ^ (if yi then 0 # x else 0) | yi <- y | z <- zs ]
+primitive pmult : {u, v} (fin u, fin v) => [1 + u] -> [1 + v] -> [1 + u + v]
/**
* Performs division of polynomials over GF(2).
*/
-pdiv : {u, v} (fin u, fin v) => [u] -> [v] -> [u]
-pdiv x y = [ z ! degree | z <- zs ]
- where
- degree : [width v]
- degree = last (ds : [1 + v]_)
- where ds = [0/0] # [if yi then i else d | yi <- reverse y | i <- [0..v] | d <- ds ]
-
- reduce : [v] -> [v]
- reduce u = if u ! degree then u ^ y else u
-
- zs : [u][v]
- zs = [ tail (reduce z # [xi]) | z <- [0] # zs | xi <- x ]
+primitive pdiv : {u, v} (fin u, fin v) => [u] -> [v] -> [u]
/**
* Performs modulus of polynomials over GF(2).
*/
-pmod : {u, v} (fin u, fin v) => [u] -> [1 + v] -> [v]
-pmod x y = if y == 0 then 0/0 else last zs
- where
- degree : [width v]
- degree = last (ds : [2 + v]_)
- where ds = [0/0] # [if yi then i else d | yi <- reverse y | i <- [0..v] | d <- ds ]
-
- reduce : [1 + v] -> [1 + v]
- reduce u = if u ! degree then u ^ y else u
-
- powers : [inf][1 + v]
- powers = [reduce 1] # [ reduce (p << 1) | p <- powers ]
-
- zs = [0] # [ z ^ (if xi then tail p else 0) | xi <- reverse x | p <- powers | z <- zs ]
-
+primitive pmod : {u, v} (fin u, fin v) => [u] -> [1 + v] -> [v]
// Experimental primitives ------------------------------------------------------------
/**
* Parallel map. The given function is applied to each element in the
* given finite seqeuence, and the results are computed in parallel.
+ * The values in the resulting sequence are reduced to normal form,
+ * as is done with the deepseq operation.
*
+ * The Eq constraint restricts this operation to types
+ * where reduction to normal form makes sense.
+ *
* This function is experimental.
*/
-primitive parmap : {a, b, n} (fin n) => (a -> b) -> [n]a -> [n]b
+primitive parmap : {a, b, n} (Eq b, fin n) => (a -> b) -> [n]a -> [n]b
// Utility operations -----------------------------------------------------------------
/**
+ * A strictness-increasing operation. The first operand
+ * is reduced to normal form before evaluating the second
+ * argument.
+ *
+ * The Eq constraint restricts this operation to types
+ * where reduction to normal form makes sense.
+ */
+primitive deepseq : {a, b} Eq a => a -> b -> b
+
+/**
+ * Reduce to normal form.
+ *
+ * The Eq constraint restricts this operation to types
+ * where reduction to normal form makes sense.
+ */
+rnf : {a} Eq a => a -> a
+rnf x = deepseq x x
+
+/**
* Raise a run-time error with the given message.
* This function can be called at any type.
*/
@@ -1009,13 +1010,13 @@
* Conjunction after applying a predicate to all elements.
*/
all : {n, a} (fin n) => (a -> Bit) -> [n]a -> Bit
-all f xs = and (map f xs)
+all f xs = foldl' (/\) True (map f xs)
/**
* Disjunction after applying a predicate to all elements.
*/
any : {n, a} (fin n) => (a -> Bit) -> [n]a -> Bit
-any f xs = or (map f xs)
+any f xs = foldl' (\/) False (map f xs)
/**
* Map a function over a sequence.
@@ -1028,24 +1029,49 @@
*
* foldl (+) 0 [1,2,3] = ((0 + 1) + 2) + 3
*/
-foldl : {n, a, b} (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]
+primitive foldl : {n, a, b} (fin n) => (a -> b -> a) -> a -> [n]b -> a
/**
+ * Functional left fold, with strict evaluation of the accumulator value.
+ * The accumulator is reduced to normal form at each step. The Eq constraint
+ * restricts the accumulator to types where reduction to normal form makes sense.
+ *
+ * foldl' (+) 0 [1,2,3] = ((0 + 1) + 2) + 3
+ */
+primitive foldl' : {n, a, b} (fin n, Eq a) => (a -> b -> a) -> a -> [n]b -> a
+
+/**
* Functional right fold.
*
* foldr (-) 0 [1,2,3] = 0 - (1 - (2 - 3))
*/
foldr : {n, a, b} (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]
+foldr f acc xs = foldl g acc (reverse xs)
+ where g b a = f a b
/**
+ * Functional right fold, with strict evaluation of the accumulator value.
+ * The accumulator is reduced to weak head normal form at each step.
+ *
+ * foldr' (-) 0 [1,2,3] = 0 - (1 - (2 - 3))
+ */
+foldr' : {n, a, b} (fin n, Eq b) => (a -> b -> b) -> b -> [n]a -> b
+foldr' f acc xs = foldl' g acc (reverse xs)
+ where g b a = f a b
+
+/**
* Compute the sum of the values in the sequence.
*/
-sum : {n, a} (fin n, Ring a) => [n]a -> a
-sum xs = foldl (+) (fromInteger 0) xs
+sum : {n, a} (fin n, Eq a, Ring a) => [n]a -> a
+sum xs = foldl' (+) (fromInteger 0) xs
+
+
+/**
+ * Compute the product of the values in the sequence.
+ */
+product : {n, a} (fin n, Eq a, Ring a) => [n]a -> a
+product xs = foldl' (*) (fromInteger 1) xs
+
/**
* Scan left is like a foldl that also emits the intermediate values.
diff --git a/lib/Cryptol/Reference.cry b/lib/Cryptol/Reference.cry
new file mode 100644
--- /dev/null
+++ b/lib/Cryptol/Reference.cry
@@ -0,0 +1,46 @@
+module Cryptol::Reference where
+
+/**
+ * Performs multiplication of polynomials over GF(2).
+ * Reference implementation.
+ */
+pmult : {u, v} (fin u, fin v) => [1 + u] -> [1 + v] -> [1 + u + v]
+pmult x y = last zs
+ where
+ zs = [0] # [ (z << 1) ^ (if yi then 0 # x else 0) | yi <- y | z <- zs ]
+
+/**
+ * Performs division of polynomials over GF(2).
+ * Reference implementation.
+ */
+pdiv : {u, v} (fin u, fin v) => [u] -> [v] -> [u]
+pdiv x y = [ z ! degree | z <- zs ]
+ where
+ degree : [width v]
+ degree = last (ds : [1 + v]_)
+ where ds = [0/0] # [if yi then i else d | yi <- reverse y | i <- [0..v] | d <- ds ]
+
+ reduce : [v] -> [v]
+ reduce u = if u ! degree then u ^ y else u
+
+ zs : [u][v]
+ zs = [ tail (reduce z # [xi]) | z <- [0] # zs | xi <- x ]
+
+/**
+ * Performs modulus of polynomials over GF(2).
+ * Reference implementation.
+ */
+pmod : {u, v} (fin u, fin v) => [u] -> [1 + v] -> [v]
+pmod x y = if y == 0 then 0/0 else last zs
+ where
+ degree : [width v]
+ degree = last (ds : [2 + v]_)
+ where ds = [0/0] # [if yi then i else d | yi <- reverse y | i <- [0..v] | d <- ds ]
+
+ reduce : [1 + v] -> [1 + v]
+ reduce u = if u ! degree then u ^ y else u
+
+ powers : [inf][1 + v]
+ powers = [reduce 1] # [ reduce (p << 1) | p <- powers ]
+
+ zs = [0] # [ z ^ (if xi then tail p else 0) | xi <- reverse x | p <- powers | z <- zs ]
diff --git a/lib/PrimeEC.cry b/lib/PrimeEC.cry
new file mode 100644
--- /dev/null
+++ b/lib/PrimeEC.cry
@@ -0,0 +1,162 @@
+module PrimeEC where
+
+/**
+ * The type of points of an elliptic curve in affine coordinates.
+ * The coefficients are taken from the prime field 'Z p' with 'p > 3'.
+ * This is intended to represent all the "normal" points
+ * on the curve, which satisfy 'x^^3 == y^^2 - 3x + b',
+ * for some curve parameter 'b'. This type cannot represent
+ * the special projective "point at infinity".
+ */
+type AffinePoint p =
+ { x : Z p
+ , y : Z p
+ }
+
+/**
+ * The type of points of an elliptic curve in (homogeneous)
+ * projective coordinates. The coefficients are taken from the
+ * prime field 'Z p' with 'p > 3'. These points should be understood as
+ * representatives of equivalence classes of points, where two representatives
+ * 'S' and 'T' are equivalent iff one is a scalar multiple of the other. That
+ * is, 'S' and 'T' are equivalent iff there exists some 'k' where
+ * 'S.x == k*T.x /\ S.y == k*T.y /\ S.z == k*T.z'. Finally, the
+ * vector with all coordinates equal to 0 is excluded and does not
+ * represent any point.
+ *
+ * Note that all the affine points are easily embedded into projective
+ * coordinates by simply setting the `z` coordinate to 1, and the "point at
+ * infinity" is represented by any point with 'z == 0'. Further, for any
+ * projective point with 'z != 0', we can compute the corresponding affine
+ * point by simply multiplying the x and y coordinates by the inverse of z.
+ */
+type ProjectivePoint p =
+ { x : Z p
+ , y : Z p
+ , z : Z p
+ }
+
+/**
+ * 'ec_is_point_affine b S' checks that the supposed affine elliptic curve
+ * point 'S' in fact lies on the curve defined by the curve parameter 'b'. Here,
+ * and throughout this module, we assume the curve parameter 'a' is equal to
+ * '-3'. Precisely, this function checks the following condition:
+ *
+ * S.y^^2 == S.x^^3 - 3*S.x + b
+ */
+ec_is_point_affine : {p} (prime p, p > 3) => Z p -> AffinePoint p -> Bit
+ec_is_point_affine b S = S.y^^2 == S.x^^3 - (3*S.x) + b
+
+
+/**
+ * 'ec_is_nonsingular' checks that the given curve parameter 'b' gives rise to
+ * a non-singular elliptic curve, appropriate for use in ECC.
+ *
+ * Precisely, this checks that '4*a^^3 + 27*b^^2 != 0 mod p'. Here, and
+ * throughout this module, we assume 'a = -3'.
+ */
+ec_is_nonsingular : {p} (prime p, p > 3) => Z p -> Bit
+ec_is_nonsingular b = (fromInteger 4) * a^^3 + (fromInteger 27) * b^^2 != 0
+ where a = -3 : Z p
+
+/**
+ * Returns true if the given point is the identity "point at infinity."
+ * This is true whenever the 'z' coordinate is 0, but one of the 'x' or
+ * 'y' coordinates is nonzero.
+ */
+ec_is_identity : {p} (prime p, p > 3) => ProjectivePoint p -> Bit
+ec_is_identity S = S.z == 0 /\ ~(S.x == 0 /\ S.y == 0)
+
+/**
+ * Test two projective points for equality, up to the equivalence relation
+ * on projective points.
+ */
+ec_equal : {p} (prime p, p > 3) => ProjectivePoint p -> ProjectivePoint p -> Bit
+ec_equal S T =
+ (S.z == 0 /\ T.z == 0) \/
+ (S.z != 0 /\ T.z != 0 /\ ec_affinify S == ec_affinify T)
+
+/**
+ * Compute a projective representative for the given affine point.
+ */
+ec_projectify : {p} (prime p, p > 3) => AffinePoint p -> ProjectivePoint p
+ec_projectify R = { x = R.x, y = R.y, z = 1 }
+
+/**
+ * Compute the affine point corresponding to the given projective point.
+ * This results in an error if the 'z' component of the given point is 0,
+ * in which case there is no corresponding affine point.
+ */
+ec_affinify : {p} (prime p, p > 3) => ProjectivePoint p -> AffinePoint p
+ec_affinify S =
+ if S.z == 0 then error "Cannot affinify the point at infinity" else R
+ where
+ R = {x = lambda^^2 * S.x, y = lambda^^3 * S.y }
+ lambda = recip S.z
+
+/**
+ * Coerce an integer modulo 'p' to a bitvector. This will reduce the value
+ * modulo '2^^a' if necessary.
+ */
+ZtoBV : {p, a} (fin p, p >= 1, fin a) => Z p -> [a]
+ZtoBV x = fromInteger (fromZ x)
+
+/**
+ * Coerce a bitvector value to an integer modulo 'p'. This will
+ * reduce the value modulo 'p' if necessary.
+ */
+BVtoZ : {p, a} (fin p, p >= 1, fin a) => [a] -> Z p
+BVtoZ x = fromInteger (toInteger x)
+
+/**
+ * Given a projective point 'S', compute '2S = S+S'.
+ */
+primitive ec_double : {p} (prime p, p > 3) =>
+ ProjectivePoint p -> ProjectivePoint p
+
+/**
+ * Given two projective points 'S' and 'T' where neither is the identity,
+ * compute 'S+T'. If the points are not known to be distinct from the point
+ * at infinity, use 'ec_add' instead.
+ */
+primitive ec_add_nonzero : {p} (prime p, p > 3) =>
+ ProjectivePoint p -> ProjectivePoint p -> ProjectivePoint p
+
+/**
+ * Given a projective point 'S', compute its negation, '-S'
+ */
+ec_negate : {p} (prime p, p > 3) => ProjectivePoint p -> ProjectivePoint p
+ec_negate S = { x = S.x, y = -S.y, z = S.z }
+
+/**
+ * Given two projective points 'S' and 'T' compute 'S+T'.
+ */
+ec_add : {p} (prime p, p > 3) =>
+ ProjectivePoint p -> ProjectivePoint p -> ProjectivePoint p
+ec_add S T =
+ if S.z == 0 then T
+ | T.z == 0 then S
+ else R
+ where R = ec_add_nonzero S T
+
+/**
+ * Given two projective points 'S' and 'T' compute 'S-T'.
+ */
+ec_sub : {p} (prime p, p > 3) =>
+ ProjectivePoint p -> ProjectivePoint p -> ProjectivePoint p
+ec_sub S T = ec_add S U
+ where U = { x = T.x, y = -T.y, z = T.z }
+
+/**
+ * Given a scalar value 'k' and a projective point 'S', compute the
+ * scalar multiplication 'kS'.
+ */
+primitive ec_mult : {p} (prime p, p > 3) =>
+ Z p -> ProjectivePoint p -> ProjectivePoint p
+
+/**
+ * Given a scalar value 'j' and a projective point 'S', and another scalar
+ * value 'k' and point 'T', compute the "twin" scalar multiplication 'jS + kT'.
+ */
+primitive ec_twin_mult : {p} (prime p, p > 3) =>
+ Z p -> ProjectivePoint p -> Z p -> ProjectivePoint p -> ProjectivePoint p
diff --git a/lib/SuiteB.cry b/lib/SuiteB.cry
new file mode 100644
--- /dev/null
+++ b/lib/SuiteB.cry
@@ -0,0 +1,236 @@
+module SuiteB where
+
+/***** AES ******/
+
+/**
+ * Key schedule parameter setting for AES-128
+ */
+type AES128 = 4
+
+/**
+ * Key schedule parameter setting for AES-192
+ */
+type AES192 = 6
+
+/**
+ * Key schedule parameter setting for AES-256
+ */
+type AES256 = 8
+
+/**
+ * Element of an AES key schedule for use in a particular round
+ */
+type AESRoundKey = [4][32]
+
+/**
+ * Expanded encryption key schedule for AES
+ */
+type AESEncryptKeySchedule k =
+ { aesEncInitialKey : AESRoundKey
+ , aesEncRoundKeys : [k+5]AESRoundKey
+ , aesEncFinalKey : AESRoundKey
+ }
+
+/**
+ * Expanded decryption key schedule for AES
+ */
+type AESDecryptKeySchedule k =
+ { aesDecInitialKey : AESRoundKey
+ , aesDecRoundKeys : [k+5]AESRoundKey
+ , aesDecFinalKey : AESRoundKey
+ }
+
+/**
+ * Encryption key expansion for AES-128.
+ * See FIPS 197, section 5.2.
+ */
+aes128EncryptSchedule : [128] -> AESEncryptKeySchedule AES128
+aes128EncryptSchedule = aesExpandEncryptSchedule
+
+/**
+ * Decryption key expansion for AES-128, for use in the "equivalent inverse cypher".
+ * See FIPS 197, sections 5.2 and 5.3.5.
+ */
+aes128DecryptSchedule : [128] -> AESDecryptKeySchedule AES128
+aes128DecryptSchedule = aesExpandDecryptSchedule
+
+/**
+ * Encryption and decryption key schedules for AES-128.
+ * If you will need both schedules, it is slightly more efficient
+ * to call this function than to compute the two schedules separately.
+ * See FIPS 197, sections 5.2 and 5.3.5.
+ */
+aes128Schedules : [128] -> (AESEncryptKeySchedule AES128, AESDecryptKeySchedule AES128)
+aes128Schedules = aesExpandSchedules
+
+/**
+ * Encryption key expansion for AES-192.
+ * See FIPS 197, section 5.2.
+ */
+aes192EncryptSchedule : [192] -> AESEncryptKeySchedule AES192
+aes192EncryptSchedule = aesExpandEncryptSchedule
+
+/**
+ * Decryption key expansion for AES-192, for use in the "equivalent inverse cypher".
+ * See FIPS 197, sections 5.2 and 5.3.5.
+ */
+aes192DecryptSchedule : [192] -> AESDecryptKeySchedule AES192
+aes192DecryptSchedule = aesExpandDecryptSchedule
+
+/**
+ * Encryption and decryption key schedules for AES-192.
+ * If you will need both schedules, it is slightly more efficient
+ * to call this function than to compute the two schedules separately.
+ * See FIPS 197, sections 5.2 and 5.3.5.
+ */
+aes192Schedules : [192] -> (AESEncryptKeySchedule AES192, AESDecryptKeySchedule AES192)
+aes192Schedules = aesExpandSchedules
+
+
+/**
+ * Encryption key expansion for AES-256.
+ * See FIPS 197, section 5.2
+ */
+aes256EncryptSchedule : [256] -> AESEncryptKeySchedule AES256
+aes256EncryptSchedule = aesExpandEncryptSchedule
+
+/**
+ * Decryption key expansion for AES-256, for use in the "equivalent inverse cypher".
+ * See FIPS 197, sections 5.2 and 5.3.5.
+ */
+aes256DecryptSchedule : [256] -> AESDecryptKeySchedule AES256
+aes256DecryptSchedule = aesExpandDecryptSchedule
+
+/**
+ * Encryption and decryption key schedules for AES-256.
+ * If you will need both schedules, it is slightly more efficient
+ * to call this function than to compute the two schedules separately.
+ * See FIPS 197, sections 5.2 and 5.3.5.
+ */
+aes256Schedules : [256] -> (AESEncryptKeySchedule AES256, AESDecryptKeySchedule AES256)
+aes256Schedules = aesExpandSchedules
+
+/**
+ * AES block encryption algorithm.
+ * See FIPS 197, section 5.1.
+ */
+aesEncryptBlock : {k} (fin k) => AESEncryptKeySchedule k -> [128] -> [128]
+aesEncryptBlock schedule plaintext = rnf (join final)
+ where
+ final = (AESEncFinalRound (rds!0)) ^ schedule.aesEncFinalKey
+
+ rds = [ schedule.aesEncInitialKey ^ split plaintext ] #
+ [ AESEncRound r ^ rdk
+ | rdk <- schedule.aesEncRoundKeys
+ | r <- rds
+ ]
+
+/**
+ * AES block decryption algorithm, via the "equivalent inverse cypher".
+ * See FIPS 197, section 5.3.5.
+ */
+aesDecryptBlock : {k} (fin k) => AESDecryptKeySchedule k -> [128] -> [128]
+aesDecryptBlock schedule cyphertext = rnf (join final)
+ where
+ final = (AESDecFinalRound (rds!0)) ^ schedule.aesDecFinalKey
+
+ rds = [ split cyphertext ^ schedule.aesDecInitialKey ] #
+ [ AESDecRound r ^ rdk
+ | rdk <- schedule.aesDecRoundKeys
+ | r <- rds
+ ]
+
+private
+ aesExpandEncryptSchedule : {k} (fin k, k >= 4, 8 >= k) => [k * 32] -> AESEncryptKeySchedule k
+ aesExpandEncryptSchedule key = rnf
+ { aesEncInitialKey = ks @ 0
+ , aesEncRoundKeys = ks @@ [ 1 .. k+5 ]
+ , aesEncFinalKey = ks @ `(k+6)
+ }
+ where
+ ks : [k+7]AESRoundKey
+ ks = groupBy`{4} (AESKeyExpand`{k} (split key))
+
+ aesEncToDecSchedule : {k} (fin k) => AESEncryptKeySchedule k -> AESDecryptKeySchedule k
+ aesEncToDecSchedule enc = rnf
+ { aesDecInitialKey = enc.aesEncFinalKey
+ , aesDecRoundKeys = map AESInvMixColumns (reverse (enc.aesEncRoundKeys))
+ , aesDecFinalKey = enc.aesEncInitialKey
+ }
+
+ aesExpandDecryptSchedule : {k} (fin k, k >= 4, 8 >= k) => [k * 32] -> AESDecryptKeySchedule k
+ aesExpandDecryptSchedule key = aesEncToDecSchedule (aesExpandEncryptSchedule key)
+
+ aesExpandSchedules : {k} (fin k, k >= 4, 8 >= k) => [k * 32] -> (AESEncryptKeySchedule k, AESDecryptKeySchedule k)
+ aesExpandSchedules key = (encS, aesEncToDecSchedule encS)
+ where encS = aesExpandEncryptSchedule key
+
+ primitive AESEncRound : [4][32] -> [4][32]
+ primitive AESEncFinalRound : [4][32] -> [4][32]
+ primitive AESDecRound : [4][32] -> [4][32]
+ primitive AESDecFinalRound : [4][32] -> [4][32]
+ primitive AESInvMixColumns : [4][32] -> [4][32]
+ primitive AESKeyExpand : {k} (fin k, k >= 4, 8 >= k) => [k][32] -> [4*(k+7)][32]
+
+
+/***** SHA2 *****/
+
+/**
+ * The SHA-224 secure hash algorithm. See FIPS 180-4, section 6.3.
+ */
+sha224 : {L} (fin L) => [L] -> [224]
+sha224 msg = join (processSHA2_224 (sha2blocks`{32} msg))
+
+/**
+ * The SHA-256 secure hash algorithm. See FIPS 180-4, section 6.2.2.
+ */
+sha256 : {L} (fin L) => [L] -> [256]
+sha256 msg = join (processSHA2_256 (sha2blocks`{32} msg))
+
+/**
+ * The SHA-384 secure hash algorithm. See FIPS 180-4, section 6.5.
+ */
+sha384 : {L} (fin L) => [L] -> [384]
+sha384 msg = join (processSHA2_384 (sha2blocks`{64} msg))
+
+/**
+ * The SHA-512 secure hash algorithm. See FIPS 180-4, section 6.4.
+ */
+sha512 : {L} (fin L) => [L] -> [512]
+sha512 msg = join (processSHA2_512 (sha2blocks`{64} msg))
+
+private
+ type sha2_block_size w = 16 * w
+ type sha2_num_blocks w L = (L+1+2*w) /^ sha2_block_size w
+ type sha2_padded_size w L = sha2_num_blocks w L * sha2_block_size w
+
+ sha2pad : {w, L} (fin w, fin L, w >= 1) => [L] -> [sha2_padded_size w L]
+ sha2pad M = M # 0b1 # zero # ((fromInteger `L) : [2*w])
+
+ sha2blocks : {w, L} (fin w, fin L, w >= 1) =>
+ [L] -> [sha2_num_blocks w L][16][w]
+ sha2blocks msg = [ split x | x <- split (sha2pad`{w} msg) ]
+
+ /**
+ * Apply the SHA224 hash algorithm to a sequence of SHA256-size blocks,
+ * which are assumed to already be correctly padded.
+ */
+ primitive processSHA2_224 : {n} (fin n) => [n][16][32] -> [7][32]
+
+ /**
+ * Apply the SHA256 hash algorithm to a sequence of SHA256-size blocks,
+ * which are assumed to already be correctly padded.
+ */
+ primitive processSHA2_256 : {n} (fin n) => [n][16][32] -> [8][32]
+
+ /**
+ * Apply the SHA384 hash algorithm to a sequence of SHA512-size blocks,
+ * which are assumed to already be correctly padded.
+ */
+ primitive processSHA2_384 : {n} (fin n) => [n][16][64] -> [6][64]
+
+ /**
+ * Apply the SHA512 hash algorithm to a sequence of SHA512-size blocks,
+ * which are assumed to already be correctly padded.
+ */
+ primitive processSHA2_512 : {n} (fin n) => [n][16][64] -> [8][64]
diff --git a/src/Cryptol/AES.hs b/src/Cryptol/AES.hs
new file mode 100644
--- /dev/null
+++ b/src/Cryptol/AES.hs
@@ -0,0 +1,493 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Cryptol.AES
+-- Copyright : (c) Levent Erkok
+-- License : BSD3
+-- Maintainer: erkokl@gmail.com
+-- Stability : experimental
+--
+-- A TBox-based implementation of AES primitives, based on
+-- the AES example code from SBV. Here we've stripped out
+-- everything except the basic primitives needed, which
+-- essentially boil down to table table lookups in most cases.
+-----------------------------------------------------------------------------
+{-# LANGUAGE ParallelListComp #-}
+module Cryptol.AES
+ ( State
+ , Key
+ , keyExpansionWords
+ , invMixColumns
+ , aesRound
+ , aesFinalRound
+ , aesInvRound
+ , aesInvFinalRound
+ ) where
+
+import Data.Bits
+import Data.List (transpose, genericDrop, genericTake)
+import Data.Word (Word8, Word32)
+
+-- | An element of the Galois Field 2^8, which are essentially polynomials with
+-- maximum degree 7. They are conveniently represented as values between 0 and 255.
+type GF28 = Word8
+
+-----------------------------------------------------------------------------
+-- ** Types and basic operations
+-----------------------------------------------------------------------------
+-- | AES state. The state consists of four 32-bit words, each of which is in turn treated
+-- as four GF28's, i.e., 4 bytes. The T-Box implementation keeps the four-bytes together
+-- for efficient representation.
+type State = [Word32]
+
+-- | The key, which can be 128, 192, or 256 bits. Represented as a sequence of 32-bit words.
+type Key = [Word32]
+
+-- | Rotating a state row by a fixed amount to the right.
+rotR :: [GF28] -> Int -> [GF28]
+rotR [a, b, c, d] 1 = [d, a, b, c]
+rotR [a, b, c, d] 2 = [c, d, a, b]
+rotR [a, b, c, d] 3 = [b, c, d, a]
+rotR xs i = error $ "rotR: Unexpected input: " ++ show (xs, i)
+
+
+toBytes :: Word32 -> [Word8]
+toBytes w = [b0,b1,b2,b3]
+ where
+ b0 = fromIntegral (w `shiftR` 24)
+ b1 = fromIntegral (w `shiftR` 16)
+ b2 = fromIntegral (w `shiftR` 8)
+ b3 = fromIntegral w
+
+fromBytes :: [Word8] -> Word32
+fromBytes [b0,b1,b2,b3] = w
+ where
+ w = ((fromIntegral b0) `shiftL` 24) .|.
+ ((fromIntegral b1) `shiftL` 16) .|.
+ ((fromIntegral b2) `shiftL` 8) .|.
+ (fromIntegral b3)
+fromBytes bs = error ("Unexpected list length in fromBytes: " ++ show (length bs))
+
+
+-----------------------------------------------------------------------------
+-- ** GF28 multiplication tables
+-----------------------------------------------------------------------------
+
+-- GF(2^8) multiplication by 0x0e
+mETable :: [GF28]
+mETable =
+ [0x00, 0x0e, 0x1c, 0x12, 0x38, 0x36, 0x24, 0x2a, 0x70, 0x7e, 0x6c,
+ 0x62, 0x48, 0x46, 0x54, 0x5a, 0xe0, 0xee, 0xfc, 0xf2, 0xd8, 0xd6,
+ 0xc4, 0xca, 0x90, 0x9e, 0x8c, 0x82, 0xa8, 0xa6, 0xb4, 0xba, 0xdb,
+ 0xd5, 0xc7, 0xc9, 0xe3, 0xed, 0xff, 0xf1, 0xab, 0xa5, 0xb7, 0xb9,
+ 0x93, 0x9d, 0x8f, 0x81, 0x3b, 0x35, 0x27, 0x29, 0x03, 0x0d, 0x1f,
+ 0x11, 0x4b, 0x45, 0x57, 0x59, 0x73, 0x7d, 0x6f, 0x61, 0xad, 0xa3,
+ 0xb1, 0xbf, 0x95, 0x9b, 0x89, 0x87, 0xdd, 0xd3, 0xc1, 0xcf, 0xe5,
+ 0xeb, 0xf9, 0xf7, 0x4d, 0x43, 0x51, 0x5f, 0x75, 0x7b, 0x69, 0x67,
+ 0x3d, 0x33, 0x21, 0x2f, 0x05, 0x0b, 0x19, 0x17, 0x76, 0x78, 0x6a,
+ 0x64, 0x4e, 0x40, 0x52, 0x5c, 0x06, 0x08, 0x1a, 0x14, 0x3e, 0x30,
+ 0x22, 0x2c, 0x96, 0x98, 0x8a, 0x84, 0xae, 0xa0, 0xb2, 0xbc, 0xe6,
+ 0xe8, 0xfa, 0xf4, 0xde, 0xd0, 0xc2, 0xcc, 0x41, 0x4f, 0x5d, 0x53,
+ 0x79, 0x77, 0x65, 0x6b, 0x31, 0x3f, 0x2d, 0x23, 0x09, 0x07, 0x15,
+ 0x1b, 0xa1, 0xaf, 0xbd, 0xb3, 0x99, 0x97, 0x85, 0x8b, 0xd1, 0xdf,
+ 0xcd, 0xc3, 0xe9, 0xe7, 0xf5, 0xfb, 0x9a, 0x94, 0x86, 0x88, 0xa2,
+ 0xac, 0xbe, 0xb0, 0xea, 0xe4, 0xf6, 0xf8, 0xd2, 0xdc, 0xce, 0xc0,
+ 0x7a, 0x74, 0x66, 0x68, 0x42, 0x4c, 0x5e, 0x50, 0x0a, 0x04, 0x16,
+ 0x18, 0x32, 0x3c, 0x2e, 0x20, 0xec, 0xe2, 0xf0, 0xfe, 0xd4, 0xda,
+ 0xc8, 0xc6, 0x9c, 0x92, 0x80, 0x8e, 0xa4, 0xaa, 0xb8, 0xb6, 0x0c,
+ 0x02, 0x10, 0x1e, 0x34, 0x3a, 0x28, 0x26, 0x7c, 0x72, 0x60, 0x6e,
+ 0x44, 0x4a, 0x58, 0x56, 0x37, 0x39, 0x2b, 0x25, 0x0f, 0x01, 0x13,
+ 0x1d, 0x47, 0x49, 0x5b, 0x55, 0x7f, 0x71, 0x63, 0x6d, 0xd7, 0xd9,
+ 0xcb, 0xc5, 0xef, 0xe1, 0xf3, 0xfd, 0xa7, 0xa9, 0xbb, 0xb5, 0x9f,
+ 0x91, 0x83, 0x8d]
+
+-- GF(2^8) multiplication by 0x0b
+mBTable :: [GF28]
+mBTable =
+ [0x00, 0x0b, 0x16, 0x1d, 0x2c, 0x27, 0x3a, 0x31, 0x58, 0x53, 0x4e,
+ 0x45, 0x74, 0x7f, 0x62, 0x69, 0xb0, 0xbb, 0xa6, 0xad, 0x9c, 0x97,
+ 0x8a, 0x81, 0xe8, 0xe3, 0xfe, 0xf5, 0xc4, 0xcf, 0xd2, 0xd9, 0x7b,
+ 0x70, 0x6d, 0x66, 0x57, 0x5c, 0x41, 0x4a, 0x23, 0x28, 0x35, 0x3e,
+ 0x0f, 0x04, 0x19, 0x12, 0xcb, 0xc0, 0xdd, 0xd6, 0xe7, 0xec, 0xf1,
+ 0xfa, 0x93, 0x98, 0x85, 0x8e, 0xbf, 0xb4, 0xa9, 0xa2, 0xf6, 0xfd,
+ 0xe0, 0xeb, 0xda, 0xd1, 0xcc, 0xc7, 0xae, 0xa5, 0xb8, 0xb3, 0x82,
+ 0x89, 0x94, 0x9f, 0x46, 0x4d, 0x50, 0x5b, 0x6a, 0x61, 0x7c, 0x77,
+ 0x1e, 0x15, 0x08, 0x03, 0x32, 0x39, 0x24, 0x2f, 0x8d, 0x86, 0x9b,
+ 0x90, 0xa1, 0xaa, 0xb7, 0xbc, 0xd5, 0xde, 0xc3, 0xc8, 0xf9, 0xf2,
+ 0xef, 0xe4, 0x3d, 0x36, 0x2b, 0x20, 0x11, 0x1a, 0x07, 0x0c, 0x65,
+ 0x6e, 0x73, 0x78, 0x49, 0x42, 0x5f, 0x54, 0xf7, 0xfc, 0xe1, 0xea,
+ 0xdb, 0xd0, 0xcd, 0xc6, 0xaf, 0xa4, 0xb9, 0xb2, 0x83, 0x88, 0x95,
+ 0x9e, 0x47, 0x4c, 0x51, 0x5a, 0x6b, 0x60, 0x7d, 0x76, 0x1f, 0x14,
+ 0x09, 0x02, 0x33, 0x38, 0x25, 0x2e, 0x8c, 0x87, 0x9a, 0x91, 0xa0,
+ 0xab, 0xb6, 0xbd, 0xd4, 0xdf, 0xc2, 0xc9, 0xf8, 0xf3, 0xee, 0xe5,
+ 0x3c, 0x37, 0x2a, 0x21, 0x10, 0x1b, 0x06, 0x0d, 0x64, 0x6f, 0x72,
+ 0x79, 0x48, 0x43, 0x5e, 0x55, 0x01, 0x0a, 0x17, 0x1c, 0x2d, 0x26,
+ 0x3b, 0x30, 0x59, 0x52, 0x4f, 0x44, 0x75, 0x7e, 0x63, 0x68, 0xb1,
+ 0xba, 0xa7, 0xac, 0x9d, 0x96, 0x8b, 0x80, 0xe9, 0xe2, 0xff, 0xf4,
+ 0xc5, 0xce, 0xd3, 0xd8, 0x7a, 0x71, 0x6c, 0x67, 0x56, 0x5d, 0x40,
+ 0x4b, 0x22, 0x29, 0x34, 0x3f, 0x0e, 0x05, 0x18, 0x13, 0xca, 0xc1,
+ 0xdc, 0xd7, 0xe6, 0xed, 0xf0, 0xfb, 0x92, 0x99, 0x84, 0x8f, 0xbe,
+ 0xb5, 0xa8, 0xa3]
+
+
+-- GF(2^8) multiplication by 0x0d
+mDTable :: [GF28]
+mDTable =
+ [0x00, 0x0d, 0x1a, 0x17, 0x34, 0x39, 0x2e, 0x23, 0x68, 0x65, 0x72,
+ 0x7f, 0x5c, 0x51, 0x46, 0x4b, 0xd0, 0xdd, 0xca, 0xc7, 0xe4, 0xe9,
+ 0xfe, 0xf3, 0xb8, 0xb5, 0xa2, 0xaf, 0x8c, 0x81, 0x96, 0x9b, 0xbb,
+ 0xb6, 0xa1, 0xac, 0x8f, 0x82, 0x95, 0x98, 0xd3, 0xde, 0xc9, 0xc4,
+ 0xe7, 0xea, 0xfd, 0xf0, 0x6b, 0x66, 0x71, 0x7c, 0x5f, 0x52, 0x45,
+ 0x48, 0x03, 0x0e, 0x19, 0x14, 0x37, 0x3a, 0x2d, 0x20, 0x6d, 0x60,
+ 0x77, 0x7a, 0x59, 0x54, 0x43, 0x4e, 0x05, 0x08, 0x1f, 0x12, 0x31,
+ 0x3c, 0x2b, 0x26, 0xbd, 0xb0, 0xa7, 0xaa, 0x89, 0x84, 0x93, 0x9e,
+ 0xd5, 0xd8, 0xcf, 0xc2, 0xe1, 0xec, 0xfb, 0xf6, 0xd6, 0xdb, 0xcc,
+ 0xc1, 0xe2, 0xef, 0xf8, 0xf5, 0xbe, 0xb3, 0xa4, 0xa9, 0x8a, 0x87,
+ 0x90, 0x9d, 0x06, 0x0b, 0x1c, 0x11, 0x32, 0x3f, 0x28, 0x25, 0x6e,
+ 0x63, 0x74, 0x79, 0x5a, 0x57, 0x40, 0x4d, 0xda, 0xd7, 0xc0, 0xcd,
+ 0xee, 0xe3, 0xf4, 0xf9, 0xb2, 0xbf, 0xa8, 0xa5, 0x86, 0x8b, 0x9c,
+ 0x91, 0x0a, 0x07, 0x10, 0x1d, 0x3e, 0x33, 0x24, 0x29, 0x62, 0x6f,
+ 0x78, 0x75, 0x56, 0x5b, 0x4c, 0x41, 0x61, 0x6c, 0x7b, 0x76, 0x55,
+ 0x58, 0x4f, 0x42, 0x09, 0x04, 0x13, 0x1e, 0x3d, 0x30, 0x27, 0x2a,
+ 0xb1, 0xbc, 0xab, 0xa6, 0x85, 0x88, 0x9f, 0x92, 0xd9, 0xd4, 0xc3,
+ 0xce, 0xed, 0xe0, 0xf7, 0xfa, 0xb7, 0xba, 0xad, 0xa0, 0x83, 0x8e,
+ 0x99, 0x94, 0xdf, 0xd2, 0xc5, 0xc8, 0xeb, 0xe6, 0xf1, 0xfc, 0x67,
+ 0x6a, 0x7d, 0x70, 0x53, 0x5e, 0x49, 0x44, 0x0f, 0x02, 0x15, 0x18,
+ 0x3b, 0x36, 0x21, 0x2c, 0x0c, 0x01, 0x16, 0x1b, 0x38, 0x35, 0x22,
+ 0x2f, 0x64, 0x69, 0x7e, 0x73, 0x50, 0x5d, 0x4a, 0x47, 0xdc, 0xd1,
+ 0xc6, 0xcb, 0xe8, 0xe5, 0xf2, 0xff, 0xb4, 0xb9, 0xae, 0xa3, 0x80,
+ 0x8d, 0x9a, 0x97]
+
+-- GF(2^8) multiplication by 0x09
+m9Table :: [GF28]
+m9Table =
+ [0x00, 0x09, 0x12, 0x1b, 0x24, 0x2d, 0x36, 0x3f, 0x48, 0x41, 0x5a,
+ 0x53, 0x6c, 0x65, 0x7e, 0x77, 0x90, 0x99, 0x82, 0x8b, 0xb4, 0xbd,
+ 0xa6, 0xaf, 0xd8, 0xd1, 0xca, 0xc3, 0xfc, 0xf5, 0xee, 0xe7, 0x3b,
+ 0x32, 0x29, 0x20, 0x1f, 0x16, 0x0d, 0x04, 0x73, 0x7a, 0x61, 0x68,
+ 0x57, 0x5e, 0x45, 0x4c, 0xab, 0xa2, 0xb9, 0xb0, 0x8f, 0x86, 0x9d,
+ 0x94, 0xe3, 0xea, 0xf1, 0xf8, 0xc7, 0xce, 0xd5, 0xdc, 0x76, 0x7f,
+ 0x64, 0x6d, 0x52, 0x5b, 0x40, 0x49, 0x3e, 0x37, 0x2c, 0x25, 0x1a,
+ 0x13, 0x08, 0x01, 0xe6, 0xef, 0xf4, 0xfd, 0xc2, 0xcb, 0xd0, 0xd9,
+ 0xae, 0xa7, 0xbc, 0xb5, 0x8a, 0x83, 0x98, 0x91, 0x4d, 0x44, 0x5f,
+ 0x56, 0x69, 0x60, 0x7b, 0x72, 0x05, 0x0c, 0x17, 0x1e, 0x21, 0x28,
+ 0x33, 0x3a, 0xdd, 0xd4, 0xcf, 0xc6, 0xf9, 0xf0, 0xeb, 0xe2, 0x95,
+ 0x9c, 0x87, 0x8e, 0xb1, 0xb8, 0xa3, 0xaa, 0xec, 0xe5, 0xfe, 0xf7,
+ 0xc8, 0xc1, 0xda, 0xd3, 0xa4, 0xad, 0xb6, 0xbf, 0x80, 0x89, 0x92,
+ 0x9b, 0x7c, 0x75, 0x6e, 0x67, 0x58, 0x51, 0x4a, 0x43, 0x34, 0x3d,
+ 0x26, 0x2f, 0x10, 0x19, 0x02, 0x0b, 0xd7, 0xde, 0xc5, 0xcc, 0xf3,
+ 0xfa, 0xe1, 0xe8, 0x9f, 0x96, 0x8d, 0x84, 0xbb, 0xb2, 0xa9, 0xa0,
+ 0x47, 0x4e, 0x55, 0x5c, 0x63, 0x6a, 0x71, 0x78, 0x0f, 0x06, 0x1d,
+ 0x14, 0x2b, 0x22, 0x39, 0x30, 0x9a, 0x93, 0x88, 0x81, 0xbe, 0xb7,
+ 0xac, 0xa5, 0xd2, 0xdb, 0xc0, 0xc9, 0xf6, 0xff, 0xe4, 0xed, 0x0a,
+ 0x03, 0x18, 0x11, 0x2e, 0x27, 0x3c, 0x35, 0x42, 0x4b, 0x50, 0x59,
+ 0x66, 0x6f, 0x74, 0x7d, 0xa1, 0xa8, 0xb3, 0xba, 0x85, 0x8c, 0x97,
+ 0x9e, 0xe9, 0xe0, 0xfb, 0xf2, 0xcd, 0xc4, 0xdf, 0xd6, 0x31, 0x38,
+ 0x23, 0x2a, 0x15, 0x1c, 0x07, 0x0e, 0x79, 0x70, 0x6b, 0x62, 0x5d,
+ 0x54, 0x4f, 0x46]
+
+
+-- GF(2^8) multiplication by 0x02
+m2Table :: [GF28]
+m2Table =
+ [0x00, 0x02, 0x04, 0x06, 0x08, 0x0a, 0x0c, 0x0e, 0x10, 0x12, 0x14,
+ 0x16, 0x18, 0x1a, 0x1c, 0x1e, 0x20, 0x22, 0x24, 0x26, 0x28, 0x2a,
+ 0x2c, 0x2e, 0x30, 0x32, 0x34, 0x36, 0x38, 0x3a, 0x3c, 0x3e, 0x40,
+ 0x42, 0x44, 0x46, 0x48, 0x4a, 0x4c, 0x4e, 0x50, 0x52, 0x54, 0x56,
+ 0x58, 0x5a, 0x5c, 0x5e, 0x60, 0x62, 0x64, 0x66, 0x68, 0x6a, 0x6c,
+ 0x6e, 0x70, 0x72, 0x74, 0x76, 0x78, 0x7a, 0x7c, 0x7e, 0x80, 0x82,
+ 0x84, 0x86, 0x88, 0x8a, 0x8c, 0x8e, 0x90, 0x92, 0x94, 0x96, 0x98,
+ 0x9a, 0x9c, 0x9e, 0xa0, 0xa2, 0xa4, 0xa6, 0xa8, 0xaa, 0xac, 0xae,
+ 0xb0, 0xb2, 0xb4, 0xb6, 0xb8, 0xba, 0xbc, 0xbe, 0xc0, 0xc2, 0xc4,
+ 0xc6, 0xc8, 0xca, 0xcc, 0xce, 0xd0, 0xd2, 0xd4, 0xd6, 0xd8, 0xda,
+ 0xdc, 0xde, 0xe0, 0xe2, 0xe4, 0xe6, 0xe8, 0xea, 0xec, 0xee, 0xf0,
+ 0xf2, 0xf4, 0xf6, 0xf8, 0xfa, 0xfc, 0xfe, 0x1b, 0x19, 0x1f, 0x1d,
+ 0x13, 0x11, 0x17, 0x15, 0x0b, 0x09, 0x0f, 0x0d, 0x03, 0x01, 0x07,
+ 0x05, 0x3b, 0x39, 0x3f, 0x3d, 0x33, 0x31, 0x37, 0x35, 0x2b, 0x29,
+ 0x2f, 0x2d, 0x23, 0x21, 0x27, 0x25, 0x5b, 0x59, 0x5f, 0x5d, 0x53,
+ 0x51, 0x57, 0x55, 0x4b, 0x49, 0x4f, 0x4d, 0x43, 0x41, 0x47, 0x45,
+ 0x7b, 0x79, 0x7f, 0x7d, 0x73, 0x71, 0x77, 0x75, 0x6b, 0x69, 0x6f,
+ 0x6d, 0x63, 0x61, 0x67, 0x65, 0x9b, 0x99, 0x9f, 0x9d, 0x93, 0x91,
+ 0x97, 0x95, 0x8b, 0x89, 0x8f, 0x8d, 0x83, 0x81, 0x87, 0x85, 0xbb,
+ 0xb9, 0xbf, 0xbd, 0xb3, 0xb1, 0xb7, 0xb5, 0xab, 0xa9, 0xaf, 0xad,
+ 0xa3, 0xa1, 0xa7, 0xa5, 0xdb, 0xd9, 0xdf, 0xdd, 0xd3, 0xd1, 0xd7,
+ 0xd5, 0xcb, 0xc9, 0xcf, 0xcd, 0xc3, 0xc1, 0xc7, 0xc5, 0xfb, 0xf9,
+ 0xff, 0xfd, 0xf3, 0xf1, 0xf7, 0xf5, 0xeb, 0xe9, 0xef, 0xed, 0xe3,
+ 0xe1, 0xe7, 0xe5]
+
+-- GF(2^8) multiplication by 0x03
+m3Table :: [GF28]
+m3Table =
+ [0x00, 0x03, 0x06, 0x05, 0x0c, 0x0f, 0x0a, 0x09, 0x18, 0x1b, 0x1e,
+ 0x1d, 0x14, 0x17, 0x12, 0x11, 0x30, 0x33, 0x36, 0x35, 0x3c, 0x3f,
+ 0x3a, 0x39, 0x28, 0x2b, 0x2e, 0x2d, 0x24, 0x27, 0x22, 0x21, 0x60,
+ 0x63, 0x66, 0x65, 0x6c, 0x6f, 0x6a, 0x69, 0x78, 0x7b, 0x7e, 0x7d,
+ 0x74, 0x77, 0x72, 0x71, 0x50, 0x53, 0x56, 0x55, 0x5c, 0x5f, 0x5a,
+ 0x59, 0x48, 0x4b, 0x4e, 0x4d, 0x44, 0x47, 0x42, 0x41, 0xc0, 0xc3,
+ 0xc6, 0xc5, 0xcc, 0xcf, 0xca, 0xc9, 0xd8, 0xdb, 0xde, 0xdd, 0xd4,
+ 0xd7, 0xd2, 0xd1, 0xf0, 0xf3, 0xf6, 0xf5, 0xfc, 0xff, 0xfa, 0xf9,
+ 0xe8, 0xeb, 0xee, 0xed, 0xe4, 0xe7, 0xe2, 0xe1, 0xa0, 0xa3, 0xa6,
+ 0xa5, 0xac, 0xaf, 0xaa, 0xa9, 0xb8, 0xbb, 0xbe, 0xbd, 0xb4, 0xb7,
+ 0xb2, 0xb1, 0x90, 0x93, 0x96, 0x95, 0x9c, 0x9f, 0x9a, 0x99, 0x88,
+ 0x8b, 0x8e, 0x8d, 0x84, 0x87, 0x82, 0x81, 0x9b, 0x98, 0x9d, 0x9e,
+ 0x97, 0x94, 0x91, 0x92, 0x83, 0x80, 0x85, 0x86, 0x8f, 0x8c, 0x89,
+ 0x8a, 0xab, 0xa8, 0xad, 0xae, 0xa7, 0xa4, 0xa1, 0xa2, 0xb3, 0xb0,
+ 0xb5, 0xb6, 0xbf, 0xbc, 0xb9, 0xba, 0xfb, 0xf8, 0xfd, 0xfe, 0xf7,
+ 0xf4, 0xf1, 0xf2, 0xe3, 0xe0, 0xe5, 0xe6, 0xef, 0xec, 0xe9, 0xea,
+ 0xcb, 0xc8, 0xcd, 0xce, 0xc7, 0xc4, 0xc1, 0xc2, 0xd3, 0xd0, 0xd5,
+ 0xd6, 0xdf, 0xdc, 0xd9, 0xda, 0x5b, 0x58, 0x5d, 0x5e, 0x57, 0x54,
+ 0x51, 0x52, 0x43, 0x40, 0x45, 0x46, 0x4f, 0x4c, 0x49, 0x4a, 0x6b,
+ 0x68, 0x6d, 0x6e, 0x67, 0x64, 0x61, 0x62, 0x73, 0x70, 0x75, 0x76,
+ 0x7f, 0x7c, 0x79, 0x7a, 0x3b, 0x38, 0x3d, 0x3e, 0x37, 0x34, 0x31,
+ 0x32, 0x23, 0x20, 0x25, 0x26, 0x2f, 0x2c, 0x29, 0x2a, 0x0b, 0x08,
+ 0x0d, 0x0e, 0x07, 0x04, 0x01, 0x02, 0x13, 0x10, 0x15, 0x16, 0x1f,
+ 0x1c, 0x19, 0x1a]
+
+
+-- table-lookup versions of gf28Mult with the constants used in invMixColumns
+-- and TBox construction
+
+m2 :: GF28 -> GF28
+m2 i = m2Table !! fromIntegral i
+
+m3 :: GF28 -> GF28
+m3 i = m3Table !! fromIntegral i
+
+mE :: GF28 -> GF28
+mE i = mETable !! fromIntegral i
+
+mB :: GF28 -> GF28
+mB i = mBTable !! fromIntegral i
+
+mD :: GF28 -> GF28
+mD i = mDTable !! fromIntegral i
+
+m9 :: GF28 -> GF28
+m9 i = m9Table !! fromIntegral i
+
+-----------------------------------------------------------------------------
+-- ** The key schedule
+-----------------------------------------------------------------------------
+
+-- | The @InvMixColumns@ transformation, as described in Section 5.3.3 of the standard. Note
+-- that this transformation is only used explicitly during key-expansion in the T-Box implementation
+-- of AES.
+invMixColumns :: State -> State
+invMixColumns state = map fromBytes $ transpose $ mmult (map toBytes state)
+ where dot f = foldr1 xor . zipWith ($) f
+ mmult :: [[Word8]] -> [[Word8]]
+ mmult n = [map (dot r) n | r <- [ [mE, mB, mD, m9]
+ , [m9, mE, mB, mD]
+ , [mD, m9, mE, mB]
+ , [mB, mD, m9, mE]
+ ]]
+
+keyExpansionWords :: Integer -> Key -> [Word32]
+keyExpansionWords nk key = genericTake (4*(nk+7)) keys
+ where keys :: [Word32]
+ keys = key ++ [nextWord i prev old | i <- [nk ..] | prev <- genericDrop (nk-1) keys | old <- keys]
+
+ nextWord :: Integer -> Word32 -> Word32 -> Word32
+ nextWord i prev old
+ | i `mod` nk == 0 = old `xor` subWordRcon (prev `rotateL` 8) (roundConstants !! fromInteger (i `div` nk))
+ | i `mod` nk == 4 && nk > 6 = old `xor` subWordRcon prev 0
+ | True = old `xor` prev
+
+ subWordRcon :: Word32 -> GF28 -> Word32
+ subWordRcon w rc = fromBytes [a `xor` rc, b, c, d]
+ where [a, b, c, d] = map sbox $ toBytes w
+
+
+-- | Definition of round-constants, as specified in Section 5.2 of the AES standard.
+-- We only need up to the 11th value for AES-128, and fewer than that for AES-192
+-- and AES-256.
+roundConstants :: [GF28]
+roundConstants = [0,1,2,4,8,16,32,64,128,27,54]
+
+-----------------------------------------------------------------------------
+-- ** The S-box transformation
+-----------------------------------------------------------------------------
+
+sboxTable :: [GF28]
+sboxTable =
+ [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]
+
+-- | The AES sbox transformation
+sbox :: GF28 -> GF28
+sbox i = sboxTable !! fromIntegral i
+
+-----------------------------------------------------------------------------
+-- ** The inverse S-box transformation
+-----------------------------------------------------------------------------
+
+unSBoxTable :: [GF28]
+unSBoxTable =
+ [0x52, 0x09, 0x6a, 0xd5, 0x30, 0x36, 0xa5, 0x38, 0xbf, 0x40, 0xa3,
+ 0x9e, 0x81, 0xf3, 0xd7, 0xfb, 0x7c, 0xe3, 0x39, 0x82, 0x9b, 0x2f,
+ 0xff, 0x87, 0x34, 0x8e, 0x43, 0x44, 0xc4, 0xde, 0xe9, 0xcb, 0x54,
+ 0x7b, 0x94, 0x32, 0xa6, 0xc2, 0x23, 0x3d, 0xee, 0x4c, 0x95, 0x0b,
+ 0x42, 0xfa, 0xc3, 0x4e, 0x08, 0x2e, 0xa1, 0x66, 0x28, 0xd9, 0x24,
+ 0xb2, 0x76, 0x5b, 0xa2, 0x49, 0x6d, 0x8b, 0xd1, 0x25, 0x72, 0xf8,
+ 0xf6, 0x64, 0x86, 0x68, 0x98, 0x16, 0xd4, 0xa4, 0x5c, 0xcc, 0x5d,
+ 0x65, 0xb6, 0x92, 0x6c, 0x70, 0x48, 0x50, 0xfd, 0xed, 0xb9, 0xda,
+ 0x5e, 0x15, 0x46, 0x57, 0xa7, 0x8d, 0x9d, 0x84, 0x90, 0xd8, 0xab,
+ 0x00, 0x8c, 0xbc, 0xd3, 0x0a, 0xf7, 0xe4, 0x58, 0x05, 0xb8, 0xb3,
+ 0x45, 0x06, 0xd0, 0x2c, 0x1e, 0x8f, 0xca, 0x3f, 0x0f, 0x02, 0xc1,
+ 0xaf, 0xbd, 0x03, 0x01, 0x13, 0x8a, 0x6b, 0x3a, 0x91, 0x11, 0x41,
+ 0x4f, 0x67, 0xdc, 0xea, 0x97, 0xf2, 0xcf, 0xce, 0xf0, 0xb4, 0xe6,
+ 0x73, 0x96, 0xac, 0x74, 0x22, 0xe7, 0xad, 0x35, 0x85, 0xe2, 0xf9,
+ 0x37, 0xe8, 0x1c, 0x75, 0xdf, 0x6e, 0x47, 0xf1, 0x1a, 0x71, 0x1d,
+ 0x29, 0xc5, 0x89, 0x6f, 0xb7, 0x62, 0x0e, 0xaa, 0x18, 0xbe, 0x1b,
+ 0xfc, 0x56, 0x3e, 0x4b, 0xc6, 0xd2, 0x79, 0x20, 0x9a, 0xdb, 0xc0,
+ 0xfe, 0x78, 0xcd, 0x5a, 0xf4, 0x1f, 0xdd, 0xa8, 0x33, 0x88, 0x07,
+ 0xc7, 0x31, 0xb1, 0x12, 0x10, 0x59, 0x27, 0x80, 0xec, 0x5f, 0x60,
+ 0x51, 0x7f, 0xa9, 0x19, 0xb5, 0x4a, 0x0d, 0x2d, 0xe5, 0x7a, 0x9f,
+ 0x93, 0xc9, 0x9c, 0xef, 0xa0, 0xe0, 0x3b, 0x4d, 0xae, 0x2a, 0xf5,
+ 0xb0, 0xc8, 0xeb, 0xbb, 0x3c, 0x83, 0x53, 0x99, 0x61, 0x17, 0x2b,
+ 0x04, 0x7e, 0xba, 0x77, 0xd6, 0x26, 0xe1, 0x69, 0x14, 0x63, 0x55,
+ 0x21, 0x0c, 0x7d]
+
+-- | The inverse s-box transformation.
+unSBox :: GF28 -> GF28
+unSBox i = unSBoxTable !! fromIntegral i
+
+
+-----------------------------------------------------------------------------
+-- ** Tables for T-Box encryption
+-----------------------------------------------------------------------------
+
+-- | T-box table generation function for encryption
+t0Func :: GF28 -> [GF28]
+t0Func a = [ m2 s, s, s, m3 s]
+ where s = sbox a
+
+-- | First look-up table used in encryption
+t0 :: GF28 -> Word32
+t0 i = t0Table !! fromIntegral i
+
+t0Table :: [Word32]
+t0Table = [fromBytes (t0Func a) | a <- [0..255]]
+
+-- | Second look-up table used in encryption
+t1 :: GF28 -> Word32
+t1 i = t1Table !! fromIntegral i
+
+t1Table :: [Word32]
+t1Table = [fromBytes (t0Func a `rotR` 1) | a <- [0..255]]
+
+-- | Third look-up table used in encryption
+t2 :: GF28 -> Word32
+t2 i = t2Table !! fromIntegral i
+
+t2Table :: [Word32]
+t2Table = [fromBytes (t0Func a `rotR` 2) | a <- [0..255]]
+
+-- | Fourth look-up table used in encryption
+t3 :: GF28 -> Word32
+t3 i = t3Table !! fromIntegral i
+
+t3Table :: [Word32]
+t3Table = [fromBytes (t0Func a `rotR` 3) | a <- [0..255]]
+
+-----------------------------------------------------------------------------
+-- ** Tables for T-Box decryption
+-----------------------------------------------------------------------------
+
+-- | T-box table generating function for decryption
+u0Func :: GF28 -> [GF28]
+u0Func a = [ mE s, m9 s, mD s, mB s ]
+ where s = unSBox a
+
+-- | First look-up table used in decryption
+u0 :: GF28 -> Word32
+u0 i = u0Table !! fromIntegral i
+
+u0Table :: [Word32]
+u0Table = [fromBytes (u0Func a) | a <- [0..255]]
+
+-- | Second look-up table used in decryption
+u1 :: GF28 -> Word32
+u1 i = u1Table !! fromIntegral i
+
+u1Table :: [Word32]
+u1Table = [fromBytes (u0Func a `rotR` 1) | a <- [0..255]]
+
+-- | Third look-up table used in decryption
+u2 :: GF28 -> Word32
+u2 i = u2Table !! fromIntegral i
+
+u2Table :: [Word32]
+u2Table = [fromBytes (u0Func a `rotR` 2) | a <- [0..255]]
+
+-- | Fourth look-up table used in decryption
+u3 :: GF28 -> Word32
+u3 i = u3Table !! fromIntegral i
+
+u3Table :: [Word32]
+u3Table = [fromBytes (u0Func a `rotR` 3) | a <- [0..255]]
+
+-----------------------------------------------------------------------------
+-- ** AES rounds
+-----------------------------------------------------------------------------
+
+aesRound :: State -> State
+aesRound s = d
+ where d = map f [0..3]
+ a = map toBytes s
+ f j = e0 `xor` e1 `xor` e2 `xor` e3
+ where e0 = t0 (a !! ((j+0) `mod` 4) !! 0)
+ e1 = t1 (a !! ((j+1) `mod` 4) !! 1)
+ e2 = t2 (a !! ((j+2) `mod` 4) !! 2)
+ e3 = t3 (a !! ((j+3) `mod` 4) !! 3)
+
+aesFinalRound :: State -> State
+aesFinalRound s = d
+ where d = map f [0..3]
+ a = map toBytes s
+ f j = fromBytes [ sbox (a !! ((j+0) `mod` 4) !! 0)
+ , sbox (a !! ((j+1) `mod` 4) !! 1)
+ , sbox (a !! ((j+2) `mod` 4) !! 2)
+ , sbox (a !! ((j+3) `mod` 4) !! 3)
+ ]
+
+aesInvRound :: State -> State
+aesInvRound s = d
+ where d = map f [0..3]
+ a = map toBytes s
+ f j = e0 `xor` e1 `xor` e2 `xor` e3
+ where e0 = u0 (a !! ((j+0) `mod` 4) !! 0)
+ e1 = u1 (a !! ((j+3) `mod` 4) !! 1)
+ e2 = u2 (a !! ((j+2) `mod` 4) !! 2)
+ e3 = u3 (a !! ((j+1) `mod` 4) !! 3)
+
+aesInvFinalRound :: State -> State
+aesInvFinalRound s = d
+ where d = map f [0..3]
+ a = map toBytes s
+ f j = fromBytes [ unSBox (a !! ((j+0) `mod` 4) !! 0)
+ , unSBox (a !! ((j+3) `mod` 4) !! 1)
+ , unSBox (a !! ((j+2) `mod` 4) !! 2)
+ , unSBox (a !! ((j+1) `mod` 4) !! 3)
+ ]
diff --git a/src/Cryptol/Backend.hs b/src/Cryptol/Backend.hs
new file mode 100644
--- /dev/null
+++ b/src/Cryptol/Backend.hs
@@ -0,0 +1,714 @@
+{-# Language FlexibleContexts #-}
+{-# Language TypeFamilies #-}
+module Cryptol.Backend
+ ( Backend(..)
+ , sDelay
+ , invalidIndex
+ , cryUserError
+ , cryNoPrimError
+ , FPArith2
+
+ -- * Rationals
+ , SRational(..)
+ , intToRational
+ , ratio
+ , rationalAdd
+ , rationalSub
+ , rationalNegate
+ , rationalMul
+ , rationalRecip
+ , rationalDivide
+ , rationalFloor
+ , rationalCeiling
+ , rationalTrunc
+ , rationalRoundAway
+ , rationalRoundToEven
+ , rationalEq
+ , rationalLessThan
+ , rationalGreaterThan
+ , iteRational
+ , ppRational
+ ) where
+
+import Control.Monad.IO.Class
+import Data.Kind (Type)
+import Data.Ratio ( (%), numerator, denominator )
+
+import Cryptol.Backend.FloatHelpers (BF)
+import Cryptol.Backend.Monad ( PPOpts(..), EvalError(..) )
+import Cryptol.TypeCheck.AST(Name)
+import Cryptol.Utils.PP
+
+
+invalidIndex :: Backend sym => sym -> Integer -> SEval sym a
+invalidIndex sym = raiseError sym . InvalidIndex . Just
+
+cryUserError :: Backend sym => sym -> String -> SEval sym a
+cryUserError sym = raiseError sym . UserError
+
+cryNoPrimError :: Backend sym => sym -> Name -> SEval sym a
+cryNoPrimError sym = raiseError sym . NoPrim
+
+
+{-# INLINE sDelay #-}
+-- | 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.
+sDelay :: Backend sym => sym -> Maybe String -> SEval sym a -> SEval sym (SEval sym a)
+sDelay sym msg m =
+ let msg' = maybe "" ("while evaluating "++) msg
+ retry = raiseError sym (LoopError msg')
+ in sDelayFill sym m retry
+
+
+-- | Representation of rational numbers.
+-- Invariant: denominator is not 0
+data SRational sym =
+ SRational
+ { sNum :: SInteger sym
+ , sDenom :: SInteger sym
+ }
+
+intToRational :: Backend sym => sym -> SInteger sym -> SEval sym (SRational sym)
+intToRational sym x = SRational x <$> (integerLit sym 1)
+
+ratio :: Backend sym => sym -> SInteger sym -> SInteger sym -> SEval sym (SRational sym)
+ratio sym n d =
+ do pz <- bitComplement sym =<< intEq sym d =<< integerLit sym 0
+ assertSideCondition sym pz DivideByZero
+ pure (SRational n d)
+
+rationalRecip :: Backend sym => sym -> SRational sym -> SEval sym (SRational sym)
+rationalRecip sym (SRational a b) = ratio sym b a
+
+rationalDivide :: Backend sym => sym -> SRational sym -> SRational sym -> SEval sym (SRational sym)
+rationalDivide sym x y = rationalMul sym x =<< rationalRecip sym y
+
+rationalFloor :: Backend sym => sym -> SRational sym -> SEval sym (SInteger sym)
+ -- NB, relies on integer division being round-to-negative-inf division
+rationalFloor sym (SRational n d) = intDiv sym n d
+
+rationalCeiling :: Backend sym => sym -> SRational sym -> SEval sym (SInteger sym)
+rationalCeiling sym r = intNegate sym =<< rationalFloor sym =<< rationalNegate sym r
+
+rationalTrunc :: Backend sym => sym -> SRational sym -> SEval sym (SInteger sym)
+rationalTrunc sym r =
+ do p <- rationalLessThan sym r =<< intToRational sym =<< integerLit sym 0
+ cr <- rationalCeiling sym r
+ fr <- rationalFloor sym r
+ iteInteger sym p cr fr
+
+rationalRoundAway :: Backend sym => sym -> SRational sym -> SEval sym (SInteger sym)
+rationalRoundAway sym r =
+ do p <- rationalLessThan sym r =<< intToRational sym =<< integerLit sym 0
+ half <- SRational <$> integerLit sym 1 <*> integerLit sym 2
+ cr <- rationalCeiling sym =<< rationalSub sym r half
+ fr <- rationalFloor sym =<< rationalAdd sym r half
+ iteInteger sym p cr fr
+
+rationalRoundToEven :: Backend sym => sym -> SRational sym -> SEval sym (SInteger sym)
+rationalRoundToEven sym r =
+ do lo <- rationalFloor sym r
+ hi <- intPlus sym lo =<< integerLit sym 1
+ -- NB: `diff` will be nonnegative because `lo <= r`
+ diff <- rationalSub sym r =<< intToRational sym lo
+ half <- SRational <$> integerLit sym 1 <*> integerLit sym 2
+
+ ite (rationalLessThan sym diff half) (pure lo) $
+ ite (rationalGreaterThan sym diff half) (pure hi) $
+ ite (isEven lo) (pure lo) (pure hi)
+
+ where
+ isEven x =
+ do parity <- intMod sym x =<< integerLit sym 2
+ intEq sym parity =<< integerLit sym 0
+
+ ite x t e =
+ do x' <- x
+ case bitAsLit sym x' of
+ Just True -> t
+ Just False -> e
+ Nothing ->
+ do t' <- t
+ e' <- e
+ iteInteger sym x' t' e'
+
+
+rationalAdd :: Backend sym => sym -> SRational sym -> SRational sym -> SEval sym (SRational sym)
+rationalAdd sym (SRational a b) (SRational c d) =
+ do ad <- intMult sym a d
+ bc <- intMult sym b c
+ bd <- intMult sym b d
+ ad_bc <- intPlus sym ad bc
+ pure (SRational ad_bc bd)
+
+rationalSub :: Backend sym => sym -> SRational sym -> SRational sym -> SEval sym (SRational sym)
+rationalSub sym (SRational a b) (SRational c d) =
+ do ad <- intMult sym a d
+ bc <- intMult sym b c
+ bd <- intMult sym b d
+ ad_bc <- intMinus sym ad bc
+ pure (SRational ad_bc bd)
+
+rationalNegate :: Backend sym => sym -> SRational sym -> SEval sym (SRational sym)
+rationalNegate sym (SRational a b) =
+ do aneg <- intNegate sym a
+ pure (SRational aneg b)
+
+rationalMul :: Backend sym => sym -> SRational sym -> SRational sym -> SEval sym (SRational sym)
+rationalMul sym (SRational a b) (SRational c d) =
+ do ac <- intMult sym a c
+ bd <- intMult sym b d
+ pure (SRational ac bd)
+
+rationalEq :: Backend sym => sym -> SRational sym -> SRational sym -> SEval sym (SBit sym)
+rationalEq sym (SRational a b) (SRational c d) =
+ do ad <- intMult sym a d
+ bc <- intMult sym b c
+ intEq sym ad bc
+
+normalizeSign :: Backend sym => sym -> SRational sym -> SEval sym (SRational sym)
+normalizeSign sym (SRational a b) =
+ do p <- intLessThan sym b =<< integerLit sym 0
+ case bitAsLit sym p of
+ Just False -> pure (SRational a b)
+ Just True ->
+ do aneg <- intNegate sym a
+ bneg <- intNegate sym b
+ pure (SRational aneg bneg)
+ Nothing ->
+ do aneg <- intNegate sym a
+ bneg <- intNegate sym b
+ a' <- iteInteger sym p aneg a
+ b' <- iteInteger sym p bneg b
+ pure (SRational a' b')
+
+rationalLessThan:: Backend sym => sym -> SRational sym -> SRational sym -> SEval sym (SBit sym)
+rationalLessThan sym x y =
+ do SRational a b <- normalizeSign sym x
+ SRational c d <- normalizeSign sym y
+ ad <- intMult sym a d
+ bc <- intMult sym b c
+ intLessThan sym ad bc
+
+rationalGreaterThan:: Backend sym => sym -> SRational sym -> SRational sym -> SEval sym (SBit sym)
+rationalGreaterThan sym = flip (rationalLessThan sym)
+
+iteRational :: Backend sym => sym -> SBit sym -> SRational sym -> SRational sym -> SEval sym (SRational sym)
+iteRational sym p (SRational a b) (SRational c d) =
+ SRational <$> iteInteger sym p a c <*> iteInteger sym p b d
+
+ppRational :: Backend sym => sym -> PPOpts -> SRational sym -> Doc
+ppRational sym opts (SRational n d)
+ | Just ni <- integerAsLit sym n
+ , Just di <- integerAsLit sym d
+ = let q = ni % di in
+ text "(ratio" <+> integer (numerator q) <+> (integer (denominator q) <> text ")")
+
+ | otherwise
+ = text "(ratio" <+> ppInteger sym opts n <+> (ppInteger sym opts d <> text ")")
+
+-- | This type class defines a collection of operations on bits, words and integers that
+-- are necessary to define generic evaluator primitives that operate on both concrete
+-- and symbolic values uniformly.
+class MonadIO (SEval sym) => Backend sym where
+ type SBit sym :: Type
+ type SWord sym :: Type
+ type SInteger sym :: Type
+ type SFloat sym :: Type
+ type SEval sym :: Type -> Type
+
+ -- ==== Evaluation monad operations ====
+
+ -- | Check if an operation is "ready", which means its
+ -- evaluation will be trivial.
+ isReady :: sym -> SEval sym a -> Bool
+
+ -- | 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.
+ sDeclareHole :: sym -> String -> SEval sym (SEval sym a, SEval sym a -> SEval sym ())
+
+ -- | 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.
+ sDelayFill :: sym -> SEval sym a -> SEval sym a -> SEval sym (SEval sym a)
+
+ -- | Begin evaluating the given computation eagerly in a separate thread
+ -- and return a thunk which will await the completion of the given computation
+ -- when forced.
+ sSpark :: sym -> SEval sym a -> SEval sym (SEval sym a)
+
+ -- | Merge the two given computations according to the predicate.
+ mergeEval ::
+ sym ->
+ (SBit sym -> a -> a -> SEval sym a) {- ^ A merge operation on values -} ->
+ SBit sym {- ^ The condition -} ->
+ SEval sym a {- ^ The "then" computation -} ->
+ SEval sym a {- ^ The "else" computation -} ->
+ SEval sym a
+
+ -- | Assert that a condition must hold, and indicate what sort of
+ -- error is indicated if the condition fails.
+ assertSideCondition :: sym -> SBit sym -> EvalError -> SEval sym ()
+
+ -- | Indiciate that an error condition exists
+ raiseError :: sym -> EvalError -> SEval sym a
+
+
+ -- ==== Pretty printing ====
+ -- | Pretty-print an individual bit
+ ppBit :: sym -> SBit sym -> Doc
+
+ -- | Pretty-print a word value
+ ppWord :: sym -> PPOpts -> SWord sym -> Doc
+
+ -- | Pretty-print an integer value
+ ppInteger :: sym -> PPOpts -> SInteger sym -> Doc
+
+ -- | Pretty-print a floating-point value
+ ppFloat :: sym -> PPOpts -> SFloat sym -> Doc
+
+
+ -- ==== Identifying literal values ====
+
+ -- | Determine if this symbolic bit is a boolean literal
+ bitAsLit :: sym -> SBit sym -> Maybe Bool
+
+ -- | The number of bits in a word value.
+ wordLen :: sym -> SWord sym -> Integer
+
+ -- | Determine if this symbolic word is a literal.
+ -- If so, return the bit width and value.
+ wordAsLit :: sym -> SWord sym -> Maybe (Integer, Integer)
+
+ -- | Attempt to render a word value as an ASCII character. Return 'Nothing'
+ -- if the character value is unknown (e.g., for symbolic values).
+ wordAsChar :: sym -> SWord sym -> Maybe Char
+
+ -- | Determine if this symbolic integer is a literal
+ integerAsLit :: sym -> SInteger sym -> Maybe Integer
+
+ -- ==== Creating literal values ====
+
+ -- | Construct a literal bit value from a boolean.
+ bitLit :: sym -> Bool -> SBit sym
+
+ -- | Construct a literal word value given a bit width and a value.
+ wordLit ::
+ sym ->
+ Integer {- ^ Width -} ->
+ Integer {- ^ Value -} ->
+ SEval sym (SWord sym)
+
+ -- | Construct a literal integer value from the given integer.
+ integerLit ::
+ sym ->
+ Integer {- ^ Value -} ->
+ SEval sym (SInteger sym)
+
+ -- | Construct a floating point value from the given rational.
+ fpLit ::
+ sym ->
+ Integer {- ^ exponent bits -} ->
+ Integer {- ^ precision bits -} ->
+ Rational {- ^ The rational -} ->
+ SEval sym (SFloat sym)
+
+ -- | Construct a floating point value from the given bit-precise
+ -- floating-point representation.
+ fpExactLit :: sym -> BF -> SEval sym (SFloat sym)
+
+ -- ==== If/then/else operations ====
+ iteBit :: sym -> SBit sym -> SBit sym -> SBit sym -> SEval sym (SBit sym)
+ iteWord :: sym -> SBit sym -> SWord sym -> SWord sym -> SEval sym (SWord sym)
+ iteInteger :: sym -> SBit sym -> SInteger sym -> SInteger sym -> SEval sym (SInteger sym)
+
+ -- ==== Bit operations ====
+ bitEq :: sym -> SBit sym -> SBit sym -> SEval sym (SBit sym)
+ bitOr :: sym -> SBit sym -> SBit sym -> SEval sym (SBit sym)
+ bitAnd :: sym -> SBit sym -> SBit sym -> SEval sym (SBit sym)
+ bitXor :: sym -> SBit sym -> SBit sym -> SEval sym (SBit sym)
+ bitComplement :: sym -> SBit sym -> SEval sym (SBit sym)
+
+
+ -- ==== Word operations ====
+
+ -- | Extract the numbered bit from the word.
+ --
+ -- NOTE: this assumes that the sequence of bits is big-endian and finite, so the
+ -- bit numbered 0 is the most significant bit.
+ wordBit ::
+ sym ->
+ SWord sym ->
+ Integer {- ^ Bit position to extract -} ->
+ SEval sym (SBit sym)
+
+ -- | Update the numbered bit in the word.
+ --
+ -- NOTE: this assumes that the sequence of bits is big-endian and finite, so the
+ -- bit numbered 0 is the most significant bit.
+ wordUpdate ::
+ sym ->
+ SWord sym ->
+ Integer {- ^ Bit position to update -} ->
+ SBit sym ->
+ SEval sym (SWord sym)
+
+ -- | 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 ::
+ sym ->
+ [SBit sym] ->
+ SEval sym (SWord sym)
+
+ -- | 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 ::
+ sym ->
+ SWord sym ->
+ SEval sym [SBit sym]
+
+ -- | Construct a packed word of the specified width from an integer value.
+ wordFromInt ::
+ sym ->
+ Integer {- ^ bit-width -} ->
+ SInteger sym ->
+ SEval sym (SWord sym)
+
+ -- | Concatenate the two given word values.
+ -- NOTE: the first argument represents the more-significant bits
+ joinWord ::
+ sym ->
+ SWord sym ->
+ SWord sym ->
+ SEval sym (SWord sym)
+
+ -- | 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 ::
+ sym ->
+ Integer {- ^ left width -} ->
+ Integer {- ^ right width -} ->
+ SWord sym ->
+ SEval sym (SWord sym, SWord sym)
+
+ -- | 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 equivalent to
+ -- first shifting @w@ right by @i@ bits, and then truncating to
+ -- @n@ bits.
+ extractWord ::
+ sym ->
+ Integer {- ^ Number of bits to take -} ->
+ Integer {- ^ starting bit -} ->
+ SWord sym ->
+ SEval sym (SWord sym)
+
+ -- | Bitwise OR
+ wordOr ::
+ sym ->
+ SWord sym ->
+ SWord sym ->
+ SEval sym (SWord sym)
+
+ -- | Bitwise AND
+ wordAnd ::
+ sym ->
+ SWord sym ->
+ SWord sym ->
+ SEval sym (SWord sym)
+
+ -- | Bitwise XOR
+ wordXor ::
+ sym ->
+ SWord sym ->
+ SWord sym ->
+ SEval sym (SWord sym)
+
+ -- | Bitwise complement
+ wordComplement ::
+ sym ->
+ SWord sym ->
+ SEval sym (SWord sym)
+
+ -- | 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 ::
+ sym ->
+ SWord sym ->
+ SWord sym ->
+ SEval sym (SWord sym)
+
+ -- | 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 ::
+ sym ->
+ SWord sym ->
+ SWord sym ->
+ SEval sym (SWord sym)
+
+ -- | 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 ::
+ sym ->
+ SWord sym ->
+ SWord sym ->
+ SEval sym (SWord sym)
+
+ -- | 2's complement unsigned division of packed words. The arguments must have
+ -- equal bit width, and the result is of the same width. It is illegal to
+ -- call with a second argument concretely equal to 0.
+ wordDiv ::
+ sym ->
+ SWord sym ->
+ SWord sym ->
+ SEval sym (SWord sym)
+
+ -- | 2's complement unsigned modulus of packed words. The arguments must have
+ -- equal bit width, and the result is of the same width. It is illegal to
+ -- call with a second argument concretely equal to 0.
+ wordMod ::
+ sym ->
+ SWord sym ->
+ SWord sym ->
+ SEval sym (SWord sym)
+
+ -- | 2's complement signed division of packed words. The arguments must have
+ -- equal bit width, and the result is of the same width. It is illegal to
+ -- call with a second argument concretely equal to 0.
+ wordSignedDiv ::
+ sym ->
+ SWord sym ->
+ SWord sym ->
+ SEval sym (SWord sym)
+
+ -- | 2's complement signed modulus of packed words. The arguments must have
+ -- equal bit width, and the result is of the same width. It is illegal to
+ -- call with a second argument concretely equal to 0.
+ wordSignedMod ::
+ sym ->
+ SWord sym ->
+ SWord sym ->
+ SEval sym (SWord sym)
+
+ -- | 2's complement negation of bitvectors
+ wordNegate ::
+ sym ->
+ SWord sym ->
+ SEval sym (SWord sym)
+
+ -- | Compute rounded-up log-2 of the input
+ wordLg2 ::
+ sym ->
+ SWord sym ->
+ SEval sym (SWord sym)
+
+ -- | Test if two words are equal. Arguments must have the same width.
+ wordEq ::
+ sym ->
+ SWord sym ->
+ SWord sym ->
+ SEval sym (SBit sym)
+
+ -- | Signed less-than comparison on words. Arguments must have the same width.
+ wordSignedLessThan ::
+ sym ->
+ SWord sym ->
+ SWord sym ->
+ SEval sym (SBit sym)
+
+ -- | Unsigned less-than comparison on words. Arguments must have the same width.
+ wordLessThan ::
+ sym ->
+ SWord sym ->
+ SWord sym ->
+ SEval sym (SBit sym)
+
+ -- | Unsigned greater-than comparison on words. Arguments must have the same width.
+ wordGreaterThan ::
+ sym ->
+ SWord sym ->
+ SWord sym ->
+ SEval sym (SBit sym)
+
+ -- | Construct an integer value from the given packed word.
+ wordToInt ::
+ sym ->
+ SWord sym ->
+ SEval sym (SInteger sym)
+
+ -- ==== Integer operations ====
+
+ -- | Addition of unbounded integers.
+ intPlus ::
+ sym ->
+ SInteger sym ->
+ SInteger sym ->
+ SEval sym (SInteger sym)
+
+ -- | Negation of unbounded integers
+ intNegate ::
+ sym ->
+ SInteger sym ->
+ SEval sym (SInteger sym)
+
+ -- | Subtraction of unbounded integers.
+ intMinus ::
+ sym ->
+ SInteger sym ->
+ SInteger sym ->
+ SEval sym (SInteger sym)
+
+ -- | Multiplication of unbounded integers.
+ intMult ::
+ sym ->
+ SInteger sym ->
+ SInteger sym ->
+ SEval sym (SInteger sym)
+
+ -- | Integer division, rounding down. It is illegal to
+ -- call with a second argument concretely equal to 0.
+ -- Same semantics as Haskell's @div@ operation.
+ intDiv ::
+ sym ->
+ SInteger sym ->
+ SInteger sym ->
+ SEval sym (SInteger sym)
+
+ -- | Integer modulus, with division rounding down. It is illegal to
+ -- call with a second argument concretely equal to 0.
+ -- Same semantics as Haskell's @mod@ operation.
+ intMod ::
+ sym ->
+ SInteger sym ->
+ SInteger sym ->
+ SEval sym (SInteger sym)
+
+ -- | Equality comparison on integers
+ intEq ::
+ sym ->
+ SInteger sym ->
+ SInteger sym ->
+ SEval sym (SBit sym)
+
+ -- | Less-than comparison on integers
+ intLessThan ::
+ sym ->
+ SInteger sym ->
+ SInteger sym ->
+ SEval sym (SBit sym)
+
+ -- | Greater-than comparison on integers
+ intGreaterThan ::
+ sym ->
+ SInteger sym ->
+ SInteger sym ->
+ SEval sym (SBit sym)
+
+
+ -- ==== Operations on Z_n ====
+
+ -- | Turn an integer into a value in Z_n
+ intToZn ::
+ sym ->
+ Integer {- ^ modulus -} ->
+ SInteger sym ->
+ SEval sym (SInteger sym)
+
+ -- | Transform a Z_n value into an integer, ensuring the value is properly
+ -- reduced modulo n
+ znToInt ::
+ sym ->
+ Integer {- ^ modulus -} ->
+ SInteger sym ->
+ SEval sym (SInteger sym)
+
+ -- | Addition of integers modulo n, for a concrete positive integer n.
+ znPlus ::
+ sym ->
+ Integer {- ^ modulus -} ->
+ SInteger sym ->
+ SInteger sym ->
+ SEval sym (SInteger sym)
+
+ -- | Additive inverse of integers modulo n
+ znNegate ::
+ sym ->
+ Integer {- ^ modulus -} ->
+ SInteger sym ->
+ SEval sym (SInteger sym)
+
+ -- | Subtraction of integers modulo n, for a concrete positive integer n.
+ znMinus ::
+ sym ->
+ Integer {- ^ modulus -} ->
+ SInteger sym ->
+ SInteger sym ->
+ SEval sym (SInteger sym)
+
+ -- | Multiplication of integers modulo n, for a concrete positive integer n.
+ znMult ::
+ sym ->
+ Integer {- ^ modulus -} ->
+ SInteger sym ->
+ SInteger sym ->
+ SEval sym (SInteger sym)
+
+ -- | Equality test of integers modulo n
+ znEq ::
+ sym ->
+ Integer {- ^ modulus -} ->
+ SInteger sym ->
+ SInteger sym ->
+ SEval sym (SBit sym)
+
+ -- | Multiplicitive inverse in (Z n).
+ -- PRECONDITION: the modulus is a prime
+ znRecip ::
+ sym ->
+ Integer {- ^ modulus -} ->
+ SInteger sym ->
+ SEval sym (SInteger sym)
+
+ -- == Float Operations ==
+ fpEq :: sym -> SFloat sym -> SFloat sym -> SEval sym (SBit sym)
+ fpLessThan :: sym -> SFloat sym -> SFloat sym -> SEval sym (SBit sym)
+ fpGreaterThan :: sym -> SFloat sym -> SFloat sym -> SEval sym (SBit sym)
+
+ fpLogicalEq :: sym -> SFloat sym -> SFloat sym -> SEval sym (SBit sym)
+
+ fpPlus, fpMinus, fpMult, fpDiv :: FPArith2 sym
+ fpNeg :: sym -> SFloat sym -> SEval sym (SFloat sym)
+
+ fpToInteger ::
+ sym ->
+ String {- ^ Name of the function for error reporting -} ->
+ SWord sym {-^ Rounding mode -} ->
+ SFloat sym -> SEval sym (SInteger sym)
+
+ fpFromInteger ::
+ sym ->
+ Integer {- exp width -} ->
+ Integer {- prec width -} ->
+ SWord sym {- ^ rounding mode -} ->
+ SInteger sym {- ^ the integeer to use -} ->
+ SEval sym (SFloat sym)
+
+type FPArith2 sym =
+ sym ->
+ SWord sym ->
+ SFloat sym ->
+ SFloat sym ->
+ SEval sym (SFloat sym)
diff --git a/src/Cryptol/Backend/Arch.hs b/src/Cryptol/Backend/Arch.hs
new file mode 100644
--- /dev/null
+++ b/src/Cryptol/Backend/Arch.hs
@@ -0,0 +1,30 @@
+-- |
+-- Module : Cryptol.Eval.Arch
+-- Copyright : (c) 2014-2016 Galois, Inc.
+-- License : BSD3
+-- Maintainer : cryptol@galois.com
+-- Stability : provisional
+-- Portability : portable
+--
+-- Architecture-specific parts of the concrete evaluator go here.
+{-# LANGUAGE CPP #-}
+module Cryptol.Backend.Arch where
+
+-- | This is the widest word we can have before gmp will fail to
+-- allocate and bring down the whole program. According to
+--
+-- the sizes are 2^32-1 for 32-bit, and 2^37 for 64-bit, however
+-- experiments show that it's somewhere under 2^37 at least on 64-bit
+-- Mac OS X.
+maxBigIntWidth :: Integer
+#if i386_HOST_ARCH
+maxBigIntWidth = 2^(32 :: Integer) - 0x1
+#elif x86_64_HOST_ARCH
+maxBigIntWidth = 2^(37 :: Integer) - 0x100
+#else
+-- Because GHC doesn't seem to define a CPP macro that will portably
+-- tell us the bit width we're compiling for, fall back on a safe choice
+-- for other architectures. If we care about large words on another
+-- architecture, we can add a special case for it.
+maxBigIntWidth = 2^(32 :: Integer) - 0x1
+#endif
diff --git a/src/Cryptol/Backend/Concrete.hs b/src/Cryptol/Backend/Concrete.hs
new file mode 100644
--- /dev/null
+++ b/src/Cryptol/Backend/Concrete.hs
@@ -0,0 +1,398 @@
+-- |
+-- Module : Cryptol.Backend.Concrete
+-- Copyright : (c) 2013-2020 Galois, Inc.
+-- License : BSD3
+-- Maintainer : cryptol@galois.com
+-- Stability : provisional
+-- Portability : portable
+
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
+module Cryptol.Backend.Concrete
+ ( BV(..)
+ , binBV
+ , unaryBV
+ , bvVal
+ , ppBV
+ , mkBv
+ , mask
+ , signedBV
+ , signedValue
+ , integerToChar
+ , lg2
+ , Concrete(..)
+ , liftBinIntMod
+ , fpBinArith
+ , fpRoundMode
+ ) where
+
+import qualified Control.Exception as X
+import Data.Bits
+import Numeric (showIntAtBase)
+import qualified LibBF as FP
+import qualified GHC.Integer.GMP.Internals as Integer
+
+import qualified Cryptol.Backend.Arch as Arch
+import qualified Cryptol.Backend.FloatHelpers as FP
+import Cryptol.Backend
+import Cryptol.Backend.Monad
+import Cryptol.TypeCheck.Solver.InfNat (genLog)
+import Cryptol.Utils.Panic (panic)
+import Cryptol.Utils.PP
+
+data Concrete = Concrete deriving Show
+
+-- | Concrete bitvector values: width, value
+-- Invariant: The value must be within the range 0 .. 2^width-1
+data BV = BV !Integer !Integer
+
+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 :: Applicative m => (Integer -> Integer -> Integer) -> BV -> BV -> m BV
+binBV f (BV w x) (BV _ y) = pure $! mkBv w (f x y)
+{-# INLINE binBV #-}
+
+-- | 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
+{-# INLINE unaryBV #-}
+
+bvVal :: BV -> Integer
+bvVal (BV _w x) = x
+{-# INLINE bvVal #-}
+
+-- | Smart constructor for 'BV's that checks for the width limit
+mkBv :: Integer -> Integer -> BV
+mkBv w i = BV w (mask w i)
+
+signedBV :: BV -> Integer
+signedBV (BV i x) = signedValue i x
+
+signedValue :: Integer -> Integer -> Integer
+signedValue i x = if testBit x (fromInteger (i-1)) then x - (bit (fromInteger i)) else x
+
+integerToChar :: Integer -> Char
+integerToChar = toEnum . fromInteger
+
+lg2 :: Integer -> Integer
+lg2 i = case genLog i 2 of
+ Just (i',isExact) | isExact -> i'
+ | otherwise -> i' + 1
+ Nothing -> 0
+
+
+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
+ where
+ base = useBase opts
+
+ padding bitsPerDigit = text (replicate padLen '0')
+ where
+ padLen | m > 0 = d + 1
+ | otherwise = d
+
+ (d,m) = (fromInteger width - (length value * bitsPerDigit))
+ `divMod` bitsPerDigit
+
+ prefix = case base of
+ 2 -> text "0b" <.> padding 1
+ 8 -> text "0o" <.> padding 3
+ 10 -> empty
+ 16 -> text "0x" <.> padding 4
+ _ -> text "0" <.> char '<' <.> int base <.> char '>'
+
+ value = showIntAtBase (toInteger base) (digits !!) i ""
+ digits = "0123456789abcdefghijklmnopqrstuvwxyz"
+
+-- Concrete Big-endian Words ------------------------------------------------------------
+
+mask ::
+ Integer {- ^ Bit-width -} ->
+ Integer {- ^ Value -} ->
+ Integer {- ^ Masked result -}
+mask w i | w >= Arch.maxBigIntWidth = wordTooWide w
+ | otherwise = i .&. (bit (fromInteger w) - 1)
+
+instance Backend Concrete where
+ type SBit Concrete = Bool
+ type SWord Concrete = BV
+ type SInteger Concrete = Integer
+ type SFloat Concrete = FP.BF
+ type SEval Concrete = Eval
+
+ raiseError _ err = io (X.throwIO err)
+
+ assertSideCondition _ True _ = return ()
+ assertSideCondition _ False err = io (X.throwIO err)
+
+ wordLen _ (BV w _) = w
+ wordAsChar _ (BV _ x) = Just $! integerToChar x
+
+ wordBit _ (BV w x) idx = pure $! testBit x (fromInteger (w - 1 - idx))
+
+ wordUpdate _ (BV w x) idx True = pure $! BV w (setBit x (fromInteger (w - 1 - idx)))
+ wordUpdate _ (BV w x) idx False = pure $! BV w (clearBit x (fromInteger (w - 1 - idx)))
+
+ isReady _ (Ready _) = True
+ isReady _ _ = False
+
+ mergeEval _sym f c mx my =
+ do x <- mx
+ y <- my
+ f c x y
+
+ sDeclareHole _ = blackhole
+ sDelayFill _ = delayFill
+ sSpark _ = evalSpark
+
+ ppBit _ b | b = text "True"
+ | otherwise = text "False"
+
+ ppWord _ = ppBV
+
+ ppInteger _ _opts i = integer i
+
+ ppFloat _ = FP.fpPP
+
+ bitLit _ b = b
+ bitAsLit _ b = Just b
+
+ bitEq _ x y = pure $! x == y
+ bitOr _ x y = pure $! x .|. y
+ bitAnd _ x y = pure $! x .&. y
+ bitXor _ x y = pure $! x `xor` y
+ bitComplement _ x = pure $! complement x
+
+ iteBit _ b x y = pure $! if b then x else y
+ iteWord _ b x y = pure $! if b then x else y
+ iteInteger _ b x y = pure $! if b then x else y
+
+ wordLit _ w i = pure $! mkBv w i
+ wordAsLit _ (BV w i) = Just (w,i)
+ integerLit _ i = pure i
+ integerAsLit _ = Just
+
+ wordToInt _ (BV _ x) = pure x
+ wordFromInt _ w x = pure $! mkBv w x
+
+ packWord _ bits = pure $! BV (toInteger w) a
+ where
+ w = case length bits of
+ len | toInteger len >= Arch.maxBigIntWidth -> wordTooWide (toInteger len)
+ | otherwise -> len
+ 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) = pure [ testBit a n | n <- [w' - 1, w' - 2 .. 0] ]
+ where
+ w' = fromInteger w
+
+ joinWord _ (BV i x) (BV j y) =
+ pure $! BV (i + j) (shiftL x (fromInteger j) + y)
+
+ splitWord _ leftW rightW (BV _ x) =
+ pure ( BV leftW (x `shiftR` (fromInteger rightW)), mkBv rightW x )
+
+ extractWord _ n i (BV _ x) = pure $! mkBv n (x `shiftR` (fromInteger i))
+
+ wordEq _ (BV i x) (BV j y)
+ | i == j = pure $! x == y
+ | otherwise = panic "Attempt to compare words of different sizes: wordEq" [show i, show j]
+
+ wordSignedLessThan _ (BV i x) (BV j y)
+ | i == j = pure $! signedValue i x < signedValue i y
+ | otherwise = panic "Attempt to compare words of different sizes: wordSignedLessThan" [show i, show j]
+
+ wordLessThan _ (BV i x) (BV j y)
+ | i == j = pure $! x < y
+ | otherwise = panic "Attempt to compare words of different sizes: wordLessThan" [show i, show j]
+
+ wordGreaterThan _ (BV i x) (BV j y)
+ | i == j = pure $! x > y
+ | otherwise = panic "Attempt to compare words of different sizes: wordGreaterThan" [show i, show j]
+
+ wordAnd _ (BV i x) (BV j y)
+ | i == j = pure $! mkBv i (x .&. y)
+ | otherwise = panic "Attempt to AND words of different sizes: wordPlus" [show i, show j]
+
+ wordOr _ (BV i x) (BV j y)
+ | i == j = pure $! mkBv i (x .|. y)
+ | otherwise = panic "Attempt to OR words of different sizes: wordPlus" [show i, show j]
+
+ wordXor _ (BV i x) (BV j y)
+ | i == j = pure $! mkBv i (x `xor` y)
+ | otherwise = panic "Attempt to XOR words of different sizes: wordPlus" [show i, show j]
+
+ wordComplement _ (BV i x) = pure $! mkBv i (complement x)
+
+ wordPlus _ (BV i x) (BV j y)
+ | i == j = pure $! mkBv i (x+y)
+ | otherwise = panic "Attempt to add words of different sizes: wordPlus" [show i, show j]
+
+ wordNegate _ (BV i x) = pure $! mkBv i (negate x)
+
+ wordMinus _ (BV i x) (BV j y)
+ | i == j = pure $! mkBv i (x-y)
+ | otherwise = panic "Attempt to subtract words of different sizes: wordMinus" [show i, show j]
+
+ wordMult _ (BV i x) (BV j y)
+ | i == j = pure $! mkBv i (x*y)
+ | otherwise = panic "Attempt to multiply words of different sizes: wordMult" [show i, show j]
+
+ wordDiv sym (BV i x) (BV j y)
+ | i == 0 && j == 0 = pure $! mkBv 0 0
+ | i == j =
+ do assertSideCondition sym (y /= 0) DivideByZero
+ pure $! mkBv i (x `div` y)
+ | otherwise = panic "Attempt to divide words of different sizes: wordDiv" [show i, show j]
+
+ wordMod sym (BV i x) (BV j y)
+ | i == 0 && j == 0 = pure $! mkBv 0 0
+ | i == j =
+ do assertSideCondition sym (y /= 0) DivideByZero
+ pure $! mkBv i (x `mod` y)
+ | otherwise = panic "Attempt to mod words of different sizes: wordMod" [show i, show j]
+
+ wordSignedDiv sym (BV i x) (BV j y)
+ | i == 0 && j == 0 = pure $! mkBv 0 0
+ | i == j =
+ do assertSideCondition sym (y /= 0) DivideByZero
+ let sx = signedValue i x
+ sy = signedValue i y
+ pure $! mkBv i (sx `quot` sy)
+ | otherwise = panic "Attempt to divide words of different sizes: wordSignedDiv" [show i, show j]
+
+ wordSignedMod sym (BV i x) (BV j y)
+ | i == 0 && j == 0 = pure $! mkBv 0 0
+ | i == j =
+ do assertSideCondition sym (y /= 0) DivideByZero
+ let sx = signedValue i x
+ sy = signedValue i y
+ pure $! mkBv i (sx `rem` sy)
+ | otherwise = panic "Attempt to mod words of different sizes: wordSignedMod" [show i, show j]
+
+ wordLg2 _ (BV i x) = pure $! mkBv i (lg2 x)
+
+ intEq _ x y = pure $! x == y
+ intLessThan _ x y = pure $! x < y
+ intGreaterThan _ x y = pure $! x > y
+
+ intPlus _ x y = pure $! x + y
+ intMinus _ x y = pure $! x - y
+ intNegate _ x = pure $! negate x
+ intMult _ x y = pure $! x * y
+ intDiv sym x y =
+ do assertSideCondition sym (y /= 0) DivideByZero
+ pure $! x `div` y
+ intMod sym x y =
+ do assertSideCondition sym (y /= 0) DivideByZero
+ pure $! x `mod` y
+
+ intToZn _ 0 _ = evalPanic "intToZn" ["0 modulus not allowed"]
+ intToZn _ m x = pure $! x `mod` m
+
+ -- NB: requires we maintain the invariant that
+ -- Z_n is in reduced form
+ znToInt _ _m x = pure x
+ znEq _ _m x y = pure $! x == y
+
+ -- NB: under the precondition that `m` is prime,
+ -- the only values for which no inverse exists are
+ -- congruent to 0 modulo m.
+ znRecip sym m x
+ | r == 0 = raiseError sym DivideByZero
+ | otherwise = pure r
+ where
+ r = Integer.recipModInteger x m
+
+ znPlus _ = liftBinIntMod (+)
+ znMinus _ = liftBinIntMod (-)
+ znMult _ = liftBinIntMod (*)
+ znNegate _ 0 _ = evalPanic "znNegate" ["0 modulus not allowed"]
+ znNegate _ m x = pure $! (negate x) `mod` m
+
+ ------------------------------------------------------------------------
+ -- Floating Point
+ fpLit _sym e p rat = pure (FP.fpLit e p rat)
+ fpExactLit _sym bf = pure bf
+ fpEq _sym x y = pure (FP.bfValue x == FP.bfValue y)
+ fpLogicalEq _sym x y = pure (FP.bfCompare (FP.bfValue x) (FP.bfValue y) == EQ)
+ fpLessThan _sym x y = pure (FP.bfValue x < FP.bfValue y)
+ fpGreaterThan _sym x y = pure (FP.bfValue x > FP.bfValue y)
+ fpPlus = fpBinArith FP.bfAdd
+ fpMinus = fpBinArith FP.bfSub
+ fpMult = fpBinArith FP.bfMul
+ fpDiv = fpBinArith FP.bfDiv
+ fpNeg _ x = pure x { FP.bfValue = FP.bfNeg (FP.bfValue x) }
+ fpFromInteger sym e p r x =
+ do opts <- FP.fpOpts e p <$> fpRoundMode sym r
+ pure FP.BF { FP.bfExpWidth = e
+ , FP.bfPrecWidth = p
+ , FP.bfValue = FP.fpCheckStatus $
+ FP.bfRoundInt opts (FP.bfFromInteger x)
+ }
+ fpToInteger = fpCvtToInteger
+
+
+{-# INLINE liftBinIntMod #-}
+liftBinIntMod :: Monad m =>
+ (Integer -> Integer -> Integer) -> Integer -> Integer -> Integer -> m Integer
+liftBinIntMod op m x y
+ | m == 0 = evalPanic "znArithmetic" ["0 modulus not allowed"]
+ | otherwise = pure $ (op x y) `mod` m
+
+
+
+{-# INLINE fpBinArith #-}
+fpBinArith ::
+ (FP.BFOpts -> FP.BigFloat -> FP.BigFloat -> (FP.BigFloat, FP.Status)) ->
+ Concrete ->
+ SWord Concrete {- ^ Rouding mode -} ->
+ SFloat Concrete ->
+ SFloat Concrete ->
+ SEval Concrete (SFloat Concrete)
+fpBinArith fun = \sym r x y ->
+ do opts <- FP.fpOpts (FP.bfExpWidth x) (FP.bfPrecWidth x)
+ <$> fpRoundMode sym r
+ pure x { FP.bfValue = FP.fpCheckStatus
+ (fun opts (FP.bfValue x) (FP.bfValue y)) }
+
+fpCvtToInteger ::
+ Concrete ->
+ String ->
+ SWord Concrete {- ^ Rounding mode -} ->
+ SFloat Concrete ->
+ SEval Concrete (SInteger Concrete)
+fpCvtToInteger sym fun rnd flt =
+ do mode <- fpRoundMode sym rnd
+ case FP.floatToInteger fun mode flt of
+ Right i -> pure i
+ Left err -> raiseError sym err
+
+fpRoundMode :: Concrete -> SWord Concrete -> SEval Concrete FP.RoundMode
+fpRoundMode sym w =
+ case FP.fpRound (bvVal w) of
+ Left err -> raiseError sym err
+ Right a -> pure a
+
+
+
+
+
diff --git a/src/Cryptol/Backend/FloatHelpers.hs b/src/Cryptol/Backend/FloatHelpers.hs
new file mode 100644
--- /dev/null
+++ b/src/Cryptol/Backend/FloatHelpers.hs
@@ -0,0 +1,248 @@
+{-# Language BlockArguments, OverloadedStrings #-}
+{-# Language BangPatterns #-}
+module Cryptol.Backend.FloatHelpers where
+
+import Data.Ratio(numerator,denominator)
+import Data.Int(Int64)
+import Data.Bits(testBit,setBit,shiftL,shiftR,(.&.),(.|.))
+import LibBF
+
+import Cryptol.Utils.PP
+import Cryptol.Utils.Panic(panic)
+import Cryptol.Backend.Monad( EvalError(..)
+ , PPOpts(..), PPFloatFormat(..), PPFloatExp(..)
+ )
+
+
+data BF = BF
+ { bfExpWidth :: Integer
+ , bfPrecWidth :: Integer
+ , bfValue :: BigFloat
+ }
+
+
+-- | Make LibBF options for the given precision and rounding mode.
+fpOpts :: Integer -> Integer -> RoundMode -> BFOpts
+fpOpts e p r =
+ case ok of
+ Just opts -> opts
+ Nothing -> panic "floatOpts" [ "Invalid Float size"
+ , "exponent: " ++ show e
+ , "precision: " ++ show p
+ ]
+ where
+ ok = do eb <- rng expBits expBitsMin expBitsMax e
+ pb <- rng precBits precBitsMin precBitsMax p
+ pure (eb <> pb <> allowSubnormal <> rnd r)
+
+ rng f a b x = if toInteger a <= x && x <= toInteger b
+ then Just (f (fromInteger x))
+ else Nothing
+
+
+
+-- | Mapping from the rounding modes defined in the `Float.cry` to
+-- the rounding modes of `LibBF`.
+fpRound :: Integer -> Either EvalError RoundMode
+fpRound n =
+ case n of
+ 0 -> Right NearEven
+ 1 -> Right NearAway
+ 2 -> Right ToPosInf
+ 3 -> Right ToNegInf
+ 4 -> Right ToZero
+ _ -> Left (BadRoundingMode n)
+
+-- | Check that we didn't get an unexpected status.
+fpCheckStatus :: (BigFloat,Status) -> BigFloat
+fpCheckStatus (r,s) =
+ case s of
+ MemError -> panic "checkStatus" [ "libBF: Memory error" ]
+ _ -> r
+
+
+-- | Pretty print a float
+fpPP :: PPOpts -> BF -> Doc
+fpPP opts bf =
+ case bfSign num of
+ Nothing -> "fpNaN"
+ Just s
+ | bfIsFinite num -> text hacStr
+ | otherwise ->
+ case s of
+ Pos -> "fpPosInf"
+ Neg -> "fpNegInf"
+ where
+ num = bfValue bf
+ precW = bfPrecWidth bf
+
+ base = useFPBase opts
+
+ withExp :: PPFloatExp -> ShowFmt -> ShowFmt
+ withExp e f = case e of
+ AutoExponent -> f
+ ForceExponent -> f <> forceExp
+
+ str = bfToString base fmt num
+ fmt = addPrefix <> showRnd NearEven <>
+ case useFPFormat opts of
+ FloatFree e -> withExp e $ showFreeMin
+ $ Just $ fromInteger precW
+ FloatFixed n e -> withExp e $ showFixed $ fromIntegral n
+ FloatFrac n -> showFrac $ fromIntegral n
+
+ -- non-base 10 literals are not overloaded so we add an explicit
+ -- .0 if one is not present.
+ hacStr
+ | base == 10 || elem '.' str = str
+ | otherwise = case break (== 'p') str of
+ (xs,ys) -> xs ++ ".0" ++ ys
+
+
+-- | Make a literal
+fpLit ::
+ Integer {- ^ Exponent width -} ->
+ Integer {- ^ Precision width -} ->
+ Rational ->
+ BF
+fpLit e p rat = floatFromRational e p NearEven rat
+
+-- | Make a floating point number from a rational, using the given rounding mode
+floatFromRational :: Integer -> Integer -> RoundMode -> Rational -> BF
+floatFromRational e p r rat =
+ BF { bfExpWidth = e
+ , bfPrecWidth = p
+ , bfValue = fpCheckStatus
+ if den == 1 then bfRoundFloat opts num
+ else bfDiv opts num (bfFromInteger den)
+ }
+ where
+ opts = fpOpts e p r
+
+ num = bfFromInteger (numerator rat)
+ den = denominator rat
+
+
+-- | Convert a floating point number to a rational, if possible.
+floatToRational :: String -> BF -> Either EvalError Rational
+floatToRational fun bf =
+ case bfToRep (bfValue bf) of
+ BFNaN -> Left (BadValue fun)
+ BFRep s num ->
+ case num of
+ Inf -> Left (BadValue fun)
+ Zero -> Right 0
+ Num i ev -> Right case s of
+ Pos -> ab
+ Neg -> negate ab
+ where ab = fromInteger i * (2 ^^ ev)
+
+
+-- | Convert a floating point number to an integer, if possible.
+floatToInteger :: String -> RoundMode -> BF -> Either EvalError Integer
+floatToInteger fun r fp =
+ do rat <- floatToRational fun fp
+ pure case r of
+ NearEven -> round rat
+ NearAway -> if rat > 0 then ceiling rat else floor rat
+ ToPosInf -> ceiling rat
+ ToNegInf -> floor rat
+ ToZero -> truncate rat
+ _ -> panic "fpCvtToInteger"
+ ["Unexpected rounding mode", show r]
+
+
+
+
+floatFromBits ::
+ Integer {- ^ Exponent width -} ->
+ Integer {- ^ Precision widht -} ->
+ Integer {- ^ Raw bits -} ->
+ BF
+floatFromBits e p bv = BF { bfValue = floatFromBits' e p bv
+ , bfExpWidth = e, bfPrecWidth = p }
+
+
+
+-- | Make a float using "raw" bits.
+floatFromBits' ::
+ Integer {- ^ Exponent width -} ->
+ Integer {- ^ Precision widht -} ->
+ Integer {- ^ Raw bits -} ->
+ BigFloat
+
+floatFromBits' e p bits
+ | expoBiased == 0 && mant == 0 = -- zero
+ if isNeg then bfNegZero else bfPosZero
+
+ | expoBiased == eMask && mant == 0 = -- infinity
+ if isNeg then bfNegInf else bfPosInf
+
+ | expoBiased == eMask = bfNaN -- NaN
+
+ | expoBiased == 0 = -- Subnormal
+ case bfMul2Exp opts (bfFromInteger mant) (expoVal + 1) of
+ (num,Ok) -> if isNeg then bfNeg num else num
+ (_,s) -> panic "floatFromBits" [ "Unexpected status: " ++ show s ]
+
+ | otherwise = -- Normal
+ case bfMul2Exp opts (bfFromInteger mantVal) expoVal of
+ (num,Ok) -> if isNeg then bfNeg num else num
+ (_,s) -> panic "floatFromBits" [ "Unexpected status: " ++ show s ]
+
+ where
+ opts = expBits e' <> precBits (p' + 1) <> allowSubnormal
+
+ e' = fromInteger e :: Int
+ p' = fromInteger p - 1 :: Int
+ eMask = (1 `shiftL` e') - 1 :: Int64
+ pMask = (1 `shiftL` p') - 1 :: Integer
+
+ isNeg = testBit bits (e' + p')
+
+ mant = pMask .&. bits :: Integer
+ mantVal = mant `setBit` p' :: Integer
+ -- accounts for the implicit 1 bit
+
+ expoBiased = eMask .&. fromInteger (bits `shiftR` p') :: Int64
+ bias = eMask `shiftR` 1 :: Int64
+ expoVal = expoBiased - bias - fromIntegral p' :: Int64
+
+
+-- | Turn a float into raw bits.
+-- @NaN@ is represented as a positive "quiet" @NaN@
+-- (most significant bit in the significand is set, the rest of it is 0)
+floatToBits :: Integer -> Integer -> BigFloat -> Integer
+floatToBits e p bf = (isNeg `shiftL` (e' + p'))
+ .|. (expBiased `shiftL` p')
+ .|. (mant `shiftL` 0)
+ where
+ e' = fromInteger e :: Int
+ p' = fromInteger p - 1 :: Int
+
+ eMask = (1 `shiftL` e') - 1 :: Integer
+ pMask = (1 `shiftL` p') - 1 :: Integer
+
+ (isNeg, expBiased, mant) =
+ case bfToRep bf of
+ BFNaN -> (0, eMask, 1 `shiftL` (p' - 1))
+ BFRep s num -> (sign, be, ma)
+ where
+ sign = case s of
+ Neg -> 1
+ Pos -> 0
+
+ (be,ma) =
+ case num of
+ Zero -> (0,0)
+ Num i ev
+ | ex == 0 -> (0, i `shiftL` (p' - m -1))
+ | otherwise -> (ex, (i `shiftL` (p' - m)) .&. pMask)
+ where
+ m = msb 0 i - 1
+ bias = eMask `shiftR` 1
+ ex = toInteger ev + bias + toInteger m
+
+ Inf -> (eMask,0)
+
+ msb !n j = if j == 0 then n else msb (n+1) (j `shiftR` 1)
diff --git a/src/Cryptol/Backend/Monad.hs b/src/Cryptol/Backend/Monad.hs
new file mode 100644
--- /dev/null
+++ b/src/Cryptol/Backend/Monad.hs
@@ -0,0 +1,394 @@
+-- |
+-- Module : Cryptol.Eval.Monad
+-- Copyright : (c) 2013-2016 Galois, Inc.
+-- License : BSD3
+-- Maintainer : cryptol@galois.com
+-- Stability : provisional
+-- Portability : portable
+
+{-# LANGUAGE Safe #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Cryptol.Backend.Monad
+( -- * Evaluation monad
+ Eval(..)
+, runEval
+, EvalOpts(..)
+, PPOpts(..)
+, asciiMode
+, PPFloatFormat(..)
+, PPFloatExp(..)
+, defaultPPOpts
+, io
+, delayFill
+, ready
+, blackhole
+, evalSpark
+, maybeReady
+ -- * Error reporting
+, Unsupported(..)
+, EvalError(..)
+, evalPanic
+, wordTooWide
+, typeCannotBeDemoted
+) where
+
+import Control.Concurrent
+import Control.Concurrent.STM
+
+import Control.Monad
+import qualified Control.Monad.Fail as Fail
+import Control.Monad.Fix
+import Control.Monad.IO.Class
+import Data.Typeable (Typeable)
+import qualified Control.Exception as X
+
+
+import Cryptol.Utils.Panic
+import Cryptol.Utils.PP
+import Cryptol.Utils.Logger(Logger)
+import Cryptol.TypeCheck.AST(Type,Name)
+
+-- | A computation that returns an already-evaluated value.
+ready :: a -> Eval a
+ready a = Ready a
+
+-- | How to pretty print things when evaluating
+data PPOpts = PPOpts
+ { useAscii :: Bool
+ , useBase :: Int
+ , useInfLength :: Int
+ , useFPBase :: Int
+ , useFPFormat :: PPFloatFormat
+ }
+
+asciiMode :: PPOpts -> Integer -> Bool
+asciiMode opts width = useAscii opts && (width == 7 || width == 8)
+
+data PPFloatFormat =
+ FloatFixed Int PPFloatExp -- ^ Use this many significant digis
+ | FloatFrac Int -- ^ Show this many digits after floating point
+ | FloatFree PPFloatExp -- ^ Use the correct number of digits
+
+data PPFloatExp = ForceExponent -- ^ Always show an exponent
+ | AutoExponent -- ^ Only show exponent when needed
+
+
+defaultPPOpts :: PPOpts
+defaultPPOpts = PPOpts { useAscii = False, useBase = 10, useInfLength = 5
+ , useFPBase = 16
+ , useFPFormat = FloatFree AutoExponent
+ }
+
+
+-- | Some options for evalutaion
+data EvalOpts = EvalOpts
+ { evalLogger :: Logger -- ^ Where to print stuff (e.g., for @trace@)
+ , evalPPOpts :: PPOpts -- ^ How to pretty print things.
+ }
+
+-- | The monad for Cryptol evaluation.
+-- A computation is either "ready", which means it represents
+-- only trivial computation, or is an "eval" action which must
+-- be computed to get the answer, or it is a "thunk", which
+-- represents a delayed, shared computation.
+data Eval a
+ = Ready !a
+ | Eval !(IO a)
+ | Thunk !(TVar (ThunkState a))
+
+-- | This datastructure tracks the lifecycle of a thunk.
+--
+-- Thunks are used for basically three use cases. First,
+-- we use thunks to preserve sharing. Basically every
+-- cryptol expression that is bound to a name, and is not
+-- already obviously a value (and in a few other places as
+-- well) will get turned into a thunk in order to avoid
+-- recomputations. These thunks will start in the `Unforced`
+-- state, and have a backup computation that just raises
+-- the `LoopError` exception.
+--
+-- Secondly, thunks are used to cut cycles when evaluating
+-- recursive definition groups. Every named clause in a
+-- recursive definition is thunked so that the value can appear
+-- in its definition. Such thunks start in the `Void` state,
+-- as they must exist before we have a definition to assign them.
+-- Forcing a thunk in the `Void` state is a programmer error (panic).
+-- Once the body of a definition is ready, we replace the
+-- thunk with the relevant computation, going to the `Unforced` state.
+--
+-- In the third case, we are using thunks to provide an optimistic
+-- shortcut for evaluation. In these cases we first try to run a
+-- computation that is stricter than the semantics actually allows.
+-- If it succeeds, all is well an we continue. However, if it tight
+-- loops, we fall back on a lazier (and generally more expensive)
+-- version, which is the "backup" computation referred to above.
+data ThunkState a
+ = Void !String
+ -- ^ This thunk has not yet been initialized
+ | Unforced !(IO a) !(IO a)
+ -- ^ This thunk has not yet been forced. We keep track of the "main"
+ -- computation to run and a "backup" computation to run if we
+ -- detect a tight loop when evaluating the first one.
+ | UnderEvaluation !ThreadId !(IO a)
+ -- ^ This thunk is currently being evaluated by the thread with the given
+ -- thread ID. We track the "backup" computation to run if we detect
+ -- a tight loop evaluating this thunk. If the thunk is being evaluated
+ -- by some other thread, the current thread will await its completion.
+ | ForcedErr !EvalError
+ -- ^ This thunk has been forced, and its evaluation results in an exception
+ | Forced !a
+ -- ^ This thunk has been forced to the given value
+
+
+-- | Test if a value is "ready", which means that
+-- it requires no computation to return.
+maybeReady :: Eval a -> Eval (Maybe a)
+maybeReady (Ready a) = pure (Just a)
+maybeReady (Thunk tv) = Eval $
+ readTVarIO tv >>= \case
+ Forced a -> pure (Just a)
+ _ -> pure Nothing
+maybeReady (Eval _) = pure Nothing
+
+
+{-# 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 e@(Ready _) _ = return e
+delayFill e@(Thunk _) _ = return e
+delayFill (Eval x) backup = Eval (Thunk <$> newTVarIO (Unforced x (runEval backup)))
+
+-- | Begin executing the given operation in a separate thread,
+-- returning a thunk which will await the completion of
+-- the computation when forced.
+evalSpark ::
+ Eval a ->
+ Eval (Eval a)
+
+-- Ready computations need no additional evaluation.
+evalSpark e@(Ready _) = return e
+
+-- A thunked computation might already have
+-- been forced. If so, return the result. Otherwise,
+-- fork a thread to force this computation and return
+-- the thunk.
+evalSpark (Thunk tv) = Eval $
+ readTVarIO tv >>= \case
+ Forced x -> return (Ready x)
+ ForcedErr ex -> return (Eval (X.throwIO ex))
+ _ ->
+ do _ <- forkIO (sparkThunk tv)
+ return (Thunk tv)
+
+-- If the computation is nontrivial but not already a thunk,
+-- create a thunk and fork a thread to force it.
+evalSpark (Eval x) = Eval $
+ do tv <- newTVarIO (Unforced x (X.throwIO (LoopError "")))
+ _ <- forkIO (sparkThunk tv)
+ return (Thunk tv)
+
+
+-- | To the work of forcing a thunk. This is the worker computation
+-- that is foked off via @evalSpark@.
+sparkThunk :: TVar (ThunkState a) -> IO ()
+sparkThunk tv =
+ do tid <- myThreadId
+ -- Try to claim the thunk. If it is still in the @Void@ state, wait
+ -- until it is in some other state. If it is @Unforced@ claim the thunk.
+ -- Otherwise, it is already evaluated or under evaluation by another thread,
+ -- and we have no work to do.
+ st <- atomically $
+ do st <- readTVar tv
+ case st of
+ Void _ -> retry
+ Unforced _ backup -> writeTVar tv (UnderEvaluation tid backup)
+ _ -> return ()
+ return st
+ -- If we successfully claimed the thunk to work on, run the computation and
+ -- update the thunk state with the result.
+ case st of
+ Unforced work _ ->
+ X.try work >>= \case
+ Left err -> atomically (writeTVar tv (ForcedErr err))
+ Right a -> atomically (writeTVar tv (Forced a))
+ _ -> return ()
+
+
+-- | 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 = Eval $
+ do tv <- newTVarIO (Void msg)
+ let set (Ready x) = io $ atomically (writeTVar tv (Forced x))
+ set m = io $ atomically (writeTVar tv (Unforced (runEval m) (X.throwIO (LoopError msg))))
+ return (Thunk tv, set)
+
+-- | Force a thunk to get the result.
+unDelay :: TVar (ThunkState a) -> IO a
+unDelay tv =
+ -- First, check if the thunk is in an evaluated state,
+ -- and return the value if so.
+ readTVarIO tv >>= \case
+ Forced x -> pure x
+ ForcedErr e -> X.throwIO e
+ _ ->
+ -- Otherwise, try to claim the thunk to work on.
+ do tid <- myThreadId
+ res <- atomically $ do
+ res <- readTVar tv
+ case res of
+ -- In this case, we claim the thunk. Update the state to indicate
+ -- that we are working on it.
+ Unforced _ backup -> writeTVar tv (UnderEvaluation tid backup)
+
+ -- In this case, the thunk is already being evaluated. If it is
+ -- under evaluation by this thread, we have to run the backup computation,
+ -- and "consume" it by updating the backup computation to one that throws
+ -- a loop error. If some other thread is evaluating, reset the
+ -- transaction to await completion of the thunk.
+ UnderEvaluation t _
+ | tid == t -> writeTVar tv (UnderEvaluation tid (X.throwIO (LoopError "")))
+ | otherwise -> retry -- wait, if some other thread is evaualting
+ _ -> return ()
+
+ -- Return the original thunk state so we can decide what work to do
+ -- after the transaction completes.
+ return res
+
+ -- helper for actually doing the work
+ let doWork work =
+ X.try work >>= \case
+ Left ex -> do atomically (writeTVar tv (ForcedErr ex))
+ X.throwIO ex
+ Right a -> do atomically (writeTVar tv (Forced a))
+ return a
+
+ -- Now, examine the thunk state and decide what to do.
+ case res of
+ Void msg -> evalPanic "unDelay" ["Thunk forced before it was initialized", msg]
+ Forced x -> pure x
+ ForcedErr e -> X.throwIO e
+ UnderEvaluation _ backup -> doWork backup -- this thread was already evaluating this thunk
+ Unforced work _ -> doWork work
+
+-- | Execute the given evaluation action.
+runEval :: Eval a -> IO a
+runEval (Ready a) = return a
+runEval (Eval x) = x
+runEval (Thunk tv) = unDelay tv
+
+{-# INLINE evalBind #-}
+evalBind :: Eval a -> (a -> Eval b) -> Eval b
+evalBind (Ready a) f = f a
+evalBind (Eval x) f = Eval (x >>= runEval . f)
+evalBind (Thunk x) f = Eval (unDelay x >>= runEval . f)
+
+instance Functor Eval where
+ fmap f (Ready x) = Ready (f x)
+ fmap f (Eval m) = Eval (f <$> m)
+ fmap f (Thunk tv) = Eval (f <$> unDelay tv)
+ {-# INLINE fmap #-}
+
+instance Applicative Eval where
+ pure = return
+ (<*>) = ap
+ {-# INLINE pure #-}
+ {-# INLINE (<*>) #-}
+
+instance Monad Eval where
+ return = Ready
+ (>>=) = evalBind
+ {-# INLINE return #-}
+ {-# INLINE (>>=) #-}
+
+instance Fail.MonadFail Eval where
+ fail x = Eval (fail x)
+
+instance MonadIO Eval where
+ liftIO = io
+
+instance MonadFix Eval where
+ mfix f = Eval $ mfix (\x -> runEval (f x))
+
+-- | Lift an 'IO' computation into the 'Eval' monad.
+io :: IO a -> Eval a
+io m = Eval m
+{-# INLINE io #-}
+
+
+-- Errors ----------------------------------------------------------------------
+
+-- | Panic from an @Eval@ context.
+evalPanic :: HasCallStack => String -> [String] -> a
+evalPanic cxt = panic ("[Eval] " ++ cxt)
+
+
+-- | Data type describing errors that can occur during evaluation.
+data EvalError
+ = InvalidIndex (Maybe Integer) -- ^ Out-of-bounds index
+ | TypeCannotBeDemoted Type -- ^ Non-numeric type passed to @number@ function
+ | DivideByZero -- ^ Division or modulus by 0
+ | NegativeExponent -- ^ Exponentiation by negative integer
+ | LogNegative -- ^ Logarithm of a negative integer
+ | WordTooWide Integer -- ^ Bitvector too large
+ | UserError String -- ^ Call to the Cryptol @error@ primitive
+ | LoopError String -- ^ Detectable nontermination
+ | NoPrim Name -- ^ Primitive with no implementation
+ | BadRoundingMode Integer -- ^ Invalid rounding mode
+ | BadValue String -- ^ Value outside the domain of a partial function.
+ deriving (Typeable,Show)
+
+instance PP EvalError where
+ ppPrec _ e = case e of
+ InvalidIndex (Just i) -> text "invalid sequence index:" <+> integer i
+ InvalidIndex Nothing -> text "invalid sequence index"
+ TypeCannotBeDemoted t -> text "type cannot be demoted:" <+> pp t
+ DivideByZero -> text "division by 0"
+ NegativeExponent -> text "negative exponent"
+ LogNegative -> text "logarithm of negative"
+ WordTooWide w ->
+ text "word too wide for memory:" <+> integer w <+> text "bits"
+ UserError x -> text "Run-time error:" <+> text x
+ LoopError x -> text "<>" <+> text x
+ BadRoundingMode r -> "invalid rounding mode" <+> integer r
+ BadValue x -> "invalid input for" <+> backticks (text x)
+ NoPrim x -> text "unimplemented primitive:" <+> pp x
+
+instance X.Exception EvalError
+
+
+data Unsupported
+ = UnsupportedSymbolicOp String -- ^ Operation cannot be supported in the symbolic simulator
+ deriving (Typeable,Show)
+
+instance PP Unsupported where
+ ppPrec _ e = case e of
+ UnsupportedSymbolicOp nm -> text "operation can not be supported on symbolic values:" <+> text nm
+
+instance X.Exception Unsupported
+
+
+-- | For things like @`(inf)@ or @`(0-1)@.
+typeCannotBeDemoted :: Type -> a
+typeCannotBeDemoted t = X.throw (TypeCannotBeDemoted t)
+
+-- | 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)
diff --git a/src/Cryptol/Backend/SBV.hs b/src/Cryptol/Backend/SBV.hs
new file mode 100644
--- /dev/null
+++ b/src/Cryptol/Backend/SBV.hs
@@ -0,0 +1,457 @@
+-- |
+-- Module : Cryptol.Backend.SBV
+-- Copyright : (c) 2013-2016 Galois, Inc.
+-- License : BSD3
+-- Maintainer : cryptol@galois.com
+-- Stability : provisional
+-- Portability : portable
+
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE ViewPatterns #-}
+module Cryptol.Backend.SBV
+ ( SBV(..), SBVEval(..), SBVResult(..)
+ , literalSWord
+ , freshSBool_
+ , freshBV_
+ , freshSInteger_
+ , addDefEqn
+ , ashr
+ , lshr
+ , shl
+ , evalPanic
+ , svFromInteger
+ , svToInteger
+ ) where
+
+import qualified Control.Exception as X
+import Control.Concurrent.MVar
+import Control.Monad.IO.Class (MonadIO(..))
+import Data.Bits (bit, complement)
+import Data.List (foldl')
+
+import qualified GHC.Integer.GMP.Internals as Integer
+
+import Data.SBV.Dynamic as SBV
+import qualified Data.SBV.Internals as SBV
+
+import Cryptol.Backend
+import Cryptol.Backend.Concrete ( integerToChar, ppBV, BV(..) )
+import Cryptol.Backend.Monad
+ ( Eval(..), blackhole, delayFill, evalSpark
+ , EvalError(..), Unsupported(..)
+ )
+
+import Cryptol.Utils.Panic (panic)
+import Cryptol.Utils.PP
+
+data SBV =
+ SBV
+ { sbvStateVar :: MVar (SBV.State)
+ , sbvDefRelations :: MVar SVal
+ }
+
+-- Utility operations -------------------------------------------------------------
+
+fromBitsLE :: [SBit SBV] -> SWord SBV
+fromBitsLE bs = foldl' f (literalSWord 0 0) bs
+ where f w b = svJoin (svToWord1 b) w
+
+packSBV :: [SBit SBV] -> SWord SBV
+packSBV bs = fromBitsLE (reverse bs)
+
+unpackSBV :: SWord SBV -> [SBit SBV]
+unpackSBV x = [ svTestBit x i | i <- reverse [0 .. intSizeOf x - 1] ]
+
+literalSWord :: Int -> Integer -> SWord SBV
+literalSWord w i = svInteger (KBounded False w) i
+
+freshBV_ :: SBV -> Int -> IO (SWord SBV)
+freshBV_ (SBV stateVar _) w =
+ withMVar stateVar (svMkSymVar Nothing (KBounded False w) Nothing)
+
+freshSBool_ :: SBV -> IO (SBit SBV)
+freshSBool_ (SBV stateVar _) =
+ withMVar stateVar (svMkSymVar Nothing KBool Nothing)
+
+freshSInteger_ :: SBV -> IO (SInteger SBV)
+freshSInteger_ (SBV stateVar _) =
+ withMVar stateVar (svMkSymVar Nothing KUnbounded Nothing)
+
+
+-- SBV Evaluation monad -------------------------------------------------------
+
+data SBVResult a
+ = SBVError !EvalError
+ | SBVResult !SVal !a -- safety predicate and result
+
+instance Functor SBVResult where
+ fmap _ (SBVError err) = SBVError err
+ fmap f (SBVResult p x) = SBVResult p (f x)
+
+instance Applicative SBVResult where
+ pure = SBVResult svTrue
+ SBVError err <*> _ = SBVError err
+ _ <*> SBVError err = SBVError err
+ SBVResult p1 f <*> SBVResult p2 x = SBVResult (svAnd p1 p2) (f x)
+
+instance Monad SBVResult where
+ return = pure
+ SBVError err >>= _ = SBVError err
+ SBVResult px x >>= m =
+ case m x of
+ SBVError err -> SBVError err
+ SBVResult pm z -> SBVResult (svAnd px pm) z
+
+newtype SBVEval a = SBVEval{ sbvEval :: Eval (SBVResult a) }
+ deriving (Functor)
+
+instance Applicative SBVEval where
+ pure = SBVEval . pure . pure
+ f <*> x = SBVEval $
+ do f' <- sbvEval f
+ x' <- sbvEval x
+ pure (f' <*> x')
+
+instance Monad SBVEval where
+ return = pure
+ x >>= f = SBVEval $
+ sbvEval x >>= \case
+ SBVError err -> pure (SBVError err)
+ SBVResult px x' ->
+ sbvEval (f x') >>= \case
+ SBVError err -> pure (SBVError err)
+ SBVResult pz z -> pure (SBVResult (svAnd px pz) z)
+
+instance MonadIO SBVEval where
+ liftIO m = SBVEval $ fmap pure (liftIO m)
+
+
+addDefEqn :: SBV -> SVal -> IO ()
+addDefEqn (SBV _ relsVar) b = modifyMVar_ relsVar (pure . svAnd b)
+
+-- Symbolic Big-endian Words -------------------------------------------------------
+
+instance Backend SBV where
+ type SBit SBV = SVal
+ type SWord SBV = SVal
+ type SInteger SBV = SVal
+ type SFloat SBV = () -- XXX: not implemented
+ type SEval SBV = SBVEval
+
+ raiseError _ err = SBVEval (pure (SBVError err))
+
+ assertSideCondition _ cond err
+ | Just False <- svAsBool cond = SBVEval (pure (SBVError err))
+ | otherwise = SBVEval (pure (SBVResult cond ()))
+
+ isReady _ (SBVEval (Ready _)) = True
+ isReady _ _ = False
+
+ sDelayFill _ m retry = SBVEval $
+ do m' <- delayFill (sbvEval m) (sbvEval retry)
+ pure (pure (SBVEval m'))
+
+ sSpark _ m = SBVEval $
+ do m' <- evalSpark (sbvEval m)
+ pure (pure (SBVEval m'))
+
+ sDeclareHole _ msg = SBVEval $
+ do (hole, fill) <- blackhole msg
+ pure (pure (SBVEval hole, \m -> SBVEval (fmap pure $ fill (sbvEval m))))
+
+ mergeEval _sym f c mx my = SBVEval $
+ do rx <- sbvEval mx
+ ry <- sbvEval my
+ case (rx, ry) of
+ (SBVError err, SBVError _) ->
+ pure $ SBVError err -- arbitrarily choose left error to report
+ (SBVError _, SBVResult p y) ->
+ pure $ SBVResult (svAnd (svNot c) p) y
+ (SBVResult p x, SBVError _) ->
+ pure $ SBVResult (svAnd c p) x
+ (SBVResult px x, SBVResult py y) ->
+ do zr <- sbvEval (f c x y)
+ case zr of
+ SBVError err -> pure $ SBVError err
+ SBVResult pz z ->
+ pure $ SBVResult (svAnd (svIte c px py) pz) z
+
+ 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 sym opts v
+ | Just x <- svAsInteger v = ppBV opts (BV (wordLen sym v) x)
+ | otherwise = text "[?]"
+ ppInteger _ _opts v
+ | Just x <- svAsInteger v = integer x
+ | otherwise = text "[?]"
+
+ iteBit _ b x y = pure $! svSymbolicMerge KBool True b x y
+ iteWord _ b x y = pure $! svSymbolicMerge (kindOf x) True b x y
+ iteInteger _ b x y = pure $! svSymbolicMerge KUnbounded True b x y
+
+ bitAsLit _ b = svAsBool b
+ wordAsLit _ w =
+ case svAsInteger w of
+ Just x -> Just (toInteger (intSizeOf w), x)
+ Nothing -> Nothing
+ integerAsLit _ v = svAsInteger v
+
+ bitLit _ b = svBool b
+ wordLit _ n x = pure $! literalSWord (fromInteger n) x
+ integerLit _ x = pure $! svInteger KUnbounded x
+
+ bitEq _ x y = pure $! svEqual x y
+ bitOr _ x y = pure $! svOr x y
+ bitAnd _ x y = pure $! svAnd x y
+ bitXor _ x y = pure $! svXOr x y
+ bitComplement _ x = pure $! svNot x
+
+ wordBit _ x idx = pure $! svTestBit x (intSizeOf x - 1 - fromInteger idx)
+
+ wordUpdate _ x idx b = pure $! svSymbolicMerge (kindOf x) False b wtrue wfalse
+ where
+ i' = intSizeOf x - 1 - fromInteger idx
+ wtrue = x `svOr` svInteger (kindOf x) (bit i' :: Integer)
+ wfalse = x `svAnd` svInteger (kindOf x) (complement (bit i' :: Integer))
+
+ packWord _ bs = pure $! packSBV bs
+ unpackWord _ x = pure $! unpackSBV x
+
+ wordEq _ x y = pure $! svEqual x y
+ wordLessThan _ x y = pure $! svLessThan x y
+ wordGreaterThan _ x y = pure $! svGreaterThan x y
+
+ wordSignedLessThan _ x y = pure $! svLessThan sx sy
+ where sx = svSign x
+ sy = svSign y
+
+ joinWord _ x y = pure $! svJoin x y
+
+ splitWord _ _leftW rightW w = pure
+ ( svExtract (intSizeOf w - 1) (fromInteger rightW) w
+ , svExtract (fromInteger rightW - 1) 0 w
+ )
+
+ extractWord _ len start w =
+ pure $! svExtract (fromInteger start + fromInteger len - 1) (fromInteger start) w
+
+ wordAnd _ a b = pure $! svAnd a b
+ wordOr _ a b = pure $! svOr a b
+ wordXor _ a b = pure $! svXOr a b
+ wordComplement _ a = pure $! svNot a
+
+ wordPlus _ a b = pure $! svPlus a b
+ wordMinus _ a b = pure $! svMinus a b
+ wordMult _ a b = pure $! svTimes a b
+ wordNegate _ a = pure $! svUNeg a
+
+ wordDiv sym a b =
+ do let z = literalSWord (intSizeOf b) 0
+ assertSideCondition sym (svNot (svEqual b z)) DivideByZero
+ pure $! svQuot a b
+
+ wordMod sym a b =
+ do let z = literalSWord (intSizeOf b) 0
+ assertSideCondition sym (svNot (svEqual b z)) DivideByZero
+ pure $! svRem a b
+
+ wordSignedDiv sym a b =
+ do let z = literalSWord (intSizeOf b) 0
+ assertSideCondition sym (svNot (svEqual b z)) DivideByZero
+ pure $! signedQuot a b
+
+ wordSignedMod sym a b =
+ do let z = literalSWord (intSizeOf b) 0
+ assertSideCondition sym (svNot (svEqual b z)) DivideByZero
+ pure $! signedRem a b
+
+ wordLg2 _ a = sLg2 a
+
+ wordToInt _ x = pure $! svToInteger x
+ wordFromInt _ w i = pure $! svFromInteger w i
+
+ intEq _ a b = pure $! svEqual a b
+ intLessThan _ a b = pure $! svLessThan a b
+ intGreaterThan _ a b = pure $! svGreaterThan a b
+
+ intPlus _ a b = pure $! svPlus a b
+ intMinus _ a b = pure $! svMinus a b
+ intMult _ a b = pure $! svTimes a b
+ intNegate _ a = pure $! SBV.svUNeg a
+
+ intDiv sym a b =
+ do let z = svInteger KUnbounded 0
+ assertSideCondition sym (svNot (svEqual b z)) DivideByZero
+ let p = svLessThan z b
+ pure $! svSymbolicMerge KUnbounded True p (svQuot a b) (svQuot (svUNeg a) (svUNeg b))
+ intMod sym a b =
+ do let z = svInteger KUnbounded 0
+ assertSideCondition sym (svNot (svEqual b z)) DivideByZero
+ let p = svLessThan z b
+ pure $! svSymbolicMerge KUnbounded True p (svRem a b) (svUNeg (svRem (svUNeg a) (svUNeg b)))
+
+ -- NB, we don't do reduction here
+ intToZn _ _m a = pure a
+
+ znToInt _ 0 _ = evalPanic "znToInt" ["0 modulus not allowed"]
+ znToInt _ m a =
+ do let m' = svInteger KUnbounded m
+ pure $! svRem a m'
+
+ znEq _ 0 _ _ = evalPanic "znEq" ["0 modulus not allowed"]
+ znEq sym m a b = svDivisible sym m (SBV.svMinus a b)
+
+ znPlus sym m a b = sModAdd sym m a b
+ znMinus sym m a b = sModSub sym m a b
+ znMult sym m a b = sModMult sym m a b
+ znNegate sym m a = sModNegate sym m a
+ znRecip = sModRecip
+
+ ppFloat _ _ _ = text "[?]"
+ fpExactLit _ _ = unsupported "fpExactLit"
+ fpLit _ _ _ _ = unsupported "fpLit"
+ fpLogicalEq _ _ _ = unsupported "fpLogicalEq"
+ fpEq _ _ _ = unsupported "fpEq"
+ fpLessThan _ _ _ = unsupported "fpLessThan"
+ fpGreaterThan _ _ _ = unsupported "fpGreaterThan"
+ fpPlus _ _ _ _ = unsupported "fpPlus"
+ fpMinus _ _ _ _ = unsupported "fpMinus"
+ fpMult _ _ _ _ = unsupported "fpMult"
+ fpDiv _ _ _ _ = unsupported "fpDiv"
+ fpNeg _ _ = unsupported "fpNeg"
+ fpFromInteger _ _ _ _ _ = unsupported "fpFromInteger"
+ fpToInteger _ _ _ _ = unsupported "fpToInteger"
+
+unsupported :: String -> SEval SBV a
+unsupported x = liftIO (X.throw (UnsupportedSymbolicOp x))
+
+
+svToInteger :: SWord SBV -> SInteger SBV
+svToInteger w =
+ case svAsInteger w of
+ Nothing -> svFromIntegral KUnbounded w
+ Just x -> svInteger KUnbounded x
+
+svFromInteger :: Integer -> SInteger SBV -> SWord SBV
+svFromInteger 0 _ = literalSWord 0 0
+svFromInteger n i =
+ case svAsInteger i of
+ Nothing -> svFromIntegral (KBounded False (fromInteger n)) i
+ Just x -> literalSWord (fromInteger n) x
+
+-- Errors ----------------------------------------------------------------------
+
+evalPanic :: String -> [String] -> a
+evalPanic cxt = panic ("[SBV] " ++ cxt)
+
+
+sModAdd :: SBV -> Integer -> SInteger SBV -> SInteger SBV -> SEval SBV (SInteger SBV)
+sModAdd _ 0 _ _ = evalPanic "sModAdd" ["0 modulus not allowed"]
+sModAdd sym modulus x y =
+ case (SBV.svAsInteger x, SBV.svAsInteger y) of
+ (Just i, Just j) -> integerLit sym ((i + j) `mod` modulus)
+ _ -> pure $ SBV.svPlus x y
+
+sModSub :: SBV -> Integer -> SInteger SBV -> SInteger SBV -> SEval SBV (SInteger SBV)
+sModSub _ 0 _ _ = evalPanic "sModSub" ["0 modulus not allowed"]
+sModSub sym modulus x y =
+ case (SBV.svAsInteger x, SBV.svAsInteger y) of
+ (Just i, Just j) -> integerLit sym ((i - j) `mod` modulus)
+ _ -> pure $ SBV.svMinus x y
+
+sModNegate :: SBV -> Integer -> SInteger SBV -> SEval SBV (SInteger SBV)
+sModNegate _ 0 _ = evalPanic "sModNegate" ["0 modulus not allowed"]
+sModNegate sym modulus x =
+ case SBV.svAsInteger x of
+ Just i -> integerLit sym ((negate i) `mod` modulus)
+ _ -> pure $ SBV.svUNeg x
+
+sModMult :: SBV -> Integer -> SInteger SBV -> SInteger SBV -> SEval SBV (SInteger SBV)
+sModMult _ 0 _ _ = evalPanic "sModMult" ["0 modulus not allowed"]
+sModMult sym modulus x y =
+ case (SBV.svAsInteger x, SBV.svAsInteger y) of
+ (Just i, Just j) -> integerLit sym ((i * j) `mod` modulus)
+ _ -> pure $ SBV.svTimes x y
+
+-- Create a fresh constant and assert that it is the
+-- multiplicitive inverse of x; return the constant.
+-- Such an inverse must exist under the precondition
+-- that the modulus is prime and the input is nonzero.
+sModRecip ::
+ SBV ->
+ Integer {- ^ modulus: must be prime -} ->
+ SInteger SBV ->
+ SEval SBV (SInteger SBV)
+sModRecip _sym 0 _ = panic "sModRecip" ["0 modulus not allowed"]
+sModRecip sym m x
+ -- If the input is concrete, evaluate the answer
+ | Just xi <- svAsInteger x
+ = let r = Integer.recipModInteger xi m
+ in if r == 0 then raiseError sym DivideByZero else integerLit sym r
+
+ -- If the input is symbolic, create a new symbolic constant
+ -- and assert that it is the desired multiplicitive inverse.
+ -- Such an inverse will exist under the precondition that
+ -- the modulus is prime, and as long as the input is nonzero.
+ | otherwise
+ = do divZero <- svDivisible sym m x
+ assertSideCondition sym (svNot divZero) DivideByZero
+
+ z <- liftIO (freshSInteger_ sym)
+ let xz = svTimes x z
+ rel <- znEq sym m xz (svInteger KUnbounded 1)
+ let range = svAnd (svLessThan (svInteger KUnbounded 0) z)
+ (svLessThan z (svInteger KUnbounded m))
+ liftIO (addDefEqn sym (svAnd range (svOr divZero rel)))
+
+ return z
+
+-- | Ceiling (log_2 x)
+sLg2 :: SWord SBV -> SEval SBV (SWord SBV)
+sLg2 x = pure $ go 0
+ where
+ lit n = literalSWord (SBV.intSizeOf x) n
+ go i | i < SBV.intSizeOf x = SBV.svIte (SBV.svLessEq x (lit (2^i))) (lit (toInteger i)) (go (i + 1))
+ | otherwise = lit (toInteger i)
+
+svDivisible :: SBV -> Integer -> SInteger SBV -> SEval SBV (SBit SBV)
+svDivisible sym m x =
+ do m' <- integerLit sym m
+ z <- integerLit sym 0
+ pure $ SBV.svEqual (SBV.svRem x m') z
+
+signedQuot :: SWord SBV -> SWord SBV -> SWord SBV
+signedQuot x y = SBV.svUnsign (SBV.svQuot (SBV.svSign x) (SBV.svSign y))
+
+signedRem :: SWord SBV -> SWord SBV -> SWord SBV
+signedRem x y = SBV.svUnsign (SBV.svRem (SBV.svSign x) (SBV.svSign y))
+
+ashr :: SVal -> SVal -> SVal
+ashr x idx =
+ case SBV.svAsInteger idx of
+ Just i -> SBV.svUnsign (SBV.svShr (SBV.svSign x) (fromInteger i))
+ Nothing -> SBV.svUnsign (SBV.svShiftRight (SBV.svSign x) idx)
+
+lshr :: SVal -> SVal -> SVal
+lshr x idx =
+ case SBV.svAsInteger idx of
+ Just i -> SBV.svShr x (fromInteger i)
+ Nothing -> SBV.svShiftRight x idx
+
+shl :: SVal -> SVal -> SVal
+shl x idx =
+ case SBV.svAsInteger idx of
+ Just i -> SBV.svShl x (fromInteger i)
+ Nothing -> SBV.svShiftLeft x idx
diff --git a/src/Cryptol/Backend/What4.hs b/src/Cryptol/Backend/What4.hs
new file mode 100644
--- /dev/null
+++ b/src/Cryptol/Backend/What4.hs
@@ -0,0 +1,666 @@
+-- |
+-- Module : Cryptol.Backend.What4
+-- Copyright : (c) 2020 Galois, Inc.
+-- License : BSD3
+-- Maintainer : cryptol@galois.com
+
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
+module Cryptol.Backend.What4 where
+
+
+import qualified Control.Exception as X
+import Control.Concurrent.MVar
+import Control.Monad (foldM,ap,liftM)
+import Control.Monad.IO.Class
+import Data.Bits (bit)
+import qualified Data.BitVector.Sized as BV
+import Data.List
+import Data.Map (Map)
+import Data.Set (Set)
+import Data.Text (Text)
+import Data.Parameterized.NatRepr
+import Data.Parameterized.Some
+
+import qualified GHC.Integer.GMP.Internals as Integer
+
+import qualified What4.Interface as W4
+import qualified What4.SWord as SW
+
+import qualified Cryptol.Backend.What4.SFloat as FP
+
+import Cryptol.Backend
+import Cryptol.Backend.Concrete( BV(..), ppBV )
+import Cryptol.Backend.FloatHelpers
+import Cryptol.Backend.Monad
+ ( Eval(..), EvalError(..), Unsupported(..)
+ , delayFill, blackhole, evalSpark
+ )
+import Cryptol.Utils.Panic
+import Cryptol.Utils.PP
+
+
+data What4 sym =
+ What4
+ { w4 :: sym
+ , w4defs :: MVar (W4.Pred sym)
+ , w4funs :: MVar (What4FunCache sym)
+ , w4uninterpWarns :: MVar (Set Text)
+ }
+
+type What4FunCache sym = Map Text (SomeSymFn sym)
+
+data SomeSymFn sym =
+ forall args ret. SomeSymFn (W4.SymFn sym args ret)
+
+{- | This is the monad used for symbolic evaluation. It adds to
+aspects to 'Eval'---'WConn' keeps track of the backend and collects
+definitional predicates, and 'W4Eval` adds support for partially
+defined values -}
+newtype W4Eval sym a = W4Eval { evalPartial :: W4Conn sym (W4Result sym a) }
+
+{- | This layer has the symbolic back-end, and can keep track of definitional
+predicates used when working with uninterpreted constants defined
+via a property. -}
+newtype W4Conn sym a = W4Conn { evalConn :: sym -> Eval a }
+
+-- | The symbolic value we computed.
+data W4Result sym a
+ = W4Error !EvalError
+ -- ^ A malformed value
+
+ | W4Result !(W4.Pred sym) !a
+ -- ^ safety predicate and result: the result only makes sense when
+ -- the predicate holds.
+
+
+--------------------------------------------------------------------------------
+-- Moving between the layers
+
+w4Eval :: W4Eval sym a -> sym -> Eval (W4Result sym a)
+w4Eval (W4Eval (W4Conn m)) = m
+
+w4Thunk :: Eval (W4Result sym a) -> W4Eval sym a
+w4Thunk m = W4Eval (W4Conn \_ -> m)
+
+-- | A value with no context.
+doEval :: W4.IsSymExprBuilder sym => Eval a -> W4Conn sym a
+doEval m = W4Conn \_sym -> m
+
+-- | A total value.
+total :: W4.IsSymExprBuilder sym => W4Conn sym a -> W4Eval sym a
+total m = W4Eval
+ do sym <- getSym
+ W4Result (W4.backendPred sym True) <$> m
+
+--------------------------------------------------------------------------------
+-- Operations in WConn
+
+instance W4.IsSymExprBuilder sym => Functor (W4Conn sym) where
+ fmap = liftM
+
+instance W4.IsSymExprBuilder sym => Applicative (W4Conn sym) where
+ pure = doEval . pure
+ (<*>) = ap
+
+instance W4.IsSymExprBuilder sym => Monad (W4Conn sym) where
+ m1 >>= f = W4Conn \sym ->
+ do res1 <- evalConn m1 sym
+ evalConn (f res1) sym
+
+instance W4.IsSymExprBuilder sym => MonadIO (W4Conn sym) where
+ liftIO = doEval . liftIO
+
+-- | Access the symbolic back-end
+getSym :: W4Conn sym sym
+getSym = W4Conn \sym -> pure sym
+
+-- | Record a definition.
+--addDef :: W4.Pred sym -> W4Conn sym ()
+--addDef p = W4Conn \_ -> pure W4Defs { w4Defs = p, w4Result = () }
+
+-- | Compute conjunction.
+w4And :: W4.IsSymExprBuilder sym =>
+ W4.Pred sym -> W4.Pred sym -> W4Conn sym (W4.Pred sym)
+w4And p q =
+ do sym <- getSym
+ liftIO (W4.andPred sym p q)
+
+-- | Compute negation.
+w4Not :: W4.IsSymExprBuilder sym => W4.Pred sym -> W4Conn sym (W4.Pred sym)
+w4Not p =
+ do sym <- getSym
+ liftIO (W4.notPred sym p)
+
+-- | Compute if-then-else.
+w4ITE :: W4.IsSymExprBuilder sym =>
+ W4.Pred sym -> W4.Pred sym -> W4.Pred sym -> W4Conn sym (W4.Pred sym)
+w4ITE ifP ifThen ifElse =
+ do sym <- getSym
+ liftIO (W4.itePred sym ifP ifThen ifElse)
+
+
+
+--------------------------------------------------------------------------------
+-- Operations in W4Eval
+
+instance W4.IsSymExprBuilder sym => Functor (W4Eval sym) where
+ fmap = liftM
+
+instance W4.IsSymExprBuilder sym => Applicative (W4Eval sym) where
+ pure = total . pure
+ (<*>) = ap
+
+instance W4.IsSymExprBuilder sym => Monad (W4Eval sym) where
+ m1 >>= f = W4Eval
+ do res1 <- evalPartial m1
+ case res1 of
+ W4Error err -> pure (W4Error err)
+ W4Result px x' ->
+ do res2 <- evalPartial (f x')
+ case res2 of
+ W4Result py y ->
+ do pz <- w4And px py
+ pure (W4Result pz y)
+ W4Error _ -> pure res2
+
+instance W4.IsSymExprBuilder sym => MonadIO (W4Eval sym) where
+ liftIO = total . liftIO
+
+
+-- | Add a definitional equation.
+-- This will always be asserted when we make queries to the solver.
+addDefEqn :: W4.IsSymExprBuilder sym => What4 sym -> W4.Pred sym -> W4Eval sym ()
+addDefEqn sym p =
+ liftIO (modifyMVar_ (w4defs sym) (W4.andPred (w4 sym) p))
+
+-- | Add s safety condition.
+addSafety :: W4.IsSymExprBuilder sym => W4.Pred sym -> W4Eval sym ()
+addSafety p = W4Eval (pure (W4Result p ()))
+
+-- | A fully undefined symbolic value
+evalError :: W4.IsSymExprBuilder sym => EvalError -> W4Eval sym a
+evalError err = W4Eval (pure (W4Error err))
+
+--------------------------------------------------------------------------------
+
+
+assertBVDivisor :: W4.IsSymExprBuilder sym => What4 sym -> SW.SWord sym -> W4Eval sym ()
+assertBVDivisor sym x =
+ do p <- liftIO (SW.bvIsNonzero (w4 sym) x)
+ assertSideCondition sym p DivideByZero
+
+assertIntDivisor ::
+ W4.IsSymExprBuilder sym => What4 sym -> W4.SymInteger sym -> W4Eval sym ()
+assertIntDivisor sym x =
+ do p <- liftIO (W4.notPred (w4 sym) =<< W4.intEq (w4 sym) x =<< W4.intLit (w4 sym) 0)
+ assertSideCondition sym p DivideByZero
+
+instance W4.IsSymExprBuilder sym => Backend (What4 sym) where
+ type SBit (What4 sym) = W4.Pred sym
+ type SWord (What4 sym) = SW.SWord sym
+ type SInteger (What4 sym) = W4.SymInteger sym
+ type SFloat (What4 sym) = FP.SFloat sym
+ type SEval (What4 sym) = W4Eval sym
+
+ raiseError _ = evalError
+
+ assertSideCondition _ cond err
+ | Just False <- W4.asConstantPred cond = evalError err
+ | otherwise = addSafety cond
+
+ isReady sym m =
+ case w4Eval m (w4 sym) of
+ Ready _ -> True
+ _ -> False
+
+ sDelayFill _ m retry =
+ total
+ do sym <- getSym
+ doEval (w4Thunk <$> delayFill (w4Eval m sym) (w4Eval retry sym))
+
+ sSpark _ m =
+ total
+ do sym <- getSym
+ doEval (w4Thunk <$> evalSpark (w4Eval m sym))
+
+
+ sDeclareHole _ msg =
+ total
+ do (hole, fill) <- doEval (blackhole msg)
+ pure ( w4Thunk hole
+ , \m -> total
+ do sym <- getSym
+ doEval (fill (w4Eval m sym))
+ )
+
+ mergeEval _sym f c mx my = W4Eval
+ do rx <- evalPartial mx
+ ry <- evalPartial my
+ case (rx, ry) of
+
+ (W4Error err, W4Error _) ->
+ pure (W4Error err) -- arbitrarily choose left error to report
+
+ (W4Error _, W4Result p y) ->
+ do p' <- w4And p =<< w4Not c
+ pure (W4Result p' y)
+
+ (W4Result p x, W4Error _) ->
+ do p' <- w4And p c
+ pure (W4Result p' x)
+
+ (W4Result px x, W4Result py y) ->
+ do zr <- evalPartial (f c x y)
+ case zr of
+ W4Error err -> pure $ W4Error err
+ W4Result pz z ->
+ do p' <- w4And pz =<< w4ITE c px py
+ pure (W4Result p' z)
+
+ wordAsChar _ bv
+ | SW.bvWidth bv == 8 = toEnum . fromInteger <$> SW.bvAsUnsignedInteger bv
+ | otherwise = Nothing
+
+ wordLen _ bv = SW.bvWidth bv
+
+ bitLit sym b = W4.backendPred (w4 sym) b
+ bitAsLit _ v = W4.asConstantPred v
+
+ wordLit sym intw i
+ | Just (Some w) <- someNat intw
+ = case isPosNat w of
+ Nothing -> pure $ SW.ZBV
+ Just LeqProof -> SW.DBV <$> liftIO (W4.bvLit (w4 sym) w (BV.mkBV w i))
+ | otherwise = panic "what4: wordLit" ["invalid bit width:", show intw ]
+
+ wordAsLit _ v
+ | Just x <- SW.bvAsUnsignedInteger v = Just (SW.bvWidth v, x)
+ | otherwise = Nothing
+
+ integerLit sym i = liftIO (W4.intLit (w4 sym) i)
+
+ integerAsLit _ v = W4.asInteger v
+
+ ppBit _ v
+ | Just b <- W4.asConstantPred v = text $! if b then "True" else "False"
+ | otherwise = text "?"
+
+ ppWord _ opts v
+ | Just x <- SW.bvAsUnsignedInteger v
+ = ppBV opts (BV (SW.bvWidth v) x)
+
+ | otherwise = text "[?]"
+
+ ppInteger _ _opts v
+ | Just x <- W4.asInteger v = integer x
+ | otherwise = text "[?]"
+
+ ppFloat _ _opts _ = text "[?]"
+
+ iteBit sym c x y = liftIO (W4.itePred (w4 sym) c x y)
+ iteWord sym c x y = liftIO (SW.bvIte (w4 sym) c x y)
+ iteInteger sym c x y = liftIO (W4.intIte (w4 sym) c x y)
+
+ bitEq sym x y = liftIO (W4.eqPred (w4 sym) x y)
+ bitAnd sym x y = liftIO (W4.andPred (w4 sym) x y)
+ bitOr sym x y = liftIO (W4.orPred (w4 sym) x y)
+ bitXor sym x y = liftIO (W4.xorPred (w4 sym) x y)
+ bitComplement sym x = liftIO (W4.notPred (w4 sym) x)
+
+ wordBit sym bv idx = liftIO (SW.bvAtBE (w4 sym) bv idx)
+ wordUpdate sym bv idx b = liftIO (SW.bvSetBE (w4 sym) bv idx b)
+
+ packWord sym bs =
+ do z <- wordLit sym (genericLength bs) 0
+ let f w (idx,b) = wordUpdate sym w idx b
+ foldM f z (zip [0..] bs)
+
+ unpackWord sym bv = liftIO $
+ mapM (SW.bvAtBE (w4 sym) bv) [0 .. SW.bvWidth bv-1]
+
+ joinWord sym x y = liftIO $ SW.bvJoin (w4 sym) x y
+
+ splitWord _sym 0 _ bv = pure (SW.ZBV, bv)
+ splitWord _sym _ 0 bv = pure (bv, SW.ZBV)
+ splitWord sym lw rw bv = liftIO $
+ do l <- SW.bvSliceBE (w4 sym) 0 lw bv
+ r <- SW.bvSliceBE (w4 sym) lw rw bv
+ return (l, r)
+
+ extractWord sym bits idx bv =
+ liftIO $ SW.bvSliceLE (w4 sym) idx bits bv
+
+ wordEq sym x y = liftIO (SW.bvEq (w4 sym) x y)
+ wordLessThan sym x y = liftIO (SW.bvult (w4 sym) x y)
+ wordGreaterThan sym x y = liftIO (SW.bvugt (w4 sym) x y)
+ wordSignedLessThan sym x y = liftIO (SW.bvslt (w4 sym) x y)
+
+ wordOr sym x y = liftIO (SW.bvOr (w4 sym) x y)
+ wordAnd sym x y = liftIO (SW.bvAnd (w4 sym) x y)
+ wordXor sym x y = liftIO (SW.bvXor (w4 sym) x y)
+ wordComplement sym x = liftIO (SW.bvNot (w4 sym) x)
+
+ wordPlus sym x y = liftIO (SW.bvAdd (w4 sym) x y)
+ wordMinus sym x y = liftIO (SW.bvSub (w4 sym) x y)
+ wordMult sym x y = liftIO (SW.bvMul (w4 sym) x y)
+ wordNegate sym x = liftIO (SW.bvNeg (w4 sym) x)
+ wordLg2 sym x = sLg2 (w4 sym) x
+
+ wordDiv sym x y =
+ do assertBVDivisor sym y
+ liftIO (SW.bvUDiv (w4 sym) x y)
+ wordMod sym x y =
+ do assertBVDivisor sym y
+ liftIO (SW.bvURem (w4 sym) x y)
+ wordSignedDiv sym x y =
+ do assertBVDivisor sym y
+ liftIO (SW.bvSDiv (w4 sym) x y)
+ wordSignedMod sym x y =
+ do assertBVDivisor sym y
+ liftIO (SW.bvSRem (w4 sym) x y)
+
+ wordToInt sym x = liftIO (SW.bvToInteger (w4 sym) x)
+ wordFromInt sym width i = liftIO (SW.integerToBV (w4 sym) i width)
+
+ intPlus sym x y = liftIO $ W4.intAdd (w4 sym) x y
+ intMinus sym x y = liftIO $ W4.intSub (w4 sym) x y
+ intMult sym x y = liftIO $ W4.intMul (w4 sym) x y
+ intNegate sym x = liftIO $ W4.intNeg (w4 sym) x
+
+ -- NB: What4's division operation provides SMTLib's euclidean division,
+ -- which doesn't match the round-to-neg-infinity semantics of Cryptol,
+ -- so we have to do some work to get the desired semantics.
+ intDiv sym x y =
+ do assertIntDivisor sym y
+ liftIO $ do
+ neg <- liftIO (W4.intLt (w4 sym) y =<< W4.intLit (w4 sym) 0)
+ case W4.asConstantPred neg of
+ Just False -> W4.intDiv (w4 sym) x y
+ Just True ->
+ do xneg <- W4.intNeg (w4 sym) x
+ yneg <- W4.intNeg (w4 sym) y
+ W4.intDiv (w4 sym) xneg yneg
+ Nothing ->
+ do xneg <- W4.intNeg (w4 sym) x
+ yneg <- W4.intNeg (w4 sym) y
+ zneg <- W4.intDiv (w4 sym) xneg yneg
+ z <- W4.intDiv (w4 sym) x y
+ W4.intIte (w4 sym) neg zneg z
+
+ -- NB: What4's division operation provides SMTLib's euclidean division,
+ -- which doesn't match the round-to-neg-infinity semantics of Cryptol,
+ -- so we have to do some work to get the desired semantics.
+ intMod sym x y =
+ do assertIntDivisor sym y
+ liftIO $ do
+ neg <- liftIO (W4.intLt (w4 sym) y =<< W4.intLit (w4 sym) 0)
+ case W4.asConstantPred neg of
+ Just False -> W4.intMod (w4 sym) x y
+ Just True ->
+ do xneg <- W4.intNeg (w4 sym) x
+ yneg <- W4.intNeg (w4 sym) y
+ W4.intNeg (w4 sym) =<< W4.intMod (w4 sym) xneg yneg
+ Nothing ->
+ do xneg <- W4.intNeg (w4 sym) x
+ yneg <- W4.intNeg (w4 sym) y
+ z <- W4.intMod (w4 sym) x y
+ zneg <- W4.intNeg (w4 sym) =<< W4.intMod (w4 sym) xneg yneg
+ W4.intIte (w4 sym) neg zneg z
+
+ intEq sym x y = liftIO $ W4.intEq (w4 sym) x y
+ intLessThan sym x y = liftIO $ W4.intLt (w4 sym) x y
+ intGreaterThan sym x y = liftIO $ W4.intLt (w4 sym) y x
+
+ -- NB, we don't do reduction here on symbolic values
+ intToZn sym m x
+ | Just xi <- W4.asInteger x
+ = liftIO $ W4.intLit (w4 sym) (xi `mod` m)
+
+ | otherwise
+ = pure x
+
+ znToInt _ 0 _ = evalPanic "znToInt" ["0 modulus not allowed"]
+ znToInt sym m x = liftIO (W4.intMod (w4 sym) x =<< W4.intLit (w4 sym) m)
+
+ znEq _ 0 _ _ = evalPanic "znEq" ["0 modulus not allowed"]
+ znEq sym m x y = liftIO $
+ do diff <- W4.intSub (w4 sym) x y
+ W4.intDivisible (w4 sym) diff (fromInteger m)
+
+ znPlus sym m x y = liftIO $ sModAdd (w4 sym) m x y
+ znMinus sym m x y = liftIO $ sModSub (w4 sym) m x y
+ znMult sym m x y = liftIO $ sModMult (w4 sym) m x y
+ znNegate sym m x = liftIO $ sModNegate (w4 sym) m x
+ znRecip = sModRecip
+
+ --------------------------------------------------------------
+
+ fpLit sym e p r = liftIO $ FP.fpFromRationalLit (w4 sym) e p r
+
+ fpExactLit sym BF{ bfExpWidth = e, bfPrecWidth = p, bfValue = bf } =
+ liftIO (FP.fpFromBinary (w4 sym) e p =<< SW.bvLit (w4 sym) (e+p) (floatToBits e p bf))
+
+ fpEq sym x y = liftIO $ FP.fpEqIEEE (w4 sym) x y
+ fpLessThan sym x y = liftIO $ FP.fpLtIEEE (w4 sym) x y
+ fpGreaterThan sym x y = liftIO $ FP.fpGtIEEE (w4 sym) x y
+ fpLogicalEq sym x y = liftIO $ FP.fpEq (w4 sym) x y
+
+ fpPlus = fpBinArith FP.fpAdd
+ fpMinus = fpBinArith FP.fpSub
+ fpMult = fpBinArith FP.fpMul
+ fpDiv = fpBinArith FP.fpDiv
+
+ fpNeg sym x = liftIO $ FP.fpNeg (w4 sym) x
+
+ fpFromInteger sym e p r x =
+ do rm <- fpRoundingMode sym r
+ liftIO $ FP.fpFromInteger (w4 sym) e p rm x
+
+ fpToInteger = fpCvtToInteger
+
+sModAdd :: W4.IsSymExprBuilder sym =>
+ sym -> Integer -> W4.SymInteger sym -> W4.SymInteger sym -> IO (W4.SymInteger sym)
+sModAdd _sym 0 _ _ = evalPanic "sModAdd" ["0 modulus not allowed"]
+sModAdd sym m x y
+ | Just xi <- W4.asInteger x
+ , Just yi <- W4.asInteger y
+ = W4.intLit sym ((xi+yi) `mod` m)
+
+ | otherwise
+ = W4.intAdd sym x y
+
+sModSub :: W4.IsSymExprBuilder sym =>
+ sym -> Integer -> W4.SymInteger sym -> W4.SymInteger sym -> IO (W4.SymInteger sym)
+sModSub _sym 0 _ _ = evalPanic "sModSub" ["0 modulus not allowed"]
+sModSub sym m x y
+ | Just xi <- W4.asInteger x
+ , Just yi <- W4.asInteger y
+ = W4.intLit sym ((xi-yi) `mod` m)
+
+ | otherwise
+ = W4.intSub sym x y
+
+
+sModMult :: W4.IsSymExprBuilder sym =>
+ sym -> Integer -> W4.SymInteger sym -> W4.SymInteger sym -> IO (W4.SymInteger sym)
+sModMult _sym 0 _ _ = evalPanic "sModMult" ["0 modulus not allowed"]
+sModMult sym m x y
+ | Just xi <- W4.asInteger x
+ , Just yi <- W4.asInteger y
+ = W4.intLit sym ((xi*yi) `mod` m)
+
+ | otherwise
+ = W4.intMul sym x y
+
+sModNegate :: W4.IsSymExprBuilder sym =>
+ sym -> Integer -> W4.SymInteger sym -> IO (W4.SymInteger sym)
+sModNegate _sym 0 _ = evalPanic "sModMult" ["0 modulus not allowed"]
+sModNegate sym m x
+ | Just xi <- W4.asInteger x
+ = W4.intLit sym ((negate xi) `mod` m)
+
+ | otherwise
+ = W4.intNeg sym x
+
+
+-- | Try successive powers of 2 to find the first that dominates the input.
+-- We could perhaps reduce to using CLZ instead...
+sLg2 :: W4.IsSymExprBuilder sym => sym -> SW.SWord sym -> SEval (What4 sym) (SW.SWord sym)
+sLg2 sym x = liftIO $ go 0
+ where
+ w = SW.bvWidth x
+ lit n = SW.bvLit sym w (toInteger n)
+
+ go i | toInteger i < w =
+ do p <- SW.bvule sym x =<< lit (bit i)
+ lazyIte (SW.bvIte sym) p (lit i) (go (i+1))
+
+ -- base case, should only happen when i = w
+ go i = lit i
+
+
+
+-- Errors ----------------------------------------------------------------------
+
+evalPanic :: String -> [String] -> a
+evalPanic cxt = panic ("[What4] " ++ cxt)
+
+lazyIte ::
+ (W4.IsExpr p, Monad m) =>
+ (p W4.BaseBoolType -> a -> a -> m a) ->
+ p W4.BaseBoolType ->
+ m a ->
+ m a ->
+ m a
+lazyIte f c mx my
+ | Just b <- W4.asConstantPred c = if b then mx else my
+ | otherwise =
+ do x <- mx
+ y <- my
+ f c x y
+
+w4bvShl :: W4.IsSymExprBuilder sym => sym -> SW.SWord sym -> SW.SWord sym -> W4Eval sym (SW.SWord sym)
+w4bvShl sym x y = liftIO $ SW.bvShl sym x y
+
+w4bvLshr :: W4.IsSymExprBuilder sym => sym -> SW.SWord sym -> SW.SWord sym -> W4Eval sym (SW.SWord sym)
+w4bvLshr sym x y = liftIO $ SW.bvLshr sym x y
+
+w4bvAshr :: W4.IsSymExprBuilder sym => sym -> SW.SWord sym -> SW.SWord sym -> W4Eval sym (SW.SWord sym)
+w4bvAshr sym x y = liftIO $ SW.bvAshr sym x y
+
+w4bvRol :: W4.IsSymExprBuilder sym => sym -> SW.SWord sym -> SW.SWord sym -> W4Eval sym (SW.SWord sym)
+w4bvRol sym x y = liftIO $ SW.bvRol sym x y
+
+w4bvRor :: W4.IsSymExprBuilder sym => sym -> SW.SWord sym -> SW.SWord sym -> W4Eval sym (SW.SWord sym)
+w4bvRor sym x y = liftIO $ SW.bvRor sym x y
+
+
+
+fpRoundingMode ::
+ W4.IsSymExprBuilder sym =>
+ What4 sym -> SWord (What4 sym) -> SEval (What4 sym) W4.RoundingMode
+fpRoundingMode sym v =
+ case wordAsLit sym v of
+ Just (_w,i) ->
+ case i of
+ 0 -> pure W4.RNE
+ 1 -> pure W4.RNA
+ 2 -> pure W4.RTP
+ 3 -> pure W4.RTN
+ 4 -> pure W4.RTZ
+ x -> raiseError sym (BadRoundingMode x)
+ _ -> liftIO $ X.throwIO $ UnsupportedSymbolicOp "rounding mode"
+
+fpBinArith ::
+ W4.IsSymExprBuilder sym =>
+ FP.SFloatBinArith sym ->
+ What4 sym ->
+ SWord (What4 sym) ->
+ SFloat (What4 sym) ->
+ SFloat (What4 sym) ->
+ SEval (What4 sym) (SFloat (What4 sym))
+fpBinArith fun = \sym r x y ->
+ do m <- fpRoundingMode sym r
+ liftIO (fun (w4 sym) m x y)
+
+
+fpCvtToInteger ::
+ (W4.IsSymExprBuilder sy, sym ~ What4 sy) =>
+ sym -> String -> SWord sym -> SFloat sym -> SEval sym (SInteger sym)
+fpCvtToInteger sym fun r x =
+ do grd <- liftIO
+ do bad1 <- FP.fpIsInf (w4 sym) x
+ bad2 <- FP.fpIsNaN (w4 sym) x
+ W4.notPred (w4 sym) =<< W4.orPred (w4 sym) bad1 bad2
+ assertSideCondition sym grd (BadValue fun)
+ rnd <- fpRoundingMode sym r
+ liftIO
+ do y <- FP.fpToReal (w4 sym) x
+ case rnd of
+ W4.RNE -> W4.realRoundEven (w4 sym) y
+ W4.RNA -> W4.realRound (w4 sym) y
+ W4.RTP -> W4.realCeil (w4 sym) y
+ W4.RTN -> W4.realFloor (w4 sym) y
+ W4.RTZ -> W4.realTrunc (w4 sym) y
+
+
+fpCvtToRational ::
+ (W4.IsSymExprBuilder sy, sym ~ What4 sy) =>
+ sym -> SFloat sym -> SEval sym (SRational sym)
+fpCvtToRational sym fp =
+ do grd <- liftIO
+ do bad1 <- FP.fpIsInf (w4 sym) fp
+ bad2 <- FP.fpIsNaN (w4 sym) fp
+ W4.notPred (w4 sym) =<< W4.orPred (w4 sym) bad1 bad2
+ assertSideCondition sym grd (BadValue "fpToRational")
+ (rel,x,y) <- liftIO (FP.fpToRational (w4 sym) fp)
+ addDefEqn sym =<< liftIO (W4.impliesPred (w4 sym) grd rel)
+ ratio sym x y
+
+fpCvtFromRational ::
+ (W4.IsSymExprBuilder sy, sym ~ What4 sy) =>
+ sym -> Integer -> Integer -> SWord sym ->
+ SRational sym -> SEval sym (SFloat sym)
+fpCvtFromRational sym e p r rat =
+ do rnd <- fpRoundingMode sym r
+ liftIO (FP.fpFromRational (w4 sym) e p rnd (sNum rat) (sDenom rat))
+
+-- Create a fresh constant and assert that it is the
+-- multiplicitive inverse of x; return the constant.
+-- Such an inverse must exist under the precondition
+-- that the modulus is prime and the input is nonzero.
+sModRecip ::
+ W4.IsSymExprBuilder sym =>
+ What4 sym ->
+ Integer ->
+ W4.SymInteger sym ->
+ W4Eval sym (W4.SymInteger sym)
+sModRecip _sym 0 _ = panic "sModRecip" ["0 modulus not allowed"]
+sModRecip sym m x
+ -- If the input is concrete, evaluate the answer
+ | Just xi <- W4.asInteger x
+ = let r = Integer.recipModInteger xi m
+ in if r == 0 then raiseError sym DivideByZero else integerLit sym r
+
+ -- If the input is symbolic, create a new symbolic constant
+ -- and assert that it is the desired multiplicitive inverse.
+ -- Such an inverse will exist under the precondition that
+ -- the modulus is prime, and as long as the input is nonzero.
+ | otherwise
+ = do divZero <- liftIO (W4.intDivisible (w4 sym) x (fromInteger m))
+ ok <- liftIO (W4.notPred (w4 sym) divZero)
+ assertSideCondition sym ok DivideByZero
+
+ z <- liftIO (W4.freshBoundedInt (w4 sym) W4.emptySymbol (Just 1) (Just (m-1)))
+ xz <- liftIO (W4.intMul (w4 sym) x z)
+ rel <- znEq sym m xz =<< liftIO (W4.intLit (w4 sym) 1)
+ addDefEqn sym =<< liftIO (W4.orPred (w4 sym) divZero rel)
+
+ return z
diff --git a/src/Cryptol/Backend/What4/SFloat.hs b/src/Cryptol/Backend/What4/SFloat.hs
new file mode 100644
--- /dev/null
+++ b/src/Cryptol/Backend/What4/SFloat.hs
@@ -0,0 +1,362 @@
+{-# Language DataKinds #-}
+{-# Language FlexibleContexts #-}
+{-# Language GADTs #-}
+{-# Language RankNTypes #-}
+{-# Language TypeApplications #-}
+{-# Language TypeOperators #-}
+-- | Working with floats of dynamic sizes.
+-- This should probably be moved to What4 one day.
+module Cryptol.Backend.What4.SFloat
+ ( -- * Interface
+ SFloat(..)
+ , fpReprOf
+ , fpSize
+ , fpRepr
+
+ -- * Constants
+ , fpFresh
+ , fpNaN
+ , fpPosInf
+ , fpFromRationalLit
+
+ -- * Interchange formats
+ , fpFromBinary
+ , fpToBinary
+
+ -- * Relations
+ , SFloatRel
+ , fpEq
+ , fpEqIEEE
+ , fpLtIEEE
+ , fpGtIEEE
+
+ -- * Arithmetic
+ , SFloatBinArith
+ , fpNeg
+ , fpAdd
+ , fpSub
+ , fpMul
+ , fpDiv
+
+ -- * Conversions
+ , fpRound
+ , fpToReal
+ , fpFromReal
+ , fpFromRational
+ , fpToRational
+ , fpFromInteger
+
+ -- * Queries
+ , fpIsInf, fpIsNaN
+
+ -- * Exceptions
+ , UnsupportedFloat(..)
+ , FPTypeError(..)
+ ) where
+
+import Control.Exception
+
+import Data.Parameterized.Some
+import Data.Parameterized.NatRepr
+
+import What4.BaseTypes
+import What4.Panic(panic)
+import What4.SWord
+import What4.Interface
+
+-- | Symbolic floating point numbers.
+data SFloat sym where
+ SFloat :: IsExpr (SymExpr sym) => SymFloat sym fpp -> SFloat sym
+
+
+
+--------------------------------------------------------------------------------
+
+-- | This exception is thrown if the operations try to create a
+-- floating point value we do not support
+data UnsupportedFloat =
+ UnsupportedFloat { fpWho :: String, exponentBits, precisionBits :: Integer }
+ deriving Show
+
+
+-- | Throw 'UnsupportedFloat' exception
+unsupported ::
+ String {- ^ Label -} ->
+ Integer {- ^ Exponent width -} ->
+ Integer {- ^ Precision width -} ->
+ IO a
+unsupported l e p =
+ throwIO UnsupportedFloat { fpWho = l
+ , exponentBits = e
+ , precisionBits = p }
+
+instance Exception UnsupportedFloat
+
+-- | This exceptoin is throws if the types don't match.
+data FPTypeError =
+ FPTypeError { fpExpected :: Some BaseTypeRepr
+ , fpActual :: Some BaseTypeRepr
+ }
+ deriving Show
+
+instance Exception FPTypeError
+
+fpTypeMismatch :: BaseTypeRepr t1 -> BaseTypeRepr t2 -> IO a
+fpTypeMismatch expect actual =
+ throwIO FPTypeError { fpExpected = Some expect
+ , fpActual = Some actual
+ }
+fpTypeError :: FloatPrecisionRepr t1 -> FloatPrecisionRepr t2 -> IO a
+fpTypeError t1 t2 =
+ fpTypeMismatch (BaseFloatRepr t1) (BaseFloatRepr t2)
+
+
+--------------------------------------------------------------------------------
+-- | Construct the 'FloatPrecisionRepr' with the given parameters.
+fpRepr ::
+ Integer {- ^ Exponent width -} ->
+ Integer {- ^ Precision width -} ->
+ Maybe (Some FloatPrecisionRepr)
+fpRepr iE iP =
+ do Some e <- someNat iE
+ LeqProof <- testLeq (knownNat @2) e
+ Some p <- someNat iP
+ LeqProof <- testLeq (knownNat @2) p
+ pure (Some (FloatingPointPrecisionRepr e p))
+
+fpReprOf ::
+ IsExpr (SymExpr sym) => sym -> SymFloat sym fpp -> FloatPrecisionRepr fpp
+fpReprOf _ e =
+ case exprType e of
+ BaseFloatRepr r -> r
+
+fpSize :: SFloat sym -> (Integer,Integer)
+fpSize (SFloat f) =
+ case exprType f of
+ BaseFloatRepr (FloatingPointPrecisionRepr e p) -> (intValue e, intValue p)
+
+
+--------------------------------------------------------------------------------
+-- Constants
+
+-- | A fresh variable of the given type.
+fpFresh ::
+ IsSymExprBuilder sym =>
+ sym ->
+ Integer ->
+ Integer ->
+ IO (SFloat sym)
+fpFresh sym e p
+ | Just (Some fpp) <- fpRepr e p =
+ SFloat <$> freshConstant sym emptySymbol (BaseFloatRepr fpp)
+ | otherwise = unsupported "fpFresh" e p
+
+-- | Not a number
+fpNaN ::
+ IsExprBuilder sym =>
+ sym ->
+ Integer {- ^ Exponent width -} ->
+ Integer {- ^ Precision width -} ->
+ IO (SFloat sym)
+fpNaN sym e p
+ | Just (Some fpp) <- fpRepr e p = SFloat <$> floatNaN sym fpp
+ | otherwise = unsupported "fpNaN" e p
+
+
+-- | Positive infinity
+fpPosInf ::
+ IsExprBuilder sym =>
+ sym ->
+ Integer {- ^ Exponent width -} ->
+ Integer {- ^ Precision width -} ->
+ IO (SFloat sym)
+fpPosInf sym e p
+ | Just (Some fpp) <- fpRepr e p = SFloat <$> floatPInf sym fpp
+ | otherwise = unsupported "fpPosInf" e p
+
+-- | A floating point number corresponding to the given rations.
+fpFromRationalLit ::
+ IsExprBuilder sym =>
+ sym ->
+ Integer {- ^ Exponent width -} ->
+ Integer {- ^ Precision width -} ->
+ Rational ->
+ IO (SFloat sym)
+fpFromRationalLit sym e p r
+ | Just (Some fpp) <- fpRepr e p = SFloat <$> floatLit sym fpp r
+ | otherwise = unsupported "fpFromRational" e p
+
+
+-- | Make a floating point number with the given bit representation.
+fpFromBinary ::
+ IsExprBuilder sym =>
+ sym ->
+ Integer {- ^ Exponent width -} ->
+ Integer {- ^ Precision width -} ->
+ SWord sym ->
+ IO (SFloat sym)
+fpFromBinary sym e p swe
+ | DBV sw <- swe
+ , Just (Some fpp) <- fpRepr e p
+ , FloatingPointPrecisionRepr ew pw <- fpp
+ , let expectW = addNat ew pw
+ , actual@(BaseBVRepr actualW) <- exprType sw =
+ case testEquality expectW actualW of
+ Just Refl -> SFloat <$> floatFromBinary sym fpp sw
+ Nothing -- we want to report type correct type errors! :-)
+ | Just LeqProof <- testLeq (knownNat @1) expectW ->
+ fpTypeMismatch (BaseBVRepr expectW) actual
+ | otherwise -> panic "fpFromBits" [ "1 >= 2" ]
+ | otherwise = unsupported "fpFromBits" e p
+
+fpToBinary :: IsExprBuilder sym => sym -> SFloat sym -> IO (SWord sym)
+fpToBinary sym (SFloat f)
+ | FloatingPointPrecisionRepr e p <- fpReprOf sym f
+ , Just LeqProof <- testLeq (knownNat @1) (addNat e p)
+ = DBV <$> floatToBinary sym f
+ | otherwise = panic "fpToBinary" [ "we messed up the types" ]
+
+
+--------------------------------------------------------------------------------
+-- Arithmetic
+
+fpNeg :: IsExprBuilder sym => sym -> SFloat sym -> IO (SFloat sym)
+fpNeg sym (SFloat fl) = SFloat <$> floatNeg sym fl
+
+fpBinArith ::
+ IsExprBuilder sym =>
+ (forall t.
+ sym ->
+ RoundingMode ->
+ SymFloat sym t ->
+ SymFloat sym t ->
+ IO (SymFloat sym t)
+ ) ->
+ sym -> RoundingMode -> SFloat sym -> SFloat sym -> IO (SFloat sym)
+fpBinArith fun sym r (SFloat x) (SFloat y) =
+ let t1 = sym `fpReprOf` x
+ t2 = sym `fpReprOf` y
+ in
+ case testEquality t1 t2 of
+ Just Refl -> SFloat <$> fun sym r x y
+ _ -> fpTypeError t1 t2
+
+type SFloatBinArith sym =
+ sym -> RoundingMode -> SFloat sym -> SFloat sym -> IO (SFloat sym)
+
+fpAdd :: IsExprBuilder sym => SFloatBinArith sym
+fpAdd = fpBinArith floatAdd
+
+fpSub :: IsExprBuilder sym => SFloatBinArith sym
+fpSub = fpBinArith floatSub
+
+fpMul :: IsExprBuilder sym => SFloatBinArith sym
+fpMul = fpBinArith floatMul
+
+fpDiv :: IsExprBuilder sym => SFloatBinArith sym
+fpDiv = fpBinArith floatDiv
+
+
+
+
+--------------------------------------------------------------------------------
+
+fpRel ::
+ IsExprBuilder sym =>
+ (forall t.
+ sym ->
+ SymFloat sym t ->
+ SymFloat sym t ->
+ IO (Pred sym)
+ ) ->
+ sym -> SFloat sym -> SFloat sym -> IO (Pred sym)
+fpRel fun sym (SFloat x) (SFloat y) =
+ let t1 = sym `fpReprOf` x
+ t2 = sym `fpReprOf` y
+ in
+ case testEquality t1 t2 of
+ Just Refl -> fun sym x y
+ _ -> fpTypeError t1 t2
+
+
+
+
+type SFloatRel sym =
+ sym -> SFloat sym -> SFloat sym -> IO (Pred sym)
+
+fpEq :: IsExprBuilder sym => SFloatRel sym
+fpEq = fpRel floatEq
+
+fpEqIEEE :: IsExprBuilder sym => SFloatRel sym
+fpEqIEEE = fpRel floatFpEq
+
+fpLtIEEE :: IsExprBuilder sym => SFloatRel sym
+fpLtIEEE = fpRel floatLt
+
+fpGtIEEE :: IsExprBuilder sym => SFloatRel sym
+fpGtIEEE = fpRel floatGt
+
+
+--------------------------------------------------------------------------------
+fpRound ::
+ IsExprBuilder sym => sym -> RoundingMode -> SFloat sym -> IO (SFloat sym)
+fpRound sym r (SFloat x) = SFloat <$> floatRound sym r x
+
+-- | This is undefined on "special" values (NaN,infinity)
+fpToReal :: IsExprBuilder sym => sym -> SFloat sym -> IO (SymReal sym)
+fpToReal sym (SFloat x) = floatToReal sym x
+
+fpFromReal ::
+ IsExprBuilder sym =>
+ sym -> Integer -> Integer -> RoundingMode -> SymReal sym -> IO (SFloat sym)
+fpFromReal sym e p r x
+ | Just (Some repr) <- fpRepr e p = SFloat <$> realToFloat sym repr r x
+ | otherwise = unsupported "fpFromReal" e p
+
+
+fpFromInteger ::
+ IsExprBuilder sym =>
+ sym -> Integer -> Integer -> RoundingMode -> SymInteger sym -> IO (SFloat sym)
+fpFromInteger sym e p r x = fpFromReal sym e p r =<< integerToReal sym x
+
+
+fpFromRational ::
+ IsExprBuilder sym =>
+ sym -> Integer -> Integer -> RoundingMode ->
+ SymInteger sym -> SymInteger sym -> IO (SFloat sym)
+fpFromRational sym e p r x y =
+ do num <- integerToReal sym x
+ den <- integerToReal sym y
+ res <- realDiv sym num den
+ fpFromReal sym e p r res
+
+{- | Returns a predicate and two integers, @x@ and @y@.
+If the the predicate holds, then @x / y@ is a rational representing
+the floating point number. Assumes the FP number is not one of the
+special ones that has no real representation. -}
+fpToRational ::
+ IsSymExprBuilder sym =>
+ sym ->
+ SFloat sym ->
+ IO (Pred sym, SymInteger sym, SymInteger sym)
+fpToRational sym fp =
+ do r <- fpToReal sym fp
+ x <- freshConstant sym emptySymbol BaseIntegerRepr
+ y <- freshConstant sym emptySymbol BaseIntegerRepr
+ num <- integerToReal sym x
+ den <- integerToReal sym y
+ res <- realDiv sym num den
+ same <- realEq sym r res
+ pure (same, x, y)
+
+
+
+--------------------------------------------------------------------------------
+fpIsInf :: IsExprBuilder sym => sym -> SFloat sym -> IO (Pred sym)
+fpIsInf sym (SFloat x) = floatIsInf sym x
+
+fpIsNaN :: IsExprBuilder sym => sym -> SFloat sym -> IO (Pred sym)
+fpIsNaN sym (SFloat x) = floatIsNaN sym x
+
+
+
diff --git a/src/Cryptol/Eval.hs b/src/Cryptol/Eval.hs
--- a/src/Cryptol/Eval.hs
+++ b/src/Cryptol/Eval.hs
@@ -13,7 +13,6 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ParallelListComp #-}
{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE Safe #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE ViewPatterns #-}
@@ -35,11 +34,11 @@
, forceValue
) where
-import Cryptol.Eval.Backend
-import Cryptol.Eval.Concrete( Concrete(..) )
+import Cryptol.Backend
+import Cryptol.Backend.Concrete( Concrete(..) )
+import Cryptol.Backend.Monad
import Cryptol.Eval.Generic ( iteValue )
import Cryptol.Eval.Env
-import Cryptol.Eval.Monad
import Cryptol.Eval.Type
import Cryptol.Eval.Value
import Cryptol.ModuleSystem.Name
@@ -54,6 +53,7 @@
import Control.Monad
import Data.List
import Data.Maybe
+import qualified Data.IntMap.Strict as IntMap
import qualified Data.Map.Strict as Map
import Data.Semigroup
@@ -63,10 +63,9 @@
type EvalEnv = GenEvalEnv Concrete
type EvalPrims sym =
- ( Backend sym, ?evalPrim :: PrimIdent -> Maybe (GenValue sym) )
+ ( Backend sym, ?evalPrim :: PrimIdent -> Maybe (Either Expr (GenValue sym)) )
-type ConcPrims =
- ?evalPrim :: PrimIdent -> Maybe (GenValue Concrete)
+type ConcPrims = ?evalPrim :: PrimIdent -> Maybe (Either Expr (GenValue Concrete))
-- Expression Evaluation -------------------------------------------------------
@@ -138,9 +137,10 @@
e' <- eval e
evalSel sym e' sel
- ESet e sel v -> {-# SCC "evalExpr->ESet" #-}
+ ESet ty e sel v -> {-# SCC "evalExpr->ESet" #-}
do e' <- eval e
- evalSetSel sym e' sel (eval v)
+ let tyv = evalValType (envTypes env) ty
+ evalSetSel sym tyv e' sel (eval v)
EIf c t f -> {-# SCC "evalExpr->EIf" #-} do
b <- fromVBit <$> eval c
@@ -157,7 +157,7 @@
Nothing -> do
envdoc <- ppEnv sym defaultPPOpts env
panic "[Eval] evalExpr"
- ["var `" ++ show (pp n) ++ "` is not defined"
+ ["var `" ++ show (pp n) ++ "` (" ++ show (nameUnique n) ++ ") is not defined"
, show envdoc
]
@@ -274,7 +274,7 @@
-- declare a "hole" for each declaration
-- and extend the evaluation environment
holes <- mapM (declHole sym) ds
- let holeEnv = Map.fromList $ [ (nm,h) | (nm,_,h,_) <- holes ]
+ let holeEnv = IntMap.fromList $ [ (nameUnique nm, h) | (nm,_,h,_) <- holes ]
let env' = env `mappend` emptyEnv{ envVars = holeEnv }
-- evaluate the declaration bodies, building a new evaluation environment
@@ -326,7 +326,7 @@
-- | '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
+-- be implemented rather more efficiently 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 sym -> Schema -> Bool
@@ -525,8 +525,9 @@
case dDefinition d of
DPrim ->
case ?evalPrim =<< asPrim (dName d) of
- Just v -> pure (bindVarDirect (dName d) v env)
- Nothing -> bindVar sym (dName d) (cryNoPrimError sym (dName d)) env
+ Just (Right v) -> pure (bindVarDirect (dName d) v env)
+ Just (Left ex) -> bindVar sym (dName d) (evalExpr sym renv ex) env
+ Nothing -> bindVar sym (dName d) (cryNoPrimError sym (dName d)) env
DExpr e -> bindVar sym (dName d) (evalExpr sym renv e) env
@@ -584,14 +585,15 @@
, show vdoc ]
{-# SPECIALIZE evalSetSel ::
ConcPrims =>
- Concrete ->
+ Concrete -> TValue ->
GenValue Concrete -> Selector -> SEval Concrete (GenValue Concrete) -> SEval Concrete (GenValue Concrete)
#-}
evalSetSel :: forall sym.
EvalPrims sym =>
sym ->
+ TValue ->
GenValue sym -> Selector -> SEval sym (GenValue sym) -> SEval sym (GenValue sym)
-evalSetSel sym e sel v =
+evalSetSel sym _tyv e sel v =
case sel of
TupleSel n _ -> setTuple n
RecordSel n _ -> setRecord n
@@ -641,25 +643,25 @@
-- name is bound to a list of values, one for each element in the list
-- comprehension.
data ListEnv sym = ListEnv
- { leVars :: !(Map.Map Name (Integer -> SEval sym (GenValue sym)))
+ { leVars :: !(IntMap.IntMap (Integer -> SEval sym (GenValue sym)))
-- ^ Bindings whose values vary by position
- , leStatic :: !(Map.Map Name (SEval sym (GenValue sym)))
+ , leStatic :: !(IntMap.IntMap (SEval sym (GenValue sym)))
-- ^ Bindings whose values are constant
, leTypes :: !TypeEnv
}
instance Semigroup (ListEnv sym) where
l <> r = ListEnv
- { leVars = Map.union (leVars l) (leVars r)
- , leStatic = Map.union (leStatic l) (leStatic r)
- , leTypes = Map.union (leTypes l) (leTypes r)
+ { leVars = IntMap.union (leVars l) (leVars r)
+ , leStatic = IntMap.union (leStatic l) (leStatic r)
+ , leTypes = IntMap.union (leTypes l) (leTypes r)
}
instance Monoid (ListEnv sym) where
mempty = ListEnv
- { leVars = Map.empty
- , leStatic = Map.empty
- , leTypes = Map.empty
+ { leVars = IntMap.empty
+ , leStatic = IntMap.empty
+ , leTypes = IntMap.empty
}
mappend l r = l <> r
@@ -679,7 +681,7 @@
evalListEnv :: ListEnv sym -> Integer -> GenEvalEnv sym
evalListEnv (ListEnv vm st tm) i =
let v = fmap ($i) vm
- in EvalEnv{ envVars = Map.union v st
+ in EvalEnv{ envVars = IntMap.union v st
, envTypes = tm
}
{-# INLINE evalListEnv #-}
@@ -690,7 +692,7 @@
(Integer -> SEval sym (GenValue sym)) ->
ListEnv sym ->
ListEnv sym
-bindVarList n vs lenv = lenv { leVars = Map.insert n vs (leVars lenv) }
+bindVarList n vs lenv = lenv { leVars = IntMap.insert (nameUnique n) vs (leVars lenv) }
{-# INLINE bindVarList #-}
-- List Comprehensions ---------------------------------------------------------
@@ -776,8 +778,8 @@
-- `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
+ let allvars = IntMap.union (fmap ($0) (leVars lenv)) (leStatic lenv)
+ let lenv' = lenv { leVars = IntMap.empty
, leStatic = allvars
}
let env = EvalEnv allvars (leTypes lenv)
diff --git a/src/Cryptol/Eval/Arch.hs b/src/Cryptol/Eval/Arch.hs
deleted file mode 100644
--- a/src/Cryptol/Eval/Arch.hs
+++ /dev/null
@@ -1,30 +0,0 @@
--- |
--- Module : Cryptol.Eval.Arch
--- Copyright : (c) 2014-2016 Galois, Inc.
--- License : BSD3
--- Maintainer : cryptol@galois.com
--- Stability : provisional
--- Portability : portable
---
--- Architecture-specific parts of the concrete evaluator go here.
-{-# LANGUAGE CPP #-}
-module Cryptol.Eval.Arch where
-
--- | This is the widest word we can have before gmp will fail to
--- allocate and bring down the whole program. According to
---
--- the sizes are 2^32-1 for 32-bit, and 2^37 for 64-bit, however
--- experiments show that it's somewhere under 2^37 at least on 64-bit
--- Mac OS X.
-maxBigIntWidth :: Integer
-#if i386_HOST_ARCH
-maxBigIntWidth = 2^(32 :: Integer) - 0x1
-#elif x86_64_HOST_ARCH
-maxBigIntWidth = 2^(37 :: Integer) - 0x100
-#else
--- Because GHC doesn't seem to define a CPP macro that will portably
--- tell us the bit width we're compiling for, fall back on a safe choice
--- for other architectures. If we care about large words on another
--- architecture, we can add a special case for it.
-maxBigIntWidth = 2^(32 :: Integer) - 0x1
-#endif
diff --git a/src/Cryptol/Eval/Backend.hs b/src/Cryptol/Eval/Backend.hs
deleted file mode 100644
--- a/src/Cryptol/Eval/Backend.hs
+++ /dev/null
@@ -1,705 +0,0 @@
-{-# Language FlexibleContexts #-}
-{-# Language TypeFamilies #-}
-module Cryptol.Eval.Backend
- ( Backend(..)
- , sDelay
- , invalidIndex
- , cryUserError
- , cryNoPrimError
- , FPArith2
-
- -- * Rationals
- , SRational(..)
- , intToRational
- , ratio
- , rationalAdd
- , rationalSub
- , rationalNegate
- , rationalMul
- , rationalRecip
- , rationalDivide
- , rationalFloor
- , rationalCeiling
- , rationalTrunc
- , rationalRoundAway
- , rationalRoundToEven
- , rationalEq
- , rationalLessThan
- , rationalGreaterThan
- , iteRational
- , ppRational
- ) where
-
-import Control.Monad.IO.Class
-import Data.Kind (Type)
-import Data.Ratio ( (%), numerator, denominator )
-
-import Cryptol.Eval.Monad
-import Cryptol.TypeCheck.AST(Name)
-import Cryptol.Utils.PP
-
-
-invalidIndex :: Backend sym => sym -> Integer -> SEval sym a
-invalidIndex sym = raiseError sym . InvalidIndex . Just
-
-cryUserError :: Backend sym => sym -> String -> SEval sym a
-cryUserError sym = raiseError sym . UserError
-
-cryNoPrimError :: Backend sym => sym -> Name -> SEval sym a
-cryNoPrimError sym = raiseError sym . NoPrim
-
-
-{-# INLINE sDelay #-}
--- | 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.
-sDelay :: Backend sym => sym -> Maybe String -> SEval sym a -> SEval sym (SEval sym a)
-sDelay sym msg m =
- let msg' = maybe "" ("while evaluating "++) msg
- retry = raiseError sym (LoopError msg')
- in sDelayFill sym m retry
-
-
--- | Representation of rational numbers.
--- Invariant: denominator is not 0
-data SRational sym =
- SRational
- { sNum :: SInteger sym
- , sDenom :: SInteger sym
- }
-
-intToRational :: Backend sym => sym -> SInteger sym -> SEval sym (SRational sym)
-intToRational sym x = SRational x <$> (integerLit sym 1)
-
-ratio :: Backend sym => sym -> SInteger sym -> SInteger sym -> SEval sym (SRational sym)
-ratio sym n d =
- do pz <- bitComplement sym =<< intEq sym d =<< integerLit sym 0
- assertSideCondition sym pz DivideByZero
- pure (SRational n d)
-
-rationalRecip :: Backend sym => sym -> SRational sym -> SEval sym (SRational sym)
-rationalRecip sym (SRational a b) = ratio sym b a
-
-rationalDivide :: Backend sym => sym -> SRational sym -> SRational sym -> SEval sym (SRational sym)
-rationalDivide sym x y = rationalMul sym x =<< rationalRecip sym y
-
-rationalFloor :: Backend sym => sym -> SRational sym -> SEval sym (SInteger sym)
- -- NB, relies on integer division being round-to-negative-inf division
-rationalFloor sym (SRational n d) = intDiv sym n d
-
-rationalCeiling :: Backend sym => sym -> SRational sym -> SEval sym (SInteger sym)
-rationalCeiling sym r = intNegate sym =<< rationalFloor sym =<< rationalNegate sym r
-
-rationalTrunc :: Backend sym => sym -> SRational sym -> SEval sym (SInteger sym)
-rationalTrunc sym r =
- do p <- rationalLessThan sym r =<< intToRational sym =<< integerLit sym 0
- cr <- rationalCeiling sym r
- fr <- rationalFloor sym r
- iteInteger sym p cr fr
-
-rationalRoundAway :: Backend sym => sym -> SRational sym -> SEval sym (SInteger sym)
-rationalRoundAway sym r =
- do p <- rationalLessThan sym r =<< intToRational sym =<< integerLit sym 0
- half <- SRational <$> integerLit sym 1 <*> integerLit sym 2
- cr <- rationalCeiling sym =<< rationalSub sym r half
- fr <- rationalFloor sym =<< rationalAdd sym r half
- iteInteger sym p cr fr
-
-rationalRoundToEven :: Backend sym => sym -> SRational sym -> SEval sym (SInteger sym)
-rationalRoundToEven sym r =
- do lo <- rationalFloor sym r
- hi <- intPlus sym lo =<< integerLit sym 1
- -- NB: `diff` will be nonnegative because `lo <= r`
- diff <- rationalSub sym r =<< intToRational sym lo
- half <- SRational <$> integerLit sym 1 <*> integerLit sym 2
-
- ite (rationalLessThan sym diff half) (pure lo) $
- ite (rationalGreaterThan sym diff half) (pure hi) $
- ite (isEven lo) (pure lo) (pure hi)
-
- where
- isEven x =
- do parity <- intMod sym x =<< integerLit sym 2
- intEq sym parity =<< integerLit sym 0
-
- ite x t e =
- do x' <- x
- case bitAsLit sym x' of
- Just True -> t
- Just False -> e
- Nothing ->
- do t' <- t
- e' <- e
- iteInteger sym x' t' e'
-
-
-rationalAdd :: Backend sym => sym -> SRational sym -> SRational sym -> SEval sym (SRational sym)
-rationalAdd sym (SRational a b) (SRational c d) =
- do ad <- intMult sym a d
- bc <- intMult sym b c
- bd <- intMult sym b d
- ad_bc <- intPlus sym ad bc
- pure (SRational ad_bc bd)
-
-rationalSub :: Backend sym => sym -> SRational sym -> SRational sym -> SEval sym (SRational sym)
-rationalSub sym (SRational a b) (SRational c d) =
- do ad <- intMult sym a d
- bc <- intMult sym b c
- bd <- intMult sym b d
- ad_bc <- intMinus sym ad bc
- pure (SRational ad_bc bd)
-
-rationalNegate :: Backend sym => sym -> SRational sym -> SEval sym (SRational sym)
-rationalNegate sym (SRational a b) =
- do aneg <- intNegate sym a
- pure (SRational aneg b)
-
-rationalMul :: Backend sym => sym -> SRational sym -> SRational sym -> SEval sym (SRational sym)
-rationalMul sym (SRational a b) (SRational c d) =
- do ac <- intMult sym a c
- bd <- intMult sym b d
- pure (SRational ac bd)
-
-rationalEq :: Backend sym => sym -> SRational sym -> SRational sym -> SEval sym (SBit sym)
-rationalEq sym (SRational a b) (SRational c d) =
- do ad <- intMult sym a d
- bc <- intMult sym b c
- intEq sym ad bc
-
-normalizeSign :: Backend sym => sym -> SRational sym -> SEval sym (SRational sym)
-normalizeSign sym (SRational a b) =
- do p <- intLessThan sym b =<< integerLit sym 0
- case bitAsLit sym p of
- Just False -> pure (SRational a b)
- Just True ->
- do aneg <- intNegate sym a
- bneg <- intNegate sym b
- pure (SRational aneg bneg)
- Nothing ->
- do aneg <- intNegate sym a
- bneg <- intNegate sym b
- a' <- iteInteger sym p aneg a
- b' <- iteInteger sym p bneg b
- pure (SRational a' b')
-
-rationalLessThan:: Backend sym => sym -> SRational sym -> SRational sym -> SEval sym (SBit sym)
-rationalLessThan sym x y =
- do SRational a b <- normalizeSign sym x
- SRational c d <- normalizeSign sym y
- ad <- intMult sym a d
- bc <- intMult sym b c
- intLessThan sym ad bc
-
-rationalGreaterThan:: Backend sym => sym -> SRational sym -> SRational sym -> SEval sym (SBit sym)
-rationalGreaterThan sym = flip (rationalLessThan sym)
-
-iteRational :: Backend sym => sym -> SBit sym -> SRational sym -> SRational sym -> SEval sym (SRational sym)
-iteRational sym p (SRational a b) (SRational c d) =
- SRational <$> iteInteger sym p a c <*> iteInteger sym p b d
-
-ppRational :: Backend sym => sym -> PPOpts -> SRational sym -> Doc
-ppRational sym opts (SRational n d)
- | Just ni <- integerAsLit sym n
- , Just di <- integerAsLit sym d
- = let q = ni % di in
- text "(ratio" <+> integer (numerator q) <+> (integer (denominator q) <> text ")")
-
- | otherwise
- = text "(ratio" <+> ppInteger sym opts n <+> (ppInteger sym opts d <> text ")")
-
--- | This type class defines a collection of operations on bits, words and integers that
--- are necessary to define generic evaluator primitives that operate on both concrete
--- and symbolic values uniformly.
-class MonadIO (SEval sym) => Backend sym where
- type SBit sym :: Type
- type SWord sym :: Type
- type SInteger sym :: Type
- type SFloat sym :: Type
- type SEval sym :: Type -> Type
-
- -- ==== Evaluation monad operations ====
-
- -- | Check if an operation is "ready", which means its
- -- evaluation will be trivial.
- isReady :: sym -> SEval sym a -> Bool
-
- -- | 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.
- sDeclareHole :: sym -> String -> SEval sym (SEval sym a, SEval sym a -> SEval sym ())
-
- -- | 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.
- sDelayFill :: sym -> SEval sym a -> SEval sym a -> SEval sym (SEval sym a)
-
- -- | Begin evaluating the given computation eagerly in a separate thread
- -- and return a thunk which will await the completion of the given computation
- -- when forced.
- sSpark :: sym -> SEval sym a -> SEval sym (SEval sym a)
-
- -- | Merge the two given computations according to the predicate.
- mergeEval ::
- sym ->
- (SBit sym -> a -> a -> SEval sym a) {- ^ A merge operation on values -} ->
- SBit sym {- ^ The condition -} ->
- SEval sym a {- ^ The "then" computation -} ->
- SEval sym a {- ^ The "else" computation -} ->
- SEval sym a
-
- -- | Assert that a condition must hold, and indicate what sort of
- -- error is indicated if the condition fails.
- assertSideCondition :: sym -> SBit sym -> EvalError -> SEval sym ()
-
- -- | Indiciate that an error condition exists
- raiseError :: sym -> EvalError -> SEval sym a
-
-
- -- ==== Pretty printing ====
- -- | Pretty-print an individual bit
- ppBit :: sym -> SBit sym -> Doc
-
- -- | Pretty-print a word value
- ppWord :: sym -> PPOpts -> SWord sym -> Doc
-
- -- | Pretty-print an integer value
- ppInteger :: sym -> PPOpts -> SInteger sym -> Doc
-
- -- | Pretty-print a floating-point value
- ppFloat :: sym -> PPOpts -> SFloat sym -> Doc
-
-
- -- ==== Identifying literal values ====
-
- -- | Determine if this symbolic bit is a boolean literal
- bitAsLit :: sym -> SBit sym -> Maybe Bool
-
- -- | The number of bits in a word value.
- wordLen :: sym -> SWord sym -> Integer
-
- -- | Determine if this symbolic word is a literal.
- -- If so, return the bit width and value.
- wordAsLit :: sym -> SWord sym -> Maybe (Integer, Integer)
-
- -- | Attempt to render a word value as an ASCII character. Return 'Nothing'
- -- if the character value is unknown (e.g., for symbolic values).
- wordAsChar :: sym -> SWord sym -> Maybe Char
-
- -- | Determine if this symbolic integer is a literal
- integerAsLit :: sym -> SInteger sym -> Maybe Integer
-
- -- ==== Creating literal values ====
-
- -- | Construct a literal bit value from a boolean.
- bitLit :: sym -> Bool -> SBit sym
-
- -- | Construct a literal word value given a bit width and a value.
- wordLit ::
- sym ->
- Integer {- ^ Width -} ->
- Integer {- ^ Value -} ->
- SEval sym (SWord sym)
-
- -- | Construct a literal integer value from the given integer.
- integerLit ::
- sym ->
- Integer {- ^ Value -} ->
- SEval sym (SInteger sym)
-
- -- | Construct a floating point value from the given rational.
- fpLit ::
- sym ->
- Integer {- ^ exponent bits -} ->
- Integer {- ^ precision bits -} ->
- Rational {- ^ The rational -} ->
- SEval sym (SFloat sym)
-
- -- ==== If/then/else operations ====
- iteBit :: sym -> SBit sym -> SBit sym -> SBit sym -> SEval sym (SBit sym)
- iteWord :: sym -> SBit sym -> SWord sym -> SWord sym -> SEval sym (SWord sym)
- iteInteger :: sym -> SBit sym -> SInteger sym -> SInteger sym -> SEval sym (SInteger sym)
-
-
- -- ==== Bit operations ====
- bitEq :: sym -> SBit sym -> SBit sym -> SEval sym (SBit sym)
- bitOr :: sym -> SBit sym -> SBit sym -> SEval sym (SBit sym)
- bitAnd :: sym -> SBit sym -> SBit sym -> SEval sym (SBit sym)
- bitXor :: sym -> SBit sym -> SBit sym -> SEval sym (SBit sym)
- bitComplement :: sym -> SBit sym -> SEval sym (SBit sym)
-
-
- -- ==== Word operations ====
-
- -- | Extract the numbered bit from the word.
- --
- -- NOTE: this assumes that the sequence of bits is big-endian and finite, so the
- -- bit numbered 0 is the most significant bit.
- wordBit ::
- sym ->
- SWord sym ->
- Integer {- ^ Bit position to extract -} ->
- SEval sym (SBit sym)
-
- -- | Update the numbered bit in the word.
- --
- -- NOTE: this assumes that the sequence of bits is big-endian and finite, so the
- -- bit numbered 0 is the most significant bit.
- wordUpdate ::
- sym ->
- SWord sym ->
- Integer {- ^ Bit position to update -} ->
- SBit sym ->
- SEval sym (SWord sym)
-
- -- | 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 ::
- sym ->
- [SBit sym] ->
- SEval sym (SWord sym)
-
- -- | 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 ::
- sym ->
- SWord sym ->
- SEval sym [SBit sym]
-
- -- | Construct a packed word of the specified width from an integer value.
- wordFromInt ::
- sym ->
- Integer {- ^ bit-width -} ->
- SInteger sym ->
- SEval sym (SWord sym)
-
- -- | Concatenate the two given word values.
- -- NOTE: the first argument represents the more-significant bits
- joinWord ::
- sym ->
- SWord sym ->
- SWord sym ->
- SEval sym (SWord sym)
-
- -- | 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 ::
- sym ->
- Integer {- ^ left width -} ->
- Integer {- ^ right width -} ->
- SWord sym ->
- SEval sym (SWord sym, SWord sym)
-
- -- | 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 equivalent to
- -- first shifting @w@ right by @i@ bits, and then truncating to
- -- @n@ bits.
- extractWord ::
- sym ->
- Integer {- ^ Number of bits to take -} ->
- Integer {- ^ starting bit -} ->
- SWord sym ->
- SEval sym (SWord sym)
-
- -- | Bitwise OR
- wordOr ::
- sym ->
- SWord sym ->
- SWord sym ->
- SEval sym (SWord sym)
-
- -- | Bitwise AND
- wordAnd ::
- sym ->
- SWord sym ->
- SWord sym ->
- SEval sym (SWord sym)
-
- -- | Bitwise XOR
- wordXor ::
- sym ->
- SWord sym ->
- SWord sym ->
- SEval sym (SWord sym)
-
- -- | Bitwise complement
- wordComplement ::
- sym ->
- SWord sym ->
- SEval sym (SWord sym)
-
- -- | 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 ::
- sym ->
- SWord sym ->
- SWord sym ->
- SEval sym (SWord sym)
-
- -- | 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 ::
- sym ->
- SWord sym ->
- SWord sym ->
- SEval sym (SWord sym)
-
- -- | 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 ::
- sym ->
- SWord sym ->
- SWord sym ->
- SEval sym (SWord sym)
-
- -- | 2's complement unsigned division of packed words. The arguments must have
- -- equal bit width, and the result is of the same width. It is illegal to
- -- call with a second argument concretely equal to 0.
- wordDiv ::
- sym ->
- SWord sym ->
- SWord sym ->
- SEval sym (SWord sym)
-
- -- | 2's complement unsigned modulus of packed words. The arguments must have
- -- equal bit width, and the result is of the same width. It is illegal to
- -- call with a second argument concretely equal to 0.
- wordMod ::
- sym ->
- SWord sym ->
- SWord sym ->
- SEval sym (SWord sym)
-
- -- | 2's complement signed division of packed words. The arguments must have
- -- equal bit width, and the result is of the same width. It is illegal to
- -- call with a second argument concretely equal to 0.
- wordSignedDiv ::
- sym ->
- SWord sym ->
- SWord sym ->
- SEval sym (SWord sym)
-
- -- | 2's complement signed modulus of packed words. The arguments must have
- -- equal bit width, and the result is of the same width. It is illegal to
- -- call with a second argument concretely equal to 0.
- wordSignedMod ::
- sym ->
- SWord sym ->
- SWord sym ->
- SEval sym (SWord sym)
-
- -- | 2's complement negation of bitvectors
- wordNegate ::
- sym ->
- SWord sym ->
- SEval sym (SWord sym)
-
- -- | Compute rounded-up log-2 of the input
- wordLg2 ::
- sym ->
- SWord sym ->
- SEval sym (SWord sym)
-
- -- | Test if two words are equal. Arguments must have the same width.
- wordEq ::
- sym ->
- SWord sym ->
- SWord sym ->
- SEval sym (SBit sym)
-
- -- | Signed less-than comparison on words. Arguments must have the same width.
- wordSignedLessThan ::
- sym ->
- SWord sym ->
- SWord sym ->
- SEval sym (SBit sym)
-
- -- | Unsigned less-than comparison on words. Arguments must have the same width.
- wordLessThan ::
- sym ->
- SWord sym ->
- SWord sym ->
- SEval sym (SBit sym)
-
- -- | Unsigned greater-than comparison on words. Arguments must have the same width.
- wordGreaterThan ::
- sym ->
- SWord sym ->
- SWord sym ->
- SEval sym (SBit sym)
-
- -- | Construct an integer value from the given packed word.
- wordToInt ::
- sym ->
- SWord sym ->
- SEval sym (SInteger sym)
-
- -- ==== Integer operations ====
-
- -- | Addition of unbounded integers.
- intPlus ::
- sym ->
- SInteger sym ->
- SInteger sym ->
- SEval sym (SInteger sym)
-
- -- | Negation of unbounded integers
- intNegate ::
- sym ->
- SInteger sym ->
- SEval sym (SInteger sym)
-
- -- | Subtraction of unbounded integers.
- intMinus ::
- sym ->
- SInteger sym ->
- SInteger sym ->
- SEval sym (SInteger sym)
-
- -- | Multiplication of unbounded integers.
- intMult ::
- sym ->
- SInteger sym ->
- SInteger sym ->
- SEval sym (SInteger sym)
-
- -- | Integer division, rounding down. It is illegal to
- -- call with a second argument concretely equal to 0.
- -- Same semantics as Haskell's @div@ operation.
- intDiv ::
- sym ->
- SInteger sym ->
- SInteger sym ->
- SEval sym (SInteger sym)
-
- -- | Integer modulus, with division rounding down. It is illegal to
- -- call with a second argument concretely equal to 0.
- -- Same semantics as Haskell's @mod@ operation.
- intMod ::
- sym ->
- SInteger sym ->
- SInteger sym ->
- SEval sym (SInteger sym)
-
- -- | Equality comparison on integers
- intEq ::
- sym ->
- SInteger sym ->
- SInteger sym ->
- SEval sym (SBit sym)
-
- -- | Less-than comparison on integers
- intLessThan ::
- sym ->
- SInteger sym ->
- SInteger sym ->
- SEval sym (SBit sym)
-
- -- | Greater-than comparison on integers
- intGreaterThan ::
- sym ->
- SInteger sym ->
- SInteger sym ->
- SEval sym (SBit sym)
-
-
- -- ==== Operations on Z_n ====
-
- -- | Turn an integer into a value in Z_n
- intToZn ::
- sym ->
- Integer {- ^ modulus -} ->
- SInteger sym ->
- SEval sym (SInteger sym)
-
- -- | Transform a Z_n value into an integer, ensuring the value is properly
- -- reduced modulo n
- znToInt ::
- sym ->
- Integer {- ^ modulus -} ->
- SInteger sym ->
- SEval sym (SInteger sym)
-
- -- | Addition of integers modulo n, for a concrete positive integer n.
- znPlus ::
- sym ->
- Integer {- ^ modulus -} ->
- SInteger sym ->
- SInteger sym ->
- SEval sym (SInteger sym)
-
- -- | Additive inverse of integers modulo n
- znNegate ::
- sym ->
- Integer {- ^ modulus -} ->
- SInteger sym ->
- SEval sym (SInteger sym)
-
- -- | Subtraction of integers modulo n, for a concrete positive integer n.
- znMinus ::
- sym ->
- Integer {- ^ modulus -} ->
- SInteger sym ->
- SInteger sym ->
- SEval sym (SInteger sym)
-
- -- | Multiplication of integers modulo n, for a concrete positive integer n.
- znMult ::
- sym ->
- Integer {- ^ modulus -} ->
- SInteger sym ->
- SInteger sym ->
- SEval sym (SInteger sym)
-
- -- | Equality test of integers modulo n
- znEq ::
- sym ->
- Integer {- ^ modulus -} ->
- SInteger sym ->
- SInteger sym ->
- SEval sym (SBit sym)
-
- -- == Float Operations ==
- fpEq :: sym -> SFloat sym -> SFloat sym -> SEval sym (SBit sym)
- fpLessThan :: sym -> SFloat sym -> SFloat sym -> SEval sym (SBit sym)
- fpGreaterThan :: sym -> SFloat sym -> SFloat sym -> SEval sym (SBit sym)
-
- fpPlus, fpMinus, fpMult, fpDiv :: FPArith2 sym
- fpNeg :: sym -> SFloat sym -> SEval sym (SFloat sym)
-
- fpToInteger ::
- sym ->
- String {- ^ Name of the function for error reporting -} ->
- SWord sym {-^ Rounding mode -} ->
- SFloat sym -> SEval sym (SInteger sym)
-
- fpFromInteger ::
- sym ->
- Integer {- exp width -} ->
- Integer {- prec width -} ->
- SWord sym {- ^ rounding mode -} ->
- SInteger sym {- ^ the integeer to use -} ->
- SEval sym (SFloat sym)
-
-type FPArith2 sym =
- sym ->
- SWord sym ->
- SFloat sym ->
- SFloat sym ->
- SEval sym (SFloat sym)
-
-
-
-
-
diff --git a/src/Cryptol/Eval/Concrete.hs b/src/Cryptol/Eval/Concrete.hs
--- a/src/Cryptol/Eval/Concrete.hs
+++ b/src/Cryptol/Eval/Concrete.hs
@@ -7,49 +7,57 @@
-- Portability : portable
{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE Safe #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
module Cryptol.Eval.Concrete
- ( module Cryptol.Eval.Concrete.Value
- , evalPrim
+ ( module Cryptol.Backend.Concrete
+ , Value
+ , primTable
, toExpr
) where
-import Control.Monad (join, guard, zipWithM)
+import Control.Monad (join, guard, zipWithM, foldM)
import Data.Bits (Bits(..))
-import Data.Ratio(numerator,denominator)
+import Data.Ratio((%),numerator,denominator)
+import Data.Word(Word32, Word64)
import MonadLib( ChoiceT, findOne, lift )
import qualified LibBF as FP
+import qualified Cryptol.F2 as F2
import qualified Data.Map.Strict as Map
+import Data.Map(Map)
import Cryptol.TypeCheck.Solver.InfNat (Nat'(..))
-import Cryptol.Eval.Backend
-import Cryptol.Eval.Concrete.Float(floatPrims)
-import Cryptol.Eval.Concrete.FloatHelpers(bfValue)
-import Cryptol.Eval.Concrete.Value
+
+import Cryptol.Backend
+import Cryptol.Backend.Concrete
+import Cryptol.Backend.FloatHelpers
+import Cryptol.Backend.Monad
+
import Cryptol.Eval.Generic hiding (logicShift)
-import Cryptol.Eval.Monad
import Cryptol.Eval.Type
import Cryptol.Eval.Value
+import qualified Cryptol.SHA as SHA
+import qualified Cryptol.AES as AES
+import qualified Cryptol.PrimeEC as PrimeEC
import Cryptol.ModuleSystem.Name
-import Cryptol.Testing.Random (randomV)
import Cryptol.TypeCheck.AST as AST
import Cryptol.Utils.Panic (panic)
-import Cryptol.Utils.Ident (PrimIdent,prelPrim,floatPrim)
+import Cryptol.Utils.Ident (PrimIdent,prelPrim,floatPrim,suiteBPrim,primeECPrim)
import Cryptol.Utils.PP
import Cryptol.Utils.Logger(logPrint)
import Cryptol.Utils.RecordMap
+type Value = GenValue Concrete
-- Value to Expression conversion ----------------------------------------------
@@ -131,12 +139,12 @@
-- Primitives ------------------------------------------------------------------
-evalPrim :: PrimIdent -> Maybe Value
-evalPrim prim = Map.lookup prim primTable
-
-primTable :: Map.Map PrimIdent Value
-primTable = let sym = Concrete in
+primTable :: EvalOpts -> Map PrimIdent Value
+primTable eOpts = let sym = Concrete in
Map.union (floatPrims sym) $
+ Map.union suiteBPrims $
+ Map.union primeECPrims $
+
Map.fromList $ map (\(n, v) -> (prelPrim n, v))
[ -- Literals
@@ -301,6 +309,20 @@
updatePrim sym updateBack_word updateBack)
-- Misc
+ , ("foldl" , {-# SCC "Prelude::foldl" #-}
+ foldlV sym)
+
+ , ("foldl'" , {-# SCC "Prelude::foldl'" #-}
+ foldl'V sym)
+
+ , ("deepseq" , {-# SCC "Prelude::deepseq" #-}
+ tlam $ \_a ->
+ tlam $ \_b ->
+ lam $ \x -> pure $
+ lam $ \y ->
+ do _ <- forceValue =<< x
+ y)
+
, ("parmap" , {-# SCC "Prelude::parmap" #-}
parmapV sym)
@@ -324,15 +346,261 @@
lam $ \x -> return $
lam $ \y -> do
msg <- valueToString sym =<< s
- EvalOpts { evalPPOpts, evalLogger } <- getEvalOpts
+ let EvalOpts { evalPPOpts, evalLogger } = eOpts
doc <- ppValue sym evalPPOpts =<< x
yv <- y
io $ logPrint evalLogger
$ if null msg then doc else text msg <+> doc
return yv)
+
+ , ("pmult",
+ ilam $ \u ->
+ ilam $ \v ->
+ wlam Concrete $ \(BV _ x) -> return $
+ wlam Concrete $ \(BV _ y) ->
+ let z = if u <= v then
+ F2.pmult (fromInteger (u+1)) x y
+ else
+ F2.pmult (fromInteger (v+1)) y x
+ in return . VWord (1+u+v) . pure . WordVal . mkBv (1+u+v) $! z)
+
+ , ("pmod",
+ ilam $ \_u ->
+ ilam $ \v ->
+ wlam Concrete $ \(BV w x) -> return $
+ wlam Concrete $ \(BV _ m) ->
+ do assertSideCondition sym (m /= 0) DivideByZero
+ return . VWord v . pure . WordVal . mkBv v $! F2.pmod (fromInteger w) x m)
+
+ , ("pdiv",
+ ilam $ \_u ->
+ ilam $ \_v ->
+ wlam Concrete $ \(BV w x) -> return $
+ wlam Concrete $ \(BV _ m) ->
+ do assertSideCondition sym (m /= 0) DivideByZero
+ return . VWord w . pure . WordVal . mkBv w $! F2.pdiv (fromInteger w) x m)
]
+primeECPrims :: Map.Map PrimIdent Value
+primeECPrims = Map.fromList $ map (\(n,v) -> (primeECPrim n, v))
+ [ ("ec_double", {-# SCC "PrimeEC::ec_double" #-}
+ ilam $ \p ->
+ lam $ \s ->
+ do s' <- toProjectivePoint =<< s
+ let r = PrimeEC.ec_double (PrimeEC.primeModulus p) s'
+ fromProjectivePoint $! r)
+
+ , ("ec_add_nonzero", {-# SCC "PrimeEC::ec_add_nonzero" #-}
+ ilam $ \p ->
+ lam $ \s -> pure $
+ lam $ \t ->
+ do s' <- toProjectivePoint =<< s
+ t' <- toProjectivePoint =<< t
+ let r = PrimeEC.ec_add_nonzero (PrimeEC.primeModulus p) s' t'
+ fromProjectivePoint $! r)
+
+ , ("ec_mult", {-# SCC "PrimeEC::ec_mult" #-}
+ ilam $ \p ->
+ lam $ \d -> pure $
+ lam $ \s ->
+ do d' <- fromVInteger <$> d
+ s' <- toProjectivePoint =<< s
+ let r = PrimeEC.ec_mult (PrimeEC.primeModulus p) d' s'
+ fromProjectivePoint $! r)
+
+ , ("ec_twin_mult", {-# SCC "PrimeEC::ec_twin_mult" #-}
+ ilam $ \p ->
+ lam $ \d0 -> pure $
+ lam $ \s -> pure $
+ lam $ \d1 -> pure $
+ lam $ \t ->
+ do d0' <- fromVInteger <$> d0
+ s' <- toProjectivePoint =<< s
+ d1' <- fromVInteger <$> d1
+ t' <- toProjectivePoint =<< t
+ let r = PrimeEC.ec_twin_mult (PrimeEC.primeModulus p) d0' s' d1' t'
+ fromProjectivePoint $! r)
+ ]
+
+toProjectivePoint :: Value -> Eval PrimeEC.ProjectivePoint
+toProjectivePoint v = PrimeEC.ProjectivePoint <$> f "x" <*> f "y" <*> f "z"
+ where
+ f nm = PrimeEC.integerToBigNat . fromVInteger <$> lookupRecord nm v
+
+fromProjectivePoint :: PrimeEC.ProjectivePoint -> Eval Value
+fromProjectivePoint (PrimeEC.ProjectivePoint x y z) =
+ pure . VRecord . recordFromFields $ [("x", f x), ("y", f y), ("z", f z)]
+ where
+ f i = pure (VInteger (PrimeEC.bigNatToInteger i))
+
+
+
+suiteBPrims :: Map.Map PrimIdent Value
+suiteBPrims = Map.fromList $ map (\(n, v) -> (suiteBPrim n, v))
+ [ ("processSHA2_224", {-# SCC "SuiteB::processSHA2_224" #-}
+ ilam $ \n ->
+ lam $ \xs ->
+ do blks <- enumerateSeqMap n . fromVSeq <$> xs
+ (SHA.SHA256S w0 w1 w2 w3 w4 w5 w6 _) <-
+ foldM (\st blk -> seq st (SHA.processSHA256Block st <$> (toSHA256Block =<< blk)))
+ SHA.initialSHA224State blks
+ let f :: Word32 -> Eval Value
+ f = pure . VWord 32 . pure . WordVal . BV 32 . toInteger
+ zs = finiteSeqMap Concrete (map f [w0,w1,w2,w3,w4,w5,w6])
+ seq zs (pure (VSeq 7 zs)))
+
+ , ("processSHA2_256", {-# SCC "SuiteB::processSHA2_256" #-}
+ ilam $ \n ->
+ lam $ \xs ->
+ do blks <- enumerateSeqMap n . fromVSeq <$> xs
+ (SHA.SHA256S w0 w1 w2 w3 w4 w5 w6 w7) <-
+ foldM (\st blk -> seq st (SHA.processSHA256Block st <$> (toSHA256Block =<< blk)))
+ SHA.initialSHA256State blks
+ let f :: Word32 -> Eval Value
+ f = pure . VWord 32 . pure . WordVal . BV 32 . toInteger
+ zs = finiteSeqMap Concrete (map f [w0,w1,w2,w3,w4,w5,w6,w7])
+ seq zs (pure (VSeq 8 zs)))
+
+ , ("processSHA2_384", {-# SCC "SuiteB::processSHA2_384" #-}
+ ilam $ \n ->
+ lam $ \xs ->
+ do blks <- enumerateSeqMap n . fromVSeq <$> xs
+ (SHA.SHA512S w0 w1 w2 w3 w4 w5 _ _) <-
+ foldM (\st blk -> seq st (SHA.processSHA512Block st <$> (toSHA512Block =<< blk)))
+ SHA.initialSHA384State blks
+ let f :: Word64 -> Eval Value
+ f = pure . VWord 64 . pure . WordVal . BV 64 . toInteger
+ zs = finiteSeqMap Concrete (map f [w0,w1,w2,w3,w4,w5])
+ seq zs (pure (VSeq 6 zs)))
+
+ , ("processSHA2_512", {-# SCC "SuiteB::processSHA2_512" #-}
+ ilam $ \n ->
+ lam $ \xs ->
+ do blks <- enumerateSeqMap n . fromVSeq <$> xs
+ (SHA.SHA512S w0 w1 w2 w3 w4 w5 w6 w7) <-
+ foldM (\st blk -> seq st (SHA.processSHA512Block st <$> (toSHA512Block =<< blk)))
+ SHA.initialSHA512State blks
+ let f :: Word64 -> Eval Value
+ f = pure . VWord 64 . pure . WordVal . BV 64 . toInteger
+ zs = finiteSeqMap Concrete (map f [w0,w1,w2,w3,w4,w5,w6,w7])
+ seq zs (pure (VSeq 8 zs)))
+
+ , ("AESKeyExpand", {-# SCC "SuiteB::AESKeyExpand" #-}
+ ilam $ \k ->
+ lam $ \seed ->
+ do ss <- fromVSeq <$> seed
+ let toWord :: Integer -> Eval Word32
+ toWord i = fromInteger. bvVal <$> (fromVWord Concrete "AESInfKeyExpand" =<< lookupSeqMap ss i)
+ let fromWord :: Word32 -> Eval Value
+ fromWord = pure . VWord 32 . pure . WordVal . BV 32 . toInteger
+ kws <- mapM toWord [0 .. k-1]
+ let ws = AES.keyExpansionWords k kws
+ let len = 4*(k+7)
+ pure (VSeq len (finiteSeqMap Concrete (map fromWord ws))))
+
+ , ("AESInvMixColumns", {-# SCC "SuiteB::AESInvMixColumns" #-}
+ lam $ \st ->
+ do ss <- fromVSeq <$> st
+ let toWord :: Integer -> Eval Word32
+ toWord i = fromInteger. bvVal <$> (fromVWord Concrete "AESInvMixColumns" =<< lookupSeqMap ss i)
+ let fromWord :: Word32 -> Eval Value
+ fromWord = pure . VWord 32 . pure . WordVal . BV 32 . toInteger
+ ws <- mapM toWord [0,1,2,3]
+ let ws' = AES.invMixColumns ws
+ pure . VSeq 4 . finiteSeqMap Concrete . map fromWord $ ws')
+
+ , ("AESEncRound", {-# SCC "SuiteB::AESEncRound" #-}
+ lam $ \st ->
+ do ss <- fromVSeq <$> st
+ let toWord :: Integer -> Eval Word32
+ toWord i = fromInteger. bvVal <$> (fromVWord Concrete "AESEncRound" =<< lookupSeqMap ss i)
+ let fromWord :: Word32 -> Eval Value
+ fromWord = pure . VWord 32 . pure . WordVal . BV 32 . toInteger
+ ws <- mapM toWord [0,1,2,3]
+ let ws' = AES.aesRound ws
+ pure . VSeq 4 . finiteSeqMap Concrete . map fromWord $ ws')
+
+ , ("AESEncFinalRound", {-# SCC "SuiteB::AESEncFinalRound" #-}
+ lam $ \st ->
+ do ss <- fromVSeq <$> st
+ let toWord :: Integer -> Eval Word32
+ toWord i = fromInteger. bvVal <$> (fromVWord Concrete "AESEncFinalRound" =<< lookupSeqMap ss i)
+ let fromWord :: Word32 -> Eval Value
+ fromWord = pure . VWord 32 . pure . WordVal . BV 32 . toInteger
+ ws <- mapM toWord [0,1,2,3]
+ let ws' = AES.aesFinalRound ws
+ pure . VSeq 4 . finiteSeqMap Concrete . map fromWord $ ws')
+
+ , ("AESDecRound", {-# SCC "SuiteB::AESDecRound" #-}
+ lam $ \st ->
+ do ss <- fromVSeq <$> st
+ let toWord :: Integer -> Eval Word32
+ toWord i = fromInteger. bvVal <$> (fromVWord Concrete "AESDecRound" =<< lookupSeqMap ss i)
+ let fromWord :: Word32 -> Eval Value
+ fromWord = pure . VWord 32 . pure . WordVal . BV 32 . toInteger
+ ws <- mapM toWord [0,1,2,3]
+ let ws' = AES.aesInvRound ws
+ pure . VSeq 4 . finiteSeqMap Concrete . map fromWord $ ws')
+
+ , ("AESDecFinalRound", {-# SCC "SuiteB::AESDecFinalRound" #-}
+ lam $ \st ->
+ do ss <- fromVSeq <$> st
+ let toWord :: Integer -> Eval Word32
+ toWord i = fromInteger. bvVal <$> (fromVWord Concrete "AESDecFinalRound" =<< lookupSeqMap ss i)
+ let fromWord :: Word32 -> Eval Value
+ fromWord = pure . VWord 32 . pure . WordVal . BV 32 . toInteger
+ ws <- mapM toWord [0,1,2,3]
+ let ws' = AES.aesInvFinalRound ws
+ pure . VSeq 4 . finiteSeqMap Concrete . map fromWord $ ws')
+ ]
+
+
+toSHA256Block :: Value -> Eval SHA.SHA256Block
+toSHA256Block blk =
+ do let ws = fromVSeq blk
+ let toWord i = fromInteger . bvVal <$> (fromVWord Concrete "toSHA256Block" =<< lookupSeqMap ws i)
+ SHA.SHA256Block <$>
+ (toWord 0) <*>
+ (toWord 1) <*>
+ (toWord 2) <*>
+ (toWord 3) <*>
+ (toWord 4) <*>
+ (toWord 5) <*>
+ (toWord 6) <*>
+ (toWord 7) <*>
+ (toWord 8) <*>
+ (toWord 9) <*>
+ (toWord 10) <*>
+ (toWord 11) <*>
+ (toWord 12) <*>
+ (toWord 13) <*>
+ (toWord 14) <*>
+ (toWord 15)
+
+
+toSHA512Block :: Value -> Eval SHA.SHA512Block
+toSHA512Block blk =
+ do let ws = fromVSeq blk
+ let toWord i = fromInteger . bvVal <$> (fromVWord Concrete "toSHA512Block" =<< lookupSeqMap ws i)
+ SHA.SHA512Block <$>
+ (toWord 0) <*>
+ (toWord 1) <*>
+ (toWord 2) <*>
+ (toWord 3) <*>
+ (toWord 4) <*>
+ (toWord 5) <*>
+ (toWord 6) <*>
+ (toWord 7) <*>
+ (toWord 8) <*>
+ (toWord 9) <*>
+ (toWord 10) <*>
+ (toWord 11) <*>
+ (toWord 12) <*>
+ (toWord 13) <*>
+ (toWord 14) <*>
+ (toWord 15)
+
--------------------------------------------------------------------------------
sshrV :: Value
@@ -527,3 +795,55 @@
updateBack_word (Nat n) _eltTy bs (Right w) val = do
idx <- bvVal <$> asWordVal Concrete w
updateWordValue Concrete bs (n - idx - 1) (fromVBit <$> val)
+
+
+floatPrims :: Concrete -> Map PrimIdent Value
+floatPrims sym = Map.fromList [ (floatPrim i,v) | (i,v) <- nonInfixTable ]
+ where
+ (~>) = (,)
+ nonInfixTable =
+ [ "fpNaN" ~> ilam \e -> ilam \p ->
+ VFloat BF { bfValue = FP.bfNaN
+ , bfExpWidth = e, bfPrecWidth = p }
+
+ , "fpPosInf" ~> ilam \e -> ilam \p ->
+ VFloat BF { bfValue = FP.bfPosInf
+ , bfExpWidth = e, bfPrecWidth = p }
+
+ , "fpFromBits" ~> ilam \e -> ilam \p -> wlam sym \bv ->
+ pure $ VFloat $ floatFromBits e p $ bvVal bv
+
+ , "fpToBits" ~> ilam \e -> ilam \p -> flam \x ->
+ pure $ word sym (e + p)
+ $ floatToBits e p
+ $ bfValue x
+ , "=.=" ~> ilam \_ -> ilam \_ -> flam \x -> pure $ flam \y ->
+ pure $ VBit
+ $ bitLit sym
+ $ FP.bfCompare (bfValue x) (bfValue y) == EQ
+
+ , "fpIsFinite" ~> ilam \_ -> ilam \_ -> flam \x ->
+ pure $ VBit $ bitLit sym $ FP.bfIsFinite $ bfValue x
+
+ -- From Backend class
+ , "fpAdd" ~> fpBinArithV sym fpPlus
+ , "fpSub" ~> fpBinArithV sym fpMinus
+ , "fpMul" ~> fpBinArithV sym fpMult
+ , "fpDiv" ~> fpBinArithV sym fpDiv
+
+ , "fpFromRational" ~>
+ ilam \e -> ilam \p -> wlam sym \r -> pure $ lam \x ->
+ do rat <- fromVRational <$> x
+ VFloat <$> do mode <- fpRoundMode sym r
+ pure $ floatFromRational e p mode
+ $ sNum rat % sDenom rat
+ , "fpToRational" ~>
+ ilam \_e -> ilam \_p -> flam \fp ->
+ case floatToRational "fpToRational" fp of
+ Left err -> raiseError sym err
+ Right r -> pure $
+ VRational
+ SRational { sNum = numerator r, sDenom = denominator r }
+ ]
+
+
diff --git a/src/Cryptol/Eval/Concrete/Float.hs b/src/Cryptol/Eval/Concrete/Float.hs
deleted file mode 100644
--- a/src/Cryptol/Eval/Concrete/Float.hs
+++ /dev/null
@@ -1,69 +0,0 @@
-{-# Language BlockArguments #-}
-{-# Language OverloadedStrings #-}
--- | Concrete evaluations for floating point primitives.
-module Cryptol.Eval.Concrete.Float where
-
-import Data.Map(Map)
-import Data.Ratio((%),numerator,denominator)
-import qualified Data.Map as Map
-import LibBF
-
-import Cryptol.Utils.Ident(PrimIdent, floatPrim)
-import Cryptol.Eval.Value
-import Cryptol.Eval.Generic
-import Cryptol.Eval.Concrete.Value
-import Cryptol.Eval.Backend(SRational(..))
-import Cryptol.Eval.Concrete.FloatHelpers
-
-
-
-floatPrims :: Concrete -> Map PrimIdent Value
-floatPrims sym = Map.fromList [ (floatPrim i,v) | (i,v) <- nonInfixTable ]
- where
- (~>) = (,)
- nonInfixTable =
- [ "fpNaN" ~> ilam \e -> ilam \p ->
- VFloat BF { bfValue = bfNaN
- , bfExpWidth = e, bfPrecWidth = p }
-
- , "fpPosInf" ~> ilam \e -> ilam \p ->
- VFloat BF { bfValue = bfPosInf
- , bfExpWidth = e, bfPrecWidth = p }
-
- , "fpFromBits" ~> ilam \e -> ilam \p -> wlam sym \bv ->
- pure $ VFloat $ floatFromBits e p $ bvVal bv
-
- , "fpToBits" ~> ilam \e -> ilam \p -> flam \x ->
- pure $ word sym (e + p)
- $ floatToBits e p
- $ bfValue x
- , "=.=" ~> ilam \_ -> ilam \_ -> flam \x -> pure $ flam \y ->
- pure $ VBit
- $ bitLit sym
- $ bfCompare (bfValue x) (bfValue y) == EQ
-
- , "fpIsFinite" ~> ilam \_ -> ilam \_ -> flam \x ->
- pure $ VBit $ bitLit sym $ bfIsFinite $ bfValue x
-
- -- From Backend class
- , "fpAdd" ~> fpBinArithV sym fpPlus
- , "fpSub" ~> fpBinArithV sym fpMinus
- , "fpMul" ~> fpBinArithV sym fpMult
- , "fpDiv" ~> fpBinArithV sym fpDiv
-
- , "fpFromRational" ~>
- ilam \e -> ilam \p -> wlam sym \r -> pure $ lam \x ->
- do rat <- fromVRational <$> x
- VFloat <$> do mode <- fpRoundMode sym r
- pure $ floatFromRational e p mode
- $ sNum rat % sDenom rat
- , "fpToRational" ~>
- ilam \_e -> ilam \_p -> flam \fp ->
- case floatToRational "fpToRational" fp of
- Left err -> raiseError sym err
- Right r -> pure $
- VRational
- SRational { sNum = numerator r, sDenom = denominator r }
- ]
-
-
diff --git a/src/Cryptol/Eval/Concrete/FloatHelpers.hs b/src/Cryptol/Eval/Concrete/FloatHelpers.hs
deleted file mode 100644
--- a/src/Cryptol/Eval/Concrete/FloatHelpers.hs
+++ /dev/null
@@ -1,252 +0,0 @@
-{-# Language BlockArguments, OverloadedStrings #-}
-{-# Language BangPatterns #-}
-module Cryptol.Eval.Concrete.FloatHelpers where
-
-import Data.Ratio(numerator,denominator)
-import Data.Int(Int64)
-import Data.Bits(testBit,setBit,shiftL,shiftR,(.&.),(.|.))
-import LibBF
-
-import Cryptol.Utils.PP
-import Cryptol.Utils.Panic(panic)
-import Cryptol.Eval.Monad( EvalError(..)
- , PPOpts(..), PPFloatFormat(..), PPFloatExp(..)
- )
-
-
-data BF = BF
- { bfExpWidth :: Integer
- , bfPrecWidth :: Integer
- , bfValue :: BigFloat
- }
-
-
--- | Make LibBF options for the given precision and rounding mode.
-fpOpts :: Integer -> Integer -> RoundMode -> BFOpts
-fpOpts e p r =
- case ok of
- Just opts -> opts
- Nothing -> panic "floatOpts" [ "Invalid Float size"
- , "exponent: " ++ show e
- , "precision: " ++ show p
- ]
- where
- ok = do eb <- rng expBits expBitsMin expBitsMax e
- pb <- rng precBits precBitsMin precBitsMax p
- pure (eb <> pb <> allowSubnormal <> rnd r)
-
- rng f a b x = if toInteger a <= x && x <= toInteger b
- then Just (f (fromInteger x))
- else Nothing
-
-
-
--- | Mapping from the rounding modes defined in the `Float.cry` to
--- the rounding modes of `LibBF`.
-fpRound :: Integer -> Either EvalError RoundMode
-fpRound n =
- case n of
- 0 -> Right NearEven
- 1 -> Right NearAway
- 2 -> Right ToPosInf
- 3 -> Right ToNegInf
- 4 -> Right ToZero
- _ -> Left (BadRoundingMode n)
-
--- | Check that we didn't get an unexpected status.
-fpCheckStatus :: (BigFloat,Status) -> BigFloat
-fpCheckStatus (r,s) =
- case s of
- MemError -> panic "checkStatus" [ "libBF: Memory error" ]
- _ -> r
-
-
--- | Pretty print a float
-fpPP :: PPOpts -> BF -> Doc
-fpPP opts bf =
- case bfSign num of
- Nothing -> "fpNaN"
- Just s
- | bfIsFinite num -> text hacStr
- | otherwise ->
- case s of
- Pos -> "fpPosInf"
- Neg -> "fpNegInf"
- where
- num = bfValue bf
- precW = bfPrecWidth bf
-
- base = useFPBase opts
-
- withExp :: PPFloatExp -> ShowFmt -> ShowFmt
- withExp e f = case e of
- AutoExponent -> f
- ForceExponent -> f <> forceExp
-
- str = bfToString base fmt num
- fmt = addPrefix <> showRnd NearEven <>
- case useFPFormat opts of
- FloatFree e -> withExp e $ showFreeMin
- $ Just $ fromInteger precW
- FloatFixed n e -> withExp e $ showFixed $ fromIntegral n
- FloatFrac n -> showFrac $ fromIntegral n
-
- -- non-base 10 literals are not overloaded so we add an explicit
- -- .0 if one is not present.
- hacStr
- | base == 10 || elem '.' str = str
- | otherwise = case break (== 'p') str of
- (xs,ys) -> xs ++ ".0" ++ ys
-
-
--- | Make a literal
-fpLit ::
- Integer {- ^ Exponent width -} ->
- Integer {- ^ Precision width -} ->
- Rational ->
- BF
-fpLit e p rat = floatFromRational e p NearEven rat
-
--- | Make a floating point number from a rational, using the given rounding mode
-floatFromRational :: Integer -> Integer -> RoundMode -> Rational -> BF
-floatFromRational e p r rat =
- BF { bfExpWidth = e
- , bfPrecWidth = p
- , bfValue = fpCheckStatus
- if den == 1 then bfRoundFloat opts num
- else bfDiv opts num (bfFromInteger den)
- }
- where
- opts = fpOpts e p r
-
- num = bfFromInteger (numerator rat)
- den = denominator rat
-
-
--- | Convert a floating point number to a rational, if possible.
-floatToRational :: String -> BF -> Either EvalError Rational
-floatToRational fun bf =
- case bfToRep (bfValue bf) of
- BFNaN -> Left (BadValue fun)
- BFRep s num ->
- case num of
- Inf -> Left (BadValue fun)
- Zero -> Right 0
- Num i ev -> Right case s of
- Pos -> ab
- Neg -> negate ab
- where ab = fromInteger i * (2 ^^ ev)
-
-
--- | Convert a floating point number to an integer, if possible.
-floatToInteger :: String -> RoundMode -> BF -> Either EvalError Integer
-floatToInteger fun r fp =
- do rat <- floatToRational fun fp
- pure case r of
- NearEven -> round rat
- NearAway -> if rat > 0 then ceiling rat else floor rat
- ToPosInf -> ceiling rat
- ToNegInf -> floor rat
- ToZero -> truncate rat
- _ -> panic "fpCvtToInteger"
- ["Unexpected rounding mode", show r]
-
-
-
-
-floatFromBits ::
- Integer {- ^ Exponent width -} ->
- Integer {- ^ Precision widht -} ->
- Integer {- ^ Raw bits -} ->
- BF
-floatFromBits e p bv = BF { bfValue = floatFromBits' e p bv
- , bfExpWidth = e, bfPrecWidth = p }
-
-
-
--- | Make a float using "raw" bits.
-floatFromBits' ::
- Integer {- ^ Exponent width -} ->
- Integer {- ^ Precision widht -} ->
- Integer {- ^ Raw bits -} ->
- BigFloat
-
-floatFromBits' e p bits
- | expoBiased == 0 && mant == 0 = -- zero
- if isNeg then bfNegZero else bfPosZero
-
- | expoBiased == eMask && mant == 0 = -- infinity
- if isNeg then bfNegInf else bfPosInf
-
- | expoBiased == eMask = bfNaN -- NaN
-
- | expoBiased == 0 = -- Subnormal
- case bfMul2Exp opts (bfFromInteger mant) (expoVal + 1) of
- (num,Ok) -> if isNeg then bfNeg num else num
- (_,s) -> panic "floatFromBits" [ "Unexpected status: " ++ show s ]
-
- | otherwise = -- Normal
- case bfMul2Exp opts (bfFromInteger mantVal) expoVal of
- (num,Ok) -> if isNeg then bfNeg num else num
- (_,s) -> panic "floatFromBits" [ "Unexpected status: " ++ show s ]
-
- where
- opts = expBits e' <> precBits (p' + 1) <> allowSubnormal
-
- e' = fromInteger e :: Int
- p' = fromInteger p - 1 :: Int
- eMask = (1 `shiftL` e') - 1 :: Int64
- pMask = (1 `shiftL` p') - 1 :: Integer
-
- isNeg = testBit bits (e' + p')
-
- mant = pMask .&. bits :: Integer
- mantVal = mant `setBit` p' :: Integer
- -- accounts for the implicit 1 bit
-
- expoBiased = eMask .&. fromInteger (bits `shiftR` p') :: Int64
- bias = eMask `shiftR` 1 :: Int64
- expoVal = expoBiased - bias - fromIntegral p' :: Int64
-
-
--- | Turn a float into raw bits.
--- @NaN@ is represented as a positive "quiet" @NaN@
--- (most significant bit in the significand is set, the rest of it is 0)
-floatToBits :: Integer -> Integer -> BigFloat -> Integer
-floatToBits e p bf = (isNeg `shiftL` (e' + p'))
- .|. (expBiased `shiftL` p')
- .|. (mant `shiftL` 0)
- where
- e' = fromInteger e :: Int
- p' = fromInteger p - 1 :: Int
-
- eMask = (1 `shiftL` e') - 1 :: Integer
- pMask = (1 `shiftL` p') - 1 :: Integer
-
- (isNeg, expBiased, mant) =
- case bfToRep bf of
- BFNaN -> (0, eMask, 1 `shiftL` (p' - 1))
- BFRep s num -> (sign, be, ma)
- where
- sign = case s of
- Neg -> 1
- Pos -> 0
-
- (be,ma) =
- case num of
- Zero -> (0,0)
- Num i ev
- | ex == 0 -> (0, i `shiftL` (p' - m -1))
- | otherwise -> (ex, (i `shiftL` (p' - m)) .&. pMask)
- where
- m = msb 0 i - 1
- bias = eMask `shiftR` 1
- ex = toInteger ev + bias + toInteger m
-
- Inf -> (eMask,0)
-
- msb !n j = if j == 0 then n else msb (n+1) (j `shiftR` 1)
-
-
-
-
diff --git a/src/Cryptol/Eval/Concrete/Value.hs b/src/Cryptol/Eval/Concrete/Value.hs
deleted file mode 100644
--- a/src/Cryptol/Eval/Concrete/Value.hs
+++ /dev/null
@@ -1,390 +0,0 @@
--- |fpToInteger r e p f
--- Module : Cryptol.Eval.Concrete.Value
--- Copyright : (c) 2013-2020 Galois, Inc.
--- License : BSD3
--- Maintainer : cryptol@galois.com
--- Stability : provisional
--- Portability : portable
-
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE BlockArguments #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE PatternGuards #-}
-{-# LANGUAGE Rank2Types #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE Safe #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE ViewPatterns #-}
-module Cryptol.Eval.Concrete.Value
- ( BV(..)
- , binBV
- , unaryBV
- , bvVal
- , ppBV
- , mkBv
- , mask
- , signedBV
- , signedValue
- , integerToChar
- , lg2
- , Value
- , Concrete(..)
- , liftBinIntMod
- , fpBinArith
- , fpRoundMode
- ) where
-
-import qualified Control.Exception as X
-import Data.Bits
-import Numeric (showIntAtBase)
-import qualified LibBF as FP
-
-import qualified Cryptol.Eval.Arch as Arch
-import qualified Cryptol.Eval.Concrete.FloatHelpers as FP
-import Cryptol.Eval.Monad
-import Cryptol.Eval.Value
-import Cryptol.TypeCheck.Solver.InfNat (genLog)
-import Cryptol.Utils.Panic (panic)
-import Cryptol.Utils.PP
-
-data Concrete = Concrete deriving Show
-
-type Value = GenValue Concrete
-
--- | Concrete bitvector values: width, value
--- Invariant: The value must be within the range 0 .. 2^width-1
-data BV = BV !Integer !Integer
-
-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 :: Applicative m => (Integer -> Integer -> Integer) -> BV -> BV -> m BV
-binBV f (BV w x) (BV _ y) = pure $! mkBv w (f x y)
-{-# INLINE binBV #-}
-
--- | 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
-{-# INLINE unaryBV #-}
-
-bvVal :: BV -> Integer
-bvVal (BV _w x) = x
-{-# INLINE bvVal #-}
-
--- | Smart constructor for 'BV's that checks for the width limit
-mkBv :: Integer -> Integer -> BV
-mkBv w i = BV w (mask w i)
-
-signedBV :: BV -> Integer
-signedBV (BV i x) = signedValue i x
-
-signedValue :: Integer -> Integer -> Integer
-signedValue i x = if testBit x (fromInteger (i-1)) then x - (bit (fromInteger i)) else x
-
-integerToChar :: Integer -> Char
-integerToChar = toEnum . fromInteger
-
-lg2 :: Integer -> Integer
-lg2 i = case genLog i 2 of
- Just (i',isExact) | isExact -> i'
- | otherwise -> i' + 1
- Nothing -> 0
-
-
-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
- where
- base = useBase opts
-
- padding bitsPerDigit = text (replicate padLen '0')
- where
- padLen | m > 0 = d + 1
- | otherwise = d
-
- (d,m) = (fromInteger width - (length value * bitsPerDigit))
- `divMod` bitsPerDigit
-
- prefix = case base of
- 2 -> text "0b" <.> padding 1
- 8 -> text "0o" <.> padding 3
- 10 -> empty
- 16 -> text "0x" <.> padding 4
- _ -> text "0" <.> char '<' <.> int base <.> char '>'
-
- value = showIntAtBase (toInteger base) (digits !!) i ""
- digits = "0123456789abcdefghijklmnopqrstuvwxyz"
-
--- Concrete Big-endian Words ------------------------------------------------------------
-
-mask ::
- Integer {- ^ Bit-width -} ->
- Integer {- ^ Value -} ->
- Integer {- ^ Masked result -}
-mask w i | w >= Arch.maxBigIntWidth = wordTooWide w
- | otherwise = i .&. (bit (fromInteger w) - 1)
-
-instance Backend Concrete where
- type SBit Concrete = Bool
- type SWord Concrete = BV
- type SInteger Concrete = Integer
- type SFloat Concrete = FP.BF
- type SEval Concrete = Eval
-
- raiseError _ err = io (X.throwIO err)
-
- assertSideCondition _ True _ = return ()
- assertSideCondition _ False err = io (X.throwIO err)
-
- wordLen _ (BV w _) = w
- wordAsChar _ (BV _ x) = Just $! integerToChar x
-
- wordBit _ (BV w x) idx = pure $! testBit x (fromInteger (w - 1 - idx))
-
- wordUpdate _ (BV w x) idx True = pure $! BV w (setBit x (fromInteger (w - 1 - idx)))
- wordUpdate _ (BV w x) idx False = pure $! BV w (clearBit x (fromInteger (w - 1 - idx)))
-
- isReady _ (Ready _) = True
- isReady _ _ = False
-
- mergeEval _sym f c mx my =
- do x <- mx
- y <- my
- f c x y
-
- sDeclareHole _ = blackhole
- sDelayFill _ = delayFill
- sSpark _ = evalSpark
-
- ppBit _ b | b = text "True"
- | otherwise = text "False"
-
- ppWord _ = ppBV
-
- ppInteger _ _opts i = integer i
-
- ppFloat _ = FP.fpPP
-
- bitLit _ b = b
- bitAsLit _ b = Just b
-
- bitEq _ x y = pure $! x == y
- bitOr _ x y = pure $! x .|. y
- bitAnd _ x y = pure $! x .&. y
- bitXor _ x y = pure $! x `xor` y
- bitComplement _ x = pure $! complement x
-
- iteBit _ b x y = pure $! if b then x else y
- iteWord _ b x y = pure $! if b then x else y
- iteInteger _ b x y = pure $! if b then x else y
-
- wordLit _ w i = pure $! mkBv w i
- wordAsLit _ (BV w i) = Just (w,i)
- integerLit _ i = pure i
- integerAsLit _ = Just
-
- wordToInt _ (BV _ x) = pure x
- wordFromInt _ w x = pure $! mkBv w x
-
- packWord _ bits = pure $! BV (toInteger w) a
- where
- w = case length bits of
- len | toInteger len >= Arch.maxBigIntWidth -> wordTooWide (toInteger len)
- | otherwise -> len
- 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) = pure [ testBit a n | n <- [w' - 1, w' - 2 .. 0] ]
- where
- w' = fromInteger w
-
- joinWord _ (BV i x) (BV j y) =
- pure $! BV (i + j) (shiftL x (fromInteger j) + y)
-
- splitWord _ leftW rightW (BV _ x) =
- pure ( BV leftW (x `shiftR` (fromInteger rightW)), mkBv rightW x )
-
- extractWord _ n i (BV _ x) = pure $! mkBv n (x `shiftR` (fromInteger i))
-
- wordEq _ (BV i x) (BV j y)
- | i == j = pure $! x == y
- | otherwise = panic "Attempt to compare words of different sizes: wordEq" [show i, show j]
-
- wordSignedLessThan _ (BV i x) (BV j y)
- | i == j = pure $! signedValue i x < signedValue i y
- | otherwise = panic "Attempt to compare words of different sizes: wordSignedLessThan" [show i, show j]
-
- wordLessThan _ (BV i x) (BV j y)
- | i == j = pure $! x < y
- | otherwise = panic "Attempt to compare words of different sizes: wordLessThan" [show i, show j]
-
- wordGreaterThan _ (BV i x) (BV j y)
- | i == j = pure $! x > y
- | otherwise = panic "Attempt to compare words of different sizes: wordGreaterThan" [show i, show j]
-
- wordAnd _ (BV i x) (BV j y)
- | i == j = pure $! mkBv i (x .&. y)
- | otherwise = panic "Attempt to AND words of different sizes: wordPlus" [show i, show j]
-
- wordOr _ (BV i x) (BV j y)
- | i == j = pure $! mkBv i (x .|. y)
- | otherwise = panic "Attempt to OR words of different sizes: wordPlus" [show i, show j]
-
- wordXor _ (BV i x) (BV j y)
- | i == j = pure $! mkBv i (x `xor` y)
- | otherwise = panic "Attempt to XOR words of different sizes: wordPlus" [show i, show j]
-
- wordComplement _ (BV i x) = pure $! mkBv i (complement x)
-
- wordPlus _ (BV i x) (BV j y)
- | i == j = pure $! mkBv i (x+y)
- | otherwise = panic "Attempt to add words of different sizes: wordPlus" [show i, show j]
-
- wordNegate _ (BV i x) = pure $! mkBv i (negate x)
-
- wordMinus _ (BV i x) (BV j y)
- | i == j = pure $! mkBv i (x-y)
- | otherwise = panic "Attempt to subtract words of different sizes: wordMinus" [show i, show j]
-
- wordMult _ (BV i x) (BV j y)
- | i == j = pure $! mkBv i (x*y)
- | otherwise = panic "Attempt to multiply words of different sizes: wordMult" [show i, show j]
-
- wordDiv sym (BV i x) (BV j y)
- | i == 0 && j == 0 = pure $! mkBv 0 0
- | i == j =
- do assertSideCondition sym (y /= 0) DivideByZero
- pure $! mkBv i (x `div` y)
- | otherwise = panic "Attempt to divide words of different sizes: wordDiv" [show i, show j]
-
- wordMod sym (BV i x) (BV j y)
- | i == 0 && j == 0 = pure $! mkBv 0 0
- | i == j =
- do assertSideCondition sym (y /= 0) DivideByZero
- pure $! mkBv i (x `mod` y)
- | otherwise = panic "Attempt to mod words of different sizes: wordMod" [show i, show j]
-
- wordSignedDiv sym (BV i x) (BV j y)
- | i == 0 && j == 0 = pure $! mkBv 0 0
- | i == j =
- do assertSideCondition sym (y /= 0) DivideByZero
- let sx = signedValue i x
- sy = signedValue i y
- pure $! mkBv i (sx `quot` sy)
- | otherwise = panic "Attempt to divide words of different sizes: wordSignedDiv" [show i, show j]
-
- wordSignedMod sym (BV i x) (BV j y)
- | i == 0 && j == 0 = pure $! mkBv 0 0
- | i == j =
- do assertSideCondition sym (y /= 0) DivideByZero
- let sx = signedValue i x
- sy = signedValue i y
- pure $! mkBv i (sx `rem` sy)
- | otherwise = panic "Attempt to mod words of different sizes: wordSignedMod" [show i, show j]
-
- wordLg2 _ (BV i x) = pure $! mkBv i (lg2 x)
-
- intEq _ x y = pure $! x == y
- intLessThan _ x y = pure $! x < y
- intGreaterThan _ x y = pure $! x > y
-
- intPlus _ x y = pure $! x + y
- intMinus _ x y = pure $! x - y
- intNegate _ x = pure $! negate x
- intMult _ x y = pure $! x * y
- intDiv sym x y =
- do assertSideCondition sym (y /= 0) DivideByZero
- pure $! x `div` y
- intMod sym x y =
- do assertSideCondition sym (y /= 0) DivideByZero
- pure $! x `mod` y
-
- intToZn _ 0 _ = evalPanic "intToZn" ["0 modulus not allowed"]
- intToZn _ m x = pure $! x `mod` m
-
- -- NB: requires we maintain the invariant that
- -- Z_n is in reduced form
- znToInt _ _m x = pure x
- znEq _ _m x y = pure $! x == y
-
- znPlus _ = liftBinIntMod (+)
- znMinus _ = liftBinIntMod (-)
- znMult _ = liftBinIntMod (*)
- znNegate _ 0 _ = evalPanic "znNegate" ["0 modulus not allowed"]
- znNegate _ m x = pure $! (negate x) `mod` m
-
- ------------------------------------------------------------------------
- -- Floating Point
- fpLit _sym e p rat = pure (FP.fpLit e p rat)
- fpEq _sym x y = pure (FP.bfValue x == FP.bfValue y)
- fpLessThan _sym x y = pure (FP.bfValue x < FP.bfValue y)
- fpGreaterThan _sym x y = pure (FP.bfValue x > FP.bfValue y)
- fpPlus = fpBinArith FP.bfAdd
- fpMinus = fpBinArith FP.bfSub
- fpMult = fpBinArith FP.bfMul
- fpDiv = fpBinArith FP.bfDiv
- fpNeg _ x = pure x { FP.bfValue = FP.bfNeg (FP.bfValue x) }
- fpFromInteger sym e p r x =
- do opts <- FP.fpOpts e p <$> fpRoundMode sym r
- pure FP.BF { FP.bfExpWidth = e
- , FP.bfPrecWidth = p
- , FP.bfValue = FP.fpCheckStatus $
- FP.bfRoundInt opts (FP.bfFromInteger x)
- }
- fpToInteger = fpCvtToInteger
-
-
-{-# INLINE liftBinIntMod #-}
-liftBinIntMod :: Monad m =>
- (Integer -> Integer -> Integer) -> Integer -> Integer -> Integer -> m Integer
-liftBinIntMod op m x y
- | m == 0 = evalPanic "znArithmetic" ["0 modulus not allowed"]
- | otherwise = pure $ (op x y) `mod` m
-
-
-
-{-# INLINE fpBinArith #-}
-fpBinArith ::
- (FP.BFOpts -> FP.BigFloat -> FP.BigFloat -> (FP.BigFloat, FP.Status)) ->
- Concrete ->
- SWord Concrete {- ^ Rouding mode -} ->
- SFloat Concrete ->
- SFloat Concrete ->
- SEval Concrete (SFloat Concrete)
-fpBinArith fun = \sym r x y ->
- do opts <- FP.fpOpts (FP.bfExpWidth x) (FP.bfPrecWidth x)
- <$> fpRoundMode sym r
- pure x { FP.bfValue = FP.fpCheckStatus
- (fun opts (FP.bfValue x) (FP.bfValue y)) }
-
-fpCvtToInteger ::
- Concrete ->
- String ->
- SWord Concrete {- ^ Rounding mode -} ->
- SFloat Concrete ->
- SEval Concrete (SInteger Concrete)
-fpCvtToInteger sym fun rnd flt =
- do mode <- fpRoundMode sym rnd
- case FP.floatToInteger fun mode flt of
- Right i -> pure i
- Left err -> raiseError sym err
-
-fpRoundMode :: Concrete -> SWord Concrete -> SEval Concrete FP.RoundMode
-fpRoundMode sym w =
- case FP.fpRound (bvVal w) of
- Left err -> raiseError sym err
- Right a -> pure a
-
-
-
-
-
diff --git a/src/Cryptol/Eval/Env.hs b/src/Cryptol/Eval/Env.hs
--- a/src/Cryptol/Eval/Env.hs
+++ b/src/Cryptol/Eval/Env.hs
@@ -14,8 +14,10 @@
{-# LANGUAGE DeriveGeneric #-}
module Cryptol.Eval.Env where
-import Cryptol.Eval.Backend
-import Cryptol.Eval.Monad( PPOpts )
+import Cryptol.Backend
+
+import Cryptol.Backend.Monad( PPOpts )
+
import Cryptol.Eval.Type
import Cryptol.Eval.Value
import Cryptol.ModuleSystem.Name
@@ -24,7 +26,7 @@
import Cryptol.Utils.PP
-import qualified Data.Map.Strict as Map
+import qualified Data.IntMap.Strict as IntMap
import Data.Semigroup
import GHC.Generics (Generic)
@@ -35,29 +37,29 @@
-- Evaluation Environment ------------------------------------------------------
data GenEvalEnv sym = EvalEnv
- { envVars :: !(Map.Map Name (SEval sym (GenValue sym)))
+ { envVars :: !(IntMap.IntMap (SEval sym (GenValue sym)))
, envTypes :: !TypeEnv
} deriving Generic
instance Semigroup (GenEvalEnv sym) where
l <> r = EvalEnv
- { envVars = Map.union (envVars l) (envVars r)
- , envTypes = Map.union (envTypes l) (envTypes r)
+ { envVars = IntMap.union (envVars l) (envVars r)
+ , envTypes = IntMap.union (envTypes l) (envTypes r)
}
instance Monoid (GenEvalEnv sym) where
mempty = EvalEnv
- { envVars = Map.empty
- , envTypes = Map.empty
+ { envVars = IntMap.empty
+ , envTypes = IntMap.empty
}
mappend l r = l <> r
ppEnv :: Backend sym => sym -> PPOpts -> GenEvalEnv sym -> SEval sym Doc
-ppEnv sym opts env = brackets . fsep <$> mapM bind (Map.toList (envVars env))
+ppEnv sym opts env = brackets . fsep <$> mapM bind (IntMap.toList (envVars env))
where
bind (k,v) = do vdoc <- ppValue sym opts =<< v
- return (pp k <+> text "->" <+> vdoc)
+ return (int k <+> text "->" <+> vdoc)
-- | Evaluation environment with no bindings
emptyEnv :: GenEvalEnv sym
@@ -74,7 +76,7 @@
bindVar sym n val env = do
let nm = show $ ppLocName n
val' <- sDelay sym (Just nm) val
- return $ env{ envVars = Map.insert n val' (envVars env) }
+ return $ env{ envVars = IntMap.insert (nameUnique n) val' (envVars env) }
-- | Bind a variable to a value in the evaluation environment, without
-- creating a thunk.
@@ -85,20 +87,20 @@
GenEvalEnv sym ->
GenEvalEnv sym
bindVarDirect n val env = do
- env{ envVars = Map.insert n (pure val) (envVars env) }
+ env{ envVars = IntMap.insert (nameUnique n) (pure val) (envVars env) }
-- | Lookup a variable in the environment.
{-# INLINE lookupVar #-}
lookupVar :: Name -> GenEvalEnv sym -> Maybe (SEval sym (GenValue sym))
-lookupVar n env = Map.lookup n (envVars env)
+lookupVar n env = IntMap.lookup (nameUnique n) (envVars env)
-- | Bind a type variable of kind *.
{-# INLINE bindType #-}
bindType :: TVar -> Either Nat' TValue -> GenEvalEnv sym -> GenEvalEnv sym
-bindType p ty env = env { envTypes = Map.insert p ty (envTypes env) }
+bindType p ty env = env { envTypes = IntMap.insert (tvUnique p) ty (envTypes env) }
-- | Lookup a type variable.
{-# INLINE lookupType #-}
lookupType :: TVar -> GenEvalEnv sym -> Maybe (Either Nat' TValue)
-lookupType p env = Map.lookup p (envTypes env)
+lookupType p env = IntMap.lookup (tvUnique p) (envTypes env)
diff --git a/src/Cryptol/Eval/Generic.hs b/src/Cryptol/Eval/Generic.hs
--- a/src/Cryptol/Eval/Generic.hs
+++ b/src/Cryptol/Eval/Generic.hs
@@ -8,7 +8,7 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE BlockArguments #-}
-{-# LANGUAGE Safe #-}
+{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards #-}
@@ -24,16 +24,20 @@
import qualified Control.Exception as X
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad (join, unless)
+import System.Random.TF.Gen (seedTFGen)
-import Data.Bits (testBit)
+import Data.Bits (testBit, (.&.), shiftR)
+
import Data.Maybe (fromMaybe)
import Data.Ratio ((%))
import Cryptol.TypeCheck.AST
import Cryptol.TypeCheck.Solver.InfNat (Nat'(..),nMul,widthInteger)
-import Cryptol.Eval.Backend
-import Cryptol.Eval.Concrete.Value (Concrete(..))
-import Cryptol.Eval.Monad
+import Cryptol.Backend
+import Cryptol.Backend.Concrete (Concrete(..))
+import Cryptol.Backend.Monad ( Eval, evalPanic, EvalError(..), Unsupported(..) )
+import Cryptol.Testing.Random( randomValue )
+
import Cryptol.Eval.Type
import Cryptol.Eval.Value
import Cryptol.Utils.Panic (panic)
@@ -48,6 +52,7 @@
mkLit :: Backend sym => sym -> TValue -> Integer -> SEval sym (GenValue sym)
mkLit sym ty i =
case ty of
+ TVBit -> pure $ VBit (bitLit sym (i > 0))
TVInteger -> VInteger <$> integerLit sym i
TVIntMod m
| m == 0 -> evalPanic "mkLit" ["0 modulus not allowed"]
@@ -544,7 +549,7 @@
r <- fpRndMode sym
xv <- fromVFloat <$> x
VFloat <$> fpDiv sym r one xv
-
+ TVIntMod m -> VInteger <$> (znRecip sym m . fromVInteger =<< x)
_ -> evalPanic "recip" [show a ++ "is not a Field"]
{-# SPECIALIZE fieldDivideV :: Concrete -> GenValue Concrete #-}
@@ -563,6 +568,12 @@
yv <- fromVFloat <$> y
r <- fpRndMode sym
VFloat <$> fpDiv sym r xv yv
+ TVIntMod m ->
+ do x' <- fromVInteger <$> x
+ y' <- fromVInteger <$> y
+ yinv <- znRecip sym m y'
+ VInteger <$> znMult sym m x' yinv
+
_ -> evalPanic "recip" [show a ++ "is not a Field"]
--------------------------------------------------------------
@@ -1909,6 +1920,77 @@
iteValue sym c (lookupSeqMap x i) (lookupSeqMap y i)
+
+foldlV :: Backend sym => sym -> GenValue sym
+foldlV sym =
+ ilam $ \_n ->
+ tlam $ \_a ->
+ tlam $ \_b ->
+ lam $ \f -> pure $
+ lam $ \z -> pure $
+ lam $ \v ->
+ v >>= \case
+ VSeq n m -> go0 f z (enumerateSeqMap n m)
+ VWord _n wv -> go0 f z . map (pure . VBit) =<< (enumerateWordValue sym =<< wv)
+ _ -> panic "Cryptol.Eval.Generic.foldlV" ["Expected finite sequence"]
+ where
+ go0 _f a [] = a
+ go0 f a bs =
+ do f' <- fromVFun <$> f
+ go1 f' a bs
+
+ go1 _f a [] = a
+ go1 f a (b:bs) =
+ do f' <- fromVFun <$> (f a)
+ go1 f (f' b) bs
+
+foldl'V :: Backend sym => sym -> GenValue sym
+foldl'V sym =
+ ilam $ \_n ->
+ tlam $ \_a ->
+ tlam $ \_b ->
+ lam $ \f -> pure $
+ lam $ \z -> pure $
+ lam $ \v ->
+ v >>= \case
+ VSeq n m -> go0 f z (enumerateSeqMap n m)
+ VWord _n wv -> go0 f z . map (pure . VBit) =<< (enumerateWordValue sym =<< wv)
+ _ -> panic "Cryptol.Eval.Generic.foldlV" ["Expected finite sequence"]
+ where
+ go0 _f a [] = a
+ go0 f a bs =
+ do f' <- fromVFun <$> f
+ a' <- sDelay sym Nothing a
+ forceValue =<< a'
+ go1 f' a' bs
+
+ go1 _f a [] = a
+ go1 f a (b:bs) =
+ do f' <- fromVFun <$> (f a)
+ a' <- sDelay sym Nothing (f' b)
+ forceValue =<< a'
+ go1 f a' bs
+
+
+-- Random Values ---------------------------------------------------------------
+
+{-# SPECIALIZE randomV ::
+ Concrete -> TValue -> Integer -> SEval Concrete (GenValue Concrete)
+ #-}
+-- | Produce a random value with the given seed. If we do not support
+-- making values of the given type, return zero of that type.
+-- TODO: do better than returning zero
+randomV :: Backend sym => sym -> TValue -> Integer -> SEval sym (GenValue sym)
+randomV sym ty seed =
+ case randomValue sym ty of
+ Nothing -> zeroV sym ty
+ Just gen ->
+ -- unpack the seed into four Word64s
+ let mask64 = 0xFFFFFFFFFFFFFFFF
+ unpack s = fromInteger (s .&. mask64) : unpack (s `shiftR` 64)
+ [a, b, c, d] = take 4 (unpack seed)
+ in fst $ gen 100 $ seedTFGen (a, b, c, d)
+
--------------------------------------------------------------------------------
-- Experimental parallel primitives
@@ -1940,7 +2022,12 @@
SeqMap sym ->
SEval sym (SeqMap sym)
sparkParMap sym f n m =
- finiteSeqMap sym <$> mapM (sSpark sym . f) (enumerateSeqMap n m)
+ finiteSeqMap sym <$> mapM (sSpark sym . g) (enumerateSeqMap n m)
+ where
+ g x =
+ do z <- sDelay sym Nothing (f x)
+ forceValue =<< z
+ z
--------------------------------------------------------------------------------
-- Floating Point Operations
diff --git a/src/Cryptol/Eval/Monad.hs b/src/Cryptol/Eval/Monad.hs
deleted file mode 100644
--- a/src/Cryptol/Eval/Monad.hs
+++ /dev/null
@@ -1,272 +0,0 @@
--- |
--- Module : Cryptol.Eval.Monad
--- Copyright : (c) 2013-2016 Galois, Inc.
--- License : BSD3
--- Maintainer : cryptol@galois.com
--- Stability : provisional
--- Portability : portable
-
-{-# LANGUAGE Safe #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE OverloadedStrings #-}
-
-module Cryptol.Eval.Monad
-( -- * Evaluation monad
- Eval(..)
-, runEval
-, EvalOpts(..)
-, getEvalOpts
-, PPOpts(..)
-, PPFloatFormat(..)
-, PPFloatExp(..)
-, defaultPPOpts
-, io
-, delayFill
-, ready
-, blackhole
-, evalSpark
- -- * Error reporting
-, Unsupported(..)
-, EvalError(..)
-, evalPanic
-, wordTooWide
-, typeCannotBeDemoted
-) where
-
-import Control.Concurrent.Async
-import Control.DeepSeq
-import Control.Monad
-import qualified Control.Monad.Fail as Fail
-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.Utils.Logger(Logger)
-import Cryptol.TypeCheck.AST(Type,Name)
-
--- | A computation that returns an already-evaluated value.
-ready :: a -> Eval a
-ready a = Ready a
-
--- | How to pretty print things when evaluating
-data PPOpts = PPOpts
- { useAscii :: Bool
- , useBase :: Int
- , useInfLength :: Int
- , useFPBase :: Int
- , useFPFormat :: PPFloatFormat
- }
-
-data PPFloatFormat =
- FloatFixed Int PPFloatExp -- ^ Use this many significant digis
- | FloatFrac Int -- ^ Show this many digits after floating point
- | FloatFree PPFloatExp -- ^ Use the correct number of digits
-
-data PPFloatExp = ForceExponent -- ^ Always show an exponent
- | AutoExponent -- ^ Only show exponent when needed
-
-
-defaultPPOpts :: PPOpts
-defaultPPOpts = PPOpts { useAscii = False, useBase = 10, useInfLength = 5
- , useFPBase = 16
- , useFPFormat = FloatFree AutoExponent
- }
-
-
--- | Some options for evalutaion
-data EvalOpts = EvalOpts
- { evalLogger :: Logger -- ^ Where to print stuff (e.g., for @trace@)
- , evalPPOpts :: PPOpts -- ^ How to pretty print things.
- }
-
-
--- | The monad for Cryptol evaluation.
-data Eval a
- = Ready !a
- | Thunk !(EvalOpts -> IO a)
-
-data ThunkState a
- = Unforced -- ^ This thunk has not yet been forced
- | BlackHole -- ^ This thunk is currently being evaluated
- | Forced !(Either EvalError a)
- -- ^ This thunk has previously been forced,
- -- and has the given value, or evaluation resulted in an error.
-
-
--- | Access the evaluation options.
-getEvalOpts :: Eval EvalOpts
-getEvalOpts = Thunk pure
-
-
-{-# 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 $ \opts -> do
- r <- newIORef Unforced
- return $ unDelay retry r (x opts)
-
-
--- | Begin executing the given operation in a separate thread,
--- returning a thunk which will await the completion of
--- the computation when forced.
-evalSpark ::
- Eval a ->
- Eval (Eval a)
-evalSpark (Ready x) = Ready (Ready x)
-evalSpark (Thunk x) = Thunk $ \opts ->
- do a <- async (x opts)
- return (Thunk $ \_ -> wait a)
-
-
--- | 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 -> io (toVal val)
- BlackHole ->
- retry
- Unforced -> io $ do
- writeIORef r BlackHole
- val <- X.try x
- writeIORef r (Forced val)
- toVal val
-
- where
- toVal mbV = case mbV of
- Right a -> pure a
- Left e -> X.throwIO e
-
--- | Execute the given evaluation action.
-runEval :: EvalOpts -> Eval a -> IO a
-runEval _ (Ready a) = return a
-runEval opts (Thunk x) = x opts
-
-{-# INLINE evalBind #-}
-evalBind :: Eval a -> (a -> Eval b) -> Eval b
-evalBind (Ready a) f = f a
-evalBind (Thunk x) f = Thunk $ \opts -> x opts >>= runEval opts . f
-
-instance Functor Eval where
- fmap f (Ready x) = Ready (f x)
- fmap f (Thunk m) = Thunk $ \opts -> f <$> m opts
- {-# INLINE fmap #-}
-
-instance Applicative Eval where
- pure = return
- (<*>) = ap
- {-# INLINE pure #-}
- {-# INLINE (<*>) #-}
-
-instance Monad Eval where
- return = Ready
- (>>=) = evalBind
- {-# INLINE return #-}
- {-# INLINE (>>=) #-}
-
-instance Fail.MonadFail Eval where
- fail x = Thunk (\_ -> fail x)
-
-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 $ \opts -> mfix (\x -> runEval opts (f x))
-
--- | Lift an 'IO' computation into the 'Eval' monad.
-io :: IO a -> Eval a
-io m = Thunk (\_ -> m)
-{-# INLINE io #-}
-
-
--- Errors ----------------------------------------------------------------------
-
--- | Panic from an @Eval@ context.
-evalPanic :: HasCallStack => String -> [String] -> a
-evalPanic cxt = panic ("[Eval] " ++ cxt)
-
-
--- | Data type describing errors that can occur during evaluation.
-data EvalError
- = InvalidIndex (Maybe Integer) -- ^ Out-of-bounds index
- | TypeCannotBeDemoted Type -- ^ Non-numeric type passed to @number@ function
- | DivideByZero -- ^ Division or modulus by 0
- | NegativeExponent -- ^ Exponentiation by negative integer
- | LogNegative -- ^ Logarithm of a negative integer
- | WordTooWide Integer -- ^ Bitvector too large
- | UserError String -- ^ Call to the Cryptol @error@ primitive
- | LoopError String -- ^ Detectable nontermination
- | NoPrim Name -- ^ Primitive with no implementation
- | BadRoundingMode Integer -- ^ Invalid rounding mode
- | BadValue String -- ^ Value outside the domain of a partial function.
- deriving (Typeable,Show)
-
-instance PP EvalError where
- ppPrec _ e = case e of
- InvalidIndex (Just i) -> text "invalid sequence index:" <+> integer i
- InvalidIndex Nothing -> text "invalid sequence index"
- TypeCannotBeDemoted t -> text "type cannot be demoted:" <+> pp t
- DivideByZero -> text "division by 0"
- NegativeExponent -> text "negative exponent"
- LogNegative -> text "logarithm of negative"
- WordTooWide w ->
- text "word too wide for memory:" <+> integer w <+> text "bits"
- UserError x -> text "Run-time error:" <+> text x
- LoopError x -> text "<>" <+> text x
- BadRoundingMode r -> "invalid rounding mode" <+> integer r
- BadValue x -> "invalid input for" <+> backticks (text x)
- NoPrim x -> text "unimplemented primitive:" <+> pp x
-
-instance X.Exception EvalError
-
-
-data Unsupported
- = UnsupportedSymbolicOp String -- ^ Operation cannot be supported in the symbolic simulator
- deriving (Typeable,Show)
-
-instance PP Unsupported where
- ppPrec _ e = case e of
- UnsupportedSymbolicOp nm -> text "operation can not be supported on symbolic values:" <+> text nm
-
-instance X.Exception Unsupported
-
-
--- | For things like @`(inf)@ or @`(0-1)@.
-typeCannotBeDemoted :: Type -> a
-typeCannotBeDemoted t = X.throw (TypeCannotBeDemoted t)
-
--- | 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)
diff --git a/src/Cryptol/Eval/Reference.lhs b/src/Cryptol/Eval/Reference.lhs
--- a/src/Cryptol/Eval/Reference.lhs
+++ b/src/Cryptol/Eval/Reference.lhs
@@ -1,1650 +1,1695 @@
> -- |
> -- Module : Cryptol.Eval.Reference
> -- Description : The reference implementation of the Cryptol evaluation semantics.
-> -- Copyright : (c) 2013-2016 Galois, Inc.
-> -- License : BSD3
-> -- Maintainer : cryptol@galois.com
-> -- Stability : provisional
-> -- Portability : portable
->
-> {-# LANGUAGE PatternGuards #-}
-> {-# LANGUAGE BlockArguments #-}
->
-> module Cryptol.Eval.Reference
-> ( Value(..)
-> , evaluate
-> , evalExpr
-> , evalDeclGroup
-> , ppValue
-> ) where
->
-> import Control.Applicative (liftA2)
-> import Data.Bits
-> import Data.Ratio((%))
-> import Data.List
-> (genericDrop, genericIndex, genericLength, genericReplicate, genericSplitAt,
-> genericTake, sortBy)
-> import Data.Ord (comparing)
-> import Data.Map (Map)
-> import qualified Data.Map as Map
-> import qualified Data.Text as T (pack)
-> import LibBF (BigFloat)
-> import qualified LibBF as FP
->
-> import Cryptol.ModuleSystem.Name (asPrim)
-> import Cryptol.TypeCheck.Solver.InfNat (Nat'(..), nAdd, nMin, nMul)
-> import Cryptol.TypeCheck.AST
-> import Cryptol.Eval.Monad (EvalError(..), PPOpts(..))
-> import Cryptol.Eval.Type (TValue(..), isTBit, evalValType, evalNumType, tvSeq)
-> import Cryptol.Eval.Concrete (mkBv, ppBV, lg2)
-> import Cryptol.Eval.Concrete.FloatHelpers (BF(..))
-> import qualified Cryptol.Eval.Concrete.FloatHelpers as FP
-> import Cryptol.Utils.Ident (Ident,PrimIdent, prelPrim, floatPrim)
-> import Cryptol.Utils.Panic (panic)
-> import Cryptol.Utils.PP
-> import Cryptol.Utils.RecordMap
->
-> import qualified Cryptol.ModuleSystem as M
-> import qualified Cryptol.ModuleSystem.Env as M (loadedModules)
-
-Overview
-========
-
-This file describes the semantics of the explicitly-typed Cryptol
-language (i.e., terms after type checking). Issues related to type
-inference, type functions, and type constraints are beyond the scope
-of this document.
-
-Cryptol Types
--------------
-
-Cryptol types come in two kinds: numeric types (kind `#`) and value
-types (kind `*`). While value types are inhabited by well-typed
-Cryptol expressions, numeric types are only used as parameters to
-other types; they have no inhabitants. In this implementation we
-represent numeric types as values of the Haskell type `Nat'` of
-natural numbers with infinity; value types are represented as values
-of type `TValue`.
-
-The value types of Cryptol, along with their Haskell representations,
-are as follows:
-
-| Cryptol type | Description | `TValue` representation |
-|:------------------|:------------------|:----------------------------|
-| `Bit` | booleans | `TVBit` |
-| `Integer` | integers | `TVInteger` |
-| `Z n` | integers modulo n | `TVIntMod n` |
-| `Rational` | rationals | `TVRational` |
-| `Float e p` | floating point | `TVFloat` |
-| `Array` | arrays | `TVArray` |
-| `[n]a` | finite lists | `TVSeq n a` |
-| `[inf]a` | infinite lists | `TVStream a` |
-| `(a, b, c)` | tuples | `TVTuple [a,b,c]` |
-| `{x:a, y:b, z:c}` | records | `TVRec [(x,a),(y,b),(z,c)]` |
-| `a -> b` | functions | `TVFun a b` |
-
-We model each Cryptol value type `t` as a complete partial order (cpo)
-*M*(`t`). To each Cryptol expression `e : t` we assign a meaning
-*M*(`e`) in *M*(`t`); in particular, recursive Cryptol programs of
-type `t` are modeled as least fixed points in *M*(`t`). In other words,
-this is a domain-theoretic denotational semantics.
-
-Evaluating a Cryptol expression of base type (one of: `Bit`, `Integer`,
-`Z n`, or `Rational`) may result in:
-
-- a defined value (e.g., `True` or `False`)
-
-- a run-time error, or
-
-- non-termination.
-
-Accordingly, *M*(`Bit`) is a flat cpo with values for `True`,
-`False`, run-time errors of type `EvalError`, and $\bot$; we
-represent it with the Haskell type `Either EvalError Bool`.
-
-Similarly, *M*(`Integer`) is a flat cpo with values for integers,
-run-time errors, and $\bot$; we represent it with the Haskell type
-`Either EvalError Integer`.
-
-The cpos for lists, tuples, and records are cartesian products. The
-cpo ordering is pointwise, and the bottom element $\bot$ is the
-list/tuple/record whose elements are all $\bot$. Trivial types `[0]t`,
-`()` and `{}` denote single-element cpos where the unique value
-`[]`/`()`/`{}` *is* the bottom element $\bot$. *M*(`a -> b`) is the
-continuous function space *M*(`a`) $\to$ *M*(`b`).
-
-Type schemas of the form `{a1 ... an} (p1 ... pk) => t` classify
-polymorphic values in Cryptol. These are represented with the Haskell
-type `Schema`. The meaning of a schema is cpo whose elements are
-functions: For each valid instantiation `t1 ... tn` of the type
-parameters `a1 ... an` that satisfies the constraints `p1 ... pk`, the
-function returns a value in *M*(`t[t1/a1 ... tn/an]`).
-
-Values
-------
-
-The Haskell code in this module defines the semantics of typed Cryptol
-terms by providing an evaluator to an appropriate `Value` type.
-
-> -- | Value type for the reference evaluator.
-> data Value
-> = VBit (Either EvalError Bool) -- ^ @ Bit @ booleans
-> | VInteger (Either EvalError Integer) -- ^ @ Integer @ or @Z n@ integers
-> | VRational (Either EvalError Rational) -- ^ @ Rational @ rationals
-> | VFloat (Either EvalError BF) -- ^ Floating point numbers
-> | VList Nat' [Value] -- ^ @ [n]a @ finite or infinite lists
-> | VTuple [Value] -- ^ @ ( .. ) @ tuples
-> | VRecord [(Ident, Value)] -- ^ @ { .. } @ records
-> | VFun (Value -> Value) -- ^ functions
-> | VPoly (TValue -> Value) -- ^ polymorphic values (kind *)
-> | VNumPoly (Nat' -> Value) -- ^ polymorphic values (kind #)
-
-Invariant: Undefinedness and run-time exceptions are only allowed
-inside the argument of a `VBit`, `VInteger` or `VRational` constructor.
-All other `Value` and list constructors should evaluate without error. For
-example, a non-terminating computation at type `(Bit,Bit)` must be
-represented as `VTuple [VBit undefined, VBit undefined]`, and not
-simply as `undefined`. Similarly, an expression like `1/0:[2]` that
-raises a run-time error must be encoded as `VList (Nat 2) [VBit (Left
-e), VBit (Left e)]` where `e = DivideByZero`.
-
-Copy Functions
---------------
-
-Functions `copyBySchema` and `copyByTValue` make a copy of the given
-value, building the spine based only on the type without forcing the
-value argument. This ensures that undefinedness appears inside `VBit`
-and `VInteger` values only, and never on any constructors of the
-`Value` type. In turn, this gives the appropriate semantics to
-recursive definitions: The bottom value for a compound type is equal
-to a value of the same type where every individual bit is bottom.
-
-For each Cryptol type `t`, the cpo *M*(`t`) can be represented as a
-subset of values of type `Value` that satisfy the datatype invariant.
-This subset consists precisely of the output range of `copyByTValue
-t`. Similarly, the range of output values of `copyBySchema` yields the
-cpo that represents any given schema.
-
-> copyBySchema :: Env -> Schema -> Value -> Value
-> copyBySchema env0 (Forall params _props ty) = go params env0
-> where
-> go :: [TParam] -> Env -> Value -> Value
-> go [] env v = copyByTValue (evalValType (envTypes env) ty) v
-> go (p : ps) env v =
-> case v of
-> VPoly f -> VPoly $ \t -> go ps (bindType (tpVar p) (Right t) env) (f t)
-> VNumPoly f -> VNumPoly $ \n -> go ps (bindType (tpVar p) (Left n) env) (f n)
-> _ -> evalPanic "copyBySchema" ["Expected polymorphic value"]
->
-> copyByTValue :: TValue -> Value -> Value
-> copyByTValue = go
-> where
-> go :: TValue -> Value -> Value
-> go ty val =
-> case ty of
-> TVBit -> VBit (fromVBit val)
-> TVInteger -> VInteger (fromVInteger val)
-> TVIntMod _ -> VInteger (fromVInteger val)
-> TVRational -> VRational (fromVRational val)
-> TVFloat _ _ -> VFloat (fromVFloat' val)
-> TVArray{} -> evalPanic "copyByTValue" ["Unsupported Array type"]
-> TVSeq w ety -> VList (Nat w) (map (go ety) (copyList w (fromVList val)))
-> TVStream ety -> VList Inf (map (go ety) (copyStream (fromVList val)))
-> TVTuple etys -> VTuple (zipWith go etys (copyList (genericLength etys) (fromVTuple val)))
-> TVRec fields -> VRecord [ (f, go fty (lookupRecord f val)) | (f, fty) <- canonicalFields fields ]
-> TVFun _ bty -> VFun (\v -> go bty (fromVFun val v))
-> TVAbstract {} -> val
->
-> copyStream :: [a] -> [a]
-> copyStream xs = head xs : copyStream (tail xs)
->
-> copyList :: Integer -> [a] -> [a]
-> copyList 0 _ = []
-> copyList n xs = head xs : copyList (n - 1) (tail xs)
-
-Operations on Values
---------------------
-
-> -- | Destructor for @VBit@.
-> fromVBit :: Value -> Either EvalError Bool
-> fromVBit (VBit b) = b
-> fromVBit _ = evalPanic "fromVBit" ["Expected a bit"]
->
-> -- | Destructor for @VInteger@.
-> fromVInteger :: Value -> Either EvalError Integer
-> fromVInteger (VInteger i) = i
-> fromVInteger _ = evalPanic "fromVInteger" ["Expected an integer"]
->
-> -- | Destructor for @VRational@.
-> fromVRational :: Value -> Either EvalError Rational
-> fromVRational (VRational i) = i
-> fromVRational _ = evalPanic "fromVRational" ["Expected a rational"]
->
-> fromVFloat :: Value -> Either EvalError BigFloat
-> fromVFloat = fmap bfValue . fromVFloat'
-
-> fromVFloat' :: Value -> Either EvalError BF
-> fromVFloat' v =
-> case v of
-> VFloat f -> f
-> _ -> evalPanic "fromVFloat" [ "Expected a floating point value." ]
-
-
-
-
->
-> -- | Destructor for @VList@.
-> fromVList :: Value -> [Value]
-> fromVList (VList _ vs) = vs
-> fromVList _ = evalPanic "fromVList" ["Expected a list"]
->
-> -- | Destructor for @VTuple@.
-> fromVTuple :: Value -> [Value]
-> fromVTuple (VTuple vs) = vs
-> fromVTuple _ = evalPanic "fromVTuple" ["Expected a tuple"]
->
-> -- | Destructor for @VRecord@.
-> fromVRecord :: Value -> [(Ident, Value)]
-> fromVRecord (VRecord fs) = fs
-> fromVRecord _ = evalPanic "fromVRecord" ["Expected a record"]
->
-> -- | Destructor for @VFun@.
-> fromVFun :: Value -> (Value -> Value)
-> fromVFun (VFun f) = f
-> fromVFun _ = evalPanic "fromVFun" ["Expected a function"]
->
-> -- | Destructor for @VPoly@.
-> fromVPoly :: Value -> (TValue -> Value)
-> fromVPoly (VPoly f) = f
-> fromVPoly _ = evalPanic "fromVPoly" ["Expected a polymorphic value"]
->
-> -- | Destructor for @VNumPoly@.
-> fromVNumPoly :: Value -> (Nat' -> Value)
-> fromVNumPoly (VNumPoly f) = f
-> fromVNumPoly _ = evalPanic "fromVNumPoly" ["Expected a polymorphic value"]
->
-> -- | Look up a field in a record.
-> lookupRecord :: Ident -> Value -> Value
-> lookupRecord f v =
-> case lookup f (fromVRecord v) of
-> Just val -> val
-> Nothing -> evalPanic "lookupRecord" ["Malformed record"]
->
-> -- | Polymorphic function values that expect a finite numeric type.
-> vFinPoly :: (Integer -> Value) -> Value
-> vFinPoly f = VNumPoly g
-> where
-> g (Nat n) = f n
-> g Inf = evalPanic "vFinPoly" ["Expected finite numeric type"]
-
-
-Environments
-------------
-
-An evaluation environment keeps track of the values of term variables
-and type variables that are in scope at any point.
-
-> data Env = Env
-> { envVars :: !(Map Name Value)
-> , envTypes :: !(Map TVar (Either Nat' TValue))
-> }
->
-> instance Semigroup Env where
-> l <> r = Env
-> { envVars = Map.union (envVars l) (envVars r)
-> , envTypes = Map.union (envTypes l) (envTypes r)
-> }
->
-> instance Monoid Env where
-> mempty = Env
-> { envVars = Map.empty
-> , envTypes = Map.empty
-> }
-> mappend l r = l <> r
->
-> -- | Bind a variable in the evaluation environment.
-> bindVar :: (Name, Value) -> Env -> Env
-> bindVar (n, val) env = env { envVars = Map.insert n val (envVars env) }
->
-> -- | Bind a type variable of kind # or *.
-> bindType :: TVar -> Either Nat' TValue -> Env -> Env
-> bindType p ty env = env { envTypes = Map.insert p ty (envTypes env) }
-
-
-Evaluation
-==========
-
-The meaning *M*(`expr`) of a Cryptol expression `expr` is defined by
-recursion over its structure. For an expression that contains free
-variables, the meaning also depends on the environment `env`, which
-assigns values to those variables.
-
-> evalExpr :: Env -- ^ Evaluation environment
-> -> Expr -- ^ Expression to evaluate
-> -> Value
-> evalExpr env expr =
-> case expr of
->
-> EList es _ty -> VList (Nat (genericLength es)) [ evalExpr env e | e <- es ]
-> ETuple es -> VTuple [ evalExpr env e | e <- es ]
-> ERec fields -> VRecord [ (f, evalExpr env e) | (f, e) <- canonicalFields fields ]
-> ESel e sel -> evalSel (evalExpr env e) sel
-> ESet e sel v -> evalSet (evalExpr env e) sel (evalExpr env v)
->
-> EIf c t f ->
-> condValue (fromVBit (evalExpr env c)) (evalExpr env t) (evalExpr env f)
->
-> EComp _n _ty e branches ->
-> evalComp env e branches
->
-> EVar n ->
-> case Map.lookup n (envVars env) of
-> Just val -> val
-> Nothing -> evalPanic "evalExpr" ["var `" ++ show (pp n) ++ "` is not defined" ]
->
-> 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 -> evalPanic "evalExpr" ["Invalid kind on type abstraction", show k]
->
-> ETApp e ty ->
-> case evalExpr env e of
-> VPoly f -> f $! (evalValType (envTypes env) ty)
-> VNumPoly f -> f $! (evalNumType (envTypes env) ty)
-> _ -> evalPanic "evalExpr" ["Expected a polymorphic value"]
->
-> EApp e1 e2 -> fromVFun (evalExpr env e1) (evalExpr env e2)
-> EAbs n _ty b -> VFun (\v -> evalExpr (bindVar (n, v) env) b)
-> EProofAbs _ e -> evalExpr env e
-> EProofApp e -> evalExpr env e
-> EWhere e dgs -> evalExpr (foldl evalDeclGroup env dgs) e
-
-
-Selectors
----------
-
-Apply the the given selector form to the given value.
-
-> evalSel :: Value -> Selector -> Value
-> evalSel val sel =
-> case sel of
-> TupleSel n _ -> tupleSel n val
-> RecordSel n _ -> recordSel n val
-> ListSel n _ -> listSel n val
-> where
-> tupleSel n v =
-> case v of
-> VTuple vs -> vs !! n
-> _ -> evalPanic "evalSel"
-> ["Unexpected value in tuple selection."]
-> recordSel n v =
-> case v of
-> VRecord _ -> lookupRecord n v
-> _ -> evalPanic "evalSel"
-> ["Unexpected value in record selection."]
-> listSel n v =
-> case v of
-> VList _ vs -> vs !! n
-> _ -> evalPanic "evalSel"
-> ["Unexpected value in list selection."]
-
-
-Update the given value using the given selector and new value.
-
-> evalSet :: Value -> Selector -> Value -> Value
-> evalSet val sel fval =
-> case sel of
-> TupleSel n _ -> updTupleAt n
-> RecordSel n _ -> updRecAt n
-> ListSel n _ -> updSeqAt n
-> where
-> updTupleAt n =
-> case val of
-> VTuple vs | (as,_:bs) <- splitAt n vs ->
-> VTuple (as ++ fval : bs)
-> _ -> bad "Invalid tuple upldate."
->
-> updRecAt n =
-> case val of
-> VRecord vs | (as, (i,_) : bs) <- break ((n==) . fst) vs ->
-> VRecord (as ++ (i,fval) : bs)
-> _ -> bad "Invalid record update."
->
-> updSeqAt n =
-> case val of
-> VList i vs | (as, _ : bs) <- splitAt n vs ->
-> VList i (as ++ fval : bs)
-> _ -> bad "Invalid sequence update."
->
-> bad msg = evalPanic "evalSet" [msg]
-
-
-
-Conditionals
-------------
-
-We evaluate conditionals on larger types by pushing the conditionals
-down to the individual bits.
-
-> condValue :: Either EvalError Bool -> Value -> Value -> Value
-> condValue c l r =
-> case l of
-> VBit b -> VBit (condBit c b (fromVBit r))
-> VInteger i -> VInteger (condBit c i (fromVInteger r))
-> VRational x -> VRational (condBit c x (fromVRational r))
-> VFloat x -> VFloat (condBit c x (fromVFloat' r))
-> VList n vs -> VList n (zipWith (condValue c) vs (fromVList r))
-> VTuple vs -> VTuple (zipWith (condValue c) vs (fromVTuple r))
-> VRecord fs -> VRecord [ (f, condValue c v (lookupRecord f r)) | (f, v) <- fs ]
-> VFun f -> VFun (\v -> condValue c (f v) (fromVFun r v))
-> VPoly f -> VPoly (\t -> condValue c (f t) (fromVPoly r t))
-> VNumPoly f -> VNumPoly (\n -> condValue c (f n) (fromVNumPoly r n))
-
-Conditionals are explicitly lazy: Run-time errors in an untaken branch
-are ignored.
-
-> condBit :: Either e Bool -> Either e a -> Either e a -> Either e a
-> condBit (Left e) _ _ = Left e
-> condBit (Right b) x y = if b then x else y
-
-
-List Comprehensions
--------------------
-
-Cryptol list comprehensions consist of one or more parallel branches;
-each branch has one or more matches that bind values to variables.
-
-The result of evaluating a match in an initial environment is a list
-of extended environments. Each new environment binds the same single
-variable to a different element of the match's list.
-
-> evalMatch :: Env -> Match -> [Env]
-> evalMatch env m =
-> case m of
-> Let d ->
-> [ bindVar (evalDecl env d) env ]
-> From n _l _ty expr ->
-> [ bindVar (n, v) env | v <- fromVList (evalExpr env expr) ]
-
-> lenMatch :: Env -> Match -> Nat'
-> lenMatch env m =
-> case m of
-> Let _ -> Nat 1
-> From _ len _ _ -> evalNumType (envTypes env) len
-
-The result of of evaluating a branch in an initial environment is a
-list of extended environments, each of which extends the initial
-environment with the same set of new variables. The length of the list
-is equal to the product of the lengths of the lists in the matches.
-
-> evalBranch :: Env -> [Match] -> [Env]
-> evalBranch env [] = [env]
-> evalBranch env (match : matches) =
-> [ env'' | env' <- evalMatch env match
-> , env'' <- evalBranch env' matches ]
-
-> lenBranch :: Env -> [Match] -> Nat'
-> lenBranch _env [] = Nat 1
-> lenBranch env (match : matches) =
-> nMul (lenMatch env match) (lenBranch env matches)
-
-The head expression of the comprehension can refer to any variable
-bound in any of the parallel branches. So to evaluate the
-comprehension, we zip and merge together the lists of extended
-environments from each branch. The head expression is then evaluated
-separately in each merged environment. The length of the resulting
-list is equal to the minimum length over all parallel branches.
-
-> evalComp :: Env -- ^ Starting evaluation environment
-> -> Expr -- ^ Head expression of the comprehension
-> -> [[Match]] -- ^ List of parallel comprehension branches
-> -> Value
-> evalComp env expr branches = VList len [ evalExpr e expr | e <- envs ]
-> where
-> -- Generate a new environment for each iteration of each
-> -- parallel branch.
-> benvs :: [[Env]]
-> benvs = map (evalBranch env) branches
->
-> -- Zip together the lists of environments from each branch,
-> -- producing a list of merged environments. Longer branches get
-> -- truncated to the length of the shortest branch.
-> envs :: [Env]
-> envs = foldr1 (zipWith mappend) benvs
->
-> len :: Nat'
-> len = foldr1 nMin (map (lenBranch env) branches)
-
-
-Declarations
-------------
-
-Function `evalDeclGroup` extends the given evaluation environment with
-the result of evaluating the given declaration group. In the case of a
-recursive declaration group, we tie the recursive knot by evaluating
-each declaration in the extended environment `env'` that includes all
-the new bindings.
-
-> evalDeclGroup :: Env -> DeclGroup -> Env
-> evalDeclGroup env dg = do
-> case dg of
-> NonRecursive d ->
-> bindVar (evalDecl env d) env
-> Recursive ds ->
-> let env' = foldr bindVar env bindings
-> bindings = map (evalDeclRecursive env') ds
-> in env'
-
-To evaluate a declaration in a non-recursive context, we need only
-evaluate the expression on the right-hand side or look up the
-appropriate primitive.
-
-> evalDecl :: Env -> Decl -> (Name, Value)
-> evalDecl env d =
-> case dDefinition d of
-> DPrim -> (dName d, evalPrim (dName d))
-> DExpr e -> (dName d, evalExpr env e)
-
-To evaluate a declaration in a recursive context, we must perform a
-type-directed copy to build the spine of the value. This ensures that
-the definedness invariant for type `Value` will be maintained.
-
-> evalDeclRecursive :: Env -> Decl -> (Name, Value)
-> evalDeclRecursive env d =
-> case dDefinition d of
-> DPrim -> (dName d, evalPrim (dName d))
-> DExpr e -> (dName d, copyBySchema env (dSignature d) (evalExpr env e))
-
-
-Primitives
-==========
-
-To evaluate a primitive, we look up its implementation by name in a table.
-
-> evalPrim :: Name -> Value
-> evalPrim n
-> | Just i <- asPrim n, Just v <- Map.lookup i primTable = v
-> | otherwise = evalPanic "evalPrim" ["Unimplemented primitive", show n]
-
-Cryptol primitives fall into several groups, mostly delenieated
-by corresponding typeclasses
-
-* Literals: `True`, `False`, `number`, `ratio`
-
-* Zero: zero
-
-* Logic: `&&`, `||`, `^`, `complement`
-
-* Ring: `+`, `-`, `*`, `negate`, `fromInteger`
-
-* Integral: `/`, `%`, `^^`, `toInteger`
-
-* Bitvector: `/$` `%$`, `lg2`, `<=$`
-
-* Comparison: `<`, `>`, `<=`, `>=`, `==`, `!=`
-
-* Sequences: `#`, `join`, `split`, `splitAt`, `reverse`, `transpose`
-
-* Shifting: `<<`, `>>`, `<<<`, `>>>`
-
-* Indexing: `@`, `@@`, `!`, `!!`, `update`, `updateEnd`
-
-* Enumerations: `fromTo`, `fromThenTo`, `infFrom`, `infFromThen`
-
-* Polynomials: `pmult`, `pdiv`, `pmod`
-
-* Miscellaneous: `error`, `random`, `trace`
-
-> primTable :: Map PrimIdent Value
-> primTable = Map.unions
-> [ cryptolPrimTable
-> , floatPrimTable
-> ]
-
-> cryptolPrimTable :: Map PrimIdent Value
-> cryptolPrimTable = Map.fromList $ map (\(n, v) -> (prelPrim (T.pack n), v))
->
-> -- Literals
-> [ ("True" , VBit (Right True))
-> , ("False" , VBit (Right False))
-> , ("number" , vFinPoly $ \val ->
-> VPoly $ \a ->
-> literal val a)
-> , ("fraction" , vFinPoly \top ->
-> vFinPoly \bot ->
-> vFinPoly \rnd ->
-> VPoly \a -> fraction top bot rnd a)
-> -- Zero
-> , ("zero" , VPoly zero)
->
-> -- Logic (bitwise)
-> , ("&&" , binary (logicBinary (&&)))
-> , ("||" , binary (logicBinary (||)))
-> , ("^" , binary (logicBinary (/=)))
-> , ("complement" , unary (logicUnary not))
->
-> -- Ring
-> , ("+" , binary (ringBinary
-> (\x y -> Right (x + y))
-> (\x y -> Right (x + y))
-> (fpBin FP.bfAdd fpImplicitRound)
-> ))
-> , ("-" , binary (ringBinary
-> (\x y -> Right (x - y))
-> (\x y -> Right (x - y))
-> (fpBin FP.bfSub fpImplicitRound)
-> ))
-> , ("*" , binary ringMul)
-> , ("negate" , unary (ringUnary (\x -> Right (- x))
-> (\x -> Right (- x))
-> (\_ _ x -> Right (FP.bfNeg x))))
-> , ("fromInteger", VPoly $ \a ->
-> VFun $ \x ->
-> ringNullary (fromVInteger x)
-> (fromInteger <$> fromVInteger x)
-> (\e p -> fpFromInteger e p <$> fromVInteger x)
-> a)
->
-> -- Integral
-> , ("toInteger" , VPoly $ \a ->
-> VFun $ \x ->
-> VInteger $ cryToInteger a x)
-> , ("/" , binary (integralBinary divWrap))
-> , ("%" , binary (integralBinary modWrap))
-> , ("^^" , VPoly $ \aty ->
-> VPoly $ \ety ->
-> VFun $ \a ->
-> VFun $ \e ->
-> ringExp aty a (cryToInteger ety e))
->
-> -- Field
-> , ("/." , binary (fieldBinary ratDiv
-> (fpBin FP.bfDiv fpImplicitRound)
-> ))
-
-> , ("recip" , unary (fieldUnary ratRecip fpRecip))
->
-> -- Round
-> , ("floor" , unary (roundUnary floor
-> (FP.floatToInteger "floor" FP.ToNegInf)
-> ))
-> , ("ceiling" , unary (roundUnary ceiling
-> (FP.floatToInteger "ceiling" FP.ToPosInf)
-> ))
-> , ("trunc" , unary (roundUnary truncate
-> (FP.floatToInteger "trunc" FP.ToZero)
-> ))
-> , ("roundAway", unary (roundUnary roundAwayRat
-> (FP.floatToInteger "roundAway" FP.Away)
-> ))
-> , ("roundToEven", unary (roundUnary round
-> (FP.floatToInteger "roundToEven" FP.NearEven)
-> ))
->
-> -- Comparison
-> , ("<" , binary (cmpOrder (\o -> o == LT)))
-> , (">" , binary (cmpOrder (\o -> o == GT)))
-> , ("<=" , binary (cmpOrder (\o -> o /= GT)))
-> , (">=" , binary (cmpOrder (\o -> o /= LT)))
-> , ("==" , binary (cmpOrder (\o -> o == EQ)))
-> , ("!=" , binary (cmpOrder (\o -> o /= EQ)))
-> , ("<$" , binary signedLessThan)
->
-> -- Bitvector
-> , ("/$" , vFinPoly $ \n ->
-> VFun $ \l ->
-> VFun $ \r ->
-> vWord n $ appOp2 divWrap (fromSignedVWord l) (fromSignedVWord r))
-> , ("%$" , vFinPoly $ \n ->
-> VFun $ \l ->
-> VFun $ \r ->
-> vWord n $ appOp2 modWrap (fromSignedVWord l) (fromSignedVWord r))
-> , (">>$" , signedShiftRV)
-> , ("lg2" , vFinPoly $ \n ->
-> VFun $ \v ->
-> vWord n $ appOp1 lg2Wrap (fromVWord v))
-> -- Rational
-> , ("ratio" , VFun $ \l ->
-> VFun $ \r ->
-> VRational (appOp2 ratioOp (fromVInteger l) (fromVInteger r)))
->
-> -- Z n
-> , ("fromZ" , vFinPoly $ \n ->
-> VFun $ \x ->
-> VInteger (flip mod n <$> fromVInteger x))
->
-> -- Sequences
-> , ("#" , VNumPoly $ \front ->
-> VNumPoly $ \back ->
-> VPoly $ \_elty ->
-> VFun $ \l ->
-> VFun $ \r ->
-> VList (nAdd front back) (fromVList l ++ fromVList r))
->
-> , ("join" , VNumPoly $ \parts ->
-> VNumPoly $ \each ->
-> VPoly $ \_a ->
-> VFun $ \xss ->
-> case each of
-> -- special case when the inner sequences are of length 0
-> Nat 0 -> VList (Nat 0) []
-> _ -> VList (nMul parts each)
-> (concat (map fromVList (fromVList xss))))
->
-> , ("split" , VNumPoly $ \parts ->
-> vFinPoly $ \each ->
-> VPoly $ \_a ->
-> VFun $ \val ->
-> VList parts (splitV parts each (fromVList val)))
->
-> , ("splitAt" , vFinPoly $ \front ->
-> VNumPoly $ \back ->
-> VPoly $ \_a ->
-> VFun $ \v ->
-> let (xs, ys) = genericSplitAt front (fromVList v)
-> in VTuple [VList (Nat front) xs, VList back ys])
->
-> , ("reverse" , VNumPoly $ \n ->
-> VPoly $ \_a ->
-> VFun $ \v ->
-> VList n (reverse (fromVList v)))
->
-> , ("transpose" , VNumPoly $ \rows ->
-> VNumPoly $ \cols ->
-> VPoly $ \_a ->
-> VFun $ \v ->
-> VList cols
-> (map (VList rows) (transposeV cols (map fromVList (fromVList v)))))
->
-> -- Shifting:
-> , ("<<" , shiftV shiftLV)
-> , (">>" , shiftV shiftRV)
-> , ("<<<" , rotateV rotateLV)
-> , (">>>" , rotateV rotateRV)
->
-> -- Indexing:
-> , ("@" , indexPrimOne indexFront)
-> , ("!" , indexPrimOne indexBack)
-> , ("update" , updatePrim updateFront)
-> , ("updateEnd" , updatePrim updateBack)
->
-> -- Enumerations
-> , ("fromTo" , vFinPoly $ \first ->
-> vFinPoly $ \lst ->
-> VPoly $ \ty ->
-> let f i = literal i ty
-> in VList (Nat (1 + lst - first)) (map f [first .. lst]))
->
-> , ("fromThenTo" , vFinPoly $ \first ->
-> vFinPoly $ \next ->
-> vFinPoly $ \_lst ->
-> VPoly $ \ty ->
-> vFinPoly $ \len ->
-> let f i = literal i ty
-> in VList (Nat len) (map f (genericTake len [first, next ..])))
->
-> , ("infFrom" , VPoly $ \ty ->
-> VFun $ \first ->
-> case cryToInteger ty first of
-> Left e -> cryError e (TVStream ty)
-> Right x -> VList Inf (map f [0 ..])
-> where f i = literal (x + i) ty)
->
-> , ("infFromThen", VPoly $ \ty ->
-> VFun $ \first ->
-> VFun $ \next ->
-> case cryToInteger ty first of
-> Left e -> cryError e (TVStream ty)
-> Right x ->
-> case cryToInteger ty next of
-> Left e -> cryError e (TVStream ty)
-> Right y -> VList Inf (map f [0 ..])
-> where f i = literal (x + diff * i) ty
-> diff = y - x)
->
-> -- Miscellaneous:
-> , ("parmap" , VPoly $ \_a ->
-> VPoly $ \_b ->
-> VNumPoly $ \n ->
-> VFun $ \f ->
-> VFun $ \xs ->
-> -- Note: the reference implementation simply
-> -- executes parmap sequentially
-> let xs' = map (fromVFun f) (fromVList xs) in
-> VList n xs')
->
-> , ("error" , VPoly $ \a ->
-> VNumPoly $ \_ ->
-> VFun $ \_s -> cryError (UserError "error") a)
-> -- TODO: obtain error string from argument s
->
-> , ("random" , VPoly $ \a ->
-> VFun $ \_seed -> cryError (UserError "random: unimplemented") a)
->
-> , ("trace" , VNumPoly $ \_n ->
-> VPoly $ \_a ->
-> VPoly $ \_b ->
-> VFun $ \_s ->
-> VFun $ \_x ->
-> VFun $ \y -> y)
-> ]
->
-
->
-> unary :: (TValue -> Value -> Value) -> Value
-> unary f = VPoly $ \ty -> VFun $ \x -> f ty x
->
-> binary :: (TValue -> Value -> Value -> Value) -> Value
-> binary f = VPoly $ \ty -> VFun $ \x -> VFun $ \y -> f ty x y
->
-> appOp1 :: (a -> Either EvalError b) -> Either EvalError a -> Either EvalError b
-> appOp1 _f (Left e) = Left e
-> appOp1 f (Right x) = f x
->
-> appOp2 :: (a -> b -> Either EvalError c) -> Either EvalError a -> Either EvalError b -> Either EvalError c
-> appOp2 _f (Left e) _y = Left e
-> appOp2 _f _x (Left e) = Left e
-> appOp2 f (Right x) (Right y) = f x y
-
-Word operations
----------------
-
-Many Cryptol primitives take numeric arguments in the form of
-bitvectors. For such operations, any output bit that depends on the
-numeric value is strict in *all* bits of the numeric argument. This is
-implemented in function `fromVWord`, which converts a value from a
-big-endian binary format to an integer. The result is an evaluation
-error if any of the input bits contain an evaluation error.
-
-> fromVWord :: Value -> Either EvalError Integer
-> fromVWord v = fmap bitsToInteger (mapM fromVBit (fromVList v))
->
-> -- | Convert a list of booleans in big-endian format to an integer.
-> bitsToInteger :: [Bool] -> Integer
-> bitsToInteger bs = foldl f 0 bs
-> where f x b = if b then 2 * x + 1 else 2 * x
-
-> fromSignedVWord :: Value -> Either EvalError Integer
-> fromSignedVWord v = fmap signedBitsToInteger (mapM fromVBit (fromVList v))
->
-> -- | Convert a list of booleans in signed big-endian format to an integer.
-> signedBitsToInteger :: [Bool] -> Integer
-> signedBitsToInteger [] = evalPanic "signedBitsToInteger" ["Bitvector has zero length"]
-> signedBitsToInteger (b0 : bs) = foldl f (if b0 then -1 else 0) bs
-> where f x b = if b then 2 * x + 1 else 2 * x
-
-Function `vWord` converts an integer back to the big-endian bitvector
-representation. If an integer-producing function raises a run-time
-exception, then the output bitvector will contain the exception in all
-bit positions.
-
-> vWord :: Integer -> Either EvalError Integer -> Value
-> vWord w e = VList (Nat w) [ VBit (fmap (test i) e) | i <- [w-1, w-2 .. 0] ]
-> where test i x = testBit x (fromInteger i)
-
-
-Errors
-------
-
-The domain semantics indicate that errors can only exist at the base
-types. This function constructs an error representation at any type
-where the given error is "pushed down" into the leaf types.
-
-> cryError :: EvalError -> TValue -> Value
-> cryError e TVBit = VBit (Left e)
-> cryError e TVInteger = VInteger (Left e)
-> cryError e TVIntMod{} = VInteger (Left e)
-> cryError e TVRational = VRational (Left e)
-> cryError e TVFloat{} = VFloat (Left e)
-> cryError _ TVArray{} = evalPanic "error" ["Array type not supported in `error`"]
-> cryError e (TVSeq n ety) = VList (Nat n) (genericReplicate n (cryError e ety))
-> cryError e (TVStream ety) = VList Inf (repeat (cryError e ety))
-> cryError e (TVTuple tys) = VTuple (map (cryError e) tys)
-> cryError e (TVRec fields) = VRecord [ (f, cryError e fty) | (f, fty) <- canonicalFields fields ]
-> cryError e (TVFun _ bty) = VFun (\_ -> cryError e bty)
-> cryError _ (TVAbstract{}) = evalPanic "error" ["Abstract type encountered in `error`"]
-
-
-Zero
-----
-
-The `Zero` class has a single method `zero` which computes
-a zero value for all the built-in types for Cryptol.
-For bits, bitvectors and the base numeric types, this
-returns the obvious 0 representation. For sequences, records,
-and tuples, the zero method operates pointwise the underlying types.
-For functions, `zero` returns the constant function that returns
-`zero` in the codomain.
-
-> zero :: TValue -> Value
-> zero TVBit = VBit (Right False)
-> zero TVInteger = VInteger (Right 0)
-> zero TVIntMod{} = VInteger (Right 0)
-> zero TVRational = VRational (Right 0)
-> zero (TVFloat e p) = VFloat (Right (fpToBF e p FP.bfPosZero))
-> zero TVArray{} = evalPanic "zero" ["Array type not in `Zero`"]
-> zero (TVSeq n ety) = VList (Nat n) (genericReplicate n (zero ety))
-> zero (TVStream ety) = VList Inf (repeat (zero ety))
-> zero (TVTuple tys) = VTuple (map zero tys)
-> zero (TVRec fields) = VRecord [ (f, zero fty) | (f, fty) <- canonicalFields fields ]
-> zero (TVFun _ bty) = VFun (\_ -> zero bty)
-> zero (TVAbstract{}) = evalPanic "zero" ["Abstract type not in `Zero`"]
-
-
-Literals
---------
-
-Given a literal integer, construct a value of a type that can represent that literal.
-
-> literal :: Integer -> TValue -> Value
-> literal i = go
-> where
-> go TVInteger = VInteger (Right i)
-> go TVRational = VRational (Right (fromInteger i))
-> go (TVIntMod n)
-> | i < n = VInteger (Right i)
-> | otherwise = evalPanic "literal" ["Literal out of range for type Z " ++ show n]
-> go (TVSeq w a)
-> | isTBit a = vWord w (Right i)
-> go ty = evalPanic "literal" [show ty ++ " cannot represent literals"]
-
-
-Given a fraction, construct a value of a type that can represent that literal.
-The rounding flag determines the behavior if the literal cannot be represented
-exactly: 0 means report and error, other numbers round to the nearest
-representable value.
-
-> fraction :: Integer -> Integer -> Integer -> TValue -> Value
-> fraction top btm _rnd ty =
-> case ty of
-> TVRational -> VRational (Right (top % btm))
-> TVFloat e p -> VFloat $ Right $ fpToBF e p $ FP.fpCheckStatus val
-> where val = FP.bfDiv opts (FP.bfFromInteger top) (FP.bfFromInteger btm)
-> opts = FP.fpOpts e p fpImplicitRound
-> _ -> evalPanic "fraction" [show ty ++ " cannot represent " ++
-> show top ++ "/" ++ show btm]
-
-
-Logic
------
-
-Bitwise logic primitives are defined by recursion over the type
-structure. On type `Bit`, we use `fmap` and `liftA2` to make these
-operations strict in all arguments. For example, `True || error "foo"`
-does not evaluate to `True`, but yields a run-time exception. On other
-types, run-time exceptions on input bits only affect the output bits
-at the same positions.
-
-> logicUnary :: (Bool -> Bool) -> TValue -> Value -> Value
-> logicUnary op = go
-> where
-> go :: TValue -> Value -> Value
-> go ty val =
-> case ty of
-> TVBit -> VBit (fmap op (fromVBit val))
-> TVSeq w ety -> VList (Nat w) (map (go ety) (fromVList val))
-> TVStream ety -> VList Inf (map (go ety) (fromVList val))
-> TVTuple etys -> VTuple (zipWith go etys (fromVTuple val))
-> TVRec fields -> VRecord [ (f, go fty (lookupRecord f val)) | (f, fty) <- canonicalFields fields ]
-> TVFun _ bty -> VFun (\v -> go bty (fromVFun val v))
-> TVInteger -> evalPanic "logicUnary" ["Integer not in class Logic"]
-> TVIntMod _ -> evalPanic "logicUnary" ["Z not in class Logic"]
-> TVArray{} -> evalPanic "logicUnary" ["Array not in class Logic"]
-> TVRational -> evalPanic "logicUnary" ["Rational not in class Logic"]
-> TVFloat{} -> evalPanic "logicUnary" ["Float not in class Logic"]
-> TVAbstract{} -> evalPanic "logicUnary" ["Abstract type not in `Logic`"]
-
-> logicBinary :: (Bool -> Bool -> Bool) -> TValue -> Value -> Value -> Value
-> logicBinary op = go
-> where
-> go :: TValue -> Value -> Value -> Value
-> go ty l r =
-> case ty of
-> TVBit -> VBit (liftA2 op (fromVBit l) (fromVBit r))
-> TVSeq w ety -> VList (Nat w) (zipWith (go ety) (fromVList l) (fromVList r))
-> TVStream ety -> VList Inf (zipWith (go ety) (fromVList l) (fromVList r))
-> TVTuple etys -> VTuple (zipWith3 go etys (fromVTuple l) (fromVTuple r))
-> TVRec fields -> VRecord [ (f, go fty (lookupRecord f l) (lookupRecord f r))
-> | (f, fty) <- canonicalFields fields ]
-> TVFun _ bty -> VFun (\v -> go bty (fromVFun l v) (fromVFun r v))
-> TVInteger -> evalPanic "logicBinary" ["Integer not in class Logic"]
-> TVIntMod _ -> evalPanic "logicBinary" ["Z not in class Logic"]
-> TVArray{} -> evalPanic "logicBinary" ["Array not in class Logic"]
-> TVRational -> evalPanic "logicBinary" ["Rational not in class Logic"]
-> TVFloat{} -> evalPanic "logicBinary" ["Float not in class Logic"]
-> TVAbstract{} -> evalPanic "logicBinary" ["Abstract type not in `Logic`"]
-
-
-Ring Arithmetic
----------------
-
-Ring primitives may be applied to any type that is made up of
-finite bitvectors or one of the numeric base types.
-On type `[n]`, arithmetic operators are strict in
-all input bits, as indicated by the definition of `fromVWord`. For
-example, `[error "foo", True] * 2` does not evaluate to `[True,
-False]`, but to `[error "foo", error "foo"]`.
-
-> ringNullary ::
-> Either EvalError Integer ->
-> Either EvalError Rational ->
-> (Integer -> Integer -> Either EvalError BigFloat) ->
-> TValue -> Value
-> ringNullary i q fl = go
-> where
-> go :: TValue -> Value
-> go ty =
-> case ty of
-> TVBit ->
-> evalPanic "arithNullary" ["Bit not in class Ring"]
-> TVInteger ->
-> VInteger i
-> TVIntMod n ->
-> VInteger (flip mod n <$> i)
-> TVRational ->
-> VRational q
-> TVFloat e p ->
-> VFloat (fpToBF e p <$> fl e p)
-> TVArray{} ->
-> evalPanic "arithNullary" ["Array not in class Ring"]
-> TVSeq w a
-> | isTBit a -> vWord w i
-> | otherwise -> VList (Nat w) (genericReplicate w (go a))
-> TVStream a ->
-> VList Inf (repeat (go a))
-> TVFun _ ety ->
-> VFun (const (go ety))
-> TVTuple tys ->
-> VTuple (map go tys)
-> TVRec fs ->
-> VRecord [ (f, go fty) | (f, fty) <- canonicalFields fs ]
-> TVAbstract {} ->
-> evalPanic "arithNullary" ["Abstract type not in `Ring`"]
-
-> ringUnary ::
-> (Integer -> Either EvalError Integer) ->
-> (Rational -> Either EvalError Rational) ->
-> (Integer -> Integer -> BigFloat -> Either EvalError BigFloat) ->
-> TValue -> Value -> Value
-> ringUnary iop qop flop = go
-> where
-> go :: TValue -> Value -> Value
-> go ty val =
-> case ty of
-> TVBit ->
-> evalPanic "arithUnary" ["Bit not in class Ring"]
-> TVInteger ->
-> VInteger $ appOp1 iop (fromVInteger val)
-> TVArray{} ->
-> evalPanic "arithUnary" ["Array not in class Ring"]
-> TVIntMod n ->
-> VInteger $ appOp1 (\i -> flip mod n <$> iop i) (fromVInteger val)
-> TVRational ->
-> VRational $ appOp1 qop (fromVRational val)
-> TVFloat e p ->
-> VFloat (fpToBF e p <$> appOp1 (flop e p) (fromVFloat val))
-> TVSeq w a
-> | isTBit a -> vWord w (iop =<< fromVWord val)
-> | otherwise -> VList (Nat w) (map (go a) (fromVList val))
-> TVStream a ->
-> VList Inf (map (go a) (fromVList val))
-> TVFun _ ety ->
-> VFun (\x -> go ety (fromVFun val x))
-> TVTuple tys ->
-> VTuple (zipWith go tys (fromVTuple val))
-> TVRec fs ->
-> VRecord [ (f, go fty (lookupRecord f val)) | (f, fty) <- canonicalFields fs ]
-> TVAbstract {} ->
-> evalPanic "arithUnary" ["Abstract type not in `Ring`"]
-
-> ringBinary ::
-> (Integer -> Integer -> Either EvalError Integer) ->
-> (Rational -> Rational -> Either EvalError Rational) ->
-> (Integer -> Integer -> BigFloat -> BigFloat -> Either EvalError BigFloat) ->
-> TValue -> Value -> Value -> Value
-> ringBinary iop qop flop = go
-> where
-> go :: TValue -> Value -> Value -> Value
-> go ty l r =
-> case ty of
-> TVBit ->
-> evalPanic "arithBinary" ["Bit not in class Ring"]
-> TVInteger ->
-> VInteger $ appOp2 iop (fromVInteger l) (fromVInteger r)
-> TVIntMod n ->
-> VInteger $ appOp2 (\i j -> flip mod n <$> iop i j) (fromVInteger l) (fromVInteger r)
-> TVRational ->
-> VRational $ appOp2 qop (fromVRational l) (fromVRational r)
-> TVFloat e p ->
-> VFloat $ fpToBF e p <$> appOp2 (flop e p) (fromVFloat l) (fromVFloat r)
-> TVArray{} ->
-> evalPanic "arithBinary" ["Array not in class Ring"]
-> TVSeq w a
-> | isTBit a -> vWord w $ appOp2 iop (fromVWord l) (fromVWord r)
-> | otherwise -> VList (Nat w) (zipWith (go a) (fromVList l) (fromVList r))
-> TVStream a ->
-> VList Inf (zipWith (go a) (fromVList l) (fromVList r))
-> TVFun _ ety ->
-> VFun (\x -> go ety (fromVFun l x) (fromVFun r x))
-> TVTuple tys ->
-> VTuple (zipWith3 go tys (fromVTuple l) (fromVTuple r))
-> TVRec fs ->
-> VRecord [ (f, go fty (lookupRecord f l) (lookupRecord f r)) | (f, fty) <- canonicalFields fs ]
-> TVAbstract {} ->
-> evalPanic "arithBinary" ["Abstract type not in class `Ring`"]
-
-
-Integral
----------
-
-> cryToInteger :: TValue -> Value -> Either EvalError Integer
-> cryToInteger ty v = case ty of
-> TVInteger -> fromVInteger v
-> TVSeq _ a | isTBit a -> fromVWord v
-> _ -> evalPanic "toInteger" [show ty ++ " is not an integral type"]
->
-> integralBinary ::
-> (Integer -> Integer -> Either EvalError Integer) ->
-> TValue -> Value -> Value -> Value
-> integralBinary op ty x y = case ty of
-> TVInteger ->
-> VInteger $ appOp2 op (fromVInteger x) (fromVInteger y)
-> TVSeq w a | isTBit a ->
-> vWord w $ appOp2 op (fromVWord x) (fromVWord y)
->
-> _ -> evalPanic "integralBinary" [show ty ++ " is not an integral type"]
->
-> ringExp :: TValue -> Value -> Either EvalError Integer -> Value
-> ringExp a _ (Left e) = cryError e a
-> ringExp a v (Right i) = foldl (ringMul a) (literal 1 a) (genericReplicate i v)
->
-> ringMul :: TValue -> Value -> Value -> Value
-> ringMul = ringBinary (\x y -> Right (x * y))
-> (\x y -> Right (x * y))
-> (fpBin FP.bfMul fpImplicitRound)
-
-
-Signed bitvector division (`/$`) and remainder (`%$`) are defined so
-that division rounds toward zero, and the remainder `x %$ y` has the
-same sign as `x`. Accordingly, they are implemented with Haskell's
-`quot` and `rem` operations.
-
-> divWrap :: Integer -> Integer -> Either EvalError Integer
-> divWrap _ 0 = Left DivideByZero
-> divWrap x y = Right (x `quot` y)
->
-> modWrap :: Integer -> Integer -> Either EvalError Integer
-> modWrap _ 0 = Left DivideByZero
-> modWrap x y = Right (x `rem` y)
->
-> lg2Wrap :: Integer -> Either EvalError Integer
-> lg2Wrap x = if x < 0 then Left LogNegative else Right (lg2 x)
-
-
-Field
------
-
-Types that represent fields are have, in addition to the ring operations
-a recipricol operator and a field division operator (not to be
-confused with integral division).
-
-> fieldUnary :: (Rational -> Either EvalError Rational) ->
-> (Integer -> Integer -> BigFloat -> Either EvalError BigFloat) ->
-> TValue -> Value -> Value
-> fieldUnary qop flop ty v = case ty of
-> TVRational -> VRational $ appOp1 qop (fromVRational v)
-> TVFloat e p -> VFloat $ fpToBF e p <$> appOp1 (flop e p) (fromVFloat v)
-> _ -> evalPanic "fieldUnary" [show ty ++ " is not a Field type"]
->
-> fieldBinary ::
-> (Rational -> Rational -> Either EvalError Rational) ->
-> (Integer -> Integer -> BigFloat -> BigFloat -> Either EvalError BigFloat) ->
-> TValue -> Value -> Value -> Value
-> fieldBinary qop flop ty l r = case ty of
-> TVRational -> VRational $ appOp2 qop (fromVRational l) (fromVRational r)
-> TVFloat e p -> VFloat $ fpToBF e p <$> appOp2 (flop e p)
-> (fromVFloat l) (fromVFloat r)
-> _ -> evalPanic "fieldBinary" [show ty ++ " is not a Field type"]
->
-> ratDiv :: Rational -> Rational -> Either EvalError Rational
-> ratDiv _ 0 = Left DivideByZero
-> ratDiv x y = Right (x / y)
->
-> ratRecip :: Rational -> Either EvalError Rational
-> ratRecip 0 = Left DivideByZero
-> ratRecip x = Right (recip x)
-
-
-Round
------
-
-> roundUnary :: (Rational -> Integer) ->
-> (BF -> Either EvalError Integer) ->
-> TValue -> Value -> Value
-> roundUnary op flop ty v = case ty of
-> TVRational -> VInteger (op <$> fromVRational v)
-> TVFloat {} -> VInteger (flop =<< fromVFloat' v)
-> _ -> evalPanic "roundUnary" [show ty ++ " is not a Round type"]
->
-
-Haskell's definition of "round" is slightly different, as it does
-"round to even" on ties.
-
-> roundAwayRat :: Rational -> Integer
-> roundAwayRat x
-> | x >= 0 = floor (x + 0.5)
-> | otherwise = ceiling (x - 0.5)
-
-
-Rational
-----------
-
-> ratioOp :: Integer -> Integer -> Either EvalError Rational
-> ratioOp _ 0 = Left DivideByZero
-> ratioOp x y = Right (fromInteger x / fromInteger y)
-
-
-Comparison
-----------
-
-Comparison primitives may be applied to any type that contains a
-finite number of bits. All such types are compared using a
-lexicographic ordering on bits, where `False` < `True`. Lists and
-tuples are compared left-to-right, and record fields are compared in
-alphabetical order.
-
-Comparisons on type `Bit` are strict in both arguments. Comparisons on
-larger types have short-circuiting behavior: A comparison involving an
-error/undefined element will only yield an error if all corresponding
-bits to the *left* of that position are equal.
-
-> -- | Process two elements based on their lexicographic ordering.
-> cmpOrder :: (Ordering -> Bool) -> TValue -> Value -> Value -> Value
-> cmpOrder p ty l r = VBit (fmap p (lexCompare ty l r))
->
-> -- | Lexicographic ordering on two values.
-> lexCompare :: TValue -> Value -> Value -> Either EvalError Ordering
-> lexCompare ty l r =
-> case ty of
-> TVBit ->
-> compare <$> fromVBit l <*> fromVBit r
-> TVInteger ->
-> compare <$> fromVInteger l <*> fromVInteger r
-> TVIntMod _ ->
-> compare <$> fromVInteger l <*> fromVInteger r
-> TVRational ->
-> compare <$> fromVRational l <*> fromVRational r
-> TVFloat{} ->
-> compare <$> fromVFloat l <*> fromVFloat r
-> TVArray{} ->
-> evalPanic "lexCompare" ["invalid type"]
-> TVSeq _w ety ->
-> lexList (zipWith (lexCompare ety) (fromVList l) (fromVList r))
-> TVStream _ ->
-> evalPanic "lexCompare" ["invalid type"]
-> TVFun _ _ ->
-> evalPanic "lexCompare" ["invalid type"]
-> TVTuple etys ->
-> lexList (zipWith3 lexCompare etys (fromVTuple l) (fromVTuple r))
-> TVRec fields ->
-> let tys = map snd (canonicalFields fields)
-> ls = map snd (sortBy (comparing fst) (fromVRecord l))
-> rs = map snd (sortBy (comparing fst) (fromVRecord r))
-> in lexList (zipWith3 lexCompare tys ls rs)
-> TVAbstract {} ->
-> evalPanic "lexCompare" ["Abstract type not in `Cmp`"]
->
-> lexList :: [Either EvalError Ordering] -> Either EvalError Ordering
-> lexList [] = Right EQ
-> lexList (e : es) =
-> case e of
-> Left err -> Left err
-> Right LT -> Right LT
-> Right EQ -> lexList es
-> Right GT -> Right GT
-
-Signed comparisons may be applied to any type made up of non-empty
-bitvectors. All such types are compared using a lexicographic
-ordering: Lists and tuples are compared left-to-right, and record
-fields are compared in alphabetical order.
-
-> signedLessThan :: TValue -> Value -> Value -> Value
-> signedLessThan ty l r = VBit (fmap (== LT) (lexSignedCompare ty l r))
->
-> -- | Lexicographic ordering on two signed values.
-> lexSignedCompare :: TValue -> Value -> Value -> Either EvalError Ordering
-> lexSignedCompare ty l r =
-> case ty of
-> TVBit ->
-> evalPanic "lexSignedCompare" ["invalid type"]
-> TVInteger ->
-> evalPanic "lexSignedCompare" ["invalid type"]
-> TVIntMod _ ->
-> evalPanic "lexSignedCompare" ["invalid type"]
-> TVRational ->
-> evalPanic "lexSignedCompare" ["invalid type"]
-> TVFloat{} ->
-> evalPanic "lexSignedCompare" ["invalid type"]
-> TVArray{} ->
-> evalPanic "lexSignedCompare" ["invalid type"]
-> TVSeq _w ety
-> | isTBit ety -> compare <$> fromSignedVWord l <*> fromSignedVWord r
-> | otherwise ->
-> lexList (zipWith (lexSignedCompare ety) (fromVList l) (fromVList r))
-> TVStream _ ->
-> evalPanic "lexSignedCompare" ["invalid type"]
-> TVFun _ _ ->
-> evalPanic "lexSignedCompare" ["invalid type"]
-> TVTuple etys ->
-> lexList (zipWith3 lexSignedCompare etys (fromVTuple l) (fromVTuple r))
-> TVRec fields ->
-> let tys = map snd (canonicalFields fields)
-> ls = map snd (sortBy (comparing fst) (fromVRecord l))
-> rs = map snd (sortBy (comparing fst) (fromVRecord r))
-> in lexList (zipWith3 lexSignedCompare tys ls rs)
-> TVAbstract {} ->
-> evalPanic "lexSignedCompare" ["Abstract type not in `Cmp`"]
-
-
-Sequences
----------
-
-> -- | Split a list into 'w' pieces, each of length 'k'.
-> splitV :: Nat' -> Integer -> [Value] -> [Value]
-> splitV w k xs =
-> case w of
-> Nat 0 -> []
-> Nat n -> VList (Nat k) ys : splitV (Nat (n - 1)) k zs
-> Inf -> VList (Nat k) ys : splitV Inf k zs
-> where
-> (ys, zs) = genericSplitAt k xs
->
-> -- | Transpose a list of length-'w' lists into 'w' lists.
-> transposeV :: Nat' -> [[Value]] -> [[Value]]
-> transposeV w xss =
-> case w of
-> Nat 0 -> []
-> Nat n -> heads : transposeV (Nat (n - 1)) tails
-> Inf -> heads : transposeV Inf tails
-> where
-> (heads, tails) = dest xss
->
-> -- Split a list of non-empty lists into
-> -- a list of heads and a list of tails
-> dest :: [[Value]] -> ([Value], [[Value]])
-> dest [] = ([], [])
-> dest ([] : _) = evalPanic "transposeV" ["Expected non-empty list"]
-> dest ((y : ys) : yss) = (y : zs, ys : zss)
-> where (zs, zss) = dest yss
-
-
-Shifting
---------
-
-Shift and rotate operations are strict in all bits of the shift/rotate
-amount, but as lazy as possible in the list values.
-
-> shiftV :: (Nat' -> Value -> [Value] -> Integer -> [Value]) -> Value
-> shiftV op =
-> VNumPoly $ \n ->
-> VPoly $ \ix ->
-> VPoly $ \a ->
-> VFun $ \v ->
-> VFun $ \x ->
-> copyByTValue (tvSeq n a) $
-> case cryToInteger ix x of
-> Left e -> cryError e (tvSeq n a)
-> Right i -> VList n (op n (zero a) (fromVList v) i)
->
-> shiftLV :: Nat' -> Value -> [Value] -> Integer -> [Value]
-> shiftLV w z vs i =
-> case w of
-> Nat n -> genericDrop (min n i) vs ++ genericReplicate (min n i) z
-> Inf -> genericDrop i vs
->
-> shiftRV :: Nat' -> Value -> [Value] -> Integer -> [Value]
-> shiftRV w z vs i =
-> case w of
-> Nat n -> genericReplicate (min n i) z ++ genericTake (n - min n i) vs
-> Inf -> genericReplicate i z ++ vs
->
-> rotateV :: (Integer -> [Value] -> Integer -> [Value]) -> Value
-> rotateV op =
-> vFinPoly $ \n ->
-> VPoly $ \ix ->
-> VPoly $ \a ->
-> VFun $ \v ->
-> VFun $ \x ->
-> copyByTValue (TVSeq n a) $
-> case cryToInteger ix x of
-> Left e -> cryError e (tvSeq (Nat n) a)
-> Right i -> VList (Nat n) (op n (fromVList v) i)
->
-> rotateLV :: Integer -> [Value] -> Integer -> [Value]
-> rotateLV 0 vs _ = vs
-> rotateLV w vs i = ys ++ xs
-> where (xs, ys) = genericSplitAt (i `mod` w) vs
->
-> rotateRV :: Integer -> [Value] -> Integer -> [Value]
-> rotateRV 0 vs _ = vs
-> rotateRV w vs i = ys ++ xs
-> where (xs, ys) = genericSplitAt ((w - i) `mod` w) vs
->
-> signedShiftRV :: Value
-> signedShiftRV =
-> VNumPoly $ \(Nat n) ->
-> VPoly $ \ix ->
-> VFun $ \v ->
-> VFun $ \x ->
-> copyByTValue (tvSeq (Nat n) TVBit) $
-> case cryToInteger ix x of
-> Left e -> cryError e (tvSeq (Nat n) TVBit)
-> Right i -> VList (Nat n) $
-> let vs = fromVList v
-> z = head vs in
-> genericReplicate (min n i) z ++ genericTake (n - min n i) vs
-
-Indexing
---------
-
-Indexing operations are strict in all index bits, but as lazy as
-possible in the list values. An index greater than or equal to the
-length of the list produces a run-time error.
-
-> -- | Indexing operations that return one element.
-> indexPrimOne :: (Nat' -> TValue -> [Value] -> Integer -> Value) -> Value
-> indexPrimOne op =
-> VNumPoly $ \n ->
-> VPoly $ \a ->
-> VPoly $ \ix ->
-> VFun $ \l ->
-> VFun $ \r ->
-> copyByTValue a $
-> case cryToInteger ix r of
-> Left e -> cryError e a
-> Right i -> op n a (fromVList l) i
->
-> indexFront :: Nat' -> TValue -> [Value] -> Integer -> Value
-> indexFront w a vs ix =
-> case w of
-> Nat n | n <= ix -> cryError (InvalidIndex (Just ix)) a
-> _ -> genericIndex vs ix
->
-> indexBack :: Nat' -> TValue -> [Value] -> Integer -> Value
-> indexBack w a vs ix =
-> case w of
-> Nat n | n > ix -> genericIndex vs (n - ix - 1)
-> | otherwise -> cryError (InvalidIndex (Just ix)) a
-> Inf -> evalPanic "indexBack" ["unexpected infinite sequence"]
->
-> updatePrim :: (Nat' -> [Value] -> Integer -> Value -> [Value]) -> Value
-> updatePrim op =
-> VNumPoly $ \len ->
-> VPoly $ \eltTy ->
-> VPoly $ \ix ->
-> VFun $ \xs ->
-> VFun $ \idx ->
-> VFun $ \val ->
-> copyByTValue (tvSeq len eltTy) $
-> case cryToInteger ix idx of
-> Left e -> cryError e (tvSeq len eltTy)
-> Right i
-> | Nat i < len -> VList len (op len (fromVList xs) i val)
-> | otherwise -> cryError (InvalidIndex (Just i)) (tvSeq len eltTy)
->
-> updateFront :: Nat' -> [Value] -> Integer -> Value -> [Value]
-> updateFront _ vs i x = updateAt vs i x
->
-> updateBack :: Nat' -> [Value] -> Integer -> Value -> [Value]
-> updateBack Inf _vs _i _x = evalPanic "Unexpected infinite sequence in updateEnd" []
-> updateBack (Nat n) vs i x = updateAt vs (n - i - 1) x
->
-> updateAt :: [a] -> Integer -> a -> [a]
-> updateAt [] _ _ = []
-> updateAt (_ : xs) 0 y = y : xs
-> updateAt (x : xs) i y = x : updateAt xs (i - 1) y
-
-
-Floating Point Numbers
-----------------------
-
-Whenever we do operations that do not have an explicit rounding mode,
-we round towards the closest number, with ties resolved to the even one.
-
-> fpImplicitRound :: FP.RoundMode
-> fpImplicitRound = FP.NearEven
-
-We annotate floating point values with their precision. This is only used
-when pretty printing values.
-
-> fpToBF :: Integer -> Integer -> BigFloat -> BF
-> fpToBF e p x = BF { bfValue = x, bfExpWidth = e, bfPrecWidth = p }
-
-
-The following two functions convert between floaitng point numbers
-and integers.
-
-> fpFromInteger :: Integer -> Integer -> Integer -> BigFloat
-> fpFromInteger e p = FP.fpCheckStatus . FP.bfRoundFloat opts . FP.bfFromInteger
-> where opts = FP.fpOpts e p fpImplicitRound
-
-These functions capture the interactions with rationals.
-
-
-This just captures a common pattern for binary floating point primitives.
-
-> fpBin :: (FP.BFOpts -> BigFloat -> BigFloat -> (BigFloat,FP.Status)) ->
-> FP.RoundMode -> Integer -> Integer ->
-> BigFloat -> BigFloat -> Either EvalError BigFloat
-> fpBin f r e p x y = Right (FP.fpCheckStatus (f (FP.fpOpts e p r) x y))
-
-
-Computes the reciprocal of a floating point number via division.
-This assumes that 1 can be represented exactly, which should be
-true for all supported precisions.
-
-> fpRecip :: Integer -> Integer -> BigFloat -> Either EvalError BigFloat
-> fpRecip e p x = pure (FP.fpCheckStatus (FP.bfDiv opts (FP.bfFromInteger 1) x))
-> where opts = FP.fpOpts e p fpImplicitRound
-
-
-> floatPrimTable :: Map PrimIdent Value
-> floatPrimTable = Map.fromList $ map (\(n, v) -> (floatPrim (T.pack n), v))
-> [ "fpNaN" ~> vFinPoly \e -> vFinPoly \p ->
-> VFloat $ Right $ fpToBF e p FP.bfNaN
->
-> , "fpPosInf" ~> vFinPoly \e -> vFinPoly \p ->
-> VFloat $ Right $ fpToBF e p FP.bfPosInf
->
-> , "fpFromBits" ~> vFinPoly \e -> vFinPoly \p -> VFun \bvv ->
-> VFloat (FP.floatFromBits e p <$> fromVWord bvv)
->
-> , "fpToBits" ~> vFinPoly \e -> vFinPoly \p -> VFun \fpv ->
-> vWord (e + p) (FP.floatToBits e p <$> fromVFloat fpv)
->
-> , "=.=" ~> vFinPoly \_ -> vFinPoly \_ -> VFun \xv -> VFun \yv ->
-> VBit do x <- fromVFloat xv
-> y <- fromVFloat yv
-> pure (FP.bfCompare x y == EQ)
->
-> , "fpIsFinite" ~> vFinPoly \_ -> vFinPoly \_ -> VFun \xv ->
-> VBit do x <- fromVFloat xv
-> pure (FP.bfIsFinite x)
->
-> , "fpAdd" ~> fpArith FP.bfAdd
-> , "fpSub" ~> fpArith FP.bfSub
-> , "fpMul" ~> fpArith FP.bfMul
-> , "fpDiv" ~> fpArith FP.bfDiv
->
-> , "fpToRational" ~>
-> vFinPoly \_ -> vFinPoly \_ -> VFun \fpv ->
-> VRational do fp <- fromVFloat' fpv
-> FP.floatToRational "fpToRational" fp
-> , "fpFromRational" ~>
-> vFinPoly \e -> vFinPoly \p -> VFun \rmv -> VFun \rv ->
-> VFloat do rm <- FP.fpRound =<< fromVWord rmv
-> rat <- fromVRational rv
-> pure (FP.floatFromRational e p rm rat)
-> ]
-> where
-> (~>) = (,)
-> fpArith f = vFinPoly \e -> vFinPoly \p ->
-> VFun \vr -> VFun \xv -> VFun \yv ->
-> VFloat do r <- fromVWord vr
-> rnd <- FP.fpRound r
-> x <- fromVFloat xv
-> y <- fromVFloat yv
-> fpToBF e p <$> fpBin f rnd e p x y
-
-
-Error Handling
---------------
-
-The `evalPanic` function is only called if an internal data invariant
-is violated, such as an expression that is not well-typed. Panics
-should (hopefully) never occur in practice; a panic message indicates
-a bug in Cryptol.
-
-> evalPanic :: String -> [String] -> a
-> evalPanic cxt = panic ("[Reference Evaluator]" ++ cxt)
-
-Pretty Printing
----------------
-
-> ppValue :: PPOpts -> Value -> Doc
-> ppValue opts val =
-> case val of
-> VBit b -> text (either show show b)
-> VInteger i -> text (either show show i)
-> VRational q -> text (either show show q)
-> VFloat fl -> text (either show (show . FP.fpPP opts) fl)
-> VList l vs ->
-> case l of
-> Inf -> ppList (map (ppValue opts) (take (useInfLength opts) vs) ++ [text "..."])
-> Nat n ->
-> -- For lists of defined bits, print the value as a numeral.
-> case traverse isBit vs of
-> Just bs -> ppBV opts (mkBv n (bitsToInteger bs))
-> Nothing -> ppList (map (ppValue opts) vs)
-> where ppList docs = brackets (fsep (punctuate comma docs))
-> isBit v = case v of VBit (Right b) -> Just b
-> _ -> Nothing
-> VTuple vs -> parens (sep (punctuate comma (map (ppValue opts) vs)))
-> VRecord fs -> braces (sep (punctuate comma (map ppField fs)))
-> where ppField (f,r) = pp f <+> char '=' <+> ppValue opts r
-> VFun _ -> text ""
-> VPoly _ -> text ""
-> VNumPoly _ -> text ""
-
-Module Command
---------------
-
-This module implements the core functionality of the `:eval
-` command for the Cryptol REPL, which prints the result of
-running the reference evaluator on an expression.
-
-> evaluate :: Expr -> M.ModuleCmd Value
+> -- Copyright : (c) 2013-2020 Galois, Inc.
+> -- License : BSD3
+> -- Maintainer : cryptol@galois.com
+> -- Stability : provisional
+> -- Portability : portable
+>
+> {-# LANGUAGE BlockArguments #-}
+> {-# LANGUAGE PatternGuards #-}
+> {-# LANGUAGE LambdaCase #-}
+>
+> module Cryptol.Eval.Reference
+> ( Value(..)
+> , E(..)
+> , evaluate
+> , evalExpr
+> , evalDeclGroup
+> , ppValue
+> , ppEValue
+> ) where
+>
+> import Data.Bits
+> import Data.Ratio((%))
+> import Data.List
+> (genericIndex, genericLength, genericReplicate, genericTake, sortBy)
+> import Data.Ord (comparing)
+> import Data.Map (Map)
+> import qualified Data.Map as Map
+> import qualified Data.IntMap as IntMap
+> import qualified Data.Text as T (pack)
+> import LibBF (BigFloat)
+> import qualified LibBF as FP
+> import qualified GHC.Integer.GMP.Internals as Integer
+>
+> import Cryptol.ModuleSystem.Name (asPrim)
+> import Cryptol.TypeCheck.Solver.InfNat (Nat'(..), nAdd, nMin, nMul)
+> import Cryptol.TypeCheck.AST
+> import Cryptol.Backend.FloatHelpers (BF(..))
+> import qualified Cryptol.Backend.FloatHelpers as FP
+> import Cryptol.Backend.Monad (EvalError(..), PPOpts(..))
+> import Cryptol.Eval.Type (TValue(..), isTBit, evalValType, evalNumType, TypeEnv)
+> import Cryptol.Eval.Concrete (mkBv, ppBV, lg2)
+> import Cryptol.Utils.Ident (Ident,PrimIdent, prelPrim, floatPrim)
+> import Cryptol.Utils.Panic (panic)
+> import Cryptol.Utils.PP
+> import Cryptol.Utils.RecordMap
+>
+> import qualified Cryptol.ModuleSystem as M
+> import qualified Cryptol.ModuleSystem.Env as M (loadedModules)
+
+Overview
+========
+
+This file describes the semantics of the explicitly-typed Cryptol
+language (i.e., terms after type checking). Issues related to type
+inference, type functions, and type constraints are beyond the scope
+of this document.
+
+Cryptol Types
+-------------
+
+Cryptol types come in two kinds: numeric types (kind `#`) and value
+types (kind `*`). While value types are inhabited by well-typed
+Cryptol expressions, numeric types are only used as parameters to
+other types; they have no inhabitants. In this implementation we
+represent numeric types as values of the Haskell type `Nat'` of
+natural numbers with infinity; value types are represented as values
+of type `TValue`.
+
+The value types of Cryptol, along with their Haskell representations,
+are as follows:
+
+| Cryptol type | Description | `TValue` representation |
+|:------------------|:------------------|:----------------------------|
+| `Bit` | booleans | `TVBit` |
+| `Integer` | integers | `TVInteger` |
+| `Z n` | integers modulo n | `TVIntMod n` |
+| `Rational` | rationals | `TVRational` |
+| `Float e p` | floating point | `TVFloat` |
+| `Array` | arrays | `TVArray` |
+| `[n]a` | finite lists | `TVSeq n a` |
+| `[inf]a` | infinite lists | `TVStream a` |
+| `(a, b, c)` | tuples | `TVTuple [a,b,c]` |
+| `{x:a, y:b, z:c}` | records | `TVRec [(x,a),(y,b),(z,c)]` |
+| `a -> b` | functions | `TVFun a b` |
+
+We model each (closed) Cryptol value type `t` as a complete partial order (cpo)
+*M*(`t`). The values of *M*(`t`) represent the _values_ present in the
+type `t`; we distinguish these from the _computations_ at type `t`.
+Operationally, the difference is that computations may raise errors or cause
+nontermination when evaluated; however, values are already evaluated, and will
+not cause errors or nontermination. Denotationally, we represent this
+difference via a monad (in the style of Moggi) called *E*. As an
+operation on CPOs, *E* adds a new bottom element representing
+nontermination, and a collection of erroneous values representing
+various runtime error conditions.
+
+To each Cryptol expression `e : t` we assign a meaning
+*M*(`e`) in *E*(*M*(`t`)); in particular, recursive Cryptol programs of
+type `t` are modeled as least fixed points in *E*(*M*(`t`)). In other words,
+this is a domain-theoretic denotational semantics. Note, we do not requre
+CPOs defined via *M*(`t`) to have bottom elements, which is why we must take
+fixpoints in *E*. We cannot directly represent values without bottom in Haskell,
+so instead we are careful in this document only to write clearly-terminating
+functions, unless they represent computations under *E*.
+
+*M*(`Bit`) is a discrete cpo with values for `True`, `False`, which
+we simply represent in Haskell as `Bool`.
+Similarly, *M*(`Integer`) is a discrete cpo with values for integers,
+which we model as Haskell's `Integer`. Likewise with the other
+base types.
+
+The value cpos for lists, tuples, and records are cartesian products
+of _computations_. For example *M*(`(a,b)`) = *E*(*M*(`a`)) × *E*(*M*(`b`)).
+The cpo ordering is pointwise. The trivial types `[0]t`,
+`()` and `{}` denote single-element cpos. *M*(`a -> b`) is the
+continuous function space *E*(*M*(`a`)) $\to$ *E*(*M*(`b`)).
+
+Type schemas of the form `{a1 ... an} (p1 ... pk) => t` classify
+polymorphic values in Cryptol. These are represented with the Haskell
+type `Schema`. The meaning of a schema is cpo whose elements are
+functions: For each valid instantiation `t1 ... tn` of the type
+parameters `a1 ... an` that satisfies the constraints `p1 ... pk`, the
+function returns a value in *E*(*M*(`t[t1/a1 ... tn/an]`)).
+
+Computation Monad
+------------------
+
+This monad represents either an evaluated thing of type `a`
+or an evaluation error. In the reference interpreter, only
+things under this monad should potentially result in errors
+or fail to terminate.
+
+> -- | Computation monad for the reference evaluator.
+> data E a = Value !a | Err EvalError
+>
+> instance Functor E where
+> fmap f (Value x) = Value (f x)
+> fmap _ (Err e) = Err e
+
+> instance Applicative E where
+> pure x = Value x
+> Err e <*> _ = Err e
+> Value _ <*> Err e = Err e
+> Value f <*> Value x = Value (f x)
+
+> instance Monad E where
+> m >>= f =
+> case m of
+> Value x -> f x
+> Err r -> Err r
+>
+> eitherToE :: Either EvalError a -> E a
+> eitherToE (Left e) = Err e
+> eitherToE (Right x) = pure x
+
+Values
+------
+
+The Haskell code in this module defines the semantics of typed Cryptol
+terms by providing an evaluator to an appropriate `Value` type.
+
+> -- | Value type for the reference evaluator.
+> data Value
+> = VBit !Bool -- ^ @ Bit @ booleans
+> | VInteger !Integer -- ^ @ Integer @ or @Z n@ integers
+> | VRational !Rational -- ^ @ Rational @ rationals
+> | VFloat !BF -- ^ Floating point numbers
+> | VList Nat' [E Value] -- ^ @ [n]a @ finite or infinite lists
+> | VTuple [E Value] -- ^ @ ( .. ) @ tuples
+> | VRecord [(Ident, E Value)] -- ^ @ { .. } @ records
+> | VFun (E Value -> E Value) -- ^ functions
+> | VPoly (TValue -> E Value) -- ^ polymorphic values (kind *)
+> | VNumPoly (Nat' -> E Value) -- ^ polymorphic values (kind #)
+
+Operations on Values
+--------------------
+
+> -- | Destructor for @VBit@.
+> fromVBit :: Value -> Bool
+> fromVBit (VBit b) = b
+> fromVBit _ = evalPanic "fromVBit" ["Expected a bit"]
+>
+> -- | Destructor for @VInteger@.
+> fromVInteger :: Value -> Integer
+> fromVInteger (VInteger i) = i
+> fromVInteger _ = evalPanic "fromVInteger" ["Expected an integer"]
+>
+> -- | Destructor for @VRational@.
+> fromVRational :: Value -> Rational
+> fromVRational (VRational i) = i
+> fromVRational _ = evalPanic "fromVRational" ["Expected a rational"]
+>
+> fromVFloat :: Value -> BigFloat
+> fromVFloat = bfValue . fromVFloat'
+>
+> fromVFloat' :: Value -> BF
+> fromVFloat' v =
+> case v of
+> VFloat f -> f
+> _ -> evalPanic "fromVFloat" [ "Expected a floating point value." ]
+>
+> -- | Destructor for @VList@.
+> fromVList :: Value -> [E Value]
+> fromVList (VList _ vs) = vs
+> fromVList _ = evalPanic "fromVList" ["Expected a list"]
+>
+> -- | Destructor for @VTuple@.
+> fromVTuple :: Value -> [E Value]
+> fromVTuple (VTuple vs) = vs
+> fromVTuple _ = evalPanic "fromVTuple" ["Expected a tuple"]
+>
+> -- | Destructor for @VRecord@.
+> fromVRecord :: Value -> [(Ident, E Value)]
+> fromVRecord (VRecord fs) = fs
+> fromVRecord _ = evalPanic "fromVRecord" ["Expected a record"]
+>
+> -- | Destructor for @VFun@.
+> fromVFun :: Value -> (E Value -> E Value)
+> fromVFun (VFun f) = f
+> fromVFun _ = evalPanic "fromVFun" ["Expected a function"]
+>
+> -- | Look up a field in a record.
+> lookupRecord :: Ident -> Value -> E Value
+> lookupRecord f v =
+> case lookup f (fromVRecord v) of
+> Just val -> val
+> Nothing -> evalPanic "lookupRecord" ["Malformed record"]
+>
+> -- | Polymorphic function values that expect a finite numeric type.
+> vFinPoly :: (Integer -> E Value) -> Value
+> vFinPoly f = VNumPoly g
+> where
+> g (Nat n) = f n
+> g Inf = evalPanic "vFinPoly" ["Expected finite numeric type"]
+
+
+Environments
+------------
+
+An evaluation environment keeps track of the values of term variables
+and type variables that are in scope at any point.
+
+> data Env = Env
+> { envVars :: !(Map Name (E Value))
+> , envTypes :: !TypeEnv
+> }
+>
+> instance Semigroup Env where
+> l <> r = Env
+> { envVars = Map.union (envVars l) (envVars r)
+> , envTypes = IntMap.union (envTypes l) (envTypes r)
+> }
+>
+> instance Monoid Env where
+> mempty = Env
+> { envVars = Map.empty
+> , envTypes = IntMap.empty
+> }
+> mappend l r = l <> r
+>
+> -- | Bind a variable in the evaluation environment.
+> bindVar :: (Name, E Value) -> Env -> Env
+> bindVar (n, val) env = env { envVars = Map.insert n val (envVars env) }
+>
+> -- | Bind a type variable of kind # or *.
+> bindType :: TVar -> Either Nat' TValue -> Env -> Env
+> bindType p ty env = env { envTypes = IntMap.insert (tvUnique p) ty (envTypes env) }
+
+
+Evaluation
+==========
+
+The meaning *M*(`expr`) of a Cryptol expression `expr` is defined by
+recursion over its structure. For an expression that contains free
+variables, the meaning also depends on the environment `env`, which
+assigns values to those variables.
+
+> evalExpr :: Env -- ^ Evaluation environment
+> -> Expr -- ^ Expression to evaluate
+> -> E Value
+> evalExpr env expr =
+> case expr of
+>
+> EList es _ty ->
+> pure $ VList (Nat (genericLength es)) [ evalExpr env e | e <- es ]
+>
+> ETuple es ->
+> pure $ VTuple [ evalExpr env e | e <- es ]
+>
+> ERec fields ->
+> pure $ VRecord [ (f, evalExpr env e) | (f, e) <- canonicalFields fields ]
+>
+> ESel e sel ->
+> evalSel sel =<< evalExpr env e
+>
+> ESet ty e sel v ->
+> evalSet (evalValType (envTypes env) ty)
+> (evalExpr env e) sel (evalExpr env v)
+>
+> EIf c t f ->
+> condValue (fromVBit <$> evalExpr env c) (evalExpr env t) (evalExpr env f)
+>
+> EComp _n _ty e branches -> evalComp env e branches
+>
+> EVar n ->
+> case Map.lookup n (envVars env) of
+> Just val -> val
+> Nothing ->
+> evalPanic "evalExpr" ["var `" ++ show (pp n) ++ "` is not defined" ]
+>
+> ETAbs tv b ->
+> case tpKind tv of
+> KType -> pure $ VPoly $ \ty ->
+> evalExpr (bindType (tpVar tv) (Right ty) env) b
+> KNum -> pure $ VNumPoly $ \n ->
+> evalExpr (bindType (tpVar tv) (Left n) env) b
+> k -> evalPanic "evalExpr" ["Invalid kind on type abstraction", show k]
+>
+> ETApp e ty ->
+> evalExpr env e >>= \case
+> VPoly f -> f $! (evalValType (envTypes env) ty)
+> VNumPoly f -> f $! (evalNumType (envTypes env) ty)
+> _ -> evalPanic "evalExpr" ["Expected a polymorphic value"]
+>
+> EApp e1 e2 -> appFun (evalExpr env e1) (evalExpr env e2)
+> EAbs n _ty b -> pure $ VFun (\v -> evalExpr (bindVar (n, v) env) b)
+> EProofAbs _ e -> evalExpr env e
+> EProofApp e -> evalExpr env e
+> EWhere e dgs -> evalExpr (foldl evalDeclGroup env dgs) e
+
+
+> appFun :: E Value -> E Value -> E Value
+> appFun f v = f >>= \f' -> fromVFun f' v
+
+
+Selectors
+---------
+
+Apply the the given selector form to the given value.
+
+> evalSel :: Selector -> Value -> E Value
+> evalSel sel val =
+> case sel of
+> TupleSel n _ -> tupleSel n val
+> RecordSel n _ -> recordSel n val
+> ListSel n _ -> listSel n val
+> where
+> tupleSel n v =
+> case v of
+> VTuple vs -> vs !! n
+> _ -> evalPanic "evalSel"
+> ["Unexpected value in tuple selection."]
+> recordSel n v =
+> case v of
+> VRecord _ -> lookupRecord n v
+> _ -> evalPanic "evalSel"
+> ["Unexpected value in record selection."]
+> listSel n v =
+> case v of
+> VList _ vs -> vs !! n
+> _ -> evalPanic "evalSel"
+> ["Unexpected value in list selection."]
+
+
+Update the given value using the given selector and new value.
+
+> evalSet :: TValue -> E Value -> Selector -> E Value -> E Value
+> evalSet tyv val sel fval =
+> case (tyv, sel) of
+> (TVTuple ts, TupleSel n _) -> updTupleAt ts n
+> (TVRec fs, RecordSel n _) -> updRecAt fs n
+> (TVSeq len _, ListSel n _) -> updSeqAt len n
+> (_, _) -> evalPanic "evalSet" ["type/selector mismatch", show tyv, show sel]
+> where
+> updTupleAt ts n =
+> pure $ VTuple
+> [ if i == n then fval else
+> do vs <- fromVTuple <$> val
+> genericIndex vs i
+> | (i,_t) <- zip [0 ..] ts
+> ]
+>
+> updRecAt fs n =
+> pure $ VRecord
+> [ (f, if f == n then fval else lookupRecord f =<< val)
+> | (f, _t) <- canonicalFields fs
+> ]
+>
+> updSeqAt len n =
+> pure $ generateV (Nat len) $ \i ->
+> if i == toInteger n then fval else
+> do vs <- fromVList <$> val
+> indexFront (Nat len) vs i
+
+Conditionals
+------------
+
+Conditionals are explicitly lazy: Run-time errors in an untaken branch
+are ignored.
+
+> condValue :: E Bool -> E Value -> E Value -> E Value
+> condValue c l r = c >>= \b -> if b then l else r
+
+List Comprehensions
+-------------------
+
+Cryptol list comprehensions consist of one or more parallel branches;
+each branch has one or more matches that bind values to variables.
+
+The result of evaluating a match in an initial environment is a list
+of extended environments. Each new environment binds the same single
+variable to a different element of the match's list.
+
+> evalMatch :: Env -> Match -> [Env]
+> evalMatch env m =
+> case m of
+> Let d -> [ bindVar (evalDecl env d) env ]
+> From nm len _ty expr -> [ bindVar (nm, get i) env | i <- idxs ]
+> where
+> get i =
+> do v <- evalExpr env expr
+> genericIndex (fromVList v) i
+>
+> idxs :: [Integer]
+> idxs =
+> case evalNumType (envTypes env) len of
+> Inf -> [0 ..]
+> Nat n -> [0 .. n-1]
+
+> lenMatch :: Env -> Match -> Nat'
+> lenMatch env m =
+> case m of
+> Let _ -> Nat 1
+> From _ len _ _ -> evalNumType (envTypes env) len
+
+The result of of evaluating a branch in an initial environment is a
+list of extended environments, each of which extends the initial
+environment with the same set of new variables. The length of the list
+is equal to the product of the lengths of the lists in the matches.
+
+> evalBranch :: Env -> [Match] -> [Env]
+> evalBranch env [] = [env]
+> evalBranch env (match : matches) =
+> [ env'' | env' <- evalMatch env match
+> , env'' <- evalBranch env' matches ]
+
+> lenBranch :: Env -> [Match] -> Nat'
+> lenBranch _env [] = Nat 1
+> lenBranch env (match : matches) =
+> nMul (lenMatch env match) (lenBranch env matches)
+
+The head expression of the comprehension can refer to any variable
+bound in any of the parallel branches. So to evaluate the
+comprehension, we zip and merge together the lists of extended
+environments from each branch. The head expression is then evaluated
+separately in each merged environment. The length of the resulting
+list is equal to the minimum length over all parallel branches.
+
+> evalComp :: Env -- ^ Starting evaluation environment
+> -> Expr -- ^ Head expression of the comprehension
+> -> [[Match]] -- ^ List of parallel comprehension branches
+> -> E Value
+> evalComp env expr branches = pure $ VList len [ evalExpr e expr | e <- envs ]
+> where
+> -- Generate a new environment for each iteration of each
+> -- parallel branch.
+> benvs :: [[Env]]
+> benvs = map (evalBranch env) branches
+>
+> -- Zip together the lists of environments from each branch,
+> -- producing a list of merged environments. Longer branches get
+> -- truncated to the length of the shortest branch.
+> envs :: [Env]
+> envs = foldr1 (zipWith mappend) benvs
+>
+> len :: Nat'
+> len = foldr1 nMin (map (lenBranch env) branches)
+
+
+Declarations
+------------
+
+Function `evalDeclGroup` extends the given evaluation environment with
+the result of evaluating the given declaration group. In the case of a
+recursive declaration group, we tie the recursive knot by evaluating
+each declaration in the extended environment `env'` that includes all
+the new bindings.
+
+> evalDeclGroup :: Env -> DeclGroup -> Env
+> evalDeclGroup env dg = do
+> case dg of
+> NonRecursive d ->
+> bindVar (evalDecl env d) env
+> Recursive ds ->
+> let env' = foldr bindVar env bindings
+> bindings = map (evalDecl env') ds
+> in env'
+>
+> evalDecl :: Env -> Decl -> (Name, E Value)
+> evalDecl env d =
+> case dDefinition d of
+> DPrim -> (dName d, pure (evalPrim (dName d)))
+> DExpr e -> (dName d, evalExpr env e)
+
+
+Primitives
+==========
+
+To evaluate a primitive, we look up its implementation by name in a table.
+
+> evalPrim :: Name -> Value
+> evalPrim n
+> | Just i <- asPrim n, Just v <- Map.lookup i primTable = v
+> | otherwise = evalPanic "evalPrim" ["Unimplemented primitive", show n]
+
+Cryptol primitives fall into several groups, mostly delineated
+by corresponding type classes:
+
+* Literals: `True`, `False`, `number`, `ratio`
+
+* Zero: zero
+
+* Logic: `&&`, `||`, `^`, `complement`
+
+* Ring: `+`, `-`, `*`, `negate`, `fromInteger`
+
+* Integral: `/`, `%`, `^^`, `toInteger`
+
+* Bitvector: `/$` `%$`, `lg2`, `<=$`
+
+* Comparison: `<`, `>`, `<=`, `>=`, `==`, `!=`
+
+* Sequences: `#`, `join`, `split`, `splitAt`, `reverse`, `transpose`
+
+* Shifting: `<<`, `>>`, `<<<`, `>>>`
+
+* Indexing: `@`, `@@`, `!`, `!!`, `update`, `updateEnd`
+
+* Enumerations: `fromTo`, `fromThenTo`, `infFrom`, `infFromThen`
+
+* Polynomials: `pmult`, `pdiv`, `pmod`
+
+* Miscellaneous: `error`, `random`, `trace`
+
+> primTable :: Map PrimIdent Value
+> primTable = Map.unions
+> [ cryptolPrimTable
+> , floatPrimTable
+> ]
+
+> infixr 0 ~>
+> (~>) :: String -> a -> (String,a)
+> nm ~> v = (nm,v)
+
+
+> cryptolPrimTable :: Map PrimIdent Value
+> cryptolPrimTable = Map.fromList $ map (\(n, v) -> (prelPrim (T.pack n), v))
+>
+> -- Literals
+> [ "True" ~> VBit True
+> , "False" ~> VBit False
+> , "number" ~> vFinPoly $ \val -> pure $
+> VPoly $ \a ->
+> literal val a
+> , "fraction" ~> vFinPoly \top -> pure $
+> vFinPoly \bot -> pure $
+> vFinPoly \rnd -> pure $
+> VPoly \a -> fraction top bot rnd a
+> -- Zero
+> , "zero" ~> VPoly (pure . zero)
+>
+> -- Logic (bitwise)
+> , "&&" ~> binary (logicBinary (&&))
+> , "||" ~> binary (logicBinary (||))
+> , "^" ~> binary (logicBinary (/=))
+> , "complement" ~> unary (logicUnary not)
+>
+> -- Ring
+> , "+" ~> binary (ringBinary
+> (\x y -> pure (x + y))
+> (\x y -> pure (x + y))
+> (fpBin FP.bfAdd fpImplicitRound)
+> )
+> , "-" ~> binary (ringBinary
+> (\x y -> pure (x - y))
+> (\x y -> pure (x - y))
+> (fpBin FP.bfSub fpImplicitRound)
+> )
+> , "*" ~> binary ringMul
+> , "negate" ~> unary (ringUnary (\x -> pure (- x))
+> (\x -> pure (- x))
+> (\_ _ x -> pure (FP.bfNeg x)))
+> , "fromInteger"~> VPoly $ \a -> pure $
+> VFun $ \x ->
+> ringNullary (fromVInteger <$> x)
+> (fromInteger . fromVInteger <$> x)
+> (\e p -> fpFromInteger e p . fromVInteger <$> x)
+> a
+>
+> -- Integral
+> , "toInteger" ~> VPoly $ \a -> pure $
+> VFun $ \x ->
+> VInteger <$> cryToInteger a x
+> , "/" ~> binary (integralBinary divWrap)
+> , "%" ~> binary (integralBinary modWrap)
+> , "^^" ~> VPoly $ \aty -> pure $
+> VPoly $ \ety -> pure $
+> VFun $ \a -> pure $
+> VFun $ \e ->
+> ringExp aty a =<< cryToInteger ety e
+>
+> -- Field
+> , "/." ~> binary (fieldBinary ratDiv zDiv
+> (fpBin FP.bfDiv fpImplicitRound)
+> )
+>
+> , "recip" ~> unary (fieldUnary ratRecip zRecip fpRecip)
+>
+> -- Round
+> , "floor" ~> unary (roundUnary floor
+> (eitherToE . FP.floatToInteger "floor" FP.ToNegInf))
+>
+> , "ceiling" ~> unary (roundUnary ceiling
+> (eitherToE . FP.floatToInteger "ceiling" FP.ToPosInf))
+>
+> , "trunc" ~> unary (roundUnary truncate
+> (eitherToE . FP.floatToInteger "trunc" FP.ToZero))
+>
+> , "roundAway" ~> unary (roundUnary roundAwayRat
+> (eitherToE . FP.floatToInteger "roundAway" FP.Away))
+>
+> , "roundToEven"~> unary (roundUnary round
+> (eitherToE . FP.floatToInteger "roundToEven" FP.NearEven))
+>
+>
+> -- Comparison
+> , "<" ~> binary (cmpOrder (\o -> o == LT))
+> , ">" ~> binary (cmpOrder (\o -> o == GT))
+> , "<=" ~> binary (cmpOrder (\o -> o /= GT))
+> , ">=" ~> binary (cmpOrder (\o -> o /= LT))
+> , "==" ~> binary (cmpOrder (\o -> o == EQ))
+> , "!=" ~> binary (cmpOrder (\o -> o /= EQ))
+> , "<$" ~> binary signedLessThan
+>
+> -- Bitvector
+> , "/$" ~> vFinPoly $ \n -> pure $
+> VFun $ \l -> pure $
+> VFun $ \r ->
+> vWord n <$> appOp2 divWrap
+> (fromSignedVWord =<< l)
+> (fromSignedVWord =<< r)
+> , "%$" ~> vFinPoly $ \n -> pure $
+> VFun $ \l -> pure $
+> VFun $ \r ->
+> vWord n <$> appOp2 modWrap
+> (fromSignedVWord =<< l)
+> (fromSignedVWord =<< r)
+> , ">>$" ~> signedShiftRV
+> , "lg2" ~> vFinPoly $ \n -> pure $
+> VFun $ \v ->
+> vWord n <$> appOp1 lg2Wrap (fromVWord =<< v)
+> -- Rational
+> , "ratio" ~> VFun $ \l -> pure $
+> VFun $ \r ->
+> VRational <$> appOp2 ratioOp
+> (fromVInteger <$> l)
+> (fromVInteger <$> r)
+>
+> -- Z n
+> , "fromZ" ~> vFinPoly $ \n -> pure $
+> VFun $ \x ->
+> VInteger . flip mod n . fromVInteger <$> x
+>
+> -- Sequences
+> , "#" ~> vFinPoly $ \front -> pure $
+> VNumPoly $ \back -> pure $
+> VPoly $ \_elty -> pure $
+> VFun $ \l -> pure $
+> VFun $ \r ->
+> pure $ generateV (nAdd (Nat front) back) $ \i ->
+> if i < front then
+> do l' <- fromVList <$> l
+> indexFront (Nat front) l' i
+> else
+> do r' <- fromVList <$> r
+> indexFront back r' (i - front)
+>
+> , "join" ~> VNumPoly $ \parts -> pure $
+> vFinPoly $ \each -> pure $
+> VPoly $ \_a -> pure $
+> VFun $ \v ->
+> pure $ generateV (nMul parts (Nat each)) $ \i ->
+> do let (q,r) = divMod i each
+> xss <- fromVList <$> v
+> xs <- fromVList <$> indexFront parts xss q
+> indexFront (Nat each) xs r
+>
+> , "split" ~> VNumPoly $ \parts -> pure $
+> vFinPoly $ \each -> pure $
+> VPoly $ \_a -> pure $
+> VFun $ \val ->
+> pure $ generateV parts $ \i ->
+> pure $ generateV (Nat each) $ \j ->
+> do vs <- fromVList <$> val
+> indexFront (nMul parts (Nat each)) vs (i * each + j)
+>
+> , "splitAt" ~> vFinPoly $ \front -> pure $
+> VNumPoly $ \back -> pure $
+> VPoly $ \_a -> pure $
+> VFun $ \v ->
+> let xs = pure $ generateV (Nat front) $ \i ->
+> do vs <- fromVList <$> v
+> indexFront (nAdd (Nat front) back) vs i
+> ys = pure $ generateV back $ \i ->
+> do vs <- fromVList <$> v
+> indexFront (nAdd (Nat front) back) vs (front+i)
+> in pure (VTuple [ xs, ys ])
+>
+> , "reverse" ~> vFinPoly $ \n -> pure $
+> VPoly $ \_a -> pure $
+> VFun $ \v ->
+> pure $ generateV (Nat n) $ \i ->
+> do vs <- fromVList <$> v
+> indexBack (Nat n) vs i
+>
+> , "transpose" ~> VNumPoly $ \rows -> pure $
+> VNumPoly $ \cols -> pure $
+> VPoly $ \_a -> pure $
+> VFun $ \val ->
+> pure $ generateV cols $ \c ->
+> pure $ generateV rows $ \r ->
+> do xss <- fromVList <$> val
+> xs <- fromVList <$> indexFront rows xss r
+> indexFront cols xs c
+>
+> -- Shifting:
+> , "<<" ~> shiftV shiftLV
+> , ">>" ~> shiftV shiftRV
+> , "<<<" ~> rotateV rotateLV
+> , ">>>" ~> rotateV rotateRV
+>
+> -- Indexing:
+> , "@" ~> indexPrimOne indexFront
+> , "!" ~> indexPrimOne indexBack
+> , "update" ~> updatePrim updateFront
+> , "updateEnd" ~> updatePrim updateBack
+>
+> -- Enumerations
+> , "fromTo" ~> vFinPoly $ \first -> pure $
+> vFinPoly $ \lst -> pure $
+> VPoly $ \ty ->
+> let f i = literal i ty
+> in pure (VList (Nat (1 + lst - first)) (map f [first .. lst]))
+>
+> , "fromThenTo" ~> vFinPoly $ \first -> pure $
+> vFinPoly $ \next -> pure $
+> vFinPoly $ \_lst -> pure $
+> VPoly $ \ty -> pure $
+> vFinPoly $ \len ->
+> let f i = literal i ty
+> in pure (VList (Nat len)
+> (map f (genericTake len [first, next ..])))
+>
+> , "infFrom" ~> VPoly $ \ty -> pure $
+> VFun $ \first ->
+> do x <- cryToInteger ty first
+> let f i = literal (x + i) ty
+> pure $ VList Inf (map f [0 ..])
+>
+> , "infFromThen"~> VPoly $ \ty -> pure $
+> VFun $ \first -> pure $
+> VFun $ \next ->
+> do x <- cryToInteger ty first
+> y <- cryToInteger ty next
+> let diff = y - x
+> f i = literal (x + diff * i) ty
+> pure $ VList Inf (map f [0 ..])
+>
+> -- Miscellaneous:
+> , "parmap" ~> VPoly $ \_a -> pure $
+> VPoly $ \_b -> pure $
+> VNumPoly $ \n -> pure $
+> VFun $ \f -> pure $
+> VFun $ \xs ->
+> do f' <- fromVFun <$> f
+> xs' <- fromVList <$> xs
+> -- Note: the reference implementation simply
+> -- executes parmap sequentially
+> pure $ VList n (map f' xs')
+>
+> , "error" ~> VPoly $ \_a -> pure $
+> VNumPoly $ \_ -> pure $
+> VFun $ \s ->
+> do msg <- evalString s
+> cryError (UserError msg)
+>
+> , "random" ~> VPoly $ \_a -> pure $
+> VFun $ \_seed -> cryError (UserError "random: unimplemented")
+>
+> , "trace" ~> VNumPoly $ \_n -> pure $
+> VPoly $ \_a -> pure $
+> VPoly $ \_b -> pure $
+> VFun $ \s -> pure $
+> VFun $ \x -> pure $
+> VFun $ \y ->
+> do _ <- evalString s -- evaluate and ignore s
+> _ <- x -- evaluate and ignore x
+> y
+> ]
+>
+>
+> evalString :: E Value -> E String
+> evalString v =
+> do cs <- fromVList <$> v
+> ws <- mapM (fromVWord =<<) cs
+> pure (map (toEnum . fromInteger) ws)
+>
+> unary :: (TValue -> E Value -> E Value) -> Value
+> unary f = VPoly $ \ty -> pure $
+> VFun $ \x -> f ty x
+>
+> binary :: (TValue -> E Value -> E Value -> E Value) -> Value
+> binary f = VPoly $ \ty -> pure $
+> VFun $ \x -> pure $
+> VFun $ \y -> f ty x y
+>
+> appOp1 :: (a -> E b) -> E a -> E b
+> appOp1 f x =
+> do x' <- x
+> f x'
+>
+> appOp2 :: (a -> b -> E c) -> E a -> E b -> E c
+> appOp2 f x y =
+> do x' <- x
+> y' <- y
+> f x' y'
+
+Word operations
+---------------
+
+Many Cryptol primitives take numeric arguments in the form of
+bitvectors. For such operations, any output bit that depends on the
+numeric value is strict in *all* bits of the numeric argument. This is
+implemented in function `fromVWord`, which converts a value from a
+big-endian binary format to an integer. The result is an evaluation
+error if any of the input bits contain an evaluation error.
+
+> fromVWord :: Value -> E Integer
+> fromVWord v = bitsToInteger <$> traverse (fmap fromVBit) (fromVList v)
+>
+> -- | Convert a list of booleans in big-endian format to an integer.
+> bitsToInteger :: [Bool] -> Integer
+> bitsToInteger bs = foldl f 0 bs
+> where f x b = if b then 2 * x + 1 else 2 * x
+
+> fromSignedVWord :: Value -> E Integer
+> fromSignedVWord v = signedBitsToInteger <$> traverse (fmap fromVBit) (fromVList v)
+>
+> -- | Convert a list of booleans in signed big-endian format to an integer.
+> signedBitsToInteger :: [Bool] -> Integer
+> signedBitsToInteger [] =
+> evalPanic "signedBitsToInteger" ["Bitvector has zero length"]
+> signedBitsToInteger (b0 : bs) = foldl f (if b0 then -1 else 0) bs
+> where f x b = if b then 2 * x + 1 else 2 * x
+
+Function `vWord` converts an integer back to the big-endian bitvector
+representation.
+
+> vWord :: Integer -> Integer -> Value
+> vWord w e
+> | w > toInteger (maxBound :: Int) =
+> evalPanic "vWord" ["Word length too large", show w]
+> | otherwise =
+> VList (Nat w) [ mkBit i | i <- [w-1, w-2 .. 0 ] ]
+> where
+> mkBit i = pure (VBit (testBit e (fromInteger i)))
+
+Errors
+------
+
+> cryError :: EvalError -> E a
+> cryError e = Err e
+
+Zero
+----
+
+The `Zero` class has a single method `zero` which computes
+a zero value for all the built-in types for Cryptol.
+For bits, bitvectors and the base numeric types, this
+returns the obvious 0 representation. For sequences, records,
+and tuples, the zero method operates pointwise the underlying types.
+For functions, `zero` returns the constant function that returns
+`zero` in the codomain.
+
+> zero :: TValue -> Value
+> zero TVBit = VBit False
+> zero TVInteger = VInteger 0
+> zero TVIntMod{} = VInteger 0
+> zero TVRational = VRational 0
+> zero (TVFloat e p) = VFloat (fpToBF e p FP.bfPosZero)
+> zero TVArray{} = evalPanic "zero" ["Array type not in `Zero`"]
+> zero (TVSeq n ety) = VList (Nat n) (genericReplicate n (pure (zero ety)))
+> zero (TVStream ety) = VList Inf (repeat (pure (zero ety)))
+> zero (TVTuple tys) = VTuple (map (pure . zero) tys)
+> zero (TVRec fields) = VRecord [ (f, pure (zero fty))
+> | (f, fty) <- canonicalFields fields ]
+> zero (TVFun _ bty) = VFun (\_ -> pure (zero bty))
+> zero (TVAbstract{}) = evalPanic "zero" ["Abstract type not in `Zero`"]
+
+
+Literals
+--------
+
+Given a literal integer, construct a value of a type that can represent that literal.
+
+> literal :: Integer -> TValue -> E Value
+> literal i = go
+> where
+> go TVInteger = pure (VInteger i)
+> go TVRational = pure (VRational (fromInteger i))
+> go (TVIntMod n)
+> | i < n = pure (VInteger i)
+> | otherwise = evalPanic "literal"
+> ["Literal out of range for type Z " ++ show n]
+> go (TVSeq w a)
+> | isTBit a = pure (vWord w i)
+> go ty = evalPanic "literal" [show ty ++ " cannot represent literals"]
+
+
+Given a fraction, construct a value of a type that can represent that literal.
+The rounding flag determines the behavior if the literal cannot be represented
+exactly: 0 means report and error, other numbers round to the nearest
+representable value.
+
+> -- TODO: we should probably be using the rounding mode here...
+> fraction :: Integer -> Integer -> Integer -> TValue -> E Value
+> fraction top btm _rnd ty =
+> case ty of
+> TVRational -> pure (VRational (top % btm))
+> TVFloat e p -> pure $ VFloat $ fpToBF e p $ FP.fpCheckStatus val
+> where val = FP.bfDiv opts (FP.bfFromInteger top) (FP.bfFromInteger btm)
+> opts = FP.fpOpts e p fpImplicitRound
+> _ -> evalPanic "fraction" [show ty ++ " cannot represent " ++
+> show top ++ "/" ++ show btm]
+
+
+Logic
+-----
+
+Bitwise logic primitives are defined by recursion over the type
+structure. On type `Bit`, the operations are strict in all
+arguments. For example, `True || error "foo"`
+does not evaluate to `True`, but yields a run-time exception. On other
+types, run-time exceptions on input bits only affect the output bits
+at the same positions.
+
+> logicUnary :: (Bool -> Bool) -> TValue -> E Value -> E Value
+> logicUnary op = go
+> where
+> go :: TValue -> E Value -> E Value
+> go ty val =
+> case ty of
+> TVBit -> VBit . op . fromVBit <$> val
+> TVSeq w ety -> VList (Nat w) . map (go ety) . fromVList <$> val
+> TVStream ety -> VList Inf . map (go ety) . fromVList <$> val
+> TVTuple etys -> VTuple . zipWith go etys . fromVTuple <$> val
+> TVRec fields ->
+> do val' <- val
+> pure $ VRecord [ (f, go fty (lookupRecord f val'))
+> | (f, fty) <- canonicalFields fields ]
+> TVFun _ bty -> pure $ VFun (\v -> go bty (appFun val v))
+> TVInteger -> evalPanic "logicUnary" ["Integer not in class Logic"]
+> TVIntMod _ -> evalPanic "logicUnary" ["Z not in class Logic"]
+> TVArray{} -> evalPanic "logicUnary" ["Array not in class Logic"]
+> TVRational -> evalPanic "logicUnary" ["Rational not in class Logic"]
+> TVFloat{} -> evalPanic "logicUnary" ["Float not in class Logic"]
+> TVAbstract{} -> evalPanic "logicUnary" ["Abstract type not in `Logic`"]
+
+> logicBinary :: (Bool -> Bool -> Bool) -> TValue -> E Value -> E Value -> E Value
+> logicBinary op = go
+> where
+> go :: TValue -> E Value -> E Value -> E Value
+> go ty l r =
+> case ty of
+> TVBit ->
+> VBit <$> (op <$> (fromVBit <$> l) <*> (fromVBit <$> r))
+> TVSeq w ety ->
+> VList (Nat w) <$> (zipWith (go ety) <$>
+> (fromVList <$> l) <*>
+> (fromVList <$> r))
+> TVStream ety ->
+> VList Inf <$> (zipWith (go ety) <$>
+> (fromVList <$> l) <*>
+> (fromVList <$> r))
+> TVTuple etys ->
+> VTuple <$> (zipWith3 go etys <$>
+> (fromVTuple <$> l) <*>
+> (fromVTuple <$> r))
+> TVRec fields ->
+> do l' <- l
+> r' <- r
+> pure $ VRecord
+> [ (f, go fty (lookupRecord f l') (lookupRecord f r'))
+> | (f, fty) <- canonicalFields fields
+> ]
+> TVFun _ bty -> pure $ VFun $ \v ->
+> do l' <- l
+> r' <- r
+> go bty (fromVFun l' v) (fromVFun r' v)
+> TVInteger -> evalPanic "logicBinary" ["Integer not in class Logic"]
+> TVIntMod _ -> evalPanic "logicBinary" ["Z not in class Logic"]
+> TVArray{} -> evalPanic "logicBinary" ["Array not in class Logic"]
+> TVRational -> evalPanic "logicBinary" ["Rational not in class Logic"]
+> TVFloat{} -> evalPanic "logicBinary" ["Float not in class Logic"]
+> TVAbstract{} -> evalPanic "logicBinary" ["Abstract type not in `Logic`"]
+
+
+Ring Arithmetic
+---------------
+
+Ring primitives may be applied to any type that is made up of
+finite bitvectors or one of the numeric base types.
+On type `[n]`, arithmetic operators are strict in
+all input bits, as indicated by the definition of `fromVWord`. For
+example, `[error "foo", True] * 2` does not evaluate to `[True,
+False]`, but to `error "foo"`.
+
+> ringNullary ::
+> E Integer ->
+> E Rational ->
+> (Integer -> Integer -> E BigFloat) ->
+> TValue -> E Value
+> ringNullary i q fl = go
+> where
+> go :: TValue -> E Value
+> go ty =
+> case ty of
+> TVBit ->
+> evalPanic "arithNullary" ["Bit not in class Ring"]
+> TVInteger ->
+> VInteger <$> i
+> TVIntMod n ->
+> VInteger . flip mod n <$> i
+> TVRational ->
+> VRational <$> q
+> TVFloat e p ->
+> VFloat . fpToBF e p <$> fl e p
+> TVArray{} ->
+> evalPanic "arithNullary" ["Array not in class Ring"]
+> TVSeq w a
+> | isTBit a -> vWord w <$> i
+> | otherwise -> pure $ VList (Nat w) (genericReplicate w (go a))
+> TVStream a ->
+> pure $ VList Inf (repeat (go a))
+> TVFun _ ety ->
+> pure $ VFun (const (go ety))
+> TVTuple tys ->
+> pure $ VTuple (map go tys)
+> TVRec fs ->
+> pure $ VRecord [ (f, go fty) | (f, fty) <- canonicalFields fs ]
+> TVAbstract {} ->
+> evalPanic "arithNullary" ["Abstract type not in `Ring`"]
+
+> ringUnary ::
+> (Integer -> E Integer) ->
+> (Rational -> E Rational) ->
+> (Integer -> Integer -> BigFloat -> E BigFloat) ->
+> TValue -> E Value -> E Value
+> ringUnary iop qop flop = go
+> where
+> go :: TValue -> E Value -> E Value
+> go ty val =
+> case ty of
+> TVBit ->
+> evalPanic "arithUnary" ["Bit not in class Ring"]
+> TVInteger ->
+> VInteger <$> appOp1 iop (fromVInteger <$> val)
+> TVArray{} ->
+> evalPanic "arithUnary" ["Array not in class Ring"]
+> TVIntMod n ->
+> VInteger <$> appOp1 (\i -> flip mod n <$> iop i) (fromVInteger <$> val)
+> TVRational ->
+> VRational <$> appOp1 qop (fromVRational <$> val)
+> TVFloat e p ->
+> VFloat . fpToBF e p <$> appOp1 (flop e p) (fromVFloat <$> val)
+> TVSeq w a
+> | isTBit a -> vWord w <$> (iop =<< (fromVWord =<< val))
+> | otherwise -> VList (Nat w) . map (go a) . fromVList <$> val
+> TVStream a ->
+> VList Inf . map (go a) . fromVList <$> val
+> TVFun _ ety ->
+> pure $ VFun (\x -> go ety (appFun val x))
+> TVTuple tys ->
+> VTuple . zipWith go tys . fromVTuple <$> val
+> TVRec fs ->
+> do val' <- val
+> pure $ VRecord [ (f, go fty (lookupRecord f val'))
+> | (f, fty) <- canonicalFields fs ]
+> TVAbstract {} ->
+> evalPanic "arithUnary" ["Abstract type not in `Ring`"]
+
+> ringBinary ::
+> (Integer -> Integer -> E Integer) ->
+> (Rational -> Rational -> E Rational) ->
+> (Integer -> Integer -> BigFloat -> BigFloat -> E BigFloat) ->
+> TValue -> E Value -> E Value -> E Value
+> ringBinary iop qop flop = go
+> where
+> go :: TValue -> E Value -> E Value -> E Value
+> go ty l r =
+> case ty of
+> TVBit ->
+> evalPanic "arithBinary" ["Bit not in class Ring"]
+> TVInteger ->
+> VInteger <$> appOp2 iop (fromVInteger <$> l) (fromVInteger <$> r)
+> TVIntMod n ->
+> VInteger <$> appOp2 (\i j -> flip mod n <$> iop i j) (fromVInteger <$> l) (fromVInteger <$> r)
+> TVRational ->
+> VRational <$> appOp2 qop (fromVRational <$> l) (fromVRational <$> r)
+> TVFloat e p ->
+> VFloat . fpToBF e p <$>
+> appOp2 (flop e p) (fromVFloat <$> l) (fromVFloat <$> r)
+> TVArray{} ->
+> evalPanic "arithBinary" ["Array not in class Ring"]
+> TVSeq w a
+> | isTBit a -> vWord w <$> appOp2 iop (fromVWord =<< l) (fromVWord =<< r)
+> | otherwise ->
+> VList (Nat w) <$> (zipWith (go a) <$>
+> (fromVList <$> l) <*>
+> (fromVList <$> r))
+> TVStream a ->
+> VList Inf <$> (zipWith (go a) <$>
+> (fromVList <$> l) <*>
+> (fromVList <$> r))
+> TVFun _ ety ->
+> pure $ VFun (\x -> go ety (appFun l x) (appFun r x))
+> TVTuple tys ->
+> VTuple <$> (zipWith3 go tys <$>
+> (fromVTuple <$> l) <*>
+> (fromVTuple <$> r))
+> TVRec fs ->
+> do l' <- l
+> r' <- r
+> pure $ VRecord
+> [ (f, go fty (lookupRecord f l') (lookupRecord f r'))
+> | (f, fty) <- canonicalFields fs ]
+> TVAbstract {} ->
+> evalPanic "arithBinary" ["Abstract type not in class `Ring`"]
+
+
+Integral
+---------
+
+> cryToInteger :: TValue -> E Value -> E Integer
+> cryToInteger ty v = case ty of
+> TVInteger -> fromVInteger <$> v
+> TVSeq _ a | isTBit a -> fromVWord =<< v
+> _ -> evalPanic "toInteger" [show ty ++ " is not an integral type"]
+>
+> integralBinary ::
+> (Integer -> Integer -> E Integer) ->
+> TValue -> E Value -> E Value -> E Value
+> integralBinary op ty x y = case ty of
+> TVInteger ->
+> VInteger <$> appOp2 op (fromVInteger <$> x) (fromVInteger <$> y)
+> TVSeq w a | isTBit a ->
+> vWord w <$> appOp2 op (fromVWord =<< x) (fromVWord =<< y)
+>
+> _ -> evalPanic "integralBinary" [show ty ++ " is not an integral type"]
+>
+> ringExp :: TValue -> E Value -> Integer -> E Value
+> ringExp a v i = foldl (ringMul a) (literal 1 a) (genericReplicate i v)
+>
+> ringMul :: TValue -> E Value -> E Value -> E Value
+> ringMul = ringBinary (\x y -> pure (x * y))
+> (\x y -> pure (x * y))
+> (fpBin FP.bfMul fpImplicitRound)
+
+
+Signed bitvector division (`/$`) and remainder (`%$`) are defined so
+that division rounds toward zero, and the remainder `x %$ y` has the
+same sign as `x`. Accordingly, they are implemented with Haskell's
+`quot` and `rem` operations.
+
+> divWrap :: Integer -> Integer -> E Integer
+> divWrap _ 0 = cryError DivideByZero
+> divWrap x y = pure (x `quot` y)
+>
+> modWrap :: Integer -> Integer -> E Integer
+> modWrap _ 0 = cryError DivideByZero
+> modWrap x y = pure (x `rem` y)
+>
+> lg2Wrap :: Integer -> E Integer
+> lg2Wrap x = if x < 0 then cryError LogNegative else pure (lg2 x)
+
+
+Field
+-----
+
+Types that represent fields have, in addition to the ring operations,
+a reciprocal operator and a field division operator (not to be
+confused with integral division).
+
+> fieldUnary :: (Rational -> E Rational) ->
+> (Integer -> Integer -> E Integer) ->
+> (Integer -> Integer -> BigFloat -> E BigFloat) ->
+> TValue -> E Value -> E Value
+> fieldUnary qop zop flop ty v = case ty of
+> TVRational -> VRational <$> appOp1 qop (fromVRational <$> v)
+> TVIntMod m -> VInteger <$> appOp1 (zop m) (fromVInteger <$> v)
+> TVFloat e p -> VFloat . fpToBF e p <$> appOp1 (flop e p) (fromVFloat <$> v)
+> _ -> evalPanic "fieldUnary" [show ty ++ " is not a Field type"]
+>
+> fieldBinary ::
+> (Rational -> Rational -> E Rational) ->
+> (Integer -> Integer -> Integer -> E Integer) ->
+> (Integer -> Integer -> BigFloat -> BigFloat -> E BigFloat) ->
+> TValue -> E Value -> E Value -> E Value
+> fieldBinary qop zop flop ty l r = case ty of
+> TVRational -> VRational <$>
+> appOp2 qop (fromVRational <$> l) (fromVRational <$> r)
+> TVIntMod m -> VInteger <$>
+> appOp2 (zop m) (fromVInteger <$> l) (fromVInteger <$> r)
+> TVFloat e p -> VFloat . fpToBF e p <$>
+> appOp2 (flop e p) (fromVFloat <$> l) (fromVFloat <$> r)
+> _ -> evalPanic "fieldBinary" [show ty ++ " is not a Field type"]
+>
+> ratDiv :: Rational -> Rational -> E Rational
+> ratDiv _ 0 = cryError DivideByZero
+> ratDiv x y = pure (x / y)
+>
+> ratRecip :: Rational -> E Rational
+> ratRecip 0 = cryError DivideByZero
+> ratRecip x = pure (recip x)
+>
+> zRecip :: Integer -> Integer -> E Integer
+> zRecip m x = if r == 0 then cryError DivideByZero else pure r
+> where r = Integer.recipModInteger x m
+>
+> zDiv :: Integer -> Integer -> Integer -> E Integer
+> zDiv m x y = f <$> zRecip m y
+> where f yinv = (x * yinv) `mod` m
+
+Round
+-----
+
+> roundUnary :: (Rational -> Integer) ->
+> (BF -> E Integer) ->
+> TValue -> E Value -> E Value
+> roundUnary op flop ty v = case ty of
+> TVRational -> VInteger . op . fromVRational <$> v
+> TVFloat {} -> VInteger <$> (flop . fromVFloat' =<< v)
+> _ -> evalPanic "roundUnary" [show ty ++ " is not a Round type"]
+>
+
+Haskell's definition of "round" is slightly different, as it does
+"round to even" on ties.
+
+> roundAwayRat :: Rational -> Integer
+> roundAwayRat x
+> | x >= 0 = floor (x + 0.5)
+> | otherwise = ceiling (x - 0.5)
+
+
+Rational
+----------
+
+> ratioOp :: Integer -> Integer -> E Rational
+> ratioOp _ 0 = cryError DivideByZero
+> ratioOp x y = pure (fromInteger x / fromInteger y)
+
+
+Comparison
+----------
+
+Comparison primitives may be applied to any type that is constructed of
+out of base types and tuples, records and finite sequences.
+All such types are compared using a lexicographic ordering of components.
+On bits, we have `False` < `True`. Sequences and
+tuples are compared left-to-right, and record fields are compared in
+alphabetical order.
+
+Comparisons on base types are strict in both arguments. Comparisons on
+larger types have short-circuiting behavior: A comparison involving an
+error/undefined element will only yield an error if all corresponding
+bits to the *left* of that position are equal.
+
+> -- | Process two elements based on their lexicographic ordering.
+> cmpOrder :: (Ordering -> Bool) -> TValue -> E Value -> E Value -> E Value
+> cmpOrder p ty l r = VBit . p <$> lexCompare ty l r
+>
+> -- | Lexicographic ordering on two values.
+> lexCompare :: TValue -> E Value -> E Value -> E Ordering
+> lexCompare ty l r =
+> case ty of
+> TVBit ->
+> compare <$> (fromVBit <$> l) <*> (fromVBit <$> r)
+> TVInteger ->
+> compare <$> (fromVInteger <$> l) <*> (fromVInteger <$> r)
+> TVIntMod _ ->
+> compare <$> (fromVInteger <$> l) <*> (fromVInteger <$> r)
+> TVRational ->
+> compare <$> (fromVRational <$> l) <*> (fromVRational <$> r)
+> TVFloat{} ->
+> compare <$> (fromVFloat <$> l) <*> (fromVFloat <$> r)
+> TVArray{} ->
+> evalPanic "lexCompare" ["invalid type"]
+> TVSeq _w ety ->
+> lexList =<< (zipWith (lexCompare ety) <$>
+> (fromVList <$> l) <*> (fromVList <$> r))
+> TVStream _ ->
+> evalPanic "lexCompare" ["invalid type"]
+> TVFun _ _ ->
+> evalPanic "lexCompare" ["invalid type"]
+> TVTuple etys ->
+> lexList =<< (zipWith3 lexCompare etys <$>
+> (fromVTuple <$> l) <*> (fromVTuple <$> r))
+> TVRec fields ->
+> do let tys = map snd (canonicalFields fields)
+> ls <- map snd . sortBy (comparing fst) . fromVRecord <$> l
+> rs <- map snd . sortBy (comparing fst) . fromVRecord <$> r
+> lexList (zipWith3 lexCompare tys ls rs)
+> TVAbstract {} ->
+> evalPanic "lexCompare" ["Abstract type not in `Cmp`"]
+>
+> lexList :: [E Ordering] -> E Ordering
+> lexList [] = pure EQ
+> lexList (e : es) =
+> e >>= \case
+> LT -> pure LT
+> EQ -> lexList es
+> GT -> pure GT
+
+Signed comparisons may be applied to any type made up of non-empty
+bitvectors using finite sequences, tuples and records.
+All such types are compared using a lexicographic
+ordering: Lists and tuples are compared left-to-right, and record
+fields are compared in alphabetical order.
+
+> signedLessThan :: TValue -> E Value -> E Value -> E Value
+> signedLessThan ty l r = VBit . (== LT) <$> (lexSignedCompare ty l r)
+>
+> -- | Lexicographic ordering on two signed values.
+> lexSignedCompare :: TValue -> E Value -> E Value -> E Ordering
+> lexSignedCompare ty l r =
+> case ty of
+> TVBit ->
+> evalPanic "lexSignedCompare" ["invalid type"]
+> TVInteger ->
+> evalPanic "lexSignedCompare" ["invalid type"]
+> TVIntMod _ ->
+> evalPanic "lexSignedCompare" ["invalid type"]
+> TVRational ->
+> evalPanic "lexSignedCompare" ["invalid type"]
+> TVFloat{} ->
+> evalPanic "lexSignedCompare" ["invalid type"]
+> TVArray{} ->
+> evalPanic "lexSignedCompare" ["invalid type"]
+> TVSeq _w ety
+> | isTBit ety ->
+> compare <$> (fromSignedVWord =<< l) <*> (fromSignedVWord =<< r)
+> | otherwise ->
+> lexList =<< (zipWith (lexSignedCompare ety) <$>
+> (fromVList <$> l) <*> (fromVList <$> r))
+> TVStream _ ->
+> evalPanic "lexSignedCompare" ["invalid type"]
+> TVFun _ _ ->
+> evalPanic "lexSignedCompare" ["invalid type"]
+> TVTuple etys ->
+> lexList =<< (zipWith3 lexSignedCompare etys <$>
+> (fromVTuple <$> l) <*> (fromVTuple <$> r))
+> TVRec fields ->
+> do let tys = map snd (canonicalFields fields)
+> ls <- map snd . sortBy (comparing fst) . fromVRecord <$> l
+> rs <- map snd . sortBy (comparing fst) . fromVRecord <$> r
+> lexList (zipWith3 lexSignedCompare tys ls rs)
+> TVAbstract {} ->
+> evalPanic "lexSignedCompare" ["Abstract type not in `Cmp`"]
+
+
+Sequences
+---------
+
+> generateV :: Nat' -> (Integer -> E Value) -> Value
+> generateV len f = VList len [ f i | i <- idxs ]
+> where
+> idxs = case len of
+> Inf -> [ 0 .. ]
+> Nat n -> [ 0 .. n-1 ]
+
+
+Shifting
+--------
+
+Shift and rotate operations are strict in all bits of the shift/rotate
+amount, but as lazy as possible in the list values.
+
+> shiftV :: (Nat' -> TValue -> E Value -> Integer -> Value) -> Value
+> shiftV op =
+> VNumPoly $ \n -> pure $
+> VPoly $ \ix -> pure $
+> VPoly $ \a -> pure $
+> VFun $ \v -> pure $
+> VFun $ \x ->
+> do i <- cryToInteger ix x
+> pure $ op n a v i
+>
+> shiftLV :: Nat' -> TValue -> E Value -> Integer -> Value
+> shiftLV w a v amt =
+> case w of
+> Inf -> generateV Inf $ \i ->
+> do vs <- fromVList <$> v
+> indexFront Inf vs (i + amt)
+> Nat n -> generateV (Nat n) $ \i ->
+> if i + amt < n then
+> do vs <- fromVList <$> v
+> indexFront (Nat n) vs (i + amt)
+> else
+> pure (zero a)
+>
+> shiftRV :: Nat' -> TValue -> E Value -> Integer -> Value
+> shiftRV w a v amt =
+> generateV w $ \i ->
+> if i < amt then
+> pure (zero a)
+> else
+> do vs <- fromVList <$> v
+> indexFront w vs (i - amt)
+>
+> rotateV :: (Integer -> E Value -> Integer -> E Value) -> Value
+> rotateV op =
+> vFinPoly $ \n -> pure $
+> VPoly $ \ix -> pure $
+> VPoly $ \_a -> pure $
+> VFun $ \v -> pure $
+> VFun $ \x ->
+> do i <- cryToInteger ix x
+> op n v i
+>
+> rotateLV :: Integer -> E Value -> Integer -> E Value
+> rotateLV 0 v _ = v
+> rotateLV w v amt =
+> pure $ generateV (Nat w) $ \i ->
+> do vs <- fromVList <$> v
+> indexFront (Nat w) vs ((i + amt) `mod` w)
+>
+> rotateRV :: Integer -> E Value -> Integer -> E Value
+> rotateRV 0 v _ = v
+> rotateRV w v amt =
+> pure $ generateV (Nat w) $ \i ->
+> do vs <- fromVList <$> v
+> indexFront (Nat w) vs ((i - amt) `mod` w)
+>
+> signedShiftRV :: Value
+> signedShiftRV =
+> VNumPoly $ \(Nat n) -> pure $
+> VPoly $ \ix -> pure $
+> VFun $ \v -> pure $
+> VFun $ \x ->
+> do amt <- cryToInteger ix x
+> pure $ generateV (Nat n) $ \i ->
+> do vs <- fromVList <$> v
+> if i < amt then
+> indexFront (Nat n) vs 0
+> else
+> indexFront (Nat n) vs (i - amt)
+
+Indexing
+--------
+
+Indexing and update operations are strict in all index bits, but as lazy as
+possible in the list values. An index greater than or equal to the
+length of the list produces a run-time error.
+
+> -- | Indexing operations that return one element.
+> indexPrimOne :: (Nat' -> [E Value] -> Integer -> E Value) -> Value
+> indexPrimOne op =
+> VNumPoly $ \n -> pure $
+> VPoly $ \_a -> pure $
+> VPoly $ \ix -> pure $
+> VFun $ \l -> pure $
+> VFun $ \r ->
+> do vs <- fromVList <$> l
+> i <- cryToInteger ix r
+> op n vs i
+>
+> indexFront :: Nat' -> [E Value] -> Integer -> E Value
+> indexFront w vs ix =
+> case w of
+> Nat n | 0 <= ix && ix < n -> genericIndex vs ix
+> Inf | 0 <= ix -> genericIndex vs ix
+> _ -> cryError (InvalidIndex (Just ix))
+>
+> indexBack :: Nat' -> [E Value] -> Integer -> E Value
+> indexBack w vs ix =
+> case w of
+> Nat n | 0 <= ix && ix < n -> genericIndex vs (n - ix - 1)
+> | otherwise -> cryError (InvalidIndex (Just ix))
+> Inf -> evalPanic "indexBack" ["unexpected infinite sequence"]
+>
+> updatePrim :: (Nat' -> Integer -> Integer) -> Value
+> updatePrim op =
+> VNumPoly $ \len -> pure $
+> VPoly $ \_eltTy -> pure $
+> VPoly $ \ix -> pure $
+> VFun $ \xs -> pure $
+> VFun $ \idx -> pure $
+> VFun $ \val ->
+> do j <- cryToInteger ix idx
+> if Nat j < len then
+> pure $ generateV len $ \i ->
+> if i == op len j then
+> val
+> else
+> do xs' <- fromVList <$> xs
+> indexFront len xs' i
+> else
+> cryError (InvalidIndex (Just j))
+>
+> updateFront :: Nat' -> Integer -> Integer
+> updateFront _ j = j
+>
+> updateBack :: Nat' -> Integer -> Integer
+> updateBack Inf _j = evalPanic "Unexpected infinite sequence in updateEnd" []
+> updateBack (Nat n) j = n - j - 1
+
+Floating Point Numbers
+----------------------
+
+Whenever we do operations that do not have an explicit rounding mode,
+we round towards the closest number, with ties resolved to the even one.
+
+> fpImplicitRound :: FP.RoundMode
+> fpImplicitRound = FP.NearEven
+
+We annotate floating point values with their precision. This is only used
+when pretty printing values.
+
+> fpToBF :: Integer -> Integer -> BigFloat -> BF
+> fpToBF e p x = BF { bfValue = x, bfExpWidth = e, bfPrecWidth = p }
+
+
+The following two functions convert between floaitng point numbers
+and integers.
+
+> fpFromInteger :: Integer -> Integer -> Integer -> BigFloat
+> fpFromInteger e p = FP.fpCheckStatus . FP.bfRoundFloat opts . FP.bfFromInteger
+> where opts = FP.fpOpts e p fpImplicitRound
+
+These functions capture the interactions with rationals.
+
+
+This just captures a common pattern for binary floating point primitives.
+
+> fpBin :: (FP.BFOpts -> BigFloat -> BigFloat -> (BigFloat,FP.Status)) ->
+> FP.RoundMode -> Integer -> Integer ->
+> BigFloat -> BigFloat -> E BigFloat
+> fpBin f r e p x y = pure (FP.fpCheckStatus (f (FP.fpOpts e p r) x y))
+
+
+Computes the reciprocal of a floating point number via division.
+This assumes that 1 can be represented exactly, which should be
+true for all supported precisions.
+
+> fpRecip :: Integer -> Integer -> BigFloat -> E BigFloat
+> fpRecip e p x = pure (FP.fpCheckStatus (FP.bfDiv opts (FP.bfFromInteger 1) x))
+> where opts = FP.fpOpts e p fpImplicitRound
+
+
+> floatPrimTable :: Map PrimIdent Value
+> floatPrimTable = Map.fromList $ map (\(n, v) -> (floatPrim (T.pack n), v))
+> [ "fpNaN" ~> vFinPoly \e -> pure $
+> vFinPoly \p ->
+> pure $ VFloat $ fpToBF e p FP.bfNaN
+>
+> , "fpPosInf" ~> vFinPoly \e -> pure $
+> vFinPoly \p ->
+> pure $ VFloat $ fpToBF e p FP.bfPosInf
+>
+> , "fpFromBits" ~> vFinPoly \e -> pure $
+> vFinPoly \p -> pure $
+> VFun \bvv ->
+> VFloat . FP.floatFromBits e p <$> (fromVWord =<< bvv)
+>
+> , "fpToBits" ~> vFinPoly \e -> pure $
+> vFinPoly \p -> pure $
+> VFun \fpv ->
+> vWord (e + p) . FP.floatToBits e p . fromVFloat <$> fpv
+>
+> , "=.=" ~> vFinPoly \_ -> pure $
+> vFinPoly \_ -> pure $
+> VFun \xv -> pure $
+> VFun \yv ->
+> do x <- fromVFloat <$> xv
+> y <- fromVFloat <$> yv
+> pure (VBit (FP.bfCompare x y == EQ))
+>
+> , "fpIsFinite" ~> vFinPoly \_ -> pure $
+> vFinPoly \_ -> pure $
+> VFun \xv ->
+> do x <- fromVFloat <$> xv
+> pure (VBit (FP.bfIsFinite x))
+>
+> , "fpAdd" ~> fpArith FP.bfAdd
+> , "fpSub" ~> fpArith FP.bfSub
+> , "fpMul" ~> fpArith FP.bfMul
+> , "fpDiv" ~> fpArith FP.bfDiv
+>
+> , "fpToRational" ~>
+> vFinPoly \_ -> pure $
+> vFinPoly \_ -> pure $
+> VFun \fpv ->
+> do fp <- fromVFloat' <$> fpv
+> VRational <$> (eitherToE (FP.floatToRational "fpToRational" fp))
+> , "fpFromRational" ~>
+> vFinPoly \e -> pure $
+> vFinPoly \p -> pure $
+> VFun \rmv -> pure $
+> VFun \rv ->
+> do rm <- fromVWord =<< rmv
+> rm' <- eitherToE (FP.fpRound rm)
+> rat <- fromVRational <$> rv
+> pure (VFloat (FP.floatFromRational e p rm' rat))
+> ]
+> where
+> fpArith f = vFinPoly \e -> pure $
+> vFinPoly \p -> pure $
+> VFun \vr -> pure $
+> VFun \xv -> pure $
+> VFun \yv ->
+> do r <- fromVWord =<< vr
+> rnd <- eitherToE (FP.fpRound r)
+> x <- fromVFloat <$> xv
+> y <- fromVFloat <$> yv
+> VFloat . fpToBF e p <$> fpBin f rnd e p x y
+
+
+Error Handling
+--------------
+
+The `evalPanic` function is only called if an internal data invariant
+is violated, such as an expression that is not well-typed. Panics
+should (hopefully) never occur in practice; a panic message indicates
+a bug in Cryptol.
+
+> evalPanic :: String -> [String] -> a
+> evalPanic cxt = panic ("[Reference Evaluator]" ++ cxt)
+
+Pretty Printing
+---------------
+
+> ppEValue :: PPOpts -> E Value -> Doc
+> ppEValue _opts (Err e) = text (show e)
+> ppEValue opts (Value v) = ppValue opts v
+>
+> ppValue :: PPOpts -> Value -> Doc
+> ppValue opts val =
+> case val of
+> VBit b -> text (show b)
+> VInteger i -> text (show i)
+> VRational q -> text (show q)
+> VFloat fl -> text (show (FP.fpPP opts fl))
+> VList l vs ->
+> case l of
+> Inf -> ppList (map (ppEValue opts)
+> (take (useInfLength opts) vs) ++ [text "..."])
+> Nat n ->
+> -- For lists of defined bits, print the value as a numeral.
+> case traverse isBit vs of
+> Just bs -> ppBV opts (mkBv n (bitsToInteger bs))
+> Nothing -> ppList (map (ppEValue opts) vs)
+> where ppList docs = brackets (fsep (punctuate comma docs))
+> isBit v = case v of Value (VBit b) -> Just b
+> _ -> Nothing
+> VTuple vs -> parens (sep (punctuate comma (map (ppEValue opts) vs)))
+> VRecord fs -> braces (sep (punctuate comma (map ppField fs)))
+> where ppField (f,r) = pp f <+> char '=' <+> ppEValue opts r
+> VFun _ -> text ""
+> VPoly _ -> text ""
+> VNumPoly _ -> text ""
+
+Module Command
+--------------
+
+This module implements the core functionality of the `:eval
+` command for the Cryptol REPL, which prints the result of
+running the reference evaluator on an expression.
+
+> evaluate :: Expr -> M.ModuleCmd (E Value)
> evaluate expr (_, _, modEnv) = return (Right (evalExpr env expr, modEnv), [])
> where
> extDgs = concatMap mDecls (M.loadedModules modEnv)
diff --git a/src/Cryptol/Eval/SBV.hs b/src/Cryptol/Eval/SBV.hs
--- a/src/Cryptol/Eval/SBV.hs
+++ b/src/Cryptol/Eval/SBV.hs
@@ -11,357 +11,43 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE ViewPatterns #-}
module Cryptol.Eval.SBV
- ( SBV(..), Value
- , SBVEval(..), SBVResult(..)
- , evalPrim
- , forallBV_, existsBV_
- , forallSBool_, existsSBool_
- , forallSInteger_, existsSInteger_
+ ( primTable
) where
import qualified Control.Exception as X
import Control.Monad (join)
import Control.Monad.IO.Class (MonadIO(..))
-import Data.Bits (bit, complement, shiftL)
-import Data.List (foldl')
+import Data.Bits (bit, shiftL)
import qualified Data.Map as Map
import qualified Data.Text as T
-import Data.SBV (symbolicEnv)
import Data.SBV.Dynamic as SBV
+import Cryptol.Backend
+import Cryptol.Backend.Monad ( EvalError(..), Unsupported(..) )
+import Cryptol.Backend.SBV
+
import Cryptol.Eval.Type (TValue(..), finNat')
-import Cryptol.Eval.Backend
import Cryptol.Eval.Generic
-import Cryptol.Eval.Monad
- ( Eval(..), blackhole, delayFill, evalSpark
- , EvalError(..), Unsupported(..)
- )
import Cryptol.Eval.Value
-import Cryptol.Eval.Concrete ( integerToChar, ppBV, BV(..) )
-import Cryptol.Testing.Random( randomV )
import Cryptol.TypeCheck.Solver.InfNat (Nat'(..), widthInteger)
import Cryptol.Utils.Ident
-import Cryptol.Utils.Panic (panic)
-import Cryptol.Utils.PP
-data SBV = SBV
-
--- Utility operations -------------------------------------------------------------
-
-fromBitsLE :: [SBit SBV] -> SWord SBV
-fromBitsLE bs = foldl' f (literalSWord 0 0) bs
- where f w b = svJoin (svToWord1 b) w
-
-packSBV :: [SBit SBV] -> SWord SBV
-packSBV bs = fromBitsLE (reverse bs)
-
-unpackSBV :: SWord SBV -> [SBit SBV]
-unpackSBV x = [ svTestBit x i | i <- reverse [0 .. intSizeOf x - 1] ]
-
-literalSWord :: Int -> Integer -> SWord SBV
-literalSWord w i = svInteger (KBounded False w) i
-
-forallBV_ :: Int -> Symbolic (SWord SBV)
-forallBV_ w = symbolicEnv >>= liftIO . svMkSymVar (Just ALL) (KBounded False w) Nothing
-
-existsBV_ :: Int -> Symbolic (SWord SBV)
-existsBV_ w = symbolicEnv >>= liftIO . svMkSymVar (Just EX) (KBounded False w) Nothing
-
-forallSBool_ :: Symbolic (SBit SBV)
-forallSBool_ = symbolicEnv >>= liftIO . svMkSymVar (Just ALL) KBool Nothing
-
-existsSBool_ :: Symbolic (SBit SBV)
-existsSBool_ = symbolicEnv >>= liftIO . svMkSymVar (Just EX) KBool Nothing
-
-forallSInteger_ :: Symbolic (SBit SBV)
-forallSInteger_ = symbolicEnv >>= liftIO . svMkSymVar (Just ALL) KUnbounded Nothing
-
-existsSInteger_ :: Symbolic (SBit SBV)
-existsSInteger_ = symbolicEnv >>= liftIO . svMkSymVar (Just EX) KUnbounded Nothing
-
-- Values ----------------------------------------------------------------------
type Value = GenValue SBV
--- SBV Evaluation monad -------------------------------------------------------
-
-data SBVResult a
- = SBVError !EvalError
- | SBVResult !SVal !a -- safety predicate and result
-
-instance Functor SBVResult where
- fmap _ (SBVError err) = SBVError err
- fmap f (SBVResult p x) = SBVResult p (f x)
-
-instance Applicative SBVResult where
- pure = SBVResult svTrue
- SBVError err <*> _ = SBVError err
- _ <*> SBVError err = SBVError err
- SBVResult p1 f <*> SBVResult p2 x = SBVResult (svAnd p1 p2) (f x)
-
-instance Monad SBVResult where
- return = pure
- SBVError err >>= _ = SBVError err
- SBVResult px x >>= m =
- case m x of
- SBVError err -> SBVError err
- SBVResult pm z -> SBVResult (svAnd px pm) z
-
-newtype SBVEval a = SBVEval{ sbvEval :: Eval (SBVResult a) }
- deriving (Functor)
-
-instance Applicative SBVEval where
- pure = SBVEval . pure . pure
- f <*> x = SBVEval $
- do f' <- sbvEval f
- x' <- sbvEval x
- pure (f' <*> x')
-
-instance Monad SBVEval where
- return = pure
- x >>= f = SBVEval $
- sbvEval x >>= \case
- SBVError err -> pure (SBVError err)
- SBVResult px x' ->
- sbvEval (f x') >>= \case
- SBVError err -> pure (SBVError err)
- SBVResult pz z -> pure (SBVResult (svAnd px pz) z)
-
-instance MonadIO SBVEval where
- liftIO m = SBVEval $ fmap pure (liftIO m)
-
-
--- Symbolic Big-endian Words -------------------------------------------------------
-
-instance Backend SBV where
- type SBit SBV = SVal
- type SWord SBV = SVal
- type SInteger SBV = SVal
- type SFloat SBV = () -- XXX: not implemented
- type SEval SBV = SBVEval
-
- raiseError _ err = SBVEval (pure (SBVError err))
-
- assertSideCondition _ cond err
- | Just False <- svAsBool cond = SBVEval (pure (SBVError err))
- | otherwise = SBVEval (pure (SBVResult cond ()))
-
- isReady _ (SBVEval (Ready _)) = True
- isReady _ _ = False
-
- sDelayFill _ m retry = SBVEval $
- do m' <- delayFill (sbvEval m) (sbvEval retry)
- pure (pure (SBVEval m'))
-
- sSpark _ m = SBVEval $
- do m' <- evalSpark (sbvEval m)
- pure (pure (SBVEval m'))
-
- sDeclareHole _ msg = SBVEval $
- do (hole, fill) <- blackhole msg
- pure (pure (SBVEval hole, \m -> SBVEval (fmap pure $ fill (sbvEval m))))
-
- mergeEval _sym f c mx my = SBVEval $
- do rx <- sbvEval mx
- ry <- sbvEval my
- case (rx, ry) of
- (SBVError err, SBVError _) ->
- pure $ SBVError err -- arbitrarily choose left error to report
- (SBVError _, SBVResult p y) ->
- pure $ SBVResult (svAnd (svNot c) p) y
- (SBVResult p x, SBVError _) ->
- pure $ SBVResult (svAnd c p) x
- (SBVResult px x, SBVResult py y) ->
- do zr <- sbvEval (f c x y)
- case zr of
- SBVError err -> pure $ SBVError err
- SBVResult pz z ->
- pure $ SBVResult (svAnd (svIte c px py) pz) z
-
- 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 SBV v) x)
- | otherwise = text "[?]"
- ppInteger _ _opts v
- | Just x <- svAsInteger v = integer x
- | otherwise = text "[?]"
-
- iteBit _ b x y = pure $! svSymbolicMerge KBool True b x y
- iteWord _ b x y = pure $! svSymbolicMerge (kindOf x) True b x y
- iteInteger _ b x y = pure $! svSymbolicMerge KUnbounded True b x y
-
- bitAsLit _ b = svAsBool b
- wordAsLit _ w =
- case svAsInteger w of
- Just x -> Just (toInteger (intSizeOf w), x)
- Nothing -> Nothing
- integerAsLit _ v = svAsInteger v
-
- bitLit _ b = svBool b
- wordLit _ n x = pure $! literalSWord (fromInteger n) x
- integerLit _ x = pure $! svInteger KUnbounded x
-
- bitEq _ x y = pure $! svEqual x y
- bitOr _ x y = pure $! svOr x y
- bitAnd _ x y = pure $! svAnd x y
- bitXor _ x y = pure $! svXOr x y
- bitComplement _ x = pure $! svNot x
-
- wordBit _ x idx = pure $! svTestBit x (intSizeOf x - 1 - fromInteger idx)
-
- wordUpdate _ x idx b = pure $! svSymbolicMerge (kindOf x) False b wtrue wfalse
- where
- i' = intSizeOf x - 1 - fromInteger idx
- wtrue = x `svOr` svInteger (kindOf x) (bit i' :: Integer)
- wfalse = x `svAnd` svInteger (kindOf x) (complement (bit i' :: Integer))
-
- packWord _ bs = pure $! packSBV bs
- unpackWord _ x = pure $! unpackSBV x
-
- wordEq _ x y = pure $! svEqual x y
- wordLessThan _ x y = pure $! svLessThan x y
- wordGreaterThan _ x y = pure $! svGreaterThan x y
-
- wordSignedLessThan _ x y = pure $! svLessThan sx sy
- where sx = svSign x
- sy = svSign y
-
- joinWord _ x y = pure $! svJoin x y
-
- splitWord _ _leftW rightW w = pure
- ( svExtract (intSizeOf w - 1) (fromInteger rightW) w
- , svExtract (fromInteger rightW - 1) 0 w
- )
-
- extractWord _ len start w =
- pure $! svExtract (fromInteger start + fromInteger len - 1) (fromInteger start) w
-
- wordAnd _ a b = pure $! svAnd a b
- wordOr _ a b = pure $! svOr a b
- wordXor _ a b = pure $! svXOr a b
- wordComplement _ a = pure $! svNot a
-
- wordPlus _ a b = pure $! svPlus a b
- wordMinus _ a b = pure $! svMinus a b
- wordMult _ a b = pure $! svTimes a b
- wordNegate _ a = pure $! svUNeg a
-
- wordDiv sym a b =
- do let z = literalSWord (intSizeOf b) 0
- assertSideCondition sym (svNot (svEqual b z)) DivideByZero
- pure $! svQuot a b
-
- wordMod sym a b =
- do let z = literalSWord (intSizeOf b) 0
- assertSideCondition sym (svNot (svEqual b z)) DivideByZero
- pure $! svRem a b
-
- wordSignedDiv sym a b =
- do let z = literalSWord (intSizeOf b) 0
- assertSideCondition sym (svNot (svEqual b z)) DivideByZero
- pure $! signedQuot a b
-
- wordSignedMod sym a b =
- do let z = literalSWord (intSizeOf b) 0
- assertSideCondition sym (svNot (svEqual b z)) DivideByZero
- pure $! signedRem a b
-
- wordLg2 _ a = sLg2 a
-
- wordToInt _ x = pure $! svToInteger x
- wordFromInt _ w i = pure $! svFromInteger w i
-
- intEq _ a b = pure $! svEqual a b
- intLessThan _ a b = pure $! svLessThan a b
- intGreaterThan _ a b = pure $! svGreaterThan a b
-
- intPlus _ a b = pure $! svPlus a b
- intMinus _ a b = pure $! svMinus a b
- intMult _ a b = pure $! svTimes a b
- intNegate _ a = pure $! SBV.svUNeg a
-
- intDiv sym a b =
- do let z = svInteger KUnbounded 0
- assertSideCondition sym (svNot (svEqual b z)) DivideByZero
- let p = svLessThan z b
- pure $! svSymbolicMerge KUnbounded True p (svQuot a b) (svQuot (svUNeg a) (svUNeg b))
- intMod sym a b =
- do let z = svInteger KUnbounded 0
- assertSideCondition sym (svNot (svEqual b z)) DivideByZero
- let p = svLessThan z b
- pure $! svSymbolicMerge KUnbounded True p (svRem a b) (svUNeg (svRem (svUNeg a) (svUNeg b)))
-
- -- NB, we don't do reduction here
- intToZn _ _m a = pure a
-
- znToInt _ 0 _ = evalPanic "znToInt" ["0 modulus not allowed"]
- znToInt _ m a =
- do let m' = svInteger KUnbounded m
- pure $! svRem a m'
-
- znEq _ 0 _ _ = evalPanic "znEq" ["0 modulus not allowed"]
- znEq _ m a b = svDivisible m (SBV.svMinus a b)
-
- znPlus _ m a b = sModAdd m a b
- znMinus _ m a b = sModSub m a b
- znMult _ m a b = sModMult m a b
- znNegate _ m a = sModNegate m a
-
- ppFloat _ _ _ = text "[?]"
- fpLit _ _ _ _ = unsupported "fpLit"
- fpEq _ _ _ = unsupported "fpEq"
- fpLessThan _ _ _ = unsupported "fpLessThan"
- fpGreaterThan _ _ _ = unsupported "fpGreaterThan"
- fpPlus _ _ _ _ = unsupported "fpPlus"
- fpMinus _ _ _ _ = unsupported "fpMinus"
- fpMult _ _ _ _ = unsupported "fpMult"
- fpDiv _ _ _ _ = unsupported "fpDiv"
- fpNeg _ _ = unsupported "fpNeg"
- fpFromInteger _ _ _ _ _ = unsupported "fpFromInteger"
- fpToInteger _ _ _ _ = unsupported "fpToInteger"
-
-unsupported :: String -> SEval SBV a
-unsupported x = liftIO (X.throw (UnsupportedSymbolicOp x))
-
-
-svToInteger :: SWord SBV -> SInteger SBV
-svToInteger w =
- case svAsInteger w of
- Nothing -> svFromIntegral KUnbounded w
- Just x -> svInteger KUnbounded x
-
-svFromInteger :: Integer -> SInteger SBV -> SWord SBV
-svFromInteger 0 _ = literalSWord 0 0
-svFromInteger n i =
- case svAsInteger i of
- Nothing -> svFromIntegral (KBounded False (fromInteger n)) i
- Just x -> literalSWord (fromInteger n) x
-
--- Errors ----------------------------------------------------------------------
-
-evalPanic :: String -> [String] -> a
-evalPanic cxt = panic ("[Symbolic]" ++ cxt)
-
-
-- Primitives ------------------------------------------------------------------
-evalPrim :: PrimIdent -> Maybe Value
-evalPrim prim = Map.lookup prim primTable
-
-- See also Cryptol.Eval.Concrete.primTable
-primTable :: Map.Map PrimIdent Value
-primTable = let sym = SBV in
+primTable :: SBV -> Map.Map PrimIdent Value
+primTable sym =
Map.fromList $ map (\(n, v) -> (prelPrim (T.pack n), v))
[ -- Literals
@@ -411,7 +97,7 @@
, ("/$" , sdivV sym)
, ("%$" , smodV sym)
, ("lg2" , lg2V sym)
- , (">>$" , sshrV)
+ , (">>$" , sshrV sym)
-- Cmp
, ("<" , binary (lessThanV sym))
@@ -487,16 +173,27 @@
rotateRightReindex rotateLeftReindex)
-- Indexing and updates
- , ("@" , indexPrim sym indexFront indexFront_bits indexFront)
- , ("!" , indexPrim sym indexBack indexBack_bits indexBack)
+ , ("@" , indexPrim sym (indexFront sym) (indexFront_bits sym) (indexFront sym))
+ , ("!" , indexPrim sym (indexBack sym) (indexBack_bits sym) (indexBack sym))
- , ("update" , updatePrim sym updateFrontSym_word updateFrontSym)
- , ("updateEnd" , updatePrim sym updateBackSym_word updateBackSym)
+ , ("update" , updatePrim sym (updateFrontSym_word sym) (updateFrontSym sym))
+ , ("updateEnd" , updatePrim sym (updateBackSym_word sym) (updateBackSym sym))
-- Misc
, ("fromZ" , fromZV sym)
+ , ("foldl" , foldlV sym)
+ , ("foldl'" , foldl'V sym)
+
+ , ("deepseq" ,
+ tlam $ \_a ->
+ tlam $ \_b ->
+ lam $ \x -> pure $
+ lam $ \y ->
+ do _ <- forceValue =<< x
+ y)
+
, ("parmap" , parmapV sym)
-- {at,len} (fin len) => [len][8] -> at
@@ -529,13 +226,14 @@
indexFront ::
+ SBV ->
Nat' ->
TValue ->
SeqMap SBV ->
TValue ->
SVal ->
SEval SBV Value
-indexFront mblen a xs _ix idx
+indexFront sym mblen a xs _ix idx
| Just i <- SBV.svAsInteger idx
= lookupSeqMap xs i
@@ -544,7 +242,7 @@
= do wvs <- traverse (fromWordVal "indexFront" =<<) (enumerateSeqMap n xs)
case asWordList wvs of
Just ws ->
- do z <- wordLit SBV wlen 0
+ do z <- wordLit sym wlen 0
return $ VWord wlen $ pure $ WordVal $ SBV.svSelect ws z idx
Nothing -> folded
@@ -553,8 +251,8 @@
where
k = SBV.kindOf idx
- def = zeroV SBV a
- f n y = iteValue SBV (SBV.svEqual idx (SBV.svInteger k n)) (lookupSeqMap xs n) y
+ def = zeroV sym a
+ f n y = iteValue sym (SBV.svEqual idx (SBV.svInteger k n)) (lookupSeqMap xs n) y
folded =
case k of
KBounded _ w ->
@@ -567,30 +265,32 @@
Inf -> liftIO (X.throw (UnsupportedSymbolicOp "unbounded integer indexing"))
indexBack ::
+ SBV ->
Nat' ->
TValue ->
SeqMap SBV ->
TValue ->
SWord SBV ->
SEval SBV Value
-indexBack (Nat n) a xs ix idx = indexFront (Nat n) a (reverseSeqMap n xs) ix idx
-indexBack Inf _ _ _ _ = evalPanic "Expected finite sequence" ["indexBack"]
+indexBack sym (Nat n) a xs ix idx = indexFront sym (Nat n) a (reverseSeqMap n xs) ix idx
+indexBack _ Inf _ _ _ _ = evalPanic "Expected finite sequence" ["indexBack"]
indexFront_bits ::
+ SBV ->
Nat' ->
TValue ->
SeqMap SBV ->
TValue ->
[SBit SBV] ->
SEval SBV Value
-indexFront_bits mblen _a xs _ix bits0 = go 0 (length bits0) bits0
+indexFront_bits sym mblen _a xs _ix bits0 = go 0 (length bits0) bits0
where
go :: Integer -> Int -> [SBit SBV] -> SEval SBV Value
go i _k []
-- For indices out of range, fail
| Nat n <- mblen
, i >= n
- = raiseError SBV (InvalidIndex (Just i))
+ = raiseError sym (InvalidIndex (Just i))
| otherwise
= lookupSeqMap xs i
@@ -600,33 +300,34 @@
-- are out of bounds
| Nat n <- mblen
, (i `shiftL` k) >= n
- = raiseError SBV (InvalidIndex Nothing)
+ = raiseError sym (InvalidIndex Nothing)
| otherwise
- = iteValue SBV b
+ = iteValue sym b
(go ((i `shiftL` 1) + 1) (k-1) bs)
(go (i `shiftL` 1) (k-1) bs)
indexBack_bits ::
+ SBV ->
Nat' ->
TValue ->
SeqMap SBV ->
TValue ->
[SBit SBV] ->
SEval SBV Value
-indexBack_bits (Nat n) a xs ix idx = indexFront_bits (Nat n) a (reverseSeqMap n xs) ix idx
-indexBack_bits Inf _ _ _ _ = evalPanic "Expected finite sequence" ["indexBack_bits"]
+indexBack_bits sym (Nat n) a xs ix idx = indexFront_bits sym (Nat n) a (reverseSeqMap n xs) ix idx
+indexBack_bits _ Inf _ _ _ _ = evalPanic "Expected finite sequence" ["indexBack_bits"]
-- | Compare a symbolic word value with a concrete integer.
-wordValueEqualsInteger :: WordValue SBV -> Integer -> SEval SBV (SBit SBV)
-wordValueEqualsInteger wv i
- | wordValueSize SBV wv < widthInteger i = return SBV.svFalse
+wordValueEqualsInteger :: SBV -> WordValue SBV -> Integer -> SEval SBV (SBit SBV)
+wordValueEqualsInteger sym wv i
+ | wordValueSize sym wv < widthInteger i = return SBV.svFalse
| otherwise =
case wv of
WordVal w -> return $ SBV.svEqual w (literalSWord (SBV.intSizeOf w) i)
- _ -> bitsAre i <$> enumerateWordValueRev SBV wv -- little-endian
+ _ -> bitsAre i <$> enumerateWordValueRev sym wv -- little-endian
where
bitsAre :: Integer -> [SBit SBV] -> SBit SBV
bitsAre n [] = SBV.svBool (n == 0)
@@ -637,49 +338,51 @@
updateFrontSym ::
+ SBV ->
Nat' ->
TValue ->
SeqMap SBV ->
Either (SInteger SBV) (WordValue SBV) ->
SEval SBV (GenValue SBV) ->
SEval SBV (SeqMap SBV)
-updateFrontSym _len _eltTy vs (Left idx) val =
+updateFrontSym sym _len _eltTy vs (Left idx) val =
case SBV.svAsInteger idx of
Just i -> return $ updateSeqMap vs i val
Nothing -> return $ IndexSeqMap $ \i ->
- do b <- intEq SBV idx =<< integerLit SBV i
- iteValue SBV b val (lookupSeqMap vs i)
+ do b <- intEq sym idx =<< integerLit sym i
+ iteValue sym b val (lookupSeqMap vs i)
-updateFrontSym _len _eltTy vs (Right wv) val =
+updateFrontSym sym _len _eltTy vs (Right wv) val =
case wv of
WordVal w | Just j <- SBV.svAsInteger w ->
return $ updateSeqMap vs j val
_ ->
return $ IndexSeqMap $ \i ->
- do b <- wordValueEqualsInteger wv i
- iteValue SBV b val (lookupSeqMap vs i)
+ do b <- wordValueEqualsInteger sym wv i
+ iteValue sym b val (lookupSeqMap vs i)
updateFrontSym_word ::
+ SBV ->
Nat' ->
TValue ->
WordValue SBV ->
Either (SInteger SBV) (WordValue SBV) ->
SEval SBV (GenValue SBV) ->
SEval SBV (WordValue SBV)
-updateFrontSym_word Inf _ _ _ _ = evalPanic "Expected finite sequence" ["updateFrontSym_bits"]
+updateFrontSym_word _ Inf _ _ _ _ = evalPanic "Expected finite sequence" ["updateFrontSym_bits"]
-updateFrontSym_word (Nat _) eltTy (LargeBitsVal n bv) idx val =
- LargeBitsVal n <$> updateFrontSym (Nat n) eltTy bv idx val
+updateFrontSym_word sym (Nat _) eltTy (LargeBitsVal n bv) idx val =
+ LargeBitsVal n <$> updateFrontSym sym (Nat n) eltTy bv idx val
-updateFrontSym_word (Nat n) eltTy (WordVal bv) (Left idx) val =
- do idx' <- wordFromInt SBV n idx
- updateFrontSym_word (Nat n) eltTy (WordVal bv) (Right (WordVal idx')) val
+updateFrontSym_word sym (Nat n) eltTy (WordVal bv) (Left idx) val =
+ do idx' <- wordFromInt sym n idx
+ updateFrontSym_word sym (Nat n) eltTy (WordVal bv) (Right (WordVal idx')) val
-updateFrontSym_word (Nat n) eltTy bv (Right wv) val =
+updateFrontSym_word sym (Nat n) eltTy bv (Right wv) val =
case wv of
WordVal idx
| Just j <- SBV.svAsInteger idx ->
- updateWordValue SBV bv j (fromVBit <$> val)
+ updateWordValue sym bv j (fromVBit <$> val)
| WordVal bw <- bv ->
WordVal <$>
@@ -692,55 +395,57 @@
let bw' = SBV.svAnd bw (SBV.svNot msk)
return $! SBV.svXOr bw' (SBV.svAnd q msk)
- _ -> LargeBitsVal n <$> updateFrontSym (Nat n) eltTy (asBitsMap SBV bv) (Right wv) val
+ _ -> LargeBitsVal n <$> updateFrontSym sym (Nat n) eltTy (asBitsMap sym bv) (Right wv) val
updateBackSym ::
+ SBV ->
Nat' ->
TValue ->
SeqMap SBV ->
Either (SInteger SBV) (WordValue SBV) ->
SEval SBV (GenValue SBV) ->
SEval SBV (SeqMap SBV)
-updateBackSym Inf _ _ _ _ = evalPanic "Expected finite sequence" ["updateBackSym"]
+updateBackSym _ Inf _ _ _ _ = evalPanic "Expected finite sequence" ["updateBackSym"]
-updateBackSym (Nat n) _eltTy vs (Left idx) val =
+updateBackSym sym (Nat n) _eltTy vs (Left idx) val =
case SBV.svAsInteger idx of
Just i -> return $ updateSeqMap vs (n - 1 - i) val
Nothing -> return $ IndexSeqMap $ \i ->
- do b <- intEq SBV idx =<< integerLit SBV (n - 1 - i)
- iteValue SBV b val (lookupSeqMap vs i)
+ do b <- intEq sym idx =<< integerLit sym (n - 1 - i)
+ iteValue sym b val (lookupSeqMap vs i)
-updateBackSym (Nat n) _eltTy vs (Right wv) val =
+updateBackSym sym (Nat n) _eltTy vs (Right wv) val =
case wv of
WordVal w | Just j <- SBV.svAsInteger w ->
return $ updateSeqMap vs (n - 1 - j) val
_ ->
return $ IndexSeqMap $ \i ->
- do b <- wordValueEqualsInteger wv (n - 1 - i)
- iteValue SBV b val (lookupSeqMap vs i)
+ do b <- wordValueEqualsInteger sym wv (n - 1 - i)
+ iteValue sym b val (lookupSeqMap vs i)
updateBackSym_word ::
+ SBV ->
Nat' ->
TValue ->
WordValue SBV ->
Either (SInteger SBV) (WordValue SBV) ->
SEval SBV (GenValue SBV) ->
SEval SBV (WordValue SBV)
-updateBackSym_word Inf _ _ _ _ = evalPanic "Expected finite sequence" ["updateBackSym_bits"]
+updateBackSym_word _ Inf _ _ _ _ = evalPanic "Expected finite sequence" ["updateBackSym_bits"]
-updateBackSym_word (Nat _) eltTy (LargeBitsVal n bv) idx val =
- LargeBitsVal n <$> updateBackSym (Nat n) eltTy bv idx val
+updateBackSym_word sym (Nat _) eltTy (LargeBitsVal n bv) idx val =
+ LargeBitsVal n <$> updateBackSym sym (Nat n) eltTy bv idx val
-updateBackSym_word (Nat n) eltTy (WordVal bv) (Left idx) val =
- do idx' <- wordFromInt SBV n idx
- updateBackSym_word (Nat n) eltTy (WordVal bv) (Right (WordVal idx')) val
+updateBackSym_word sym (Nat n) eltTy (WordVal bv) (Left idx) val =
+ do idx' <- wordFromInt sym n idx
+ updateBackSym_word sym (Nat n) eltTy (WordVal bv) (Right (WordVal idx')) val
-updateBackSym_word (Nat n) eltTy bv (Right wv) val = do
+updateBackSym_word sym (Nat n) eltTy bv (Right wv) val = do
case wv of
WordVal idx
| Just j <- SBV.svAsInteger idx ->
- updateWordValue SBV bv (n - 1 - j) (fromVBit <$> val)
+ updateWordValue sym bv (n - 1 - j) (fromVBit <$> val)
| WordVal bw <- bv ->
WordVal <$>
@@ -753,7 +458,7 @@
let bw' = SBV.svAnd bw (SBV.svNot msk)
return $! SBV.svXOr bw' (SBV.svAnd q msk)
- _ -> LargeBitsVal n <$> updateBackSym (Nat n) eltTy (asBitsMap SBV bv) (Right wv) val
+ _ -> LargeBitsVal n <$> updateBackSym sym (Nat n) eltTy (asBitsMap sym bv) (Right wv) val
asWordList :: [WordValue SBV] -> Maybe [SWord SBV]
@@ -763,88 +468,21 @@
go f (WordVal x :vs) = go (f . (x:)) vs
go _f (LargeBitsVal _ _ : _) = Nothing
-
-sModAdd :: Integer -> SInteger SBV -> SInteger SBV -> SEval SBV (SInteger SBV)
-sModAdd 0 _ _ = evalPanic "sModAdd" ["0 modulus not allowed"]
-sModAdd modulus x y =
- case (SBV.svAsInteger x, SBV.svAsInteger y) of
- (Just i, Just j) -> integerLit SBV ((i + j) `mod` modulus)
- _ -> pure $ SBV.svPlus x y
-
-sModSub :: Integer -> SInteger SBV -> SInteger SBV -> SEval SBV (SInteger SBV)
-sModSub 0 _ _ = evalPanic "sModSub" ["0 modulus not allowed"]
-sModSub modulus x y =
- case (SBV.svAsInteger x, SBV.svAsInteger y) of
- (Just i, Just j) -> integerLit SBV ((i - j) `mod` modulus)
- _ -> pure $ SBV.svMinus x y
-
-sModNegate :: Integer -> SInteger SBV -> SEval SBV (SInteger SBV)
-sModNegate 0 _ = evalPanic "sModNegate" ["0 modulus not allowed"]
-sModNegate modulus x =
- case SBV.svAsInteger x of
- Just i -> integerLit SBV ((negate i) `mod` modulus)
- _ -> pure $ SBV.svUNeg x
-
-sModMult :: Integer -> SInteger SBV -> SInteger SBV -> SEval SBV (SInteger SBV)
-sModMult 0 _ _ = evalPanic "sModMult" ["0 modulus not allowed"]
-sModMult modulus x y =
- case (SBV.svAsInteger x, SBV.svAsInteger y) of
- (Just i, Just j) -> integerLit SBV ((i * j) `mod` modulus)
- _ -> pure $ SBV.svTimes x y
-
--- | Ceiling (log_2 x)
-sLg2 :: SWord SBV -> SEval SBV (SWord SBV)
-sLg2 x = pure $ go 0
- where
- lit n = literalSWord (SBV.intSizeOf x) n
- go i | i < SBV.intSizeOf x = SBV.svIte (SBV.svLessEq x (lit (2^i))) (lit (toInteger i)) (go (i + 1))
- | otherwise = lit (toInteger i)
-
-svDivisible :: Integer -> SInteger SBV -> SEval SBV (SBit SBV)
-svDivisible m x =
- do m' <- integerLit SBV m
- z <- integerLit SBV 0
- pure $ SBV.svEqual (SBV.svRem x m') z
-
-signedQuot :: SWord SBV -> SWord SBV -> SWord SBV
-signedQuot x y = SBV.svUnsign (SBV.svQuot (SBV.svSign x) (SBV.svSign y))
-
-signedRem :: SWord SBV -> SWord SBV -> SWord SBV
-signedRem x y = SBV.svUnsign (SBV.svRem (SBV.svSign x) (SBV.svSign y))
-
-ashr :: SVal -> SVal -> SVal
-ashr x idx =
- case SBV.svAsInteger idx of
- Just i -> SBV.svUnsign (SBV.svShr (SBV.svSign x) (fromInteger i))
- Nothing -> SBV.svUnsign (SBV.svShiftRight (SBV.svSign x) idx)
-
-lshr :: SVal -> SVal -> SVal
-lshr x idx =
- case SBV.svAsInteger idx of
- Just i -> SBV.svShr x (fromInteger i)
- Nothing -> SBV.svShiftRight x idx
-
-shl :: SVal -> SVal -> SVal
-shl x idx =
- case SBV.svAsInteger idx of
- Just i -> SBV.svShl x (fromInteger i)
- Nothing -> SBV.svShiftLeft x idx
-
-sshrV :: Value
-sshrV =
+sshrV :: SBV -> Value
+sshrV sym =
nlam $ \n ->
tlam $ \ix ->
- wlam SBV $ \x -> return $
+ wlam sym $ \x -> return $
lam $ \y ->
- y >>= asIndex SBV ">>$" ix >>= \case
+ y >>= asIndex sym ">>$" ix >>= \case
Left idx ->
do let w = toInteger (SBV.intSizeOf x)
let pneg = svLessThan idx (svInteger KUnbounded 0)
- zneg <- shl x . svFromInteger w <$> shiftShrink SBV n ix (SBV.svUNeg idx)
- zpos <- ashr x . svFromInteger w <$> shiftShrink SBV n ix idx
+ zneg <- shl x . svFromInteger w <$> shiftShrink sym n ix (SBV.svUNeg idx)
+ zpos <- ashr x . svFromInteger w <$> shiftShrink sym n ix idx
let z = svSymbolicMerge (kindOf x) True pneg zneg zpos
return . VWord w . pure . WordVal $ z
Right wv ->
- do z <- ashr x <$> asWordVal SBV wv
+ do z <- ashr x <$> asWordVal sym wv
return . VWord (toInteger (SBV.intSizeOf x)) . pure . WordVal $ z
diff --git a/src/Cryptol/Eval/Type.hs b/src/Cryptol/Eval/Type.hs
--- a/src/Cryptol/Eval/Type.hs
+++ b/src/Cryptol/Eval/Type.hs
@@ -11,7 +11,7 @@
{-# LANGUAGE DeriveGeneric #-}
module Cryptol.Eval.Type where
-import Cryptol.Eval.Monad
+import Cryptol.Backend.Monad (evalPanic, typeCannotBeDemoted)
import Cryptol.TypeCheck.AST
import Cryptol.TypeCheck.PP(pp)
import Cryptol.TypeCheck.Solver.InfNat
@@ -20,9 +20,8 @@
import Cryptol.Utils.RecordMap
import Data.Maybe(fromMaybe)
-import qualified Data.Map.Strict as Map
+import qualified Data.IntMap.Strict as IntMap
import GHC.Generics (Generic)
-import GHC.Stack(HasCallStack)
import Control.DeepSeq
-- | An evaluated type of kind *.
@@ -91,15 +90,15 @@
-- Type Evaluation -------------------------------------------------------------
-type TypeEnv = Map.Map TVar (Either Nat' TValue)
+type TypeEnv = IntMap.IntMap (Either Nat' TValue)
-- | Evaluation for types (kind * or #).
-evalType :: HasCallStack => TypeEnv -> Type -> Either Nat' TValue
+evalType :: TypeEnv -> Type -> Either Nat' TValue
evalType env ty =
case ty of
TVar tv ->
- case Map.lookup tv env of
+ case IntMap.lookup (tvUnique tv) env of
Just v -> v
Nothing -> evalPanic "evalType" ["type variable not bound", show tv]
@@ -133,8 +132,8 @@
_ -> 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)]
+ TCon (TError _) ts -> evalPanic "evalType"
+ $ "Lingering invalid type" : map (show . pp) ts
where
val = evalValType env
num = evalNumType env
@@ -144,14 +143,14 @@
["Expecting a finite size, but got `inf`"]
-- | Evaluation for value types (kind *).
-evalValType :: HasCallStack => TypeEnv -> 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
-- | Evaluation for number types (kind #).
-evalNumType :: HasCallStack => TypeEnv -> Type -> Nat'
+evalNumType :: TypeEnv -> Type -> Nat'
evalNumType env ty =
case evalType env ty of
Left n -> n
@@ -159,7 +158,7 @@
-- | Reduce type functions, raising an exception for undefined values.
-evalTF :: HasCallStack => TFun -> [Nat'] -> Nat'
+evalTF :: TFun -> [Nat'] -> Nat'
evalTF f vs
| TCAdd <- f, [x,y] <- vs = nAdd x y
| TCSub <- f, [x,y] <- vs = mb $ nSub x y
diff --git a/src/Cryptol/Eval/Value.hs b/src/Cryptol/Eval/Value.hs
--- a/src/Cryptol/Eval/Value.hs
+++ b/src/Cryptol/Eval/Value.hs
@@ -98,9 +98,9 @@
import qualified Data.Map.Strict as Map
import MonadLib
-import qualified Cryptol.Eval.Arch as Arch
-import Cryptol.Eval.Backend
-import Cryptol.Eval.Monad
+import Cryptol.Backend
+import qualified Cryptol.Backend.Arch as Arch
+import Cryptol.Backend.Monad ( PPOpts(..), evalPanic, wordTooWide, defaultPPOpts, asciiMode )
import Cryptol.Eval.Type
import Cryptol.TypeCheck.Solver.InfNat(Nat'(..))
@@ -132,7 +132,7 @@
-- | An arbitrarily-chosen number of elements where we switch from a dense
-- sequence representation of bit-level words to 'SeqMap' representation.
largeBitSize :: Integer
-largeBitSize = 1 `shiftL` 16
+largeBitSize = 1 `shiftL` 48
-- | Generate a finite sequence map from a list of values
finiteSeqMap :: Backend sym => sym -> [SEval sym (GenValue sym)] -> SeqMap sym
@@ -205,13 +205,13 @@
doEval cache i = do
v <- lookupSeqMap x i
- liftIO $ modifyIORef' cache (Map.insert i v)
+ liftIO $ atomicModifyIORef' cache (\m -> (Map.insert i v m, ()))
return v
-- | Apply the given evaluation function pointwise to the two given
-- sequence maps.
zipSeqMap ::
- Backend sym =>
+ Backend sym =>
(GenValue sym -> GenValue sym -> SEval sym (GenValue sym)) ->
SeqMap sym ->
SeqMap sym ->
@@ -221,7 +221,7 @@
-- | Apply the given function to each value in the given sequence map
mapSeqMap ::
- Backend sym =>
+ Backend sym =>
(GenValue sym -> SEval sym (GenValue sym)) ->
SeqMap sym -> SEval sym (SeqMap sym)
mapSeqMap f x =
@@ -281,7 +281,7 @@
-- | Produce a new 'WordValue' from the one given by updating the @i@th bit with the
-- given bit value.
updateWordValue :: Backend sym => sym -> WordValue sym -> Integer -> SEval sym (SBit sym) -> SEval sym (WordValue sym)
-updateWordValue sym (WordVal w) idx b
+updateWordValue sym (WordVal w) idx b
| idx < 0 || idx >= wordLen sym w = invalidIndex sym idx
| isReady sym b = WordVal <$> (wordUpdate sym w idx =<< b)
@@ -336,6 +336,7 @@
VNumPoly _ -> return ()
+
instance Backend sym => Show (GenValue sym) where
show v = case v of
VRecord fs -> "record:" ++ show (displayOrder fs)
@@ -401,9 +402,6 @@
_ -> return $ brackets (fsep (punctuate comma $ map (ppWord x 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)
-- Value Constructors ----------------------------------------------------------
diff --git a/src/Cryptol/Eval/What4.hs b/src/Cryptol/Eval/What4.hs
--- a/src/Cryptol/Eval/What4.hs
+++ b/src/Cryptol/Eval/What4.hs
@@ -4,41 +4,69 @@
-- License : BSD3
-- Maintainer : cryptol@galois.com
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
module Cryptol.Eval.What4
- ( What4(..)
- , W4Result(..)
- , W4Defs(..)
- , W4Eval
- , w4Eval
- , Value
- , evalPrim
+ ( Value
+ , primTable
+ , floatPrims
) where
-
-import Control.Monad (join)
+import qualified Control.Exception as X
+import Control.Concurrent.MVar
+import Control.Monad (join,foldM)
+import Control.Monad.IO.Class
+import Data.Bits
import qualified Data.Map as Map
+import Data.Map (Map)
+import qualified Data.Set as Set
+import Data.Text (Text)
+import qualified Data.Text as Text
+import Data.Parameterized.Context
+import Data.Parameterized.Some
+import Data.Parameterized.TraversableFC
+import qualified Data.BitVector.Sized as BV
import qualified What4.Interface as W4
+import qualified What4.SWord as SW
+import qualified What4.Utils.AbstractDomains as W4
-import Cryptol.Eval.Backend
+import Cryptol.Backend
+import Cryptol.Backend.Monad ( EvalError(..), Unsupported(..) )
+import Cryptol.Backend.What4
+import qualified Cryptol.Backend.What4.SFloat as W4
+
import Cryptol.Eval.Generic
-import Cryptol.Eval.Type (finNat')
+import Cryptol.Eval.Type (finNat', TValue(..))
import Cryptol.Eval.Value
-import Cryptol.Eval.What4.Value
-import Cryptol.Eval.What4.Float(floatPrims)
-import Cryptol.Testing.Random( randomV )
-import Cryptol.Utils.Ident
+import qualified Cryptol.SHA as SHA
-evalPrim :: W4.IsSymExprBuilder sym => sym -> PrimIdent -> Maybe (Value sym)
-evalPrim sym prim = Map.lookup prim (primTable sym)
+import Cryptol.TypeCheck.Solver.InfNat( Nat'(..), widthInteger )
+import Cryptol.Utils.Ident
+import Cryptol.Utils.Panic
+import Cryptol.Utils.RecordMap
+
+type Value sym = GenValue (What4 sym)
+
-- See also Cryptol.Prims.Eval.primTable
-primTable :: W4.IsSymExprBuilder sym => sym -> Map.Map PrimIdent (Value sym)
-primTable w4sym = let sym = What4 w4sym in
+primTable :: W4.IsSymExprBuilder sym => What4 sym -> Map.Map PrimIdent (Value sym)
+primTable sym =
+ let w4sym = w4 sym in
Map.union (floatPrims sym) $
+ Map.union (suiteBPrims sym) $
+ Map.union (primeECPrims sym) $
+
Map.fromList $ map (\(n, v) -> (prelPrim n, v))
[ -- Literals
@@ -88,7 +116,7 @@
, ("/$" , sdivV sym)
, ("%$" , smodV sym)
, ("lg2" , lg2V sym)
- , (">>$" , sshrV w4sym)
+ , (">>$" , sshrV sym)
-- Cmp
, ("<" , binary (lessThanV sym))
@@ -153,14 +181,25 @@
rotateRightReindex rotateLeftReindex)
-- Indexing and updates
- , ("@" , indexPrim sym (indexFront_int w4sym) (indexFront_bits w4sym) (indexFront_word w4sym))
- , ("!" , indexPrim sym (indexBack_int w4sym) (indexBack_bits w4sym) (indexBack_word w4sym))
+ , ("@" , indexPrim sym (indexFront_int sym) (indexFront_bits sym) (indexFront_word sym))
+ , ("!" , indexPrim sym (indexBack_int sym) (indexBack_bits sym) (indexBack_word sym))
- , ("update" , updatePrim sym (updateFrontSym_word w4sym) (updateFrontSym w4sym))
- , ("updateEnd" , updatePrim sym (updateBackSym_word w4sym) (updateBackSym w4sym))
+ , ("update" , updatePrim sym (updateFrontSym_word sym) (updateFrontSym sym))
+ , ("updateEnd" , updatePrim sym (updateBackSym_word sym) (updateBackSym sym))
-- Misc
+ , ("foldl" , foldlV sym)
+ , ("foldl'" , foldl'V sym)
+
+ , ("deepseq" ,
+ tlam $ \_a ->
+ tlam $ \_b ->
+ lam $ \x -> pure $
+ lam $ \y ->
+ do _ <- forceValue =<< x
+ y)
+
, ("parmap" , parmapV sym)
, ("fromZ" , fromZV sym)
@@ -193,5 +232,805 @@
y)
]
+primeECPrims :: W4.IsSymExprBuilder sym => What4 sym -> Map.Map PrimIdent (Value sym)
+primeECPrims sym = Map.fromList $ [ (primeECPrim n, v) | (n,v) <- prims ]
+ where
+ (~>) = (,)
+ prims =
+ [ -- {p} (prime p, p > 3) => ProjectivePoint p -> ProjectivePoint p
+ "ec_double" ~>
+ ilam \p ->
+ lam \s ->
+ do p' <- integerLit sym p
+ s' <- toProjectivePoint sym =<< s
+ addUninterpWarning sym "Prime ECC"
+ fn <- liftIO $ getUninterpFn sym "ec_double"
+ (Empty :> W4.BaseIntegerRepr :> projectivePointRepr) projectivePointRepr
+ z <- liftIO $ W4.applySymFn (w4 sym) fn (Empty :> p' :> s')
+ fromProjectivePoint sym z
+ -- {p} (prime p, p > 3) => ProjectivePoint p -> ProjectivePoint p -> ProjectivePoint p
+ , "ec_add_nonzero" ~>
+ ilam \p ->
+ lam \s -> pure $
+ lam \t ->
+ do p' <- integerLit sym p
+ s' <- toProjectivePoint sym =<< s
+ t' <- toProjectivePoint sym =<< t
+ addUninterpWarning sym "Prime ECC"
+ fn <- liftIO $ getUninterpFn sym "ec_add_nonzero"
+ (Empty :> W4.BaseIntegerRepr :> projectivePointRepr :> projectivePointRepr) projectivePointRepr
+ z <- liftIO $ W4.applySymFn (w4 sym) fn (Empty :> p' :> s' :> t')
+ fromProjectivePoint sym z
+
+ -- {p} (prime p, p > 3) => Z p -> ProjectivePoint p -> ProjectivePoint p
+ , "ec_mult" ~>
+ ilam \p ->
+ lam \k -> pure $
+ lam \s ->
+ do p' <- integerLit sym p
+ k' <- fromVInteger <$> k
+ s' <- toProjectivePoint sym =<< s
+ addUninterpWarning sym "Prime ECC"
+ fn <- liftIO $ getUninterpFn sym "ec_mult"
+ (Empty :> W4.BaseIntegerRepr :> W4.BaseIntegerRepr :> projectivePointRepr) projectivePointRepr
+ z <- liftIO $ W4.applySymFn (w4 sym) fn (Empty :> p' :> k' :> s')
+ fromProjectivePoint sym z
+
+ -- {p} (prime p, p > 3) => Z p -> ProjectivePoint p -> Z p -> ProjectivePoint p -> ProjectivePoint p
+ , "ec_twin_mult" ~>
+ ilam \p ->
+ lam \j -> pure $
+ lam \s -> pure $
+ lam \k -> pure $
+ lam \t ->
+ do p' <- integerLit sym p
+ j' <- fromVInteger <$> j
+ s' <- toProjectivePoint sym =<< s
+ k' <- fromVInteger <$> k
+ t' <- toProjectivePoint sym =<< t
+ addUninterpWarning sym "Prime ECC"
+ fn <- liftIO $ getUninterpFn sym "ec_twin_mult"
+ (Empty :> W4.BaseIntegerRepr :> W4.BaseIntegerRepr :> projectivePointRepr :>
+ W4.BaseIntegerRepr :> projectivePointRepr)
+ projectivePointRepr
+ z <- liftIO $ W4.applySymFn (w4 sym) fn (Empty :> p' :> j' :> s' :> k' :> t')
+ fromProjectivePoint sym z
+ ]
+
+
+type ProjectivePoint = W4.BaseStructType (EmptyCtx ::> W4.BaseIntegerType ::> W4.BaseIntegerType ::> W4.BaseIntegerType)
+
+projectivePointRepr :: W4.BaseTypeRepr ProjectivePoint
+projectivePointRepr = W4.knownRepr
+
+toProjectivePoint :: W4.IsSymExprBuilder sym =>
+ What4 sym -> Value sym -> SEval (What4 sym) (W4.SymExpr sym ProjectivePoint)
+toProjectivePoint sym v =
+ do x <- fromVInteger <$> lookupRecord "x" v
+ y <- fromVInteger <$> lookupRecord "y" v
+ z <- fromVInteger <$> lookupRecord "z" v
+ liftIO $ W4.mkStruct (w4 sym) (Empty :> x :> y :> z)
+
+fromProjectivePoint :: W4.IsSymExprBuilder sym =>
+ What4 sym -> W4.SymExpr sym ProjectivePoint -> SEval (What4 sym) (Value sym)
+fromProjectivePoint sym p = liftIO $
+ do x <- VInteger <$> W4.structField (w4 sym) p (natIndex @0)
+ y <- VInteger <$> W4.structField (w4 sym) p (natIndex @1)
+ z <- VInteger <$> W4.structField (w4 sym) p (natIndex @2)
+ pure $ VRecord $ recordFromFields [ (packIdent "x",pure x), (packIdent "y",pure y),(packIdent "z",pure z) ]
+
+suiteBPrims :: W4.IsSymExprBuilder sym => What4 sym -> Map.Map PrimIdent (Value sym)
+suiteBPrims sym = Map.fromList $ [ (suiteBPrim n, v) | (n,v) <- prims ]
+ where
+ (~>) = (,)
+
+ prims =
+ [ "AESEncRound" ~>
+ lam \st ->
+ do addUninterpWarning sym "AES encryption"
+ applyAESStateFunc sym "AESEncRound" =<< st
+ , "AESEncFinalRound" ~>
+ lam \st ->
+ do addUninterpWarning sym "AES encryption"
+ applyAESStateFunc sym "AESEncFinalRound" =<< st
+ , "AESDecRound" ~>
+ lam \st ->
+ do addUninterpWarning sym "AES decryption"
+ applyAESStateFunc sym "AESDecRound" =<< st
+ , "AESDecFinalRound" ~>
+ lam \st ->
+ do addUninterpWarning sym "AES decryption"
+ applyAESStateFunc sym "AESDecFinalRound" =<< st
+ , "AESInvMixColumns" ~>
+ lam \st ->
+ do addUninterpWarning sym "AES key expansion"
+ applyAESStateFunc sym "AESInvMixColumns" =<< st
+
+ -- {k} (fin k, k >= 4, 8 >= k) => [k][32] -> [4*(k+7)][32]
+ , "AESKeyExpand" ~>
+ ilam \k ->
+ lam \st ->
+ do ss <- fromVSeq <$> st
+ -- pack the arguments into a k-tuple of 32-bit values
+ Some ws <- generateSomeM (fromInteger k) (\i -> Some <$> toWord32 sym "AESKeyExpand" ss (toInteger i))
+ -- get the types of the arguments
+ let args = fmapFC W4.exprType ws
+ -- compute the return type which is a tuple of @4*(k+7)@ 32-bit values
+ Some ret <- pure $ generateSome (4*(fromInteger k + 7)) (\_ -> Some (W4.BaseBVRepr (W4.knownNat @32)))
+ -- retrieve the relevant uninterpreted function and apply it to the arguments
+ addUninterpWarning sym "AES key expansion"
+ fn <- liftIO $ getUninterpFn sym ("AESKeyExpand" <> Text.pack (show k)) args (W4.BaseStructRepr ret)
+ z <- liftIO $ W4.applySymFn (w4 sym) fn ws
+ -- compute a sequence that projects the relevant fields from the outout tuple
+ pure $ VSeq (4*(k+7)) $ IndexSeqMap $ \i ->
+ case intIndex (fromInteger i) (size ret) of
+ Just (Some idx) | Just W4.Refl <- W4.testEquality (ret!idx) (W4.BaseBVRepr (W4.knownNat @32)) ->
+ fromWord32 =<< liftIO (W4.structField (w4 sym) z idx)
+ _ -> invalidIndex sym i
+
+ -- {n} (fin n) => [n][16][32] -> [7][32]
+ , "processSHA2_224" ~>
+ ilam \n ->
+ lam \xs ->
+ do blks <- enumerateSeqMap n . fromVSeq <$> xs
+ addUninterpWarning sym "SHA-224"
+ initSt <- liftIO (mkSHA256InitialState sym SHA.initialSHA224State)
+ finalSt <- foldM (\st blk -> processSHA256Block sym st =<< blk) initSt blks
+ pure $ VSeq 7 $ IndexSeqMap \i ->
+ case intIndex (fromInteger i) (knownSize :: Size SHA256State) of
+ Just (Some idx) ->
+ do z <- liftIO $ W4.structField (w4 sym) finalSt idx
+ case W4.testEquality (W4.exprType z) (W4.BaseBVRepr (W4.knownNat @32)) of
+ Just W4.Refl -> fromWord32 z
+ Nothing -> invalidIndex sym i
+ Nothing -> invalidIndex sym i
+
+ -- {n} (fin n) => [n][16][32] -> [8][32]
+ , "processSHA2_256" ~>
+ ilam \n ->
+ lam \xs ->
+ do blks <- enumerateSeqMap n . fromVSeq <$> xs
+ addUninterpWarning sym "SHA-256"
+ initSt <- liftIO (mkSHA256InitialState sym SHA.initialSHA256State)
+ finalSt <- foldM (\st blk -> processSHA256Block sym st =<< blk) initSt blks
+ pure $ VSeq 8 $ IndexSeqMap \i ->
+ case intIndex (fromInteger i) (knownSize :: Size SHA256State) of
+ Just (Some idx) ->
+ do z <- liftIO $ W4.structField (w4 sym) finalSt idx
+ case W4.testEquality (W4.exprType z) (W4.BaseBVRepr (W4.knownNat @32)) of
+ Just W4.Refl -> fromWord32 z
+ Nothing -> invalidIndex sym i
+ Nothing -> invalidIndex sym i
+
+ -- {n} (fin n) => [n][16][64] -> [6][64]
+ , "processSHA2_384" ~>
+ ilam \n ->
+ lam \xs ->
+ do blks <- enumerateSeqMap n . fromVSeq <$> xs
+ addUninterpWarning sym "SHA-384"
+ initSt <- liftIO (mkSHA512InitialState sym SHA.initialSHA384State)
+ finalSt <- foldM (\st blk -> processSHA512Block sym st =<< blk) initSt blks
+ pure $ VSeq 6 $ IndexSeqMap \i ->
+ case intIndex (fromInteger i) (knownSize :: Size SHA512State) of
+ Just (Some idx) ->
+ do z <- liftIO $ W4.structField (w4 sym) finalSt idx
+ case W4.testEquality (W4.exprType z) (W4.BaseBVRepr (W4.knownNat @64)) of
+ Just W4.Refl -> fromWord64 z
+ Nothing -> invalidIndex sym i
+ Nothing -> invalidIndex sym i
+
+ -- {n} (fin n) => [n][16][64] -> [8][64]
+ , "processSHA2_512" ~>
+ ilam \n ->
+ lam \xs ->
+ do blks <- enumerateSeqMap n . fromVSeq <$> xs
+ addUninterpWarning sym "SHA-512"
+ initSt <- liftIO (mkSHA512InitialState sym SHA.initialSHA512State)
+ finalSt <- foldM (\st blk -> processSHA512Block sym st =<< blk) initSt blks
+ pure $ VSeq 8 $ IndexSeqMap \i ->
+ case intIndex (fromInteger i) (knownSize :: Size SHA512State) of
+ Just (Some idx) ->
+ do z <- liftIO $ W4.structField (w4 sym) finalSt idx
+ case W4.testEquality (W4.exprType z) (W4.BaseBVRepr (W4.knownNat @64)) of
+ Just W4.Refl -> fromWord64 z
+ Nothing -> invalidIndex sym i
+ Nothing -> invalidIndex sym i
+ ]
+
+
+type SHA256State =
+ EmptyCtx ::>
+ W4.BaseBVType 32 ::> W4.BaseBVType 32 ::> W4.BaseBVType 32 ::> W4.BaseBVType 32 ::>
+ W4.BaseBVType 32 ::> W4.BaseBVType 32 ::> W4.BaseBVType 32 ::> W4.BaseBVType 32
+
+type SHA512State =
+ EmptyCtx ::>
+ W4.BaseBVType 64 ::> W4.BaseBVType 64 ::> W4.BaseBVType 64 ::> W4.BaseBVType 64 ::>
+ W4.BaseBVType 64 ::> W4.BaseBVType 64 ::> W4.BaseBVType 64 ::> W4.BaseBVType 64
+
+
+mkSHA256InitialState :: W4.IsSymExprBuilder sym =>
+ What4 sym ->
+ SHA.SHA256State ->
+ IO (W4.SymExpr sym (W4.BaseStructType SHA256State))
+mkSHA256InitialState sym (SHA.SHA256S s0 s1 s2 s3 s4 s5 s6 s7) =
+ do z0 <- lit s0
+ z1 <- lit s1
+ z2 <- lit s2
+ z3 <- lit s3
+ z4 <- lit s4
+ z5 <- lit s5
+ z6 <- lit s6
+ z7 <- lit s7
+ W4.mkStruct (w4 sym) (Empty :> z0 :> z1 :> z2 :> z3 :> z4 :> z5 :> z6 :> z7)
+ where lit w = W4.bvLit (w4 sym) (W4.knownNat @32) (BV.word32 w)
+
+mkSHA512InitialState :: W4.IsSymExprBuilder sym =>
+ What4 sym ->
+ SHA.SHA512State ->
+ IO (W4.SymExpr sym (W4.BaseStructType SHA512State))
+mkSHA512InitialState sym (SHA.SHA512S s0 s1 s2 s3 s4 s5 s6 s7) =
+ do z0 <- lit s0
+ z1 <- lit s1
+ z2 <- lit s2
+ z3 <- lit s3
+ z4 <- lit s4
+ z5 <- lit s5
+ z6 <- lit s6
+ z7 <- lit s7
+ W4.mkStruct (w4 sym) (Empty :> z0 :> z1 :> z2 :> z3 :> z4 :> z5 :> z6 :> z7)
+ where lit w = W4.bvLit (w4 sym) (W4.knownNat @64) (BV.word64 w)
+
+processSHA256Block :: W4.IsSymExprBuilder sym =>
+ What4 sym ->
+ W4.SymExpr sym (W4.BaseStructType SHA256State) ->
+ Value sym ->
+ SEval (What4 sym) (W4.SymExpr sym (W4.BaseStructType SHA256State))
+processSHA256Block sym st blk =
+ do let ss = fromVSeq blk
+ b0 <- toWord32 sym "processSHA256Block" ss 0
+ b1 <- toWord32 sym "processSHA256Block" ss 1
+ b2 <- toWord32 sym "processSHA256Block" ss 2
+ b3 <- toWord32 sym "processSHA256Block" ss 3
+ b4 <- toWord32 sym "processSHA256Block" ss 4
+ b5 <- toWord32 sym "processSHA256Block" ss 5
+ b6 <- toWord32 sym "processSHA256Block" ss 6
+ b7 <- toWord32 sym "processSHA256Block" ss 7
+ b8 <- toWord32 sym "processSHA256Block" ss 8
+ b9 <- toWord32 sym "processSHA256Block" ss 9
+ b10 <- toWord32 sym "processSHA256Block" ss 10
+ b11 <- toWord32 sym "processSHA256Block" ss 11
+ b12 <- toWord32 sym "processSHA256Block" ss 12
+ b13 <- toWord32 sym "processSHA256Block" ss 13
+ b14 <- toWord32 sym "processSHA256Block" ss 14
+ b15 <- toWord32 sym "processSHA256Block" ss 15
+ let args = Empty :> st :>
+ b0 :> b1 :> b2 :> b3 :>
+ b4 :> b5 :> b6 :> b7 :>
+ b8 :> b9 :> b10 :> b11 :>
+ b12 :> b13 :> b14 :> b15
+ let ret = W4.exprType st
+ fn <- liftIO $ getUninterpFn sym "processSHA256Block" (fmapFC W4.exprType args) ret
+ liftIO $ W4.applySymFn (w4 sym) fn args
+
+
+processSHA512Block :: W4.IsSymExprBuilder sym =>
+ What4 sym ->
+ W4.SymExpr sym (W4.BaseStructType SHA512State) ->
+ Value sym ->
+ SEval (What4 sym) (W4.SymExpr sym (W4.BaseStructType SHA512State))
+processSHA512Block sym st blk =
+ do let ss = fromVSeq blk
+ b0 <- toWord64 sym "processSHA512Block" ss 0
+ b1 <- toWord64 sym "processSHA512Block" ss 1
+ b2 <- toWord64 sym "processSHA512Block" ss 2
+ b3 <- toWord64 sym "processSHA512Block" ss 3
+ b4 <- toWord64 sym "processSHA512Block" ss 4
+ b5 <- toWord64 sym "processSHA512Block" ss 5
+ b6 <- toWord64 sym "processSHA512Block" ss 6
+ b7 <- toWord64 sym "processSHA512Block" ss 7
+ b8 <- toWord64 sym "processSHA512Block" ss 8
+ b9 <- toWord64 sym "processSHA512Block" ss 9
+ b10 <- toWord64 sym "processSHA512Block" ss 10
+ b11 <- toWord64 sym "processSHA512Block" ss 11
+ b12 <- toWord64 sym "processSHA512Block" ss 12
+ b13 <- toWord64 sym "processSHA512Block" ss 13
+ b14 <- toWord64 sym "processSHA512Block" ss 14
+ b15 <- toWord64 sym "processSHA512Block" ss 15
+ let args = Empty :> st :>
+ b0 :> b1 :> b2 :> b3 :>
+ b4 :> b5 :> b6 :> b7 :>
+ b8 :> b9 :> b10 :> b11 :>
+ b12 :> b13 :> b14 :> b15
+ let ret = W4.exprType st
+ fn <- liftIO $ getUninterpFn sym "processSHA512Block" (fmapFC W4.exprType args) ret
+ liftIO $ W4.applySymFn (w4 sym) fn args
+
+
+addUninterpWarning :: MonadIO m => What4 sym -> Text -> m ()
+addUninterpWarning sym nm = liftIO (modifyMVar_ (w4uninterpWarns sym) (pure . Set.insert nm))
+
+-- | Retrieve the named uninterpreted function, with the given argument types and
+-- return type, from a cache. Create a fresh function if it has not previously
+-- been requested. A particular named function is required to be used with
+-- consistent types every time it is requested; otherwise this function will panic.
+getUninterpFn :: W4.IsSymExprBuilder sym =>
+ What4 sym ->
+ Text {- ^ Function name -} ->
+ Assignment W4.BaseTypeRepr args {- ^ function argument types -} ->
+ W4.BaseTypeRepr ret {- ^ function return type -} ->
+ IO (W4.SymFn sym args ret)
+getUninterpFn sym funNm args ret =
+ modifyMVar (w4funs sym) $ \m ->
+ case Map.lookup funNm m of
+ Nothing ->
+ do fn <- W4.freshTotalUninterpFn (w4 sym) (W4.safeSymbol (Text.unpack funNm)) args ret
+ let m' = Map.insert funNm (SomeSymFn fn) m
+ return (m', fn)
+
+ Just (SomeSymFn fn)
+ | Just W4.Refl <- W4.testEquality args (W4.fnArgTypes fn)
+ , Just W4.Refl <- W4.testEquality ret (W4.fnReturnType fn)
+ -> return (m, fn)
+
+ | otherwise -> panic "getUninterpFn"
+ [ "Function" ++ show funNm ++ "used at incompatible types"
+ , "Created with types:"
+ , show (W4.fnArgTypes fn) ++ " -> " ++ show (W4.fnReturnType fn)
+ , "Requested at types:"
+ , show args ++ " -> " ++ show ret
+ ]
+
+toWord32 :: W4.IsSymExprBuilder sym =>
+ What4 sym -> String -> SeqMap (What4 sym) -> Integer -> SEval (What4 sym) (W4.SymBV sym 32)
+toWord32 sym nm ss i =
+ do x <- fromVWord sym nm =<< lookupSeqMap ss i
+ case x of
+ SW.DBV x' | Just W4.Refl <- W4.testEquality (W4.bvWidth x') (W4.knownNat @32) -> pure x'
+ _ -> panic nm ["Unexpected word size", show (SW.bvWidth x)]
+
+fromWord32 :: W4.IsSymExprBuilder sym => W4.SymBV sym 32 -> SEval (What4 sym) (Value sym)
+fromWord32 = pure . VWord 32 . pure . WordVal . SW.DBV
+
+
+toWord64 :: W4.IsSymExprBuilder sym =>
+ What4 sym -> String -> SeqMap (What4 sym) -> Integer -> SEval (What4 sym) (W4.SymBV sym 64)
+toWord64 sym nm ss i =
+ do x <- fromVWord sym nm =<< lookupSeqMap ss i
+ case x of
+ SW.DBV x' | Just W4.Refl <- W4.testEquality (W4.bvWidth x') (W4.knownNat @64) -> pure x'
+ _ -> panic nm ["Unexpected word size", show (SW.bvWidth x)]
+
+fromWord64 :: W4.IsSymExprBuilder sym => W4.SymBV sym 64 -> SEval (What4 sym) (Value sym)
+fromWord64 = pure . VWord 64 . pure . WordVal . SW.DBV
+
+
+
+-- | Apply the named uninterpreted function to a sequence of @[4][32]@ values,
+-- and return a sequence of @[4][32]@ values. This shape of function is used
+-- for most of the SuiteB AES primitives.
+applyAESStateFunc :: forall sym. W4.IsSymExprBuilder sym =>
+ What4 sym -> Text -> Value sym -> SEval (What4 sym) (Value sym)
+applyAESStateFunc sym funNm x =
+ do let ss = fromVSeq x
+ w0 <- toWord32 sym nm ss 0
+ w1 <- toWord32 sym nm ss 1
+ w2 <- toWord32 sym nm ss 2
+ w3 <- toWord32 sym nm ss 3
+ fn <- liftIO $ getUninterpFn sym funNm argCtx (W4.BaseStructRepr argCtx)
+ z <- liftIO $ W4.applySymFn (w4 sym) fn (Empty :> w0 :> w1 :> w2 :> w3)
+ pure $ VSeq 4 $ IndexSeqMap \i ->
+ if | i == 0 -> fromWord32 =<< liftIO (W4.structField (w4 sym) z (natIndex @0))
+ | i == 1 -> fromWord32 =<< liftIO (W4.structField (w4 sym) z (natIndex @1))
+ | i == 2 -> fromWord32 =<< liftIO (W4.structField (w4 sym) z (natIndex @2))
+ | i == 3 -> fromWord32 =<< liftIO (W4.structField (w4 sym) z (natIndex @3))
+ | otherwise -> invalidIndex sym i
+
+ where
+ nm = Text.unpack funNm
+
+ argCtx :: Assignment W4.BaseTypeRepr
+ (EmptyCtx ::> W4.BaseBVType 32 ::> W4.BaseBVType 32 ::> W4.BaseBVType 32 ::> W4.BaseBVType 32)
+ argCtx = W4.knownRepr
+
+
+sshrV :: W4.IsSymExprBuilder sym => What4 sym -> Value sym
+sshrV sym =
+ nlam $ \(Nat n) ->
+ tlam $ \ix ->
+ wlam sym $ \x -> return $
+ lam $ \y ->
+ y >>= asIndex sym ">>$" ix >>= \case
+ Left i ->
+ do pneg <- intLessThan sym i =<< integerLit sym 0
+ zneg <- do i' <- shiftShrink sym (Nat n) ix =<< intNegate sym i
+ amt <- wordFromInt sym n i'
+ w4bvShl (w4 sym) x amt
+ zpos <- do i' <- shiftShrink sym (Nat n) ix i
+ amt <- wordFromInt sym n i'
+ w4bvAshr (w4 sym) x amt
+ return (VWord (SW.bvWidth x) (WordVal <$> iteWord sym pneg zneg zpos))
+
+ Right wv ->
+ do amt <- asWordVal sym wv
+ return (VWord (SW.bvWidth x) (WordVal <$> w4bvAshr (w4 sym) x amt))
+
+indexFront_int ::
+ W4.IsSymExprBuilder sym =>
+ What4 sym ->
+ Nat' ->
+ TValue ->
+ SeqMap (What4 sym) ->
+ TValue ->
+ SInteger (What4 sym) ->
+ SEval (What4 sym) (Value sym)
+indexFront_int sym mblen _a xs ix idx
+ | Just i <- W4.asInteger idx
+ = lookupSeqMap xs i
+
+ | (lo, Just hi) <- bounds
+ = foldr f def [lo .. hi]
+
+ | otherwise
+ = liftIO (X.throw (UnsupportedSymbolicOp "unbounded integer indexing"))
+
+ where
+ w4sym = w4 sym
+
+ def = raiseError sym (InvalidIndex Nothing)
+
+ f n y =
+ do p <- liftIO (W4.intEq w4sym idx =<< W4.intLit w4sym n)
+ iteValue sym p (lookupSeqMap xs n) y
+
+ bounds =
+ (case W4.rangeLowBound (W4.integerBounds idx) of
+ W4.Inclusive l -> max l 0
+ _ -> 0
+ , case (maxIdx, W4.rangeHiBound (W4.integerBounds idx)) of
+ (Just n, W4.Inclusive h) -> Just (min n h)
+ (Just n, _) -> Just n
+ _ -> Nothing
+ )
+
+ -- Maximum possible in-bounds index given `Z m`
+ -- type information and the length
+ -- of the sequence. If the sequences is infinite and the
+ -- integer is unbounded, there isn't much we can do.
+ maxIdx =
+ case (mblen, ix) of
+ (Nat n, TVIntMod m) -> Just (min (toInteger n) (toInteger m))
+ (Nat n, _) -> Just n
+ (_ , TVIntMod m) -> Just m
+ _ -> Nothing
+
+indexBack_int ::
+ W4.IsSymExprBuilder sym =>
+ What4 sym ->
+ Nat' ->
+ TValue ->
+ SeqMap (What4 sym) ->
+ TValue ->
+ SInteger (What4 sym) ->
+ SEval (What4 sym) (Value sym)
+indexBack_int sym (Nat n) a xs ix idx = indexFront_int sym (Nat n) a (reverseSeqMap n xs) ix idx
+indexBack_int _ Inf _ _ _ _ = evalPanic "Expected finite sequence" ["indexBack_int"]
+
+indexFront_word ::
+ W4.IsSymExprBuilder sym =>
+ What4 sym ->
+ Nat' ->
+ TValue ->
+ SeqMap (What4 sym) ->
+ TValue ->
+ SWord (What4 sym) ->
+ SEval (What4 sym) (Value sym)
+indexFront_word sym mblen _a xs _ix idx
+ | Just i <- SW.bvAsUnsignedInteger idx
+ = lookupSeqMap xs i
+
+ | otherwise
+ = foldr f def idxs
+
+ where
+ w4sym = w4 sym
+
+ w = SW.bvWidth idx
+ def = raiseError sym (InvalidIndex Nothing)
+
+ f n y =
+ do p <- liftIO (SW.bvEq w4sym idx =<< SW.bvLit w4sym w n)
+ iteValue sym p (lookupSeqMap xs n) y
+
+ -- maximum possible in-bounds index given the bitwidth
+ -- of the index value and the length of the sequence
+ maxIdx =
+ case mblen of
+ Nat n | n < 2^w -> n-1
+ _ -> 2^w - 1
+
+ -- concrete indices to consider, intersection of the
+ -- range of values the index value might take with
+ -- the legal values
+ idxs =
+ case SW.unsignedBVBounds idx of
+ Just (lo, hi) -> [lo .. min hi maxIdx]
+ _ -> [0 .. maxIdx]
+
+indexBack_word ::
+ W4.IsSymExprBuilder sym =>
+ What4 sym ->
+ Nat' ->
+ TValue ->
+ SeqMap (What4 sym) ->
+ TValue ->
+ SWord (What4 sym) ->
+ SEval (What4 sym) (Value sym)
+indexBack_word sym (Nat n) a xs ix idx = indexFront_word sym (Nat n) a (reverseSeqMap n xs) ix idx
+indexBack_word _ Inf _ _ _ _ = evalPanic "Expected finite sequence" ["indexBack_word"]
+
+indexFront_bits :: forall sym.
+ W4.IsSymExprBuilder sym =>
+ What4 sym ->
+ Nat' ->
+ TValue ->
+ SeqMap (What4 sym) ->
+ TValue ->
+ [SBit (What4 sym)] ->
+ SEval (What4 sym) (Value sym)
+indexFront_bits sym mblen _a xs _ix bits0 = go 0 (length bits0) bits0
+ where
+ go :: Integer -> Int -> [W4.Pred sym] -> W4Eval sym (Value sym)
+ go i _k []
+ -- For indices out of range, fail
+ | Nat n <- mblen
+ , i >= n
+ = raiseError sym (InvalidIndex (Just i))
+
+ | otherwise
+ = lookupSeqMap xs i
+
+ go i k (b:bs)
+ -- Fail early when all possible indices we could compute from here
+ -- are out of bounds
+ | Nat n <- mblen
+ , (i `shiftL` k) >= n
+ = raiseError sym (InvalidIndex Nothing)
+
+ | otherwise
+ = iteValue sym b
+ (go ((i `shiftL` 1) + 1) (k-1) bs)
+ (go (i `shiftL` 1) (k-1) bs)
+
+indexBack_bits ::
+ W4.IsSymExprBuilder sym =>
+ What4 sym ->
+ Nat' ->
+ TValue ->
+ SeqMap (What4 sym) ->
+ TValue ->
+ [SBit (What4 sym)] ->
+ SEval (What4 sym) (Value sym)
+indexBack_bits sym (Nat n) a xs ix idx = indexFront_bits sym (Nat n) a (reverseSeqMap n xs) ix idx
+indexBack_bits _ Inf _ _ _ _ = evalPanic "Expected finite sequence" ["indexBack_bits"]
+
+
+-- | Compare a symbolic word value with a concrete integer.
+wordValueEqualsInteger :: forall sym.
+ W4.IsSymExprBuilder sym =>
+ What4 sym ->
+ WordValue (What4 sym) ->
+ Integer ->
+ W4Eval sym (W4.Pred sym)
+wordValueEqualsInteger sym wv i
+ | wordValueSize sym wv < widthInteger i = return (W4.falsePred w4sym)
+ | otherwise =
+ case wv of
+ WordVal w -> liftIO (SW.bvEq w4sym w =<< SW.bvLit w4sym (SW.bvWidth w) i)
+ _ -> liftIO . bitsAre i =<< enumerateWordValueRev sym wv -- little-endian
+ where
+ w4sym = w4 sym
+
+ bitsAre :: Integer -> [W4.Pred sym] -> IO (W4.Pred sym)
+ bitsAre n [] = pure (W4.backendPred w4sym (n == 0))
+ bitsAre n (b : bs) =
+ do pb <- bitIs (testBit n 0) b
+ pbs <- bitsAre (n `shiftR` 1) bs
+ W4.andPred w4sym pb pbs
+
+ bitIs :: Bool -> W4.Pred sym -> IO (W4.Pred sym)
+ bitIs b x = if b then pure x else W4.notPred w4sym x
+
+updateFrontSym ::
+ W4.IsSymExprBuilder sym =>
+ What4 sym ->
+ Nat' ->
+ TValue ->
+ SeqMap (What4 sym) ->
+ Either (SInteger (What4 sym)) (WordValue (What4 sym)) ->
+ SEval (What4 sym) (Value sym) ->
+ SEval (What4 sym) (SeqMap (What4 sym))
+updateFrontSym sym _len _eltTy vs (Left idx) val =
+ case W4.asInteger idx of
+ Just i -> return $ updateSeqMap vs i val
+ Nothing -> return $ IndexSeqMap $ \i ->
+ do b <- intEq sym idx =<< integerLit sym i
+ iteValue sym b val (lookupSeqMap vs i)
+
+updateFrontSym sym _len _eltTy vs (Right wv) val =
+ case wv of
+ WordVal w | Just j <- SW.bvAsUnsignedInteger w ->
+ return $ updateSeqMap vs j val
+ _ ->
+ memoMap $ IndexSeqMap $ \i ->
+ do b <- wordValueEqualsInteger sym wv i
+ iteValue sym b val (lookupSeqMap vs i)
+
+updateBackSym ::
+ W4.IsSymExprBuilder sym =>
+ What4 sym ->
+ Nat' ->
+ TValue ->
+ SeqMap (What4 sym) ->
+ Either (SInteger (What4 sym)) (WordValue (What4 sym)) ->
+ SEval (What4 sym) (Value sym) ->
+ SEval (What4 sym) (SeqMap (What4 sym))
+updateBackSym _ Inf _ _ _ _ = evalPanic "Expected finite sequence" ["updateBackSym"]
+
+updateBackSym sym (Nat n) _eltTy vs (Left idx) val =
+ case W4.asInteger idx of
+ Just i -> return $ updateSeqMap vs (n - 1 - i) val
+ Nothing -> return $ IndexSeqMap $ \i ->
+ do b <- intEq sym idx =<< integerLit sym (n - 1 - i)
+ iteValue sym b val (lookupSeqMap vs i)
+
+updateBackSym sym (Nat n) _eltTy vs (Right wv) val =
+ case wv of
+ WordVal w | Just j <- SW.bvAsUnsignedInteger w ->
+ return $ updateSeqMap vs (n - 1 - j) val
+ _ ->
+ memoMap $ IndexSeqMap $ \i ->
+ do b <- wordValueEqualsInteger sym wv (n - 1 - i)
+ iteValue sym b val (lookupSeqMap vs i)
+
+
+updateFrontSym_word ::
+ W4.IsSymExprBuilder sym =>
+ What4 sym ->
+ Nat' ->
+ TValue ->
+ WordValue (What4 sym) ->
+ Either (SInteger (What4 sym)) (WordValue (What4 sym)) ->
+ SEval (What4 sym) (GenValue (What4 sym)) ->
+ SEval (What4 sym) (WordValue (What4 sym))
+updateFrontSym_word _ Inf _ _ _ _ = evalPanic "Expected finite sequence" ["updateFrontSym_word"]
+
+updateFrontSym_word sym (Nat _) eltTy (LargeBitsVal n bv) idx val =
+ LargeBitsVal n <$> updateFrontSym sym (Nat n) eltTy bv idx val
+
+updateFrontSym_word sym (Nat n) eltTy (WordVal bv) (Left idx) val =
+ do idx' <- wordFromInt sym n idx
+ updateFrontSym_word sym (Nat n) eltTy (WordVal bv) (Right (WordVal idx')) val
+
+updateFrontSym_word sym (Nat n) eltTy bv (Right wv) val =
+ case wv of
+ WordVal idx
+ | Just j <- SW.bvAsUnsignedInteger idx ->
+ updateWordValue sym bv j (fromVBit <$> val)
+
+ | WordVal bw <- bv ->
+ WordVal <$>
+ do b <- fromVBit <$> val
+ let sz = SW.bvWidth bw
+ highbit <- liftIO (SW.bvLit (w4 sym) sz (bit (fromInteger (sz-1))))
+ msk <- w4bvLshr (w4 sym) highbit idx
+ liftIO $
+ case W4.asConstantPred b of
+ Just True -> SW.bvOr (w4 sym) bw msk
+ Just False -> SW.bvAnd (w4 sym) bw =<< SW.bvNot (w4 sym) msk
+ Nothing ->
+ do q <- SW.bvFill (w4 sym) sz b
+ bw' <- SW.bvAnd (w4 sym) bw =<< SW.bvNot (w4 sym) msk
+ SW.bvXor (w4 sym) bw' =<< SW.bvAnd (w4 sym) q msk
+
+ _ -> LargeBitsVal (wordValueSize sym wv) <$>
+ updateFrontSym sym (Nat n) eltTy (asBitsMap sym bv) (Right wv) val
+
+
+updateBackSym_word ::
+ W4.IsSymExprBuilder sym =>
+ What4 sym ->
+ Nat' ->
+ TValue ->
+ WordValue (What4 sym) ->
+ Either (SInteger (What4 sym)) (WordValue (What4 sym)) ->
+ SEval (What4 sym) (GenValue (What4 sym)) ->
+ SEval (What4 sym) (WordValue (What4 sym))
+updateBackSym_word _ Inf _ _ _ _ = evalPanic "Expected finite sequence" ["updateBackSym_word"]
+
+updateBackSym_word sym (Nat _) eltTy (LargeBitsVal n bv) idx val =
+ LargeBitsVal n <$> updateBackSym sym (Nat n) eltTy bv idx val
+
+updateBackSym_word sym (Nat n) eltTy (WordVal bv) (Left idx) val =
+ do idx' <- wordFromInt sym n idx
+ updateBackSym_word sym (Nat n) eltTy (WordVal bv) (Right (WordVal idx')) val
+
+updateBackSym_word sym (Nat n) eltTy bv (Right wv) val =
+ case wv of
+ WordVal idx
+ | Just j <- SW.bvAsUnsignedInteger idx ->
+ updateWordValue sym bv (n - 1 - j) (fromVBit <$> val)
+
+ | WordVal bw <- bv ->
+ WordVal <$>
+ do b <- fromVBit <$> val
+ let sz = SW.bvWidth bw
+ lowbit <- liftIO (SW.bvLit (w4 sym) sz 1)
+ msk <- w4bvShl (w4 sym) lowbit idx
+ liftIO $
+ case W4.asConstantPred b of
+ Just True -> SW.bvOr (w4 sym) bw msk
+ Just False -> SW.bvAnd (w4 sym) bw =<< SW.bvNot (w4 sym) msk
+ Nothing ->
+ do q <- SW.bvFill (w4 sym) sz b
+ bw' <- SW.bvAnd (w4 sym) bw =<< SW.bvNot (w4 sym) msk
+ SW.bvXor (w4 sym) bw' =<< SW.bvAnd (w4 sym) q msk
+
+ _ -> LargeBitsVal (wordValueSize sym wv) <$>
+ updateBackSym sym (Nat n) eltTy (asBitsMap sym bv) (Right wv) val
+
+
+
+
+-- | Table of floating point primitives
+floatPrims :: W4.IsSymExprBuilder sym => What4 sym -> Map PrimIdent (Value sym)
+floatPrims sym =
+ Map.fromList [ (floatPrim i,v) | (i,v) <- nonInfixTable ]
+ where
+ w4sym = w4 sym
+ (~>) = (,)
+
+ nonInfixTable =
+ [ "fpNaN" ~> fpConst (W4.fpNaN w4sym)
+ , "fpPosInf" ~> fpConst (W4.fpPosInf w4sym)
+ , "fpFromBits" ~> ilam \e -> ilam \p -> wlam sym \w ->
+ VFloat <$> liftIO (W4.fpFromBinary w4sym e p w)
+ , "fpToBits" ~> ilam \e -> ilam \p -> flam \x ->
+ pure $ VWord (e+p)
+ $ WordVal <$> liftIO (W4.fpToBinary w4sym x)
+ , "=.=" ~> ilam \_ -> ilam \_ -> flam \x -> pure $ flam \y ->
+ VBit <$> liftIO (W4.fpEq w4sym x y)
+ , "fpIsFinite" ~> ilam \_ -> ilam \_ -> flam \x ->
+ VBit <$> liftIO do inf <- W4.fpIsInf w4sym x
+ nan <- W4.fpIsNaN w4sym x
+ weird <- W4.orPred w4sym inf nan
+ W4.notPred w4sym weird
+
+ , "fpAdd" ~> fpBinArithV sym fpPlus
+ , "fpSub" ~> fpBinArithV sym fpMinus
+ , "fpMul" ~> fpBinArithV sym fpMult
+ , "fpDiv" ~> fpBinArithV sym fpDiv
+
+ , "fpFromRational" ~>
+ ilam \e -> ilam \p -> wlam sym \r -> pure $ lam \x ->
+ do rat <- fromVRational <$> x
+ VFloat <$> fpCvtFromRational sym e p r rat
+
+ , "fpToRational" ~>
+ ilam \_e -> ilam \_p -> flam \fp ->
+ VRational <$> fpCvtToRational sym fp
+ ]
+
+
+
+-- | A helper for definitng floating point constants.
+fpConst ::
+ W4.IsSymExprBuilder sym =>
+ (Integer -> Integer -> IO (W4.SFloat sym)) ->
+ Value sym
+fpConst mk =
+ ilam \ e ->
+ VNumPoly \ ~(Nat p) ->
+ VFloat <$> liftIO (mk e p)
diff --git a/src/Cryptol/Eval/What4/Float.hs b/src/Cryptol/Eval/What4/Float.hs
deleted file mode 100644
--- a/src/Cryptol/Eval/What4/Float.hs
+++ /dev/null
@@ -1,68 +0,0 @@
-{-# Language BlockArguments #-}
-{-# Language OverloadedStrings #-}
--- | Floating point primitives for the What4 backend.
-module Cryptol.Eval.What4.Float (floatPrims) where
-
-import Data.Map(Map)
-import qualified Data.Map as Map
-import qualified What4.Interface as W4
-import Control.Monad.IO.Class
-
-import Cryptol.TypeCheck.Solver.InfNat(Nat'(..))
-import Cryptol.Eval.Value
-import Cryptol.Eval.Generic
-import Cryptol.Eval.What4.Value
-import qualified Cryptol.Eval.What4.SFloat as W4
-import Cryptol.Utils.Ident(PrimIdent, floatPrim)
-
--- | Table of floating point primitives
-floatPrims :: W4.IsSymExprBuilder sym => What4 sym -> Map PrimIdent (Value sym)
-floatPrims sym4@(What4 sym) =
- Map.fromList [ (floatPrim i,v) | (i,v) <- nonInfixTable ]
- where
- (~>) = (,)
-
- nonInfixTable =
- [ "fpNaN" ~> fpConst (W4.fpNaN sym)
- , "fpPosInf" ~> fpConst (W4.fpPosInf sym)
- , "fpFromBits" ~> ilam \e -> ilam \p -> wlam sym4 \w ->
- VFloat <$> liftIO (W4.fpFromBinary sym e p w)
- , "fpToBits" ~> ilam \e -> ilam \p -> flam \x ->
- pure $ VWord (e+p)
- $ WordVal <$> liftIO (W4.fpToBinary sym x)
- , "=.=" ~> ilam \_ -> ilam \_ -> flam \x -> pure $ flam \y ->
- VBit <$> liftIO (W4.fpEq sym x y)
- , "fpIsFinite" ~> ilam \_ -> ilam \_ -> flam \x ->
- VBit <$> liftIO do inf <- W4.fpIsInf sym x
- nan <- W4.fpIsNaN sym x
- weird <- W4.orPred sym inf nan
- W4.notPred sym weird
-
- , "fpAdd" ~> fpBinArithV sym4 fpPlus
- , "fpSub" ~> fpBinArithV sym4 fpMinus
- , "fpMul" ~> fpBinArithV sym4 fpMult
- , "fpDiv" ~> fpBinArithV sym4 fpDiv
-
- , "fpFromRational" ~>
- ilam \e -> ilam \p -> wlam sym4 \r -> pure $ lam \x ->
- do rat <- fromVRational <$> x
- VFloat <$> fpCvtFromRational sym4 e p r rat
-
- , "fpToRational" ~>
- ilam \_e -> ilam \_p -> flam \fp ->
- VRational <$> fpCvtToRational sym4 fp
- ]
-
-
-
--- | A helper for definitng floating point constants.
-fpConst ::
- W4.IsExprBuilder sym =>
- (Integer -> Integer -> IO (W4.SFloat sym)) ->
- Value sym
-fpConst mk =
- ilam \ e ->
- VNumPoly \ ~(Nat p) ->
- VFloat <$> liftIO (mk e p)
-
-
diff --git a/src/Cryptol/Eval/What4/SFloat.hs b/src/Cryptol/Eval/What4/SFloat.hs
deleted file mode 100644
--- a/src/Cryptol/Eval/What4/SFloat.hs
+++ /dev/null
@@ -1,361 +0,0 @@
-{-# Language DataKinds #-}
-{-# Language FlexibleContexts #-}
-{-# Language GADTs #-}
-{-# Language RankNTypes #-}
-{-# Language TypeApplications #-}
-{-# Language TypeOperators #-}
--- | Working with floats of dynamic sizes.
--- This should probably be moved to What4 one day.
-module Cryptol.Eval.What4.SFloat
- ( -- * Interface
- SFloat(..)
- , fpReprOf
- , fpSize
-
- -- * Constants
- , fpFresh
- , fpNaN
- , fpPosInf
- , fpFromRationalLit
-
- -- * Interchange formats
- , fpFromBinary
- , fpToBinary
-
- -- * Relations
- , SFloatRel
- , fpEq
- , fpEqIEEE
- , fpLtIEEE
- , fpGtIEEE
-
- -- * Arithmetic
- , SFloatBinArith
- , fpNeg
- , fpAdd
- , fpSub
- , fpMul
- , fpDiv
-
- -- * Conversions
- , fpRound
- , fpToReal
- , fpFromReal
- , fpFromRational
- , fpToRational
- , fpFromInteger
-
- -- * Queries
- , fpIsInf, fpIsNaN
-
- -- * Exceptions
- , UnsupportedFloat(..)
- , FPTypeError(..)
- ) where
-
-import Control.Exception
-
-import Data.Parameterized.Some
-import Data.Parameterized.NatRepr
-
-import What4.BaseTypes
-import What4.Panic(panic)
-import What4.SWord
-import What4.Interface
-
--- | Symbolic floating point numbers.
-data SFloat sym where
- SFloat :: IsExpr (SymExpr sym) => SymFloat sym fpp -> SFloat sym
-
-
-
---------------------------------------------------------------------------------
-
--- | This exception is thrown if the operations try to create a
--- floating point value we do not support
-data UnsupportedFloat =
- UnsupportedFloat { fpWho :: String, exponentBits, precisionBits :: Integer }
- deriving Show
-
-
--- | Throw 'UnsupportedFloat' exception
-unsupported ::
- String {- ^ Label -} ->
- Integer {- ^ Exponent width -} ->
- Integer {- ^ Precision width -} ->
- IO a
-unsupported l e p =
- throwIO UnsupportedFloat { fpWho = l
- , exponentBits = e
- , precisionBits = p }
-
-instance Exception UnsupportedFloat
-
--- | This exceptoin is throws if the types don't match.
-data FPTypeError =
- FPTypeError { fpExpected :: Some BaseTypeRepr
- , fpActual :: Some BaseTypeRepr
- }
- deriving Show
-
-instance Exception FPTypeError
-
-fpTypeMismatch :: BaseTypeRepr t1 -> BaseTypeRepr t2 -> IO a
-fpTypeMismatch expect actual =
- throwIO FPTypeError { fpExpected = Some expect
- , fpActual = Some actual
- }
-fpTypeError :: FloatPrecisionRepr t1 -> FloatPrecisionRepr t2 -> IO a
-fpTypeError t1 t2 =
- fpTypeMismatch (BaseFloatRepr t1) (BaseFloatRepr t2)
-
-
---------------------------------------------------------------------------------
--- | Construct the 'FloatPrecisionRepr' with the given parameters.
-fpRepr ::
- Integer {- ^ Exponent width -} ->
- Integer {- ^ Precision width -} ->
- Maybe (Some FloatPrecisionRepr)
-fpRepr iE iP =
- do Some e <- someNat iE
- LeqProof <- testLeq (knownNat @2) e
- Some p <- someNat iP
- LeqProof <- testLeq (knownNat @2) p
- pure (Some (FloatingPointPrecisionRepr e p))
-
-fpReprOf ::
- IsExpr (SymExpr sym) => sym -> SymFloat sym fpp -> FloatPrecisionRepr fpp
-fpReprOf _ e =
- case exprType e of
- BaseFloatRepr r -> r
-
-fpSize :: SFloat sym -> (Integer,Integer)
-fpSize (SFloat f) =
- case exprType f of
- BaseFloatRepr (FloatingPointPrecisionRepr e p) -> (intValue e, intValue p)
-
-
---------------------------------------------------------------------------------
--- Constants
-
--- | A fresh variable of the given type.
-fpFresh ::
- IsSymExprBuilder sym =>
- sym ->
- Integer ->
- Integer ->
- IO (SFloat sym)
-fpFresh sym e p
- | Just (Some fpp) <- fpRepr e p =
- SFloat <$> freshConstant sym emptySymbol (BaseFloatRepr fpp)
- | otherwise = unsupported "fpFresh" e p
-
--- | Not a number
-fpNaN ::
- IsExprBuilder sym =>
- sym ->
- Integer {- ^ Exponent width -} ->
- Integer {- ^ Precision width -} ->
- IO (SFloat sym)
-fpNaN sym e p
- | Just (Some fpp) <- fpRepr e p = SFloat <$> floatNaN sym fpp
- | otherwise = unsupported "fpNaN" e p
-
-
--- | Positive infinity
-fpPosInf ::
- IsExprBuilder sym =>
- sym ->
- Integer {- ^ Exponent width -} ->
- Integer {- ^ Precision width -} ->
- IO (SFloat sym)
-fpPosInf sym e p
- | Just (Some fpp) <- fpRepr e p = SFloat <$> floatPInf sym fpp
- | otherwise = unsupported "fpPosInf" e p
-
--- | A floating point number corresponding to the given rations.
-fpFromRationalLit ::
- IsExprBuilder sym =>
- sym ->
- Integer {- ^ Exponent width -} ->
- Integer {- ^ Precision width -} ->
- Rational ->
- IO (SFloat sym)
-fpFromRationalLit sym e p r
- | Just (Some fpp) <- fpRepr e p = SFloat <$> floatLit sym fpp r
- | otherwise = unsupported "fpFromRational" e p
-
-
--- | Make a floating point number with the given bit representation.
-fpFromBinary ::
- IsExprBuilder sym =>
- sym ->
- Integer {- ^ Exponent width -} ->
- Integer {- ^ Precision width -} ->
- SWord sym ->
- IO (SFloat sym)
-fpFromBinary sym e p swe
- | DBV sw <- swe
- , Just (Some fpp) <- fpRepr e p
- , FloatingPointPrecisionRepr ew pw <- fpp
- , let expectW = addNat ew pw
- , actual@(BaseBVRepr actualW) <- exprType sw =
- case testEquality expectW actualW of
- Just Refl -> SFloat <$> floatFromBinary sym fpp sw
- Nothing -- we want to report type correct type errors! :-)
- | Just LeqProof <- testLeq (knownNat @1) expectW ->
- fpTypeMismatch (BaseBVRepr expectW) actual
- | otherwise -> panic "fpFromBits" [ "1 >= 2" ]
- | otherwise = unsupported "fpFromBits" e p
-
-fpToBinary :: IsExprBuilder sym => sym -> SFloat sym -> IO (SWord sym)
-fpToBinary sym (SFloat f)
- | FloatingPointPrecisionRepr e p <- fpReprOf sym f
- , Just LeqProof <- testLeq (knownNat @1) (addNat e p)
- = DBV <$> floatToBinary sym f
- | otherwise = panic "fpToBinary" [ "we messed up the types" ]
-
-
---------------------------------------------------------------------------------
--- Arithmetic
-
-fpNeg :: IsExprBuilder sym => sym -> SFloat sym -> IO (SFloat sym)
-fpNeg sym (SFloat fl) = SFloat <$> floatNeg sym fl
-
-fpBinArith ::
- IsExprBuilder sym =>
- (forall t.
- sym ->
- RoundingMode ->
- SymFloat sym t ->
- SymFloat sym t ->
- IO (SymFloat sym t)
- ) ->
- sym -> RoundingMode -> SFloat sym -> SFloat sym -> IO (SFloat sym)
-fpBinArith fun sym r (SFloat x) (SFloat y) =
- let t1 = sym `fpReprOf` x
- t2 = sym `fpReprOf` y
- in
- case testEquality t1 t2 of
- Just Refl -> SFloat <$> fun sym r x y
- _ -> fpTypeError t1 t2
-
-type SFloatBinArith sym =
- sym -> RoundingMode -> SFloat sym -> SFloat sym -> IO (SFloat sym)
-
-fpAdd :: IsExprBuilder sym => SFloatBinArith sym
-fpAdd = fpBinArith floatAdd
-
-fpSub :: IsExprBuilder sym => SFloatBinArith sym
-fpSub = fpBinArith floatSub
-
-fpMul :: IsExprBuilder sym => SFloatBinArith sym
-fpMul = fpBinArith floatMul
-
-fpDiv :: IsExprBuilder sym => SFloatBinArith sym
-fpDiv = fpBinArith floatDiv
-
-
-
-
---------------------------------------------------------------------------------
-
-fpRel ::
- IsExprBuilder sym =>
- (forall t.
- sym ->
- SymFloat sym t ->
- SymFloat sym t ->
- IO (Pred sym)
- ) ->
- sym -> SFloat sym -> SFloat sym -> IO (Pred sym)
-fpRel fun sym (SFloat x) (SFloat y) =
- let t1 = sym `fpReprOf` x
- t2 = sym `fpReprOf` y
- in
- case testEquality t1 t2 of
- Just Refl -> fun sym x y
- _ -> fpTypeError t1 t2
-
-
-
-
-type SFloatRel sym =
- sym -> SFloat sym -> SFloat sym -> IO (Pred sym)
-
-fpEq :: IsExprBuilder sym => SFloatRel sym
-fpEq = fpRel floatEq
-
-fpEqIEEE :: IsExprBuilder sym => SFloatRel sym
-fpEqIEEE = fpRel floatFpEq
-
-fpLtIEEE :: IsExprBuilder sym => SFloatRel sym
-fpLtIEEE = fpRel floatLt
-
-fpGtIEEE :: IsExprBuilder sym => SFloatRel sym
-fpGtIEEE = fpRel floatGt
-
-
---------------------------------------------------------------------------------
-fpRound ::
- IsExprBuilder sym => sym -> RoundingMode -> SFloat sym -> IO (SFloat sym)
-fpRound sym r (SFloat x) = SFloat <$> floatRound sym r x
-
--- | This is undefined on "special" values (NaN,infinity)
-fpToReal :: IsExprBuilder sym => sym -> SFloat sym -> IO (SymReal sym)
-fpToReal sym (SFloat x) = floatToReal sym x
-
-fpFromReal ::
- IsExprBuilder sym =>
- sym -> Integer -> Integer -> RoundingMode -> SymReal sym -> IO (SFloat sym)
-fpFromReal sym e p r x
- | Just (Some repr) <- fpRepr e p = SFloat <$> realToFloat sym repr r x
- | otherwise = unsupported "fpFromReal" e p
-
-
-fpFromInteger ::
- IsExprBuilder sym =>
- sym -> Integer -> Integer -> RoundingMode -> SymInteger sym -> IO (SFloat sym)
-fpFromInteger sym e p r x = fpFromReal sym e p r =<< integerToReal sym x
-
-
-fpFromRational ::
- IsExprBuilder sym =>
- sym -> Integer -> Integer -> RoundingMode ->
- SymInteger sym -> SymInteger sym -> IO (SFloat sym)
-fpFromRational sym e p r x y =
- do num <- integerToReal sym x
- den <- integerToReal sym y
- res <- realDiv sym num den
- fpFromReal sym e p r res
-
-{- | Returns a predicate and two integers, @x@ and @y@.
-If the the predicate holds, then @x / y@ is a rational representing
-the floating point number. Assumes the FP number is not one of the
-special ones that has no real representation. -}
-fpToRational ::
- IsSymExprBuilder sym =>
- sym ->
- SFloat sym ->
- IO (Pred sym, SymInteger sym, SymInteger sym)
-fpToRational sym fp =
- do r <- fpToReal sym fp
- x <- freshConstant sym emptySymbol BaseIntegerRepr
- y <- freshConstant sym emptySymbol BaseIntegerRepr
- num <- integerToReal sym x
- den <- integerToReal sym y
- res <- realDiv sym num den
- same <- realEq sym r res
- pure (same, x, y)
-
-
-
---------------------------------------------------------------------------------
-fpIsInf :: IsExprBuilder sym => sym -> SFloat sym -> IO (Pred sym)
-fpIsInf sym (SFloat x) = floatIsInf sym x
-
-fpIsNaN :: IsExprBuilder sym => sym -> SFloat sym -> IO (Pred sym)
-fpIsNaN sym (SFloat x) = floatIsNaN sym x
-
-
-
diff --git a/src/Cryptol/Eval/What4/Value.hs b/src/Cryptol/Eval/What4/Value.hs
deleted file mode 100644
--- a/src/Cryptol/Eval/What4/Value.hs
+++ /dev/null
@@ -1,975 +0,0 @@
--- |
--- Module : Cryptol.Eval.What4
--- Copyright : (c) 2020 Galois, Inc.
--- License : BSD3
--- Maintainer : cryptol@galois.com
-
-{-# LANGUAGE BlockArguments #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE ViewPatterns #-}
-module Cryptol.Eval.What4.Value where
-
-
-import qualified Control.Exception as X
-import Control.Monad (foldM,ap,liftM)
-import Control.Monad.IO.Class
-import Data.Bits (bit, shiftR, shiftL, testBit)
-import qualified Data.BitVector.Sized as BV
-import Data.List
-import Data.Parameterized.NatRepr
-import Data.Parameterized.Some
-
-import qualified What4.Interface as W4
-import qualified What4.SWord as SW
-import qualified Cryptol.Eval.What4.SFloat as FP
-import qualified What4.Utils.AbstractDomains as W4
-
-import Cryptol.Eval.Backend
-import Cryptol.Eval.Concrete.Value( BV(..), ppBV )
-import Cryptol.Eval.Generic
-import Cryptol.Eval.Monad
- ( Eval(..), EvalError(..), Unsupported(..)
- , delayFill, blackhole, evalSpark
- )
-import Cryptol.Eval.Type (TValue(..))
-import Cryptol.Eval.Value
-import Cryptol.TypeCheck.Solver.InfNat (Nat'(..), widthInteger)
-import Cryptol.Utils.Panic
-import Cryptol.Utils.PP
-
-
-data What4 sym = What4 sym
-
-type Value sym = GenValue (What4 sym)
-
-{- | This is the monad used for symbolic evaluation. It adds to
-aspects to 'Eval'---'WConn' keeps track of the backend and collects
-definitional predicates, and 'W4Eval` adds support for partially
-defined values -}
-newtype W4Eval sym a = W4Eval { evalPartial :: W4Conn sym (W4Result sym a) }
-
-{- | This layer has the symbolic back-end, and can keep track of definitional
-predicates used when working with uninterpreted constants defined
-via a property. -}
-newtype W4Conn sym a = W4Conn { evalConn :: sym -> Eval (W4Defs sym a) }
-
--- | Keep track of a value and a context defining uninterpeted vairables.
-data W4Defs sym a = W4Defs
- { w4Defs :: !(W4.Pred sym)
- , w4Result :: !a
- }
-
--- | The symbolic value we computed.
-data W4Result sym a
- = W4Error !EvalError
- -- ^ A malformed value
-
- | W4Result !(W4.Pred sym) !a
- -- ^ safety predicate and result: the result only makes sense when
- -- the predicate holds.
-
-
---------------------------------------------------------------------------------
--- Moving between the layers
-
-w4Eval :: W4Eval sym a -> sym -> Eval (W4Defs sym (W4Result sym a))
-w4Eval (W4Eval (W4Conn m)) = m
-
-w4Thunk :: Eval (W4Defs sym (W4Result sym a)) -> W4Eval sym a
-w4Thunk m = W4Eval (W4Conn \_ -> m)
-
--- | A value with no context.
-doEval :: W4.IsExprBuilder sym => Eval a -> W4Conn sym a
-doEval m = W4Conn \sym ->
- do a <- m
- pure W4Defs { w4Defs = W4.backendPred sym True
- , w4Result = a
- }
-
--- | A total value.
-total :: W4.IsExprBuilder sym => W4Conn sym a -> W4Eval sym a
-total m = W4Eval
- do sym <- getSym
- W4Result (W4.backendPred sym True) <$> m
-
-
-
---------------------------------------------------------------------------------
--- Operations in WConn
-
-instance W4.IsExprBuilder sym => Functor (W4Conn sym) where
- fmap = liftM
-
-instance W4.IsExprBuilder sym => Applicative (W4Conn sym) where
- pure = doEval . pure
- (<*>) = ap
-
-instance W4.IsExprBuilder sym => Monad (W4Conn sym) where
- m1 >>= f = W4Conn \sym ->
- do res1 <- evalConn m1 sym
- res2 <- evalConn (f (w4Result res1)) sym
- defs <- liftIO (W4.andPred sym (w4Defs res1) (w4Defs res2))
- pure res2 { w4Defs = defs }
-
-instance W4.IsExprBuilder sym => MonadIO (W4Conn sym) where
- liftIO = doEval . liftIO
-
--- | Access the symbolic back-end
-getSym :: W4.IsExprBuilder sym => W4Conn sym sym
-getSym = W4Conn \sym -> pure W4Defs { w4Defs = W4.backendPred sym True
- , w4Result = sym }
-
--- | Record a definition.
-addDef :: W4.Pred sym -> W4Conn sym ()
-addDef p = W4Conn \_ -> pure W4Defs { w4Defs = p, w4Result = () }
-
--- | Compute conjunction.
-w4And :: W4.IsExprBuilder sym =>
- W4.Pred sym -> W4.Pred sym -> W4Conn sym (W4.Pred sym)
-w4And p q =
- do sym <- getSym
- liftIO (W4.andPred sym p q)
-
--- | Compute negation.
-w4Not :: W4.IsExprBuilder sym => W4.Pred sym -> W4Conn sym (W4.Pred sym)
-w4Not p =
- do sym <- getSym
- liftIO (W4.notPred sym p)
-
--- | Compute if-then-else.
-w4ITE :: W4.IsExprBuilder sym =>
- W4.Pred sym -> W4.Pred sym -> W4.Pred sym -> W4Conn sym (W4.Pred sym)
-w4ITE ifP ifThen ifElse =
- do sym <- getSym
- liftIO (W4.itePred sym ifP ifThen ifElse)
-
-
-
---------------------------------------------------------------------------------
--- Operations in W4Eval
-
-instance W4.IsExprBuilder sym => Functor (W4Eval sym) where
- fmap = liftM
-
-instance W4.IsExprBuilder sym => Applicative (W4Eval sym) where
- pure = total . pure
- (<*>) = ap
-
-instance W4.IsExprBuilder sym => Monad (W4Eval sym) where
- m1 >>= f = W4Eval
- do res1 <- evalPartial m1
- case res1 of
- W4Error err -> pure (W4Error err)
- W4Result px x' ->
- do res2 <- evalPartial (f x')
- case res2 of
- W4Result py y ->
- do pz <- w4And px py
- pure (W4Result pz y)
- W4Error _ -> pure res2
-
-instance W4.IsExprBuilder sym => MonadIO (W4Eval sym) where
- liftIO = total . liftIO
-
-
--- | Add a definitional equation.
--- This will always be asserted when we make queries to the solver.
-addDefEqn :: W4.IsExprBuilder sym => W4.Pred sym -> W4Eval sym ()
-addDefEqn p = total (addDef p)
-
--- | Add s safety condition.
-addSafety :: W4.IsExprBuilder sym => W4.Pred sym -> W4Eval sym ()
-addSafety p = W4Eval (pure (W4Result p ()))
-
--- | A fully undefined symbolic value
-evalError :: W4.IsExprBuilder sym => EvalError -> W4Eval sym a
-evalError err = W4Eval (pure (W4Error err))
---------------------------------------------------------------------------------
-
-
-assertBVDivisor :: W4.IsExprBuilder sym => sym -> SW.SWord sym -> W4Eval sym ()
-assertBVDivisor sym x =
- do p <- liftIO (SW.bvIsNonzero sym x)
- assertSideCondition (What4 sym) p DivideByZero
-
-assertIntDivisor ::
- W4.IsExprBuilder sym => sym -> W4.SymInteger sym -> W4Eval sym ()
-assertIntDivisor sym x =
- do p <- liftIO (W4.notPred sym =<< W4.intEq sym x =<< W4.intLit sym 0)
- assertSideCondition (What4 sym) p DivideByZero
-
-
-
-instance W4.IsExprBuilder sym => Backend (What4 sym) where
- type SBit (What4 sym) = W4.Pred sym
- type SWord (What4 sym) = SW.SWord sym
- type SInteger (What4 sym) = W4.SymInteger sym
- type SFloat (What4 sym) = FP.SFloat sym
- type SEval (What4 sym) = W4Eval sym
-
- raiseError _ = evalError
-
- assertSideCondition _ cond err
- | Just False <- W4.asConstantPred cond = evalError err
- | otherwise = addSafety cond
-
- isReady (What4 sym) m =
- case w4Eval m sym of
- Ready _ -> True
- _ -> False
-
- sDelayFill _ m retry =
- total
- do sym <- getSym
- doEval (w4Thunk <$> delayFill (w4Eval m sym) (w4Eval retry sym))
-
- sSpark _ m =
- total
- do sym <- getSym
- doEval (w4Thunk <$> evalSpark (w4Eval m sym))
-
-
- sDeclareHole _ msg =
- total
- do (hole, fill) <- doEval (blackhole msg)
- pure ( w4Thunk hole
- , \m -> total
- do sym <- getSym
- doEval (fill (w4Eval m sym))
- )
-
- mergeEval _sym f c mx my = W4Eval
- do rx <- evalPartial mx
- ry <- evalPartial my
- case (rx, ry) of
-
- (W4Error err, W4Error _) ->
- pure (W4Error err) -- arbitrarily choose left error to report
-
- (W4Error _, W4Result p y) ->
- do p' <- w4And p =<< w4Not c
- pure (W4Result p' y)
-
- (W4Result p x, W4Error _) ->
- do p' <- w4And p c
- pure (W4Result p' x)
-
- (W4Result px x, W4Result py y) ->
- do zr <- evalPartial (f c x y)
- case zr of
- W4Error err -> pure $ W4Error err
- W4Result pz z ->
- do p' <- w4And pz =<< w4ITE c px py
- pure (W4Result p' z)
-
- wordAsChar _ bv
- | SW.bvWidth bv == 8 = toEnum . fromInteger <$> SW.bvAsUnsignedInteger bv
- | otherwise = Nothing
-
- wordLen _ bv = SW.bvWidth bv
-
- bitLit (What4 sym) b = W4.backendPred sym b
- bitAsLit _ v = W4.asConstantPred v
-
- wordLit (What4 sym) intw i
- | Just (Some w) <- someNat intw
- = case isPosNat w of
- Nothing -> pure $ SW.ZBV
- Just LeqProof -> SW.DBV <$> liftIO (W4.bvLit sym w (BV.mkBV w i))
- | otherwise = panic "what4: wordLit" ["invalid bit width:", show intw ]
-
- wordAsLit _ v
- | Just x <- SW.bvAsUnsignedInteger v = Just (SW.bvWidth v, x)
- | otherwise = Nothing
-
- integerLit (What4 sym) i = liftIO (W4.intLit sym i)
-
- integerAsLit _ v = W4.asInteger v
-
- ppBit _ v
- | Just b <- W4.asConstantPred v = text $! if b then "True" else "False"
- | otherwise = text "?"
-
- ppWord _ opts v
- | Just x <- SW.bvAsUnsignedInteger v
- = ppBV opts (BV (SW.bvWidth v) x)
-
- | otherwise = text "[?]"
-
- ppInteger _ _opts v
- | Just x <- W4.asInteger v = integer x
- | otherwise = text "[?]"
-
- ppFloat _ _opts _ = text "[?]"
-
-
- iteBit (What4 sym) c x y = liftIO (W4.itePred sym c x y)
- iteWord (What4 sym) c x y = liftIO (SW.bvIte sym c x y)
- iteInteger (What4 sym) c x y = liftIO (W4.intIte sym c x y)
-
- bitEq (What4 sym) x y = liftIO (W4.eqPred sym x y)
- bitAnd (What4 sym) x y = liftIO (W4.andPred sym x y)
- bitOr (What4 sym) x y = liftIO (W4.orPred sym x y)
- bitXor (What4 sym) x y = liftIO (W4.xorPred sym x y)
- bitComplement (What4 sym) x = liftIO (W4.notPred sym x)
-
- wordBit (What4 sym) bv idx = liftIO (SW.bvAtBE sym bv idx)
- wordUpdate (What4 sym) bv idx b = liftIO (SW.bvSetBE sym bv idx b)
-
- packWord sym bs =
- do z <- wordLit sym (genericLength bs) 0
- let f w (idx,b) = wordUpdate sym w idx b
- foldM f z (zip [0..] bs)
-
- unpackWord (What4 sym) bv = liftIO $
- mapM (SW.bvAtBE sym bv) [0 .. SW.bvWidth bv-1]
-
- joinWord (What4 sym) x y = liftIO $ SW.bvJoin sym x y
-
- splitWord _sym 0 _ bv = pure (SW.ZBV, bv)
- splitWord _sym _ 0 bv = pure (bv, SW.ZBV)
- splitWord (What4 sym) lw rw bv = liftIO $
- do l <- SW.bvSliceBE sym 0 lw bv
- r <- SW.bvSliceBE sym lw rw bv
- return (l, r)
-
- extractWord (What4 sym) bits idx bv =
- liftIO $ SW.bvSliceBE sym idx bits bv
-
- wordEq (What4 sym) x y = liftIO (SW.bvEq sym x y)
- wordLessThan (What4 sym) x y = liftIO (SW.bvult sym x y)
- wordGreaterThan (What4 sym) x y = liftIO (SW.bvugt sym x y)
- wordSignedLessThan (What4 sym) x y = liftIO (SW.bvslt sym x y)
-
- wordOr (What4 sym) x y = liftIO (SW.bvOr sym x y)
- wordAnd (What4 sym) x y = liftIO (SW.bvAnd sym x y)
- wordXor (What4 sym) x y = liftIO (SW.bvXor sym x y)
- wordComplement (What4 sym) x = liftIO (SW.bvNot sym x)
-
- wordPlus (What4 sym) x y = liftIO (SW.bvAdd sym x y)
- wordMinus (What4 sym) x y = liftIO (SW.bvSub sym x y)
- wordMult (What4 sym) x y = liftIO (SW.bvMul sym x y)
- wordNegate (What4 sym) x = liftIO (SW.bvNeg sym x)
- wordLg2 (What4 sym) x = sLg2 sym x
-
- wordDiv (What4 sym) x y =
- do assertBVDivisor sym y
- liftIO (SW.bvUDiv sym x y)
- wordMod (What4 sym) x y =
- do assertBVDivisor sym y
- liftIO (SW.bvURem sym x y)
- wordSignedDiv (What4 sym) x y =
- do assertBVDivisor sym y
- liftIO (SW.bvSDiv sym x y)
- wordSignedMod (What4 sym) x y =
- do assertBVDivisor sym y
- liftIO (SW.bvSRem sym x y)
-
- wordToInt (What4 sym) x = liftIO (SW.bvToInteger sym x)
- wordFromInt (What4 sym) width i = liftIO (SW.integerToBV sym i width)
-
- intPlus (What4 sym) x y = liftIO $ W4.intAdd sym x y
- intMinus (What4 sym) x y = liftIO $ W4.intSub sym x y
- intMult (What4 sym) x y = liftIO $ W4.intMul sym x y
- intNegate (What4 sym) x = liftIO $ W4.intNeg sym x
-
- -- NB: What4's division operation provides SMTLib's euclidean division,
- -- which doesn't match the round-to-neg-infinity semantics of Cryptol,
- -- so we have to do some work to get the desired semantics.
- intDiv (What4 sym) x y =
- do assertIntDivisor sym y
- liftIO $ do
- neg <- liftIO (W4.intLt sym y =<< W4.intLit sym 0)
- case W4.asConstantPred neg of
- Just False -> W4.intDiv sym x y
- Just True ->
- do xneg <- W4.intNeg sym x
- yneg <- W4.intNeg sym y
- W4.intDiv sym xneg yneg
- Nothing ->
- do xneg <- W4.intNeg sym x
- yneg <- W4.intNeg sym y
- zneg <- W4.intDiv sym xneg yneg
- z <- W4.intDiv sym x y
- W4.intIte sym neg zneg z
-
- -- NB: What4's division operation provides SMTLib's euclidean division,
- -- which doesn't match the round-to-neg-infinity semantics of Cryptol,
- -- so we have to do some work to get the desired semantics.
- intMod (What4 sym) x y =
- do assertIntDivisor sym y
- liftIO $ do
- neg <- liftIO (W4.intLt sym y =<< W4.intLit sym 0)
- case W4.asConstantPred neg of
- Just False -> W4.intMod sym x y
- Just True ->
- do xneg <- W4.intNeg sym x
- yneg <- W4.intNeg sym y
- W4.intNeg sym =<< W4.intMod sym xneg yneg
- Nothing ->
- do xneg <- W4.intNeg sym x
- yneg <- W4.intNeg sym y
- z <- W4.intMod sym x y
- zneg <- W4.intNeg sym =<< W4.intMod sym xneg yneg
- W4.intIte sym neg zneg z
-
- intEq (What4 sym) x y = liftIO $ W4.intEq sym x y
- intLessThan (What4 sym) x y = liftIO $ W4.intLt sym x y
- intGreaterThan (What4 sym) x y = liftIO $ W4.intLt sym y x
-
- -- NB, we don't do reduction here on symbolic values
- intToZn (What4 sym) m x
- | Just xi <- W4.asInteger x
- = liftIO $ W4.intLit sym (xi `mod` m)
-
- | otherwise
- = pure x
-
- znToInt _ 0 _ = evalPanic "znToInt" ["0 modulus not allowed"]
- znToInt (What4 sym) m x = liftIO (W4.intMod sym x =<< W4.intLit sym m)
-
- znEq _ 0 _ _ = evalPanic "znEq" ["0 modulus not allowed"]
- znEq (What4 sym) m x y = liftIO $
- do diff <- W4.intSub sym x y
- W4.intDivisible sym diff (fromInteger m)
-
- znPlus (What4 sym) m x y = liftIO $ sModAdd sym m x y
- znMinus (What4 sym) m x y = liftIO $ sModSub sym m x y
- znMult (What4 sym) m x y = liftIO $ sModMult sym m x y
- znNegate (What4 sym) m x = liftIO $ sModNegate sym m x
-
- --------------------------------------------------------------
-
- fpLit (What4 sym) e p r = liftIO $ FP.fpFromRationalLit sym e p r
- fpEq (What4 sym) x y = liftIO $ FP.fpEqIEEE sym x y
- fpLessThan (What4 sym) x y = liftIO $ FP.fpLtIEEE sym x y
- fpGreaterThan (What4 sym) x y = liftIO $ FP.fpGtIEEE sym x y
-
- fpPlus = fpBinArith FP.fpAdd
- fpMinus = fpBinArith FP.fpSub
- fpMult = fpBinArith FP.fpMul
- fpDiv = fpBinArith FP.fpDiv
-
- fpNeg (What4 sym) x = liftIO $ FP.fpNeg sym x
-
- fpFromInteger sym@(What4 sy) e p r x =
- do rm <- fpRoundingMode sym r
- liftIO $ FP.fpFromInteger sy e p rm x
-
- fpToInteger = fpCvtToInteger
-
-sModAdd :: W4.IsExprBuilder sym =>
- sym -> Integer -> W4.SymInteger sym -> W4.SymInteger sym -> IO (W4.SymInteger sym)
-sModAdd _sym 0 _ _ = evalPanic "sModAdd" ["0 modulus not allowed"]
-sModAdd sym m x y
- | Just xi <- W4.asInteger x
- , Just yi <- W4.asInteger y
- = W4.intLit sym ((xi+yi) `mod` m)
-
- | otherwise
- = W4.intAdd sym x y
-
-sModSub :: W4.IsExprBuilder sym =>
- sym -> Integer -> W4.SymInteger sym -> W4.SymInteger sym -> IO (W4.SymInteger sym)
-sModSub _sym 0 _ _ = evalPanic "sModSub" ["0 modulus not allowed"]
-sModSub sym m x y
- | Just xi <- W4.asInteger x
- , Just yi <- W4.asInteger y
- = W4.intLit sym ((xi-yi) `mod` m)
-
- | otherwise
- = W4.intSub sym x y
-
-
-sModMult :: W4.IsExprBuilder sym =>
- sym -> Integer -> W4.SymInteger sym -> W4.SymInteger sym -> IO (W4.SymInteger sym)
-sModMult _sym 0 _ _ = evalPanic "sModMult" ["0 modulus not allowed"]
-sModMult sym m x y
- | Just xi <- W4.asInteger x
- , Just yi <- W4.asInteger y
- = W4.intLit sym ((xi*yi) `mod` m)
-
- | otherwise
- = W4.intMul sym x y
-
-sModNegate :: W4.IsExprBuilder sym =>
- sym -> Integer -> W4.SymInteger sym -> IO (W4.SymInteger sym)
-sModNegate _sym 0 _ = evalPanic "sModMult" ["0 modulus not allowed"]
-sModNegate sym m x
- | Just xi <- W4.asInteger x
- = W4.intLit sym ((negate xi) `mod` m)
-
- | otherwise
- = W4.intNeg sym x
-
-
--- | Try successive powers of 2 to find the first that dominates the input.
--- We could perhaps reduce to using CLZ instead...
-sLg2 :: W4.IsExprBuilder sym => sym -> SW.SWord sym -> SEval (What4 sym) (SW.SWord sym)
-sLg2 sym x = liftIO $ go 0
- where
- w = SW.bvWidth x
- lit n = SW.bvLit sym w (toInteger n)
-
- go i | toInteger i < w =
- do p <- SW.bvule sym x =<< lit (bit i)
- lazyIte (SW.bvIte sym) p (lit i) (go (i+1))
-
- -- base case, should only happen when i = w
- go i = lit i
-
-
-
--- Errors ----------------------------------------------------------------------
-
-evalPanic :: String -> [String] -> a
-evalPanic cxt = panic ("[What4 Symbolic]" ++ cxt)
-
-
-lazyIte ::
- (W4.IsExpr p, Monad m) =>
- (p W4.BaseBoolType -> a -> a -> m a) ->
- p W4.BaseBoolType ->
- m a ->
- m a ->
- m a
-lazyIte f c mx my
- | Just b <- W4.asConstantPred c = if b then mx else my
- | otherwise =
- do x <- mx
- y <- my
- f c x y
-
-indexFront_int ::
- W4.IsExprBuilder sym =>
- sym ->
- Nat' ->
- TValue ->
- SeqMap (What4 sym) ->
- TValue ->
- SInteger (What4 sym) ->
- SEval (What4 sym) (Value sym)
-indexFront_int sym mblen _a xs ix idx
- | Just i <- W4.asInteger idx
- = lookupSeqMap xs i
-
- | (lo, Just hi) <- bounds
- = foldr f def [lo .. hi]
-
- | otherwise
- = liftIO (X.throw (UnsupportedSymbolicOp "unbounded integer indexing"))
-
- where
- def = raiseError (What4 sym) (InvalidIndex Nothing)
-
- f n y =
- do p <- liftIO (W4.intEq sym idx =<< W4.intLit sym n)
- iteValue (What4 sym) p (lookupSeqMap xs n) y
-
- bounds =
- (case W4.rangeLowBound (W4.integerBounds idx) of
- W4.Inclusive l -> max l 0
- _ -> 0
- , case (maxIdx, W4.rangeHiBound (W4.integerBounds idx)) of
- (Just n, W4.Inclusive h) -> Just (min n h)
- (Just n, _) -> Just n
- _ -> Nothing
- )
-
- -- Maximum possible in-bounds index given `Z m`
- -- type information and the length
- -- of the sequence. If the sequences is infinite and the
- -- integer is unbounded, there isn't much we can do.
- maxIdx =
- case (mblen, ix) of
- (Nat n, TVIntMod m) -> Just (min (toInteger n) (toInteger m))
- (Nat n, _) -> Just n
- (_ , TVIntMod m) -> Just m
- _ -> Nothing
-
-indexBack_int ::
- W4.IsExprBuilder sym =>
- sym ->
- Nat' ->
- TValue ->
- SeqMap (What4 sym) ->
- TValue ->
- SInteger (What4 sym) ->
- SEval (What4 sym) (Value sym)
-indexBack_int sym (Nat n) a xs ix idx = indexFront_int sym (Nat n) a (reverseSeqMap n xs) ix idx
-indexBack_int _ Inf _ _ _ _ = evalPanic "Expected finite sequence" ["indexBack_int"]
-
-indexFront_word ::
- W4.IsExprBuilder sym =>
- sym ->
- Nat' ->
- TValue ->
- SeqMap (What4 sym) ->
- TValue ->
- SWord (What4 sym) ->
- SEval (What4 sym) (Value sym)
-indexFront_word sym mblen _a xs _ix idx
- | Just i <- SW.bvAsUnsignedInteger idx
- = lookupSeqMap xs i
-
- | otherwise
- = foldr f def idxs
-
- where
- w = SW.bvWidth idx
- def = raiseError (What4 sym) (InvalidIndex Nothing)
-
- f n y =
- do p <- liftIO (SW.bvEq sym idx =<< SW.bvLit sym w n)
- iteValue (What4 sym) p (lookupSeqMap xs n) y
-
- -- maximum possible in-bounds index given the bitwidth
- -- of the index value and the length of the sequence
- maxIdx =
- case mblen of
- Nat n | n < 2^w -> n-1
- _ -> 2^w - 1
-
- -- concrete indices to consider, intersection of the
- -- range of values the index value might take with
- -- the legal values
- idxs =
- case SW.unsignedBVBounds idx of
- Just (lo, hi) -> [lo .. min hi maxIdx]
- _ -> [0 .. maxIdx]
-
-indexBack_word ::
- W4.IsExprBuilder sym =>
- sym ->
- Nat' ->
- TValue ->
- SeqMap (What4 sym) ->
- TValue ->
- SWord (What4 sym) ->
- SEval (What4 sym) (Value sym)
-indexBack_word sym (Nat n) a xs ix idx = indexFront_word sym (Nat n) a (reverseSeqMap n xs) ix idx
-indexBack_word _ Inf _ _ _ _ = evalPanic "Expected finite sequence" ["indexBack_word"]
-
-indexFront_bits :: forall sym.
- W4.IsExprBuilder sym =>
- sym ->
- Nat' ->
- TValue ->
- SeqMap (What4 sym) ->
- TValue ->
- [SBit (What4 sym)] ->
- SEval (What4 sym) (Value sym)
-indexFront_bits sym mblen _a xs _ix bits0 = go 0 (length bits0) bits0
- where
- go :: Integer -> Int -> [W4.Pred sym] -> W4Eval sym (Value sym)
- go i _k []
- -- For indices out of range, fail
- | Nat n <- mblen
- , i >= n
- = raiseError (What4 sym) (InvalidIndex (Just i))
-
- | otherwise
- = lookupSeqMap xs i
-
- go i k (b:bs)
- -- Fail early when all possible indices we could compute from here
- -- are out of bounds
- | Nat n <- mblen
- , (i `shiftL` k) >= n
- = raiseError (What4 sym) (InvalidIndex Nothing)
-
- | otherwise
- = iteValue (What4 sym) b
- (go ((i `shiftL` 1) + 1) (k-1) bs)
- (go (i `shiftL` 1) (k-1) bs)
-
-indexBack_bits ::
- W4.IsExprBuilder sym =>
- sym ->
- Nat' ->
- TValue ->
- SeqMap (What4 sym) ->
- TValue ->
- [SBit (What4 sym)] ->
- SEval (What4 sym) (Value sym)
-indexBack_bits sym (Nat n) a xs ix idx = indexFront_bits sym (Nat n) a (reverseSeqMap n xs) ix idx
-indexBack_bits _ Inf _ _ _ _ = evalPanic "Expected finite sequence" ["indexBack_bits"]
-
-
--- | Compare a symbolic word value with a concrete integer.
-wordValueEqualsInteger :: forall sym.
- W4.IsExprBuilder sym =>
- sym ->
- WordValue (What4 sym) ->
- Integer ->
- W4Eval sym (W4.Pred sym)
-wordValueEqualsInteger sym wv i
- | wordValueSize (What4 sym) wv < widthInteger i = return (W4.falsePred sym)
- | otherwise =
- case wv of
- WordVal w -> liftIO (SW.bvEq sym w =<< SW.bvLit sym (SW.bvWidth w) i)
- _ -> liftIO . bitsAre i =<< enumerateWordValueRev (What4 sym) wv -- little-endian
- where
- bitsAre :: Integer -> [W4.Pred sym] -> IO (W4.Pred sym)
- bitsAre n [] = pure (W4.backendPred sym (n == 0))
- bitsAre n (b : bs) =
- do pb <- bitIs (testBit n 0) b
- pbs <- bitsAre (n `shiftR` 1) bs
- W4.andPred sym pb pbs
-
- bitIs :: Bool -> W4.Pred sym -> IO (W4.Pred sym)
- bitIs b x = if b then pure x else W4.notPred sym x
-
-updateFrontSym ::
- W4.IsExprBuilder sym =>
- sym ->
- Nat' ->
- TValue ->
- SeqMap (What4 sym) ->
- Either (SInteger (What4 sym)) (WordValue (What4 sym)) ->
- SEval (What4 sym) (Value sym) ->
- SEval (What4 sym) (SeqMap (What4 sym))
-updateFrontSym sym _len _eltTy vs (Left idx) val =
- case W4.asInteger idx of
- Just i -> return $ updateSeqMap vs i val
- Nothing -> return $ IndexSeqMap $ \i ->
- do b <- intEq (What4 sym) idx =<< integerLit (What4 sym) i
- iteValue (What4 sym) b val (lookupSeqMap vs i)
-
-updateFrontSym sym _len _eltTy vs (Right wv) val =
- case wv of
- WordVal w | Just j <- SW.bvAsUnsignedInteger w ->
- return $ updateSeqMap vs j val
- _ ->
- memoMap $ IndexSeqMap $ \i ->
- do b <- wordValueEqualsInteger sym wv i
- iteValue (What4 sym) b val (lookupSeqMap vs i)
-
-updateBackSym ::
- W4.IsExprBuilder sym =>
- sym ->
- Nat' ->
- TValue ->
- SeqMap (What4 sym) ->
- Either (SInteger (What4 sym)) (WordValue (What4 sym)) ->
- SEval (What4 sym) (Value sym) ->
- SEval (What4 sym) (SeqMap (What4 sym))
-updateBackSym _ Inf _ _ _ _ = evalPanic "Expected finite sequence" ["updateBackSym"]
-
-updateBackSym sym (Nat n) _eltTy vs (Left idx) val =
- case W4.asInteger idx of
- Just i -> return $ updateSeqMap vs (n - 1 - i) val
- Nothing -> return $ IndexSeqMap $ \i ->
- do b <- intEq (What4 sym) idx =<< integerLit (What4 sym) (n - 1 - i)
- iteValue (What4 sym) b val (lookupSeqMap vs i)
-
-updateBackSym sym (Nat n) _eltTy vs (Right wv) val =
- case wv of
- WordVal w | Just j <- SW.bvAsUnsignedInteger w ->
- return $ updateSeqMap vs (n - 1 - j) val
- _ ->
- memoMap $ IndexSeqMap $ \i ->
- do b <- wordValueEqualsInteger sym wv (n - 1 - i)
- iteValue (What4 sym) b val (lookupSeqMap vs i)
-
-
-updateFrontSym_word ::
- W4.IsExprBuilder sym =>
- sym ->
- Nat' ->
- TValue ->
- WordValue (What4 sym) ->
- Either (SInteger (What4 sym)) (WordValue (What4 sym)) ->
- SEval (What4 sym) (GenValue (What4 sym)) ->
- SEval (What4 sym) (WordValue (What4 sym))
-updateFrontSym_word _ Inf _ _ _ _ = evalPanic "Expected finite sequence" ["updateFrontSym_word"]
-
-updateFrontSym_word sym (Nat _) eltTy (LargeBitsVal n bv) idx val =
- LargeBitsVal n <$> updateFrontSym sym (Nat n) eltTy bv idx val
-
-updateFrontSym_word sym (Nat n) eltTy (WordVal bv) (Left idx) val =
- do idx' <- wordFromInt (What4 sym) n idx
- updateFrontSym_word sym (Nat n) eltTy (WordVal bv) (Right (WordVal idx')) val
-
-updateFrontSym_word sym (Nat n) eltTy bv (Right wv) val =
- case wv of
- WordVal idx
- | Just j <- SW.bvAsUnsignedInteger idx ->
- updateWordValue (What4 sym) bv j (fromVBit <$> val)
-
- | WordVal bw <- bv ->
- WordVal <$>
- do b <- fromVBit <$> val
- let sz = SW.bvWidth bw
- highbit <- liftIO (SW.bvLit sym sz (bit (fromInteger (sz-1))))
- msk <- w4bvLshr sym highbit idx
- liftIO $
- case W4.asConstantPred b of
- Just True -> SW.bvOr sym bw msk
- Just False -> SW.bvAnd sym bw =<< SW.bvNot sym msk
- Nothing ->
- do q <- SW.bvFill sym sz b
- bw' <- SW.bvAnd sym bw =<< SW.bvNot sym msk
- SW.bvXor sym bw' =<< SW.bvAnd sym q msk
-
- _ -> LargeBitsVal (wordValueSize (What4 sym) wv) <$>
- updateFrontSym sym (Nat n) eltTy (asBitsMap (What4 sym) bv) (Right wv) val
-
-
-updateBackSym_word ::
- W4.IsExprBuilder sym =>
- sym ->
- Nat' ->
- TValue ->
- WordValue (What4 sym) ->
- Either (SInteger (What4 sym)) (WordValue (What4 sym)) ->
- SEval (What4 sym) (GenValue (What4 sym)) ->
- SEval (What4 sym) (WordValue (What4 sym))
-updateBackSym_word _ Inf _ _ _ _ = evalPanic "Expected finite sequence" ["updateBackSym_word"]
-
-updateBackSym_word sym (Nat _) eltTy (LargeBitsVal n bv) idx val =
- LargeBitsVal n <$> updateBackSym sym (Nat n) eltTy bv idx val
-
-updateBackSym_word sym (Nat n) eltTy (WordVal bv) (Left idx) val =
- do idx' <- wordFromInt (What4 sym) n idx
- updateBackSym_word sym (Nat n) eltTy (WordVal bv) (Right (WordVal idx')) val
-
-updateBackSym_word sym (Nat n) eltTy bv (Right wv) val =
- case wv of
- WordVal idx
- | Just j <- SW.bvAsUnsignedInteger idx ->
- updateWordValue (What4 sym) bv (n - 1 - j) (fromVBit <$> val)
-
- | WordVal bw <- bv ->
- WordVal <$>
- do b <- fromVBit <$> val
- let sz = SW.bvWidth bw
- lowbit <- liftIO (SW.bvLit sym sz 1)
- msk <- w4bvShl sym lowbit idx
- liftIO $
- case W4.asConstantPred b of
- Just True -> SW.bvOr sym bw msk
- Just False -> SW.bvAnd sym bw =<< SW.bvNot sym msk
- Nothing ->
- do q <- SW.bvFill sym sz b
- bw' <- SW.bvAnd sym bw =<< SW.bvNot sym msk
- SW.bvXor sym bw' =<< SW.bvAnd sym q msk
-
- _ -> LargeBitsVal (wordValueSize (What4 sym) wv) <$>
- updateBackSym sym (Nat n) eltTy (asBitsMap (What4 sym) bv) (Right wv) val
-
-
-sshrV :: W4.IsExprBuilder sym => sym -> Value sym
-sshrV sym =
- nlam $ \(Nat n) ->
- tlam $ \ix ->
- wlam (What4 sym) $ \x -> return $
- lam $ \y ->
- y >>= asIndex (What4 sym) ">>$" ix >>= \case
- Left i ->
- do pneg <- intLessThan (What4 sym) i =<< integerLit (What4 sym) 0
- zneg <- do i' <- shiftShrink (What4 sym) (Nat n) ix =<< intNegate (What4 sym) i
- amt <- wordFromInt (What4 sym) n i'
- w4bvShl sym x amt
- zpos <- do i' <- shiftShrink (What4 sym) (Nat n) ix i
- amt <- wordFromInt (What4 sym) n i'
- w4bvAshr sym x amt
- return (VWord (SW.bvWidth x) (WordVal <$> iteWord (What4 sym) pneg zneg zpos))
-
- Right wv ->
- do amt <- asWordVal (What4 sym) wv
- return (VWord (SW.bvWidth x) (WordVal <$> w4bvAshr sym x amt))
-
-
-w4bvShl :: W4.IsExprBuilder sym => sym -> SW.SWord sym -> SW.SWord sym -> W4Eval sym (SW.SWord sym)
-w4bvShl sym x y = liftIO $ SW.bvShl sym x y
-
-w4bvLshr :: W4.IsExprBuilder sym => sym -> SW.SWord sym -> SW.SWord sym -> W4Eval sym (SW.SWord sym)
-w4bvLshr sym x y = liftIO $ SW.bvLshr sym x y
-
-w4bvAshr :: W4.IsExprBuilder sym => sym -> SW.SWord sym -> SW.SWord sym -> W4Eval sym (SW.SWord sym)
-w4bvAshr sym x y = liftIO $ SW.bvAshr sym x y
-
-w4bvRol :: W4.IsExprBuilder sym => sym -> SW.SWord sym -> SW.SWord sym -> W4Eval sym (SW.SWord sym)
-w4bvRol sym x y = liftIO $ SW.bvRol sym x y
-
-w4bvRor :: W4.IsExprBuilder sym => sym -> SW.SWord sym -> SW.SWord sym -> W4Eval sym (SW.SWord sym)
-w4bvRor sym x y = liftIO $ SW.bvRor sym x y
-
-
-
-fpRoundingMode ::
- W4.IsExprBuilder sym =>
- What4 sym -> SWord (What4 sym) -> SEval (What4 sym) W4.RoundingMode
-fpRoundingMode sym@(What4 sy) v =
- case wordAsLit sym v of
- Just (_w,i) ->
- case i of
- 0 -> pure W4.RNE
- 1 -> pure W4.RNA
- 2 -> pure W4.RTP
- 3 -> pure W4.RTN
- 4 -> pure W4.RTZ
- x -> do let err = BadRoundingMode x
- assertSideCondition sym (W4.falsePred sy) err
- raiseError sym err
- _ -> liftIO $ X.throwIO $ UnsupportedSymbolicOp "rounding mode"
-
-fpBinArith ::
- W4.IsExprBuilder sym =>
- FP.SFloatBinArith sym ->
- What4 sym ->
- SWord (What4 sym) ->
- SFloat (What4 sym) ->
- SFloat (What4 sym) ->
- SEval (What4 sym) (SFloat (What4 sym))
-fpBinArith fun = \sym@(What4 s) r x y ->
- do m <- fpRoundingMode sym r
- liftIO (fun s m x y)
-
-
-fpCvtToInteger ::
- (W4.IsExprBuilder sy, sym ~ What4 sy) =>
- sym -> String -> SWord sym -> SFloat sym -> SEval sym (SInteger sym)
-fpCvtToInteger sym@(What4 sy) fun r x =
- do grd <- liftIO
- do bad1 <- FP.fpIsInf sy x
- bad2 <- FP.fpIsNaN sy x
- W4.notPred sy =<< W4.orPred sy bad1 bad2
- assertSideCondition sym grd (BadValue fun)
- rnd <- fpRoundingMode sym r
- liftIO
- do y <- FP.fpToReal sy x
- case rnd of
- W4.RNE -> W4.realRoundEven sy y
- W4.RNA -> W4.realRound sy y
- W4.RTP -> W4.realCeil sy y
- W4.RTN -> W4.realFloor sy y
- W4.RTZ -> W4.realTrunc sy y
-
-
-fpCvtToRational ::
- (W4.IsSymExprBuilder sy, sym ~ What4 sy) =>
- sym -> SFloat sym -> SEval sym (SRational sym)
-fpCvtToRational sym@(What4 sy) fp =
- do grd <- liftIO
- do bad1 <- FP.fpIsInf sy fp
- bad2 <- FP.fpIsNaN sy fp
- W4.notPred sy =<< W4.orPred sy bad1 bad2
- assertSideCondition sym grd (BadValue "fpToRational")
- (rel,x,y) <- liftIO (FP.fpToRational sy fp)
- addDefEqn rel
- ratio sym x y
-
-fpCvtFromRational ::
- (W4.IsExprBuilder sy, sym ~ What4 sy) =>
- sym -> Integer -> Integer -> SWord sym ->
- SRational sym -> SEval sym (SFloat sym)
-fpCvtFromRational sym@(What4 sy) e p r rat =
- do rnd <- fpRoundingMode sym r
- liftIO (FP.fpFromRational sy e p rnd (sNum rat) (sDenom rat))
-
-
diff --git a/src/Cryptol/F2.hs b/src/Cryptol/F2.hs
new file mode 100644
--- /dev/null
+++ b/src/Cryptol/F2.hs
@@ -0,0 +1,48 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE MagicHash #-}
+module Cryptol.F2 where
+
+import Data.Bits
+import Cryptol.TypeCheck.Solver.InfNat (widthInteger)
+
+pmult :: Int -> Integer -> Integer -> Integer
+pmult w x y = go (w-1) 0
+ where
+ go !i !z
+ | i >= 0 = go (i-1) (if testBit x i then (z `shiftL` 1) `xor` y else (z `shiftL` 1))
+ | otherwise = z
+
+pdiv :: Int -> Integer -> Integer -> Integer
+pdiv w x m = go (w-1) 0 0
+ where
+ degree :: Int
+ degree = fromInteger (widthInteger m - 1)
+
+ reduce :: Integer -> Integer
+ reduce u = if testBit u degree then u `xor` m else u
+ {-# INLINE reduce #-}
+
+ go !i !z !r
+ | i >= 0 = go (i-1) z' r'
+ | otherwise = r
+ where
+ zred = reduce z
+ z' = if testBit x i then (zred `shiftL` 1) .|. 1 else zred `shiftL` 1
+ r' = if testBit z' degree then (r `shiftL` 1) .|. 1 else r `shiftL` 1
+
+
+pmod :: Int -> Integer -> Integer -> Integer
+pmod w x m = mask .&. go 0 0 (reduce 1)
+ where
+ degree :: Int
+ degree = fromInteger (widthInteger m - 1)
+
+ reduce :: Integer -> Integer
+ reduce u = if testBit u degree then u `xor` m else u
+ {-# INLINE reduce #-}
+
+ mask = bit degree - 1
+
+ go !i !z !p
+ | i < w = go (i+1) (if testBit x i then z `xor` p else z) (reduce (p `shiftL` 1))
+ | otherwise = z
diff --git a/src/Cryptol/IR/FreeVars.hs b/src/Cryptol/IR/FreeVars.hs
--- a/src/Cryptol/IR/FreeVars.hs
+++ b/src/Cryptol/IR/FreeVars.hs
@@ -103,7 +103,7 @@
ETuple es -> freeVars es
ERec fs -> freeVars (recordElements fs)
ESel e _ -> freeVars e
- ESet e _ v -> freeVars [e,v]
+ ESet ty e _ v -> freeVars ty <> freeVars [e,v]
EIf e1 e2 e3 -> freeVars [e1,e2,e3]
EComp t1 t2 e mss -> freeVars [t1,t2] <> rmVals (defs mss) (freeVars e)
<> mconcat (map foldFree mss)
diff --git a/src/Cryptol/ModuleSystem.hs b/src/Cryptol/ModuleSystem.hs
--- a/src/Cryptol/ModuleSystem.hs
+++ b/src/Cryptol/ModuleSystem.hs
@@ -75,7 +75,7 @@
loadModuleByName n (evo, byteReader, env) =
runModuleM (evo, byteReader, resetModuleEnv env) $ do
unloadModule ((n ==) . lmName)
- (path,m') <- Base.loadModuleFrom (FromModule n)
+ (path,m') <- Base.loadModuleFrom False (FromModule n)
setFocusedModule (T.mName m')
return (path,m')
diff --git a/src/Cryptol/ModuleSystem/Base.hs b/src/Cryptol/ModuleSystem/Base.hs
--- a/src/Cryptol/ModuleSystem/Base.hs
+++ b/src/Cryptol/ModuleSystem/Base.hs
@@ -42,15 +42,15 @@
import qualified Cryptol.TypeCheck.PP as T
import qualified Cryptol.TypeCheck.Sanity as TcSanity
import Cryptol.Transform.AddModParams (addModParams)
-import Cryptol.Utils.Ident (preludeName, floatName, arrayName, interactiveName
- , modNameChunks, notParamInstModName
- , isParamInstModName )
+import Cryptol.Utils.Ident ( preludeName, floatName, arrayName, suiteBName, primeECName
+ , preludeReferenceName, interactiveName, modNameChunks
+ , notParamInstModName, isParamInstModName )
import Cryptol.Utils.PP (pretty)
import Cryptol.Utils.Panic (panic)
import Cryptol.Utils.Logger(logPutStrLn, logPrint)
-import Cryptol.Prelude (preludeContents, floatContents, arrayContents)
-
+import Cryptol.Prelude ( preludeContents, floatContents, arrayContents
+ , suiteBContents, primeECContents, preludeReferenceContents )
import Cryptol.Transform.MonoValues (rewModule)
import qualified Control.Exception as X
@@ -164,7 +164,7 @@
case lookupModule n env of
-- loadModule will calculate the canonical path again
- Nothing -> doLoadModule (FromModule n) (InFile foundPath) fp pm
+ Nothing -> doLoadModule False (FromModule n) (InFile foundPath) fp pm
Just lm
| path' == loaded -> return (lmModule lm)
| otherwise -> duplicateModuleName n path' loaded
@@ -172,8 +172,8 @@
-- | Load a module, unless it was previously loaded.
-loadModuleFrom :: ImportSource -> ModuleM (ModulePath,T.Module)
-loadModuleFrom isrc =
+loadModuleFrom :: Bool {- ^ quiet mode -} -> ImportSource -> ModuleM (ModulePath,T.Module)
+loadModuleFrom quiet isrc =
do let n = importedModule isrc
mb <- getLoadedMaybe n
case mb of
@@ -182,27 +182,29 @@
do path <- findModule n
errorInFile path $
do (fp, pm) <- parseModule path
- m <- doLoadModule isrc path fp pm
+ m <- doLoadModule quiet isrc path fp pm
return (path,m)
-- | Load dependencies, typecheck, and add to the eval environment.
doLoadModule ::
+ Bool {- ^ quiet mode: true suppresses the "loading module" message -} ->
ImportSource ->
ModulePath ->
Fingerprint ->
P.Module PName ->
ModuleM T.Module
-doLoadModule isrc path fp pm0 =
+doLoadModule quiet isrc path fp pm0 =
loading isrc $
do let pm = addPrelude pm0
loadDeps pm
- withLogger logPutStrLn
+ unless quiet $ withLogger logPutStrLn
("Loading module " ++ pretty (P.thing (P.mName pm)))
tcm <- optionalInstantiate =<< checkModule isrc path pm
-- extend the eval env, unless a functor.
- let ?evalPrim = Concrete.evalPrim
+ tbl <- Concrete.primTable <$> getEvalOpts
+ let ?evalPrim = \i -> Right <$> Map.lookup i tbl
unless (T.isParametrizedModule tcm) $ modifyEvalEnv (E.moduleEnv Concrete tcm)
loadedModule path fp tcm
@@ -260,7 +262,10 @@
case n of
m | m == preludeName -> pure (InMem "Cryptol" preludeContents)
| m == floatName -> pure (InMem "Float" floatContents)
- | m == arrayName -> pure (InMem "Array" arrayContents)
+ | m == arrayName -> pure (InMem "Array" arrayContents)
+ | m == suiteBName -> pure (InMem "SuiteB" suiteBContents)
+ | m == primeECName -> pure (InMem "PrimeEC" primeECContents)
+ | m == preludeReferenceName -> pure (InMem "Cryptol::Reference" preludeReferenceContents)
_ -> moduleNotFound n =<< getSearchPath
-- generate all possible search paths
@@ -310,9 +315,9 @@
do mapM_ loadI (P.mImports m)
mapM_ loadF (P.mInstance m)
where
- loadI i = do (_,m1) <- loadModuleFrom (FromImport i)
+ loadI i = do (_,m1) <- loadModuleFrom False (FromImport i)
when (T.isParametrizedModule m1) $ importParamModule $ T.mName m1
- loadF f = do _ <- loadModuleFrom (FromModuleInstance f)
+ loadF f = do _ <- loadModuleFrom False (FromModuleInstance f)
return ()
@@ -500,10 +505,10 @@
case out of
- T.InferOK warns seeds supply' o ->
+ T.InferOK nameMap warns seeds supply' o ->
do setNameSeeds seeds
setSupply supply'
- typeCheckWarnings warns
+ typeCheckWarnings nameMap warns
menv <- getModuleEnv
case meCoreLint menv of
NoCoreLint -> return ()
@@ -514,9 +519,9 @@
Left err -> panic "Core lint failed:" [show err]
return o
- T.InferFailed warns errs ->
- do typeCheckWarnings warns
- typeCheckingFailed errs
+ T.InferFailed nameMap warns errs ->
+ do typeCheckWarnings nameMap warns
+ typeCheckingFailed nameMap errs
-- | Generate input for the typechecker.
genInferInput :: Range -> PrimMap ->
@@ -555,8 +560,9 @@
env <- getEvalEnv
denv <- getDynEnv
evopts <- getEvalOpts
- let ?evalPrim = Concrete.evalPrim
- io $ E.runEval evopts $ (E.evalExpr Concrete (env <> deEnv denv) e)
+ let tbl = Concrete.primTable evopts
+ let ?evalPrim = \i -> Right <$> Map.lookup i tbl
+ io $ E.runEval $ (E.evalExpr Concrete (env <> deEnv denv) e)
evalDecls :: [T.DeclGroup] -> ModuleM ()
evalDecls dgs = do
@@ -564,8 +570,9 @@
denv <- getDynEnv
evOpts <- getEvalOpts
let env' = env <> deEnv denv
- let ?evalPrim = Concrete.evalPrim
- deEnv' <- io $ E.runEval evOpts $ E.evalDecls Concrete dgs env'
+ let tbl = Concrete.primTable evOpts
+ let ?evalPrim = \i -> Right <$> Map.lookup i tbl
+ deEnv' <- io $ E.runEval $ E.evalDecls Concrete dgs env'
let denv' = denv { deDecls = deDecls denv ++ dgs
, deEnv = deEnv'
}
diff --git a/src/Cryptol/ModuleSystem/InstantiateModule.hs b/src/Cryptol/ModuleSystem/InstantiateModule.hs
--- a/src/Cryptol/ModuleSystem/InstantiateModule.hs
+++ b/src/Cryptol/ModuleSystem/InstantiateModule.hs
@@ -14,6 +14,7 @@
import Cryptol.ModuleSystem.Name
import Cryptol.TypeCheck.AST
import Cryptol.TypeCheck.Subst(listParamSubst, apSubst)
+import Cryptol.TypeCheck.SimpType(tRebuild)
import Cryptol.Utils.Ident(ModName,modParamIdent)
{-
@@ -186,7 +187,7 @@
ETuple es -> ETuple (inst env es)
ERec xs -> ERec (fmap go xs)
ESel e s -> ESel (go e) s
- ESet e x v -> ESet (go e) x (go v)
+ ESet ty e x v -> ESet (inst env ty) (go e) x (go v)
EIf e1 e2 e3 -> EIf (go e1) (go e2) (go e3)
EComp t1 t2 e mss -> EComp (inst env t1) (inst env t2)
(go e)
@@ -232,6 +233,7 @@
instance Inst Type where
inst env ty =
+ tRebuild $
case ty of
TCon tc ts -> TCon (inst env tc) (inst env ts)
TVar tv ->
diff --git a/src/Cryptol/ModuleSystem/Interface.hs b/src/Cryptol/ModuleSystem/Interface.hs
--- a/src/Cryptol/ModuleSystem/Interface.hs
+++ b/src/Cryptol/ModuleSystem/Interface.hs
@@ -32,6 +32,7 @@
import qualified Data.Map as Map
import Data.Semigroup
+import Data.Text (Text)
import GHC.Generics (Generic)
import Control.DeepSeq
@@ -100,7 +101,7 @@
, ifDeclPragmas :: [Pragma] -- ^ Pragmas
, ifDeclInfix :: Bool -- ^ Is this an infix thing
, ifDeclFixity :: Maybe Fixity -- ^ Fixity information
- , ifDeclDoc :: Maybe String -- ^ Documentation
+ , ifDeclDoc :: Maybe Text -- ^ Documentation
} deriving (Show, Generic, NFData)
mkIfaceDecl :: Decl -> IfaceDecl
diff --git a/src/Cryptol/ModuleSystem/Monad.hs b/src/Cryptol/ModuleSystem/Monad.hs
--- a/src/Cryptol/ModuleSystem/Monad.hs
+++ b/src/Cryptol/ModuleSystem/Monad.hs
@@ -14,7 +14,8 @@
import Cryptol.Eval (EvalEnv,EvalOpts(..))
-import qualified Cryptol.Eval.Monad as E
+import qualified Cryptol.Backend.Monad as E
+
import Cryptol.ModuleSystem.Env
import Cryptol.ModuleSystem.Fingerprint
import Cryptol.ModuleSystem.Interface
@@ -95,7 +96,7 @@
-- ^ Problems during the NoPat phase
| NoIncludeErrors ImportSource [NoInc.IncludeError]
-- ^ Problems during the NoInclude phase
- | TypeCheckingFailed ImportSource [(Range,T.Error)]
+ | TypeCheckingFailed ImportSource T.NameMap [(Range,T.Error)]
-- ^ Problems during type checking
| OtherFailure String
-- ^ Problems after type checking, eg. specialization
@@ -127,7 +128,7 @@
RenamerErrors src errs -> src `deepseq` errs `deepseq` ()
NoPatErrors src errs -> src `deepseq` errs `deepseq` ()
NoIncludeErrors src errs -> src `deepseq` errs `deepseq` ()
- TypeCheckingFailed src errs -> src `deepseq` errs `deepseq` ()
+ TypeCheckingFailed nm src errs -> nm `deepseq` src `deepseq` errs `deepseq` ()
ModuleNameMismatch expected found ->
expected `deepseq` found `deepseq` ()
DuplicateModuleName name path1 path2 ->
@@ -175,7 +176,7 @@
NoIncludeErrors _src errs -> vcat (map NoInc.ppIncludeError errs)
- TypeCheckingFailed _src errs -> vcat (map T.ppError errs)
+ TypeCheckingFailed _src nm errs -> vcat (map (T.ppNamedError nm) errs)
ModuleNameMismatch expected found ->
hang (text "[error]" <+> pp (P.srcRange found) <.> char ':')
@@ -238,10 +239,10 @@
src <- getImportSource
ModuleT (raise (NoIncludeErrors src errs))
-typeCheckingFailed :: [(Range,T.Error)] -> ModuleM a
-typeCheckingFailed errs = do
+typeCheckingFailed :: T.NameMap -> [(Range,T.Error)] -> ModuleM a
+typeCheckingFailed nameMap errs = do
src <- getImportSource
- ModuleT (raise (TypeCheckingFailed src errs))
+ ModuleT (raise (TypeCheckingFailed src nameMap errs))
moduleNameMismatch :: P.ModName -> Located P.ModName -> ModuleM a
moduleNameMismatch expected found =
@@ -272,22 +273,22 @@
-- Warnings --------------------------------------------------------------------
data ModuleWarning
- = TypeCheckWarnings [(Range,T.Warning)]
+ = TypeCheckWarnings T.NameMap [(Range,T.Warning)]
| RenamerWarnings [RenamerWarning]
deriving (Show, Generic, NFData)
instance PP ModuleWarning where
ppPrec _ w = case w of
- TypeCheckWarnings ws -> vcat (map T.ppWarning ws)
+ TypeCheckWarnings nm ws -> vcat (map (T.ppNamedWarning nm) ws)
RenamerWarnings ws -> vcat (map pp ws)
warn :: [ModuleWarning] -> ModuleM ()
warn = ModuleT . put
-typeCheckWarnings :: [(Range,T.Warning)] -> ModuleM ()
-typeCheckWarnings ws
+typeCheckWarnings :: T.NameMap -> [(Range,T.Warning)] -> ModuleM ()
+typeCheckWarnings nameMap ws
| null ws = return ()
- | otherwise = warn [TypeCheckWarnings ws]
+ | otherwise = warn [TypeCheckWarnings nameMap ws]
renamerWarnings :: [RenamerWarning] -> ModuleM ()
renamerWarnings ws
@@ -488,8 +489,7 @@
modifyEvalEnv f = ModuleT $ do
env <- get
let evalEnv = meEvalEnv env
- evOpts <- unModuleT getEvalOpts
- evalEnv' <- inBase $ E.runEval evOpts (f evalEnv)
+ evalEnv' <- inBase $ E.runEval (f evalEnv)
set $! env { meEvalEnv = evalEnv' }
getEvalEnv :: ModuleM EvalEnv
diff --git a/src/Cryptol/ModuleSystem/Name.hs b/src/Cryptol/ModuleSystem/Name.hs
--- a/src/Cryptol/ModuleSystem/Name.hs
+++ b/src/Cryptol/ModuleSystem/Name.hs
@@ -172,7 +172,7 @@
-- | Figure out how the name should be displayed, by referencing the display
-- function in the environment. NOTE: this function doesn't take into account
--- the need for parenthesis.
+-- the need for parentheses.
ppName :: Name -> Doc
ppName Name { .. } =
case nInfo of
diff --git a/src/Cryptol/Parser.y b/src/Cryptol/Parser.y
--- a/src/Cryptol/Parser.y
+++ b/src/Cryptol/Parser.y
@@ -59,6 +59,8 @@
IDENT { $$@(Located _ (Token (Ident [] _) _))}
QIDENT { $$@(Located _ (Token Ident{} _))}
+ SELECTOR { $$@(Located _ (Token (Selector _) _))}
+
'include' { Located $$ (Token (KW KW_include) _)}
'import' { Located $$ (Token (KW KW_import) _)}
'as' { Located $$ (Token (KW KW_as) _)}
@@ -95,7 +97,7 @@
')' { Located $$ (Token (Sym ParenR ) _)}
',' { Located $$ (Token (Sym Comma ) _)}
';' { Located $$ (Token (Sym Semi ) _)}
- '.' { Located $$ (Token (Sym Dot ) _)}
+ -- '.' { Located $$ (Token (Sym Dot ) _)}
'{' { Located $$ (Token (Sym CurlyL ) _)}
'}' { Located $$ (Token (Sym CurlyR ) _)}
'<|' { Located $$ (Token (Sym TriL ) _)}
@@ -271,10 +273,10 @@
(mkProp $4) }
-doc :: { Located String }
+doc :: { Located Text }
: DOC { mkDoc (fmap tokenText $1) }
-mbDoc :: { Maybe (Located String) }
+mbDoc :: { Maybe (Located Text) }
: doc { Just $1 }
| {- empty -} { Nothing }
@@ -355,6 +357,10 @@
: apats indices { ($1, $2) }
| '@' indices1 { ([], $2) }
+opt_apats_indices :: { ([Pattern PName], [Pattern PName]) }
+ : {- empty -} { ([],[]) }
+ | apats_indices { $1 }
+
decls :: { [Decl PName] }
: decl ';' { [$1] }
| decls decl ';' { $2 : $1 }
@@ -371,6 +377,7 @@
repl :: { ReplInput PName }
: expr { ExprInput $1 }
| let_decl { LetInput $1 }
+ | {- empty -} { EmptyInput }
--------------------------------------------------------------------------------
@@ -483,8 +490,8 @@
no_sel_aexpr :: { Expr PName }
: qname { at $1 $ EVar (thing $1) }
- | NUM { at $1 $ numLit (tokenType (thing $1)) }
- | FRAC { at $1 $ fracLit (tokenType (thing $1)) }
+ | NUM { at $1 $ numLit (thing $1) }
+ | FRAC { at $1 $ fracLit (thing $1) }
| STRLIT { at $1 $ ELit $ ECString $ getStr $1 }
| CHARLIT { at $1 $ ELit $ ECChar $ getChr $1 }
| '_' { at $1 $ EVar $ mkUnqual $ mkIdent "_" }
@@ -506,9 +513,11 @@
| '<|' poly_terms '|>' {% mkPoly (rComb $1 $3) $2 }
sel_expr :: { Expr PName }
- : no_sel_aexpr '.' selector { at ($1,$3) $ ESel $1 (thing $3) }
- | sel_expr '.' selector { at ($1,$3) $ ESel $1 (thing $3) }
+ : no_sel_aexpr selector { at ($1,$2) $ ESel $1 (thing $2) }
+ | sel_expr selector { at ($1,$2) $ ESel $1 (thing $2) }
+selector :: { Located Selector }
+ : SELECTOR { mkSelector `fmap` $1 }
poly_terms :: { [(Bool, Integer)] }
: poly_term { [$1] }
@@ -519,11 +528,6 @@
| 'x' {% polyTerm $1 1 1 }
| 'x' '^^' NUM {% polyTerm (rComb $1 (srcRange $3))
1 (getNum $3) }
-
-selector :: { Located Selector }
- : ident { fmap (`RecordSel` Nothing) $1 }
- | NUM {% mkTupleSel (srcRange $1) (getNum $1) }
-
tuple_exprs :: { [Expr PName] }
: expr ',' expr { [ $3, $1] }
| tuple_exprs ',' expr { $3 : $1 }
@@ -534,24 +538,21 @@
| '_' '|' field_exprs { Left (EUpd Nothing (reverse $3)) }
| field_exprs {% Right `fmap` mapM ufToNamed $1 }
-field_expr :: { UpdField PName }
- : selector field_how expr { UpdField $2 [$1] $3 }
- | sels field_how expr { UpdField $2 $1 $3 }
- | sels apats_indices field_how expr
- { UpdField $3 $1 (mkIndexedExpr $2 $4) }
- | selector apats_indices field_how expr
- { UpdField $3 [$1] (mkIndexedExpr $2 $4) }
-
-field_how :: { UpdHow }
- : '=' { UpdSet }
- | '->' { UpdFun }
-
-sels :: { [ Located Selector ] }
- : sel_expr {% selExprToSels $1 }
-
field_exprs :: { [UpdField PName] }
: field_expr { [$1] }
| field_exprs ',' field_expr { $3 : $1 }
+
+field_expr :: { UpdField PName }
+ : field_path opt_apats_indices
+ field_how expr { UpdField $3 $1 (mkIndexedExpr $2 $4) }
+
+field_path :: { [Located Selector] }
+ : aexpr {% exprToFieldPath $1 }
+
+field_how :: { UpdHow }
+ : '=' { UpdSet }
+ | '->' { UpdFun }
+
list_expr :: { Expr PName }
: expr '|' list_alts { EComp $1 (reverse $3) }
diff --git a/src/Cryptol/Parser/AST.hs b/src/Cryptol/Parser/AST.hs
--- a/src/Cryptol/Parser/AST.hs
+++ b/src/Cryptol/Parser/AST.hs
@@ -90,6 +90,7 @@
import Data.Bits(shiftR)
import Data.Maybe (catMaybes)
import Data.Ratio(numerator,denominator)
+import Data.Text (Text)
import Numeric(showIntAtBase,showFloat,showHFloat)
import GHC.Generics (Generic)
@@ -160,7 +161,7 @@
data ParameterType name = ParameterType
{ ptName :: Located name -- ^ name of type parameter
, ptKind :: Kind -- ^ kind of parameter
- , ptDoc :: Maybe String -- ^ optional documentation
+ , ptDoc :: Maybe Text -- ^ optional documentation
, ptFixity :: Maybe Fixity -- ^ info for infix use
, ptNumber :: !Int -- ^ number of the parameter
} deriving (Eq,Show,Generic,NFData)
@@ -169,7 +170,7 @@
data ParameterFun name = ParameterFun
{ pfName :: Located name -- ^ name of value parameter
, pfSchema :: Schema name -- ^ schema for parameter
- , pfDoc :: Maybe String -- ^ optional documentation
+ , pfDoc :: Maybe Text -- ^ optional documentation
, pfFixity :: Maybe Fixity -- ^ info for infix use
} deriving (Eq,Show,Generic,NFData)
@@ -230,7 +231,7 @@
, bFixity :: Maybe Fixity -- ^ Optional fixity info
, bPragmas :: [Pragma] -- ^ Optional pragmas
, bMono :: Bool -- ^ Is this a monomorphic binding
- , bDoc :: Maybe String -- ^ Optional doc string
+ , bDoc :: Maybe Text -- ^ Optional doc string
} deriving (Eq, Generic, NFData, Functor, Show)
type LBindDef = Located (BindDef PName)
@@ -257,10 +258,11 @@
, primTFixity :: Maybe Fixity
} deriving (Show,Generic,NFData)
--- | Input at the REPL, which can either be an expression or a @let@
--- statement.
+-- | Input at the REPL, which can be an expression, a @let@
+-- statement, or empty (possibly a comment).
data ReplInput name = ExprInput (Expr name)
| LetInput (Decl name)
+ | EmptyInput
deriving (Eq, Show)
-- | Export information for a declaration.
@@ -270,25 +272,25 @@
-- | A top-level module declaration.
data TopLevel a = TopLevel { tlExport :: ExportType
- , tlDoc :: Maybe (Located String)
+ , tlDoc :: Maybe (Located Text)
, tlValue :: a
}
deriving (Show, Generic, NFData, Functor, Foldable, Traversable)
-- | Infromation about the representation of a numeric constant.
-data NumInfo = BinLit Int -- ^ n-digit binary literal
- | OctLit Int -- ^ n-digit octal literal
- | DecLit -- ^ overloaded decimal literal
- | HexLit Int -- ^ n-digit hex literal
+data NumInfo = BinLit Text Int -- ^ n-digit binary literal
+ | OctLit Text Int -- ^ n-digit octal literal
+ | DecLit Text -- ^ overloaded decimal literal
+ | HexLit Text Int -- ^ n-digit hex literal
| PolyLit Int -- ^ polynomial literal
deriving (Eq, Show, Generic, NFData)
-- | Information about fractional literals.
-data FracInfo = BinFrac
- | OctFrac
- | DecFrac
- | HexFrac
+data FracInfo = BinFrac Text
+ | OctFrac Text
+ | DecFrac Text
+ | HexFrac Text
deriving (Eq,Show,Generic,NFData)
-- | Literals.
@@ -646,10 +648,10 @@
ppFracLit x i
| toRational dbl == x =
case i of
- BinFrac -> frac
- OctFrac -> frac
- DecFrac -> text (showFloat dbl "")
- HexFrac -> text (showHFloat dbl "")
+ BinFrac _ -> frac
+ OctFrac _ -> frac
+ DecFrac _ -> text (showFloat dbl "")
+ HexFrac _ -> text (showHFloat dbl "")
| otherwise = frac
where
dbl = fromRational x :: Double
@@ -660,11 +662,11 @@
ppNumLit :: Integer -> NumInfo -> Doc
ppNumLit n info =
case info of
- DecLit -> integer n
- BinLit w -> pad 2 "0b" w
- OctLit w -> pad 8 "0o" w
- HexLit w -> pad 16 "0x" w
- PolyLit w -> text "<|" <+> poly w <+> text "|>"
+ DecLit _ -> integer n
+ BinLit _ w -> pad 2 "0b" w
+ OctLit _ w -> pad 8 "0o" w
+ HexLit _ w -> pad 16 "0x" w
+ PolyLit w -> text "<|" <+> poly w <+> text "|>"
where
pad base pref w =
let txt = showIntAtBase base ("0123456789abcdef" !!) n ""
diff --git a/src/Cryptol/Parser/Lexer.x b/src/Cryptol/Parser/Lexer.x
--- a/src/Cryptol/Parser/Lexer.x
+++ b/src/Cryptol/Parser/Lexer.x
@@ -45,18 +45,11 @@
@qual_id = @qual @id
@qual_op = @qual @op
-@digits2 = (_*[0-1])+
-@digits8 = (_*[0-7])+
-@digits16 = (_*[0-9A-Fa-f])+
-@num2 = "0b" @digits2
-@num8 = "0o" @digits8
-@num10 = [0-9](_*[0-9])*
-@num16 = "0x" @digits16
-@fnum2 = @num2 "." @digits2 ([pP] [\+\-]? @num10)?
-@fnum8 = @num8 "." @digits8 ([pP] [\+\-]? @num10)?
-@fnum10 = @num10 "." @num10 ([eE] [\+\-]? @num10)?
-@fnum16 = @num16 "." @digits16 ([pP] [\+\-]? @num10)?
+@num = [0-9] @id_next*
+@fnum = [0-9] @id_next* "." (@id_next | [pPeE][\+\-])+
+@selector = "." @id_next+
+
@strPart = [^\\\"]+
@chrPart = [^\\\']+
@@ -130,19 +123,12 @@
"Prop" { emit $ KW KW_Prop }
-@num2 { emitS (numToken 2 . Text.drop 2) }
-@num8 { emitS (numToken 8 . Text.drop 2) }
-@num10 { emitS (numToken 10 . Text.drop 0) }
-@num16 { emitS (numToken 16 . Text.drop 2) }
-@fnum2 { emitS (fnumToken 2 . Text.drop 2) }
-@fnum8 { emitS (fnumToken 8 . Text.drop 2) }
-@fnum10 { emitS (fnumToken 10 . Text.drop 0) }
-@fnum16 { emitS (fnumToken 16 . Text.drop 2) }
-
-
+@num { emitS numToken }
+@fnum { emitFancy fnumTokens }
"_" { emit $ Sym Underscore }
@id { mkIdent }
+@selector { emitS selectorToken }
"\" { emit $ Sym Lambda }
"->" { emit $ Sym ArrR }
@@ -152,7 +138,6 @@
"=" { emit $ Sym EqDef }
"," { emit $ Sym Comma }
";" { emit $ Sym Semi }
-"." { emit $ Sym Dot }
":" { emit $ Sym Colon }
"`" { emit $ Sym BackTick }
".." { emit $ Sym DotDot }
@@ -261,9 +246,7 @@
let txt = Text.take l (input i)
(mtok,s') = act cfg (alexPos i) txt s
(rest,pos) = run i' $! s'
- in case mtok of
- Nothing -> (rest, pos)
- Just t -> (t : rest, pos)
+ in (mtok ++ rest, pos)
-- vim: ft=haskell
}
diff --git a/src/Cryptol/Parser/LexerUtils.hs b/src/Cryptol/Parser/LexerUtils.hs
--- a/src/Cryptol/Parser/LexerUtils.hs
+++ b/src/Cryptol/Parser/LexerUtils.hs
@@ -10,6 +10,7 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE BlockArguments #-}
module Cryptol.Parser.LexerUtils where
import Cryptol.Parser.Position
@@ -17,10 +18,13 @@
import Cryptol.Utils.PP
import Cryptol.Utils.Panic
-import Data.Char(toLower,generalCategory,isAscii,ord,isSpace)
+import Control.Monad(guard)
+import Data.Char(toLower,generalCategory,isAscii,ord,isSpace,
+ isAlphaNum,isAlpha)
import qualified Data.Char as Char
import Data.Text(Text)
import qualified Data.Text as T
+import qualified Data.Text.Read as T
import Data.Word(Word8)
import GHC.Generics (Generic)
@@ -47,7 +51,7 @@
type Action = Config -> Position -> Text -> LexS
- -> (Maybe (Located Token), LexS)
+ -> ([Located Token], LexS)
data LexS = Normal
| InComment Bool Position ![Position] [Text]
@@ -56,7 +60,7 @@
startComment :: Bool -> Action
-startComment isDoc _ p txt s = (Nothing, InComment d p stack chunks)
+startComment isDoc _ p txt s = ([], InComment d p stack chunks)
where (d,stack,chunks) = case s of
Normal -> (isDoc, [], [txt])
InComment doc q qs cs -> (doc, q : qs, txt : cs)
@@ -65,8 +69,8 @@
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))
+ InComment d f [] cs -> ([mkToken d f cs], Normal)
+ InComment d _ (q:qs) cs -> ([], InComment d q qs (txt : cs))
_ -> panic "[Lexer] endComment" ["outside comment"]
where
mkToken isDoc f cs =
@@ -77,7 +81,7 @@
in Located { srcRange = r, thing = Token (White tok) str }
addToComment :: Action
-addToComment _ _ txt s = (Nothing, InComment doc p stack (txt : chunks))
+addToComment _ _ txt s = ([], InComment doc p stack (txt : chunks))
where
(doc, p, stack, chunks) =
case s of
@@ -87,7 +91,7 @@
startEndComment :: Action
startEndComment cfg p txt s =
case s of
- Normal -> (Just tok, Normal)
+ Normal -> ([tok], Normal)
where tok = Located
{ srcRange = Range { from = p
, to = moves p txt
@@ -95,15 +99,15 @@
}
, thing = Token (White BlockComment) txt
}
- InComment d p1 ps cs -> (Nothing, InComment d p1 ps (txt : cs))
+ InComment d p1 ps cs -> ([], InComment d p1 ps (txt : cs))
_ -> panic "[Lexer] startEndComment" ["in string or char?"]
startString :: Action
-startString _ p txt _ = (Nothing,InString p txt)
+startString _ p txt _ = ([],InString p txt)
endString :: Action
endString cfg pe txt s = case s of
- InString ps str -> (Just (mkToken ps str), Normal)
+ InString ps str -> ([mkToken ps str], Normal)
_ -> panic "[Lexer] endString" ["outside string"]
where
parseStr s1 = case reads s1 of
@@ -126,17 +130,17 @@
addToString :: Action
addToString _ _ txt s = case s of
- InString p str -> (Nothing,InString p (str `T.append` txt))
+ InString p str -> ([],InString p (str `T.append` txt))
_ -> panic "[Lexer] addToString" ["outside string"]
startChar :: Action
-startChar _ p txt _ = (Nothing,InChar p txt)
+startChar _ p txt _ = ([],InChar p txt)
endChar :: Action
endChar cfg pe txt s =
case s of
- InChar ps str -> (Just (mkToken ps str), Normal)
+ InChar ps str -> ([mkToken ps str], Normal)
_ -> panic "[Lexer] endString" ["outside character"]
where
@@ -161,39 +165,41 @@
addToChar :: Action
addToChar _ _ txt s = case s of
- InChar p str -> (Nothing,InChar p (str `T.append` txt))
+ InChar p str -> ([],InChar p (str `T.append` txt))
_ -> panic "[Lexer] addToChar" ["outside character"]
mkIdent :: Action
-mkIdent cfg p s z = (Just Located { srcRange = r, thing = Token t s }, z)
+mkIdent cfg p s z = ([Located { srcRange = r, thing = Token t s }], z)
where
r = Range { from = p, to = moves p s, source = cfgSource cfg }
t = Ident [] s
mkQualIdent :: Action
-mkQualIdent cfg p s z = (Just Located { srcRange = r, thing = Token t s}, z)
+mkQualIdent cfg p s z = ([Located { srcRange = r, thing = Token t s}], z)
where
r = Range { from = p, to = moves p s, source = cfgSource cfg }
t = Ident ns i
(ns,i) = splitQual s
mkQualOp :: Action
-mkQualOp cfg p s z = (Just Located { srcRange = r, thing = Token t s}, z)
+mkQualOp cfg p s z = ([Located { srcRange = r, thing = Token t s}], z)
where
r = Range { from = p, to = moves p s, source = cfgSource cfg }
t = Op (Other ns i)
(ns,i) = splitQual s
emit :: TokenT -> Action
-emit t cfg p s z = (Just Located { srcRange = r, thing = Token t s }, z)
+emit t cfg p s z = ([Located { srcRange = r, thing = Token t s }], z)
where r = Range { from = p, to = moves p s, source = cfgSource cfg }
-
emitS :: (Text -> TokenT) -> Action
emitS t cfg p s z = emit (t s) cfg p s z
+emitFancy :: (FilePath -> Position -> Text -> [Located Token]) -> Action
+emitFancy f = \cfg p s z -> (f (cfgSource cfg) p s, z)
+
-- | Split out the prefix and name part of an identifier/operator.
splitQual :: T.Text -> ([T.Text], T.Text)
splitQual t =
@@ -213,52 +219,121 @@
--------------------------------------------------------------------------------
-numToken :: Int {- ^ base -} -> Text -> TokenT
-numToken rad ds = Num (toVal ds') rad (T.length ds')
+numToken :: Text -> TokenT
+numToken ds = case toVal of
+ Just v -> Num v rad (T.length ds')
+ Nothing -> Err MalformedLiteral
where
- ds' = T.filter (/= '_') ds
- toVal = T.foldl' (\x c -> toInteger rad * x + fromDigit c) 0
+ rad
+ | "0b" `T.isPrefixOf` ds = 2
+ | "0o" `T.isPrefixOf` ds = 8
+ | "0x" `T.isPrefixOf` ds = 16
+ | otherwise = 10
-fromDigit :: Char -> Integer
-fromDigit x'
- | 'a' <= x && x <= 'z' = toInteger (10 + fromEnum x - fromEnum 'a')
- | otherwise = toInteger (fromEnum x - fromEnum '0')
- where x = toLower x'
+ ds1 = if rad == 10 then ds else T.drop 2 ds
+ ds' = T.filter (/= '_') ds1
+ toVal = T.foldl' step (Just 0) ds'
+ irad = toInteger rad
+ step mb x = do soFar <- mb
+ d <- fromDigit irad x
+ pure $! (irad * soFar + d)
--- XXX: For now we just keep the number as a rational.
--- It might be better to keep the exponent representation,
--- to avoid making huge numbers, and using up all the memory though...
-fnumToken :: Int -> Text -> TokenT
-fnumToken rad ds = Frac ((wholenNum + fracNum) * (eBase ^^ expNum)) rad
+fromDigit :: Integer -> Char -> Maybe Integer
+fromDigit r x' =
+ do d <- v
+ guard (d < r)
+ pure d
where
+ x = toLower x'
+ v | '0' <= x && x <= '9' = Just $ toInteger $ fromEnum x - fromEnum '0'
+ | 'a' <= x && x <= 'z' = Just $ toInteger $ 10 + fromEnum x - fromEnum 'a'
+ | otherwise = Nothing
+
+
+-- | Interpret something either as a fractional token,
+-- a number followed by a selector, or an error.
+fnumTokens :: FilePath -> Position -> Text -> [Located Token]
+fnumTokens file pos ds =
+ case wholeNum of
+ Nothing -> [ tokFrom pos ds (Err MalformedLiteral) ]
+ Just i
+ | Just f <- fracNum, Just e <- expNum ->
+ [ tokFrom pos ds (Frac ((fromInteger i + f) * (eBase ^^ e)) rad) ]
+ | otherwise ->
+ [ tokFrom pos whole (Num i rad (T.length whole))
+ , tokFrom afterWhole rest (selectorToken rest)
+ ]
+
+ where
+ tokFrom tpos txt t =
+ Located { srcRange =
+ Range { from = tpos, to = moves tpos txt, source = file }
+ , thing = Token { tokenText = txt, tokenType = t }
+ }
+
+ afterWhole = moves pos whole
+
+ rad
+ | "0b" `T.isPrefixOf` ds = 2
+ | "0o" `T.isPrefixOf` ds = 8
+ | "0x" `T.isPrefixOf` ds = 16
+ | otherwise = 10
+
radI = fromIntegral rad :: Integer
radR = fromIntegral rad :: Rational
- (whole,rest) = T.break (== '.') ds
+ (whole,rest) = T.break (== '.') (if rad == 10 then ds else T.drop 2 ds)
digits = T.filter (/= '_')
expSym e = if rad == 10 then toLower e == 'e' else toLower e == 'p'
(frac,mbExp) = T.break expSym (T.drop 1 rest)
+ wholeStep mb c = do soFar <- mb
+ d <- fromDigit radI c
+ pure $! (radI * soFar + d)
- wholenNum = fromInteger
- $ T.foldl' (\x c -> radI * x + fromDigit c) 0
- $ digits whole
+ wholeNum = T.foldl' wholeStep (Just 0) (digits whole)
- fracNum = T.foldl' (\x c -> (x + fromInteger (fromDigit c)) / radR) 0
- $ T.reverse $ digits frac
+ fracStep mb c = do soFar <- mb
+ d <- fromInteger <$> fromDigit radI c
+ pure $! ((soFar + d) / radR)
+ fracNum = do let fds = T.reverse (digits frac)
+ guard (T.length fds > 0)
+ T.foldl' fracStep (Just 0) fds
+
expNum = case T.uncons mbExp of
- Nothing -> 0 :: Integer
+ Nothing -> Just (0 :: Integer)
Just (_,es) ->
case T.uncons es of
- Just ('+', more) -> read $ T.unpack more
- _ -> read $ T.unpack es
+ Just ('+', more) -> readDecimal more
+ Just ('-', more) -> negate <$> readDecimal more
+ _ -> readDecimal es
eBase = if rad == 10 then 10 else 2 :: Rational
+-- assumes we start with a dot
+selectorToken :: Text -> TokenT
+selectorToken txt
+ | Just n <- readDecimal body, n >= 0 = Selector (TupleSelectorTok n)
+ | Just (x,xs) <- T.uncons body
+ , id_first x
+ , T.all id_next xs = Selector (RecordSelectorTok body)
+ | otherwise = Err MalformedSelector
+ where
+ body = T.drop 1 txt
+ id_first x = isAlpha x || x == '_'
+ id_next x = isAlphaNum x || x == '_' || x == '\''
+
+
+readDecimal :: Integral a => Text -> Maybe a
+readDecimal txt = case T.decimal txt of
+ Right (a,more) | T.null more -> Just a
+ _ -> Nothing
+
+
-------------------------------------------------------------------------------
data AlexInput = Inp { alexPos :: !Position
@@ -462,13 +537,19 @@
| InvalidString
| InvalidChar
| LexicalError
+ | MalformedLiteral
+ | MalformedSelector
deriving (Eq, Show, Generic, NFData)
+data SelectorType = RecordSelectorTok Text | TupleSelectorTok Int
+ deriving (Eq, Show, Generic, NFData)
+
data TokenT = Num !Integer !Int !Int -- ^ value, base, number of digits
| Frac !Rational !Int -- ^ value, base.
| ChrLit !Char -- ^ character literal
| Ident ![T.Text] !T.Text -- ^ (qualified) identifier
| StrLit !String -- ^ string literal
+ | Selector !SelectorType -- ^ .hello or .123
| KW !TokenKW -- ^ keyword
| Op !TokenOp -- ^ operator
| Sym !TokenSym -- ^ symbol
diff --git a/src/Cryptol/Parser/NoPat.hs b/src/Cryptol/Parser/NoPat.hs
--- a/src/Cryptol/Parser/NoPat.hs
+++ b/src/Cryptol/Parser/NoPat.hs
@@ -29,6 +29,7 @@
import MonadLib hiding (mapM)
import Data.Maybe(maybeToList)
import qualified Data.Map as Map
+import Data.Text (Text)
import GHC.Generics (Generic)
import Control.DeepSeq
@@ -323,7 +324,7 @@
, annSigs :: Map.Map PName [Located (Schema PName)]
, annValueFs :: Map.Map PName [Located Fixity ]
, annTypeFs :: Map.Map PName [Located Fixity ]
- , annDocs :: Map.Map PName [Located String ]
+ , annDocs :: Map.Map PName [Located Text ]
}
type Annotates a = a -> StateT AnnotMap NoPatM a
@@ -477,7 +478,7 @@
return (Just (thing x))
-checkDocs :: PName -> [Located String] -> NoPatM (Maybe String)
+checkDocs :: PName -> [Located Text] -> NoPatM (Maybe Text)
checkDocs _ [] = return Nothing
checkDocs _ [d] = return (Just (thing d))
checkDocs f ds@(d:_) = do recordError $ MultipleDocs f (map srcRange ds)
@@ -502,7 +503,7 @@
toFixity _ = []
-- | Does this top-level declaration provide a documentation string?
-toDocs :: TopLevel (Decl PName) -> [(PName, [Located String])]
+toDocs :: TopLevel (Decl PName) -> [(PName, [Located Text])]
toDocs TopLevel { .. }
| Just txt <- tlDoc = go txt tlValue
| otherwise = []
diff --git a/src/Cryptol/Parser/ParserUtils.hs b/src/Cryptol/Parser/ParserUtils.hs
--- a/src/Cryptol/Parser/ParserUtils.hs
+++ b/src/Cryptol/Parser/ParserUtils.hs
@@ -22,6 +22,7 @@
import Data.Text(Text)
import qualified Data.Text as T
import qualified Data.Map as Map
+import Text.Read(readMaybe)
import GHC.Generics (Generic)
import Control.DeepSeq
@@ -32,6 +33,7 @@
import Cryptol.Parser.AST
import Cryptol.Parser.Lexer
+import Cryptol.Parser.LexerUtils(SelectorType(..))
import Cryptol.Parser.Position
import Cryptol.Parser.Utils (translateExprToNumT,widthIdent)
import Cryptol.Utils.Ident(packModName)
@@ -67,12 +69,16 @@
UnterminatedComment -> "unterminated comment"
UnterminatedString -> "unterminated string"
UnterminatedChar -> "unterminated character"
- InvalidString -> "invalid string literal:" ++
+ InvalidString -> "invalid string literal: " ++
T.unpack (tokenText it)
- InvalidChar -> "invalid character literal:" ++
+ InvalidChar -> "invalid character literal: " ++
T.unpack (tokenText it)
- LexicalError -> "unrecognized character:" ++
+ LexicalError -> "unrecognized character: " ++
T.unpack (tokenText it)
+ MalformedLiteral -> "malformed literal: " ++
+ T.unpack (tokenText it)
+ MalformedSelector -> "malformed selector: " ++
+ T.unpack (tokenText it)
where it = thing t
t : more -> unP (k t) cfg p s { sPrevTok = Just t, sTokens = more }
@@ -201,23 +207,23 @@
Token (StrLit x) _ -> x
_ -> panic "[Parser] getStr" ["not a string:", show l]
-numLit :: TokenT -> Expr PName
-numLit (Num x base digs)
- | base == 2 = ELit $ ECNum x (BinLit digs)
- | base == 8 = ELit $ ECNum x (OctLit digs)
- | base == 10 = ELit $ ECNum x DecLit
- | base == 16 = ELit $ ECNum x (HexLit digs)
+numLit :: Token -> Expr PName
+numLit Token { tokenText = txt, tokenType = Num x base digs }
+ | base == 2 = ELit $ ECNum x (BinLit txt digs)
+ | base == 8 = ELit $ ECNum x (OctLit txt digs)
+ | base == 10 = ELit $ ECNum x (DecLit txt)
+ | base == 16 = ELit $ ECNum x (HexLit txt digs)
numLit x = panic "[Parser] numLit" ["invalid numeric literal", show x]
-fracLit :: TokenT -> Expr PName
+fracLit :: Token -> Expr PName
fracLit tok =
- case tok of
+ case tokenType tok of
Frac x base
- | base == 2 -> ELit $ ECFrac x BinFrac
- | base == 8 -> ELit $ ECFrac x OctFrac
- | base == 10 -> ELit $ ECFrac x DecFrac
- | base == 16 -> ELit $ ECFrac x HexFrac
+ | base == 2 -> ELit $ ECFrac x $ BinFrac $ tokenText tok
+ | base == 8 -> ELit $ ECFrac x $ OctFrac $ tokenText tok
+ | base == 10 -> ELit $ ECFrac x $ DecFrac $ tokenText tok
+ | base == 16 -> ELit $ ECFrac x $ HexFrac $ tokenText tok
_ -> panic "[Parser] fracLit" [ "Invalid fraction", show tok ]
@@ -234,14 +240,6 @@
(errorMessage (srcRange tok) "Fixity levels must be between 1 and 100")
return (DFixity (Fixity assoc (fromInteger l)) qns)
-mkTupleSel :: Range -> Integer -> ParseM (Located Selector)
-mkTupleSel pos n
- | n < 0 = errorMessage pos
- (show n ++ " is not a valid tuple selector (they start from 0).")
- | toInteger asInt /= n = errorMessage pos "Tuple selector is too large."
- | otherwise = return $ Located pos $ TupleSel asInt Nothing
- where asInt = fromInteger n
-
fromStrLit :: Located Token -> ParseM (Located String)
fromStrLit loc = case tokenType (thing loc) of
StrLit str -> return loc { thing = str }
@@ -360,18 +358,18 @@
where noName = Located { srcRange = r, thing = mkIdent (T.pack "") }
toField t = Named { name = noName, value = t }
-exportDecl :: Maybe (Located String) -> ExportType -> Decl PName -> TopDecl PName
+exportDecl :: Maybe (Located Text) -> ExportType -> Decl PName -> TopDecl PName
exportDecl mbDoc e d = Decl TopLevel { tlExport = e
, tlDoc = mbDoc
, tlValue = d }
-exportNewtype :: ExportType -> Maybe (Located String) -> Newtype PName ->
+exportNewtype :: ExportType -> Maybe (Located Text) -> Newtype PName ->
TopDecl PName
exportNewtype e d n = TDNewtype TopLevel { tlExport = e
, tlDoc = d
, tlValue = n }
-mkParFun :: Maybe (Located String) ->
+mkParFun :: Maybe (Located Text) ->
Located PName ->
Schema PName ->
TopDecl PName
@@ -381,7 +379,7 @@
, pfFixity = Nothing
}
-mkParType :: Maybe (Located String) ->
+mkParType :: Maybe (Located Text) ->
Located PName ->
Located Kind ->
ParseM (TopDecl PName)
@@ -515,7 +513,7 @@
-- instead of just place it on the binding directly. A better solution might be
-- to just have a different constructor for primitives.
mkPrimDecl ::
- Maybe (Located String) -> LPName -> Schema PName -> [TopDecl PName]
+ Maybe (Located Text) -> LPName -> Schema PName -> [TopDecl PName]
mkPrimDecl mbDoc ln sig =
[ exportDecl mbDoc Public
$ DBind Bind { bName = ln
@@ -533,7 +531,7 @@
]
mkPrimTypeDecl ::
- Maybe (Located String) ->
+ Maybe (Located Text) ->
Schema PName ->
Located Kind ->
ParseM [TopDecl PName]
@@ -601,12 +599,11 @@
-- | Fix-up the documentation strings by removing the comment delimiters on each
-- end, and stripping out common prefixes on all the remaining lines.
-mkDoc :: Located Text -> Located String
+mkDoc :: Located Text -> Located Text
mkDoc ltxt = ltxt { thing = docStr }
where
- docStr = unlines
- $ map T.unpack
+ docStr = T.unlines
$ dropPrefix
$ trimFront
$ T.lines
@@ -713,8 +710,8 @@
_ -> errorMessage (srcRange (head ls))
"Invalid record field. Perhaps you meant to update a record?"
-selExprToSels :: Expr PName -> ParseM [Located Selector]
-selExprToSels e0 = reverse <$> go noLoc e0
+exprToFieldPath :: Expr PName -> ParseM [Located Selector]
+exprToFieldPath e0 = reverse <$> go noLoc e0
where
noLoc = panic "selExprToSels" ["Missing location?"]
go loc expr =
@@ -726,10 +723,35 @@
pure (Located { thing = s, srcRange = rng } : ls)
EVar (UnQual l) ->
pure [ Located { thing = RecordSel l Nothing, srcRange = loc } ]
- ELit (ECNum n _) ->
- do ts <- mkTupleSel loc n
- pure [ ts ]
+
+ ELit (ECNum n (DecLit {})) ->
+ pure [ Located { thing = TupleSel (fromInteger n) Nothing
+ , srcRange = loc } ]
+
+ ELit (ECFrac _ (DecFrac txt))
+ | (as,bs') <- T.break (== '.') txt
+ , Just a <- readMaybe (T.unpack as)
+ , Just (_,bs) <- T.uncons bs'
+ , Just b <- readMaybe (T.unpack bs)
+ , let fromP = from loc
+ , let midP = fromP { col = col fromP + T.length as + 1 } ->
+ -- these are backward because we reverse above
+ pure [ Located { thing = TupleSel b Nothing
+ , srcRange = loc { from = midP }
+ }
+ , Located { thing = TupleSel a Nothing
+ , srcRange = loc { to = midP }
+ }
+ ]
+
_ -> errorMessage loc "Invalid label in record update."
+mkSelector :: Token -> Selector
+mkSelector tok =
+ case tokenType tok of
+ Selector (TupleSelectorTok n) -> TupleSel n Nothing
+ Selector (RecordSelectorTok t) -> RecordSel (mkIdent t) Nothing
+ _ -> panic "mkSelector"
+ [ "Unexpected selector token", show tok ]
diff --git a/src/Cryptol/Prelude.hs b/src/Cryptol/Prelude.hs
--- a/src/Cryptol/Prelude.hs
+++ b/src/Cryptol/Prelude.hs
@@ -15,8 +15,11 @@
module Cryptol.Prelude
( preludeContents
+ , preludeReferenceContents
, floatContents
, arrayContents
+ , suiteBContents
+ , primeECContents
, cryptolTcContents
) where
@@ -28,11 +31,20 @@
preludeContents :: ByteString
preludeContents = B.pack [there|lib/Cryptol.cry|]
+preludeReferenceContents :: ByteString
+preludeReferenceContents = B.pack [there|lib/Cryptol/Reference.cry|]
+
floatContents :: ByteString
floatContents = B.pack [there|lib/Float.cry|]
arrayContents :: ByteString
arrayContents = B.pack [there|lib/Array.cry|]
+
+suiteBContents :: ByteString
+suiteBContents = B.pack [there|lib/SuiteB.cry|]
+
+primeECContents :: ByteString
+primeECContents = B.pack [there|lib/PrimeEC.cry|]
cryptolTcContents :: String
cryptolTcContents = [there|lib/CryptolTC.z3|]
diff --git a/src/Cryptol/PrimeEC.hs b/src/Cryptol/PrimeEC.hs
new file mode 100644
--- /dev/null
+++ b/src/Cryptol/PrimeEC.hs
@@ -0,0 +1,574 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Cryptol.PrimeEC
+-- Copyright : (c) Galois, Inc.
+-- License : BSD3
+-- Maintainer: rdockins@galois.com
+-- Stability : experimental
+--
+-- This module provides fast primitives for elliptic curve cryptography
+-- defined on @Z p@ for prime @p > 3@. These are exposed in cryptol
+-- by importing the built-in module "PrimeEC". The primary primitives
+-- exposed here are the doubling and addition primitives in the ECC group
+-- as well as scalar multiplication and the "twin" multiplication primitive,
+-- which simultaneously computes the addition of two scalar multiplies.
+--
+-- This module makes heavy use of some GHC internals regarding the
+-- representation of the Integer type, and the underlying GMP primitives
+-- in order to speed up the basic modular arithmetic operations.
+-----------------------------------------------------------------------------
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module Cryptol.PrimeEC
+ ( PrimeModulus
+ , primeModulus
+ , ProjectivePoint(..)
+ , integerToBigNat
+ , Integer.bigNatToInteger
+
+ , ec_double
+ , ec_add_nonzero
+ , ec_mult
+ , ec_twin_mult
+ ) where
+
+
+import GHC.Integer.GMP.Internals (BigNat)
+import qualified GHC.Integer.GMP.Internals as Integer
+import GHC.Prim
+import Data.Bits
+
+import Cryptol.TypeCheck.Solver.InfNat (widthInteger)
+import Cryptol.Utils.Panic
+
+-- | Points in the projective plane represented in
+-- homogenous coordinates.
+data ProjectivePoint =
+ ProjectivePoint
+ { px :: !BigNat
+ , py :: !BigNat
+ , pz :: !BigNat
+ }
+
+-- | The projective "point at infinity", which represents the zero element
+-- of the ECC group.
+zro :: ProjectivePoint
+zro = ProjectivePoint Integer.oneBigNat Integer.oneBigNat Integer.zeroBigNat
+
+-- | Coerce an integer value to a @BigNat@. This operation only really makes
+-- sense for nonnegative values, but this condition is not checked.
+integerToBigNat :: Integer -> BigNat
+integerToBigNat (Integer.S# i) = Integer.wordToBigNat (int2Word# i)
+integerToBigNat (Integer.Jp# b) = b
+integerToBigNat (Integer.Jn# b) = b
+
+-- | Simple newtype wrapping the @BigNat@ value of the
+-- modulus of the underlying field Z p. This modulus
+-- is required to be prime.
+newtype PrimeModulus = PrimeModulus { primeMod :: BigNat }
+
+
+-- | Inject an integer value into the @PrimeModulus@ type.
+-- This modulus is required to be prime.
+primeModulus :: Integer -> PrimeModulus
+primeModulus = PrimeModulus . integerToBigNat
+{-# INLINE primeModulus #-}
+
+
+-- Barrett reduction replaces a division by the modulus with
+-- two multiplications and some shifting, masking, and additions
+-- (and some fairly negligible pre-processing). For the size of
+-- moduli we are working with for ECC, this does not appear to be
+-- a performance win. Even for largest NIST curve (P-521) Barrett
+-- reduction is about 20% slower than naive modular reduction.
+-- Smaller curves are worse WRT the baseline.
+
+-- {-# INLINE primeModulus #-}
+-- primeModulus :: Integer -> PrimeModulus
+-- primeModulus = untrie modulusParameters
+
+-- data PrimeModulus = PrimeModulus
+-- { primeMod :: !Integer
+-- , barrettInverse :: !Integer
+-- , barrettK :: !Int
+-- , barrettMask :: !Integer
+-- }
+-- deriving (Show, Eq)
+
+-- {-# NOINLINE modulusParameters #-}
+-- modulusParameters :: Integer :->: PrimeModulus
+-- modulusParameters = trie computeModulusParameters
+
+-- computeModulusParameters :: Integer -> PrimeModulus
+-- computeModulusParameters p = PrimeModulus p inv k mask
+-- where
+-- k = fromInteger w
+
+-- b :: Integer
+-- b = 2 ^ (64::Int)
+
+-- -- w is the number of 64-bit words required to express p
+-- w = (widthInteger p + 63) `div` 64
+
+-- mask = b^(k+1) - 1
+
+-- -- inv = floor ( b^(2*k) / p )
+-- inv = b^(2*k) `div` p
+
+-- barrettReduction :: PrimeModulus -> Integer -> Integer
+-- barrettReduction p x = go r3
+-- where
+-- m = primeMod p
+-- k = barrettK p
+-- inv = barrettInverse p
+-- mask = barrettMask p
+
+-- -- q1 <- floor (x / b^(k-1))
+-- q1 = x `shiftR` (64 * (k-1))
+
+-- -- q2 <- q1 * floor ( b^(2*k) / m )
+-- q2 = q1 * inv
+
+-- -- q3 <- floor (q2 / b^(k+1))
+-- q3 = q2 `shiftR` (64 * (k+1))
+
+-- -- r1 <- x mod b^(k+1)
+-- r1 = x .&. mask
+
+-- -- r2 <- (q3 * m) mod b^(k+1)
+-- r2 = (q3 * m) .&. mask
+
+-- -- r3 <- r1 - r2
+-- r3 = r1 - r2
+
+-- -- up to 2 multiples of m must be removed
+-- go z = if z > m then go (z - m) else z
+
+-- | Modular addition of two values. The inputs are
+-- required to be in reduced form, and will output
+-- a value in reduced form.
+mod_add :: PrimeModulus -> BigNat -> BigNat -> BigNat
+mod_add p !x !y =
+ case Integer.isNullBigNat# rmp of
+ 0# -> rmp
+ _ -> r
+ where r = Integer.plusBigNat x y
+ rmp = Integer.minusBigNat r (primeMod p)
+
+-- | Compute the "half" value of a modular integer. For a given input @x@
+-- this is a value @y@ such that @y+y == x@. Such values must exist
+-- in @Z p@ when @p > 2@. The input @x@ is required to be in reduced form,
+-- and will output a value in reduced form.
+mod_half :: PrimeModulus -> BigNat -> BigNat
+mod_half p !x = if Integer.testBitBigNat x 0# then qodd else qeven
+ where
+ qodd = (Integer.plusBigNat x (primeMod p)) `Integer.shiftRBigNat` 1#
+ qeven = x `Integer.shiftRBigNat` 1#
+
+-- | Compute the modular multiplication of two input values. Currently, this
+-- uses naive modular reduction, and does not require the inputs to be in
+-- reduced form. The output is in reduced form.
+mod_mul :: PrimeModulus -> BigNat -> BigNat -> BigNat
+mod_mul p !x !y = (Integer.timesBigNat x y) `Integer.remBigNat` (primeMod p)
+
+-- | Compute the modular difference of two input values. The inputs are
+-- required to be in reduced form, and will output a value in reduced form.
+mod_sub :: PrimeModulus -> BigNat -> BigNat -> BigNat
+mod_sub p !x !y = mod_add p x (Integer.minusBigNat (primeMod p) y)
+
+-- | Compute the modular square of an input value @x@; that is, @x*x@.
+-- The input is not required to be in reduced form, and the output
+-- will be in reduced form.
+mod_square :: PrimeModulus -> BigNat -> BigNat
+mod_square p !x = Integer.sqrBigNat x `Integer.remBigNat` primeMod p
+
+-- | Compute the modular scalar multiplication @2x = x+x@.
+-- The input is required to be in reduced form and the output
+-- will be in reduced form.
+mul2 :: PrimeModulus -> BigNat -> BigNat
+mul2 p !x =
+ case Integer.isNullBigNat# rmp of
+ 0# -> rmp
+ _ -> r
+ where
+ r = x `Integer.shiftLBigNat` 1#
+ rmp = Integer.minusBigNat r (primeMod p)
+
+-- | Compute the modular scalar multiplication @3x = x+x+x@.
+-- The input is required to be in reduced form and the output
+-- will be in reduced form.
+mul3 :: PrimeModulus -> BigNat -> BigNat
+mul3 p x = mod_add p x $! mul2 p x
+
+-- | Compute the modular scalar multiplication @4x = x+x+x+x@.
+-- The input is required to be in reduced form and the output
+-- will be in reduced form.
+mul4 :: PrimeModulus -> BigNat -> BigNat
+mul4 p x = mul2 p $! mul2 p x
+
+-- | Compute the modular scalar multiplication @8x = x+x+x+x+x+x+x+x@.
+-- The input is required to be in reduced form and the output
+-- will be in reduced form.
+mul8 :: PrimeModulus -> BigNat -> BigNat
+mul8 p x = mul2 p $! mul4 p x
+
+-- | Compute the elliptic curve group doubling operation.
+-- In other words, if @S@ is a projective point on a curve,
+-- this operation computes @S+S@ in the ECC group.
+--
+-- In geometric terms, this operation computes a tangent line
+-- to the curve at @S@ and finds the (unique) intersection point of this
+-- line with the curve, @R@; then returns the point @R'@, which is @R@
+-- reflected across the x axis.
+ec_double :: PrimeModulus -> ProjectivePoint -> ProjectivePoint
+ec_double p (ProjectivePoint sx sy sz) =
+ if Integer.isZeroBigNat sz then zro else ProjectivePoint r18 r23 r13
+
+ where
+ r7 = mod_square p sz {- 7: t4 <- (t3)^2 -}
+ r8 = mod_sub p sx r7 {- 8: t5 <- t1 - t4 -}
+ r9 = mod_add p sx r7 {- 9: t4 <- t1 + t4 -}
+ r10 = mod_mul p r9 r8 {- 10: t5 <- t4 * t5 -}
+ r11 = mul3 p r10 {- 11: t4 <- 3 * t5 -}
+ r12 = mod_mul p sz sy {- 12: t3 <- t3 * t2 -}
+ r13 = mul2 p r12 {- 13: t3 <- 2 * t3 -}
+ r14 = mod_square p sy {- 14: t2 <- (t2)^2 -}
+ r15 = mod_mul p sx r14 {- 15: t5 <- t1 * t2 -}
+ r16 = mul4 p r15 {- 16: t5 <- 4 * t5 -}
+ r17 = mod_square p r11 {- 17: t1 <- (t4)^2 -}
+ r18 = mod_sub p r17 (mul2 p r16) {- 18: t1 <- t1 - 2 * t5 -}
+ r19 = mod_square p r14 {- 19: t2 <- (t2)^2 -}
+ r20 = mul8 p r19 {- 20: t2 <- 8 * t2 -}
+ r21 = mod_sub p r16 r18 {- 21: t5 <- t5 - t1 -}
+ r22 = mod_mul p r11 r21 {- 22: t5 <- t4 * t5 -}
+ r23 = mod_sub p r22 r20 {- 23: t2 <- t5 - t2 -}
+
+-- | Compute the elliptic curve group addition operation, including the special
+-- case for adding points which might be the identity.
+ec_add :: PrimeModulus -> ProjectivePoint -> ProjectivePoint -> ProjectivePoint
+ec_add p s t
+ | Integer.isZeroBigNat (pz s) = t
+ | Integer.isZeroBigNat (pz t) = s
+ | otherwise = ec_add_nonzero p s t
+{-# INLINE ec_add #-}
+
+
+-- | Compute the elliptic curve group subtraction operation, including the special
+-- cases for subtracting points which might be the identity.
+ec_sub :: PrimeModulus -> ProjectivePoint -> ProjectivePoint -> ProjectivePoint
+ec_sub p s t = ec_add p s u
+ where u = t{ py = Integer.minusBigNat (primeMod p) (py t) }
+{-# INLINE ec_sub #-}
+
+
+ec_negate :: PrimeModulus -> ProjectivePoint -> ProjectivePoint
+ec_negate p s = s{ py = Integer.minusBigNat (primeMod p) (py s) }
+{-# INLINE ec_negate #-}
+
+-- | Compute the elliptic curve group addition operation
+-- for values known not to be the identity.
+-- In other words, if @S@ and @T@ are projective points on a curve,
+-- with nonzero @z@ coordinate this operation computes @S+T@ in the ECC group.
+--
+-- In geometric terms, this operation computes a line that passes through
+-- @S@ and @T@, and finds the (unique) other point @R@ where the line intersects
+-- the curve; then returns the point @R'@, which is @R@ reflected across the x axis.
+-- In the special case where @S == T@, we instead call the @ec_double@ operation,
+-- which instead computes a tangent line to @S@ .
+ec_add_nonzero :: PrimeModulus -> ProjectivePoint -> ProjectivePoint -> ProjectivePoint
+ec_add_nonzero p s@(ProjectivePoint sx sy sz) (ProjectivePoint tx ty tz) =
+ if Integer.isZeroBigNat r13 then
+ if Integer.isZeroBigNat r14 then
+ ec_double p s
+ else
+ zro
+ else
+ ProjectivePoint r32 r37 r27
+
+ where
+ tNormalized = Integer.eqBigNat tz Integer.oneBigNat
+
+ tz2 = mod_square p tz
+ tz3 = mod_mul p tz tz2
+
+ r5 = if tNormalized then sx else mod_mul p sx tz2
+ r7 = if tNormalized then sy else mod_mul p sy tz3
+
+ r9 = mod_square p sz {- 9: t7 <- (t3)^2 -}
+ r10 = mod_mul p tx r9 {- 10: t4 <- t4 * t7 -}
+ r11 = mod_mul p sz r9 {- 11: t7 <- t3 * t7 -}
+ r12 = mod_mul p ty r11 {- 12: t5 <- t5 * t7 -}
+ r13 = mod_sub p r5 r10 {- 13: t4 <- t1 - t4 -}
+ r14 = mod_sub p r7 r12 {- 14: t5 <- t2 - t5 -}
+
+ r22 = mod_sub p (mul2 p r5) r13 {- 22: t1 <- 2*t1 - t4 -}
+ r23 = mod_sub p (mul2 p r7) r14 {- 23: t2 <- 2*t2 - t5 -}
+
+ r25 = if tNormalized then sz else mod_mul p sz tz
+
+ r27 = mod_mul p r25 r13 {- 27: t3 <- t3 * t4 -}
+ r28 = mod_square p r13 {- 28: t7 <- (t4)^2 -}
+ r29 = mod_mul p r13 r28 {- 29: t4 <- t4 * t7 -}
+ r30 = mod_mul p r22 r28 {- 30: t7 <- t1 * t7 -}
+ r31 = mod_square p r14 {- 31: t1 <- (t5)^2 -}
+ r32 = mod_sub p r31 r30 {- 32: t1 <- t1 - t7 -}
+ r33 = mod_sub p r30 (mul2 p r32) {- 33: t7 <- t7 - 2*t1 -}
+ r34 = mod_mul p r14 r33 {- 34: t5 <- t5 * t7 -}
+ r35 = mod_mul p r23 r29 {- 35: t4 <- t2 * t4 -}
+ r36 = mod_sub p r34 r35 {- 36: t2 <- t5 - t4 -}
+ r37 = mod_half p r36 {- 37: t2 <- t2/2 -}
+
+
+-- | Given a nonidentity projective point, normalize it so that
+-- its z component is 1. This helps to avoid some modular
+-- multiplies in @ec_add@, and may be a win if the point will
+-- be added many times.
+ec_normalize :: PrimeModulus -> ProjectivePoint -> ProjectivePoint
+ec_normalize p s@(ProjectivePoint x y z)
+ | Integer.eqBigNat z Integer.oneBigNat = s
+ | otherwise = ProjectivePoint x' y' Integer.oneBigNat
+ where
+ m = primeMod p
+
+ l = Integer.recipModBigNat z m
+ l2 = Integer.sqrBigNat l
+ l3 = Integer.timesBigNat l l2
+
+ x' = (Integer.timesBigNat x l2) `Integer.remBigNat` m
+ y' = (Integer.timesBigNat y l3) `Integer.remBigNat` m
+
+
+-- | Given an integer @k@ and a projective point @S@, compute
+-- the scalar multiplication @kS@, which is @S@ added to itself
+-- @k@ times.
+ec_mult :: PrimeModulus -> Integer -> ProjectivePoint -> ProjectivePoint
+ec_mult p d s
+ | d == 0 = zro
+ | d == 1 = s
+ | Integer.isZeroBigNat (pz s) = zro
+ | otherwise =
+ case m of
+ 0# -> panic "ec_mult" ["modulus too large", show (Integer.bigNatToInteger (primeMod p))]
+ _ -> go m zro
+
+ where
+ s' = ec_normalize p s
+ h = 3*d
+
+ d' = integerToBigNat d
+ h' = integerToBigNat h
+
+ m = case widthInteger h of
+ Integer.S# mint -> mint
+ _ -> 0#
+
+ go i !r
+ | tagToEnum# (i ==# 0#) = r
+ | otherwise = go (i -# 1#) r'
+
+ where
+ h_i = Integer.testBitBigNat h' i
+ d_i = Integer.testBitBigNat d' i
+
+ r' = if h_i then
+ if d_i then r2 else ec_add p r2 s'
+ else
+ if d_i then ec_sub p r2 s' else r2
+
+ r2 = ec_double p r
+
+{-# INLINE normalizeForTwinMult #-}
+
+-- | Compute the sum and difference of the given points,
+-- and normalize all four values. This can be done jointly
+-- in a more efficient way than computing the necessary
+-- field inverses separately.
+-- When given points S and T, the returned tuple contains
+-- normalized representations for (S, T, S+T, S-T).
+--
+-- Note there are some special cases that must be handled separately.
+normalizeForTwinMult ::
+ PrimeModulus -> ProjectivePoint -> ProjectivePoint ->
+ (ProjectivePoint, ProjectivePoint, ProjectivePoint, ProjectivePoint)
+normalizeForTwinMult p s t
+ -- S == 0 && T == 0
+ | Integer.isZeroBigNat a && Integer.isZeroBigNat b =
+ (zro, zro, zro, zro)
+
+ -- S == 0 && T != 0
+ | Integer.isZeroBigNat a =
+ let tnorm = ec_normalize p t
+ in (zro, tnorm, tnorm, ec_negate p tnorm)
+
+ -- T == 0 && S != 0
+ | Integer.isZeroBigNat b =
+ let snorm = ec_normalize p s
+ in (snorm, zro, snorm, snorm)
+
+ -- S+T == 0, both != 0
+ | Integer.isZeroBigNat c =
+ let snorm = ec_normalize p s
+ in (snorm, ec_negate p snorm, zro, ec_double p snorm)
+
+ -- S-T == 0, both != 0
+ | Integer.isZeroBigNat d =
+ let snorm = ec_normalize p s
+ in (snorm, snorm, ec_double p snorm, zro)
+
+ -- S, T, S+T and S-T all != 0
+ | otherwise = (s',t',spt',smt')
+
+ where
+ spt = ec_add p s t
+ smt = ec_sub p s t
+
+ m = primeMod p
+
+ a = pz s
+ b = pz t
+ c = pz spt
+ d = pz smt
+
+ ab = mod_mul p a b
+ cd = mod_mul p c d
+ abc = mod_mul p ab c
+ abd = mod_mul p ab d
+ acd = mod_mul p a cd
+ bcd = mod_mul p b cd
+
+ abcd = mod_mul p a bcd
+
+ e = Integer.recipModBigNat abcd m
+
+ a_inv = mod_mul p e bcd
+ b_inv = mod_mul p e acd
+ c_inv = mod_mul p e abd
+ d_inv = mod_mul p e abc
+
+ a_inv2 = mod_square p a_inv
+ a_inv3 = mod_mul p a_inv a_inv2
+
+ b_inv2 = mod_square p b_inv
+ b_inv3 = mod_mul p b_inv b_inv2
+
+ c_inv2 = mod_square p c_inv
+ c_inv3 = mod_mul p c_inv c_inv2
+
+ d_inv2 = mod_square p d_inv
+ d_inv3 = mod_mul p d_inv d_inv2
+
+ s' = ProjectivePoint (mod_mul p (px s) a_inv2) (mod_mul p (py s) a_inv3) Integer.oneBigNat
+ t' = ProjectivePoint (mod_mul p (px t) b_inv2) (mod_mul p (py t) b_inv3) Integer.oneBigNat
+
+ spt' = ProjectivePoint (mod_mul p (px spt) c_inv2) (mod_mul p (py spt) c_inv3) Integer.oneBigNat
+ smt' = ProjectivePoint (mod_mul p (px smt) d_inv2) (mod_mul p (py smt) d_inv3) Integer.oneBigNat
+
+
+-- | Given an integer @j@ and a projective point @S@, together with
+-- another integer @k@ and point @T@ compute the "twin" scalar
+-- the scalar multiplication @jS + kT@. This computation can be done
+-- essentially the same number of modular arithmetic operations
+-- as a single scalar multiplication by doing some additional bookkeeping
+-- and setup.
+ec_twin_mult :: PrimeModulus ->
+ Integer -> ProjectivePoint ->
+ Integer -> ProjectivePoint ->
+ ProjectivePoint
+ec_twin_mult p (integerToBigNat -> d0) s (integerToBigNat -> d1) t =
+ case m of
+ 0# -> panic "ec_twin_mult" ["modulus too large", show (Integer.bigNatToInteger (primeMod p))]
+ _ -> go m init_c0 init_c1 zro
+
+ where
+ (s',t',spt',smt') = normalizeForTwinMult p s t
+
+ m = case max 4 (widthInteger (Integer.bigNatToInteger (primeMod p))) of
+ Integer.S# mint -> mint
+ _ -> 0# -- if `m` doesn't fit into an Int, should be impossible
+
+ init_c0 = C False False (tst d0 (m -# 1#)) (tst d0 (m -# 2#)) (tst d0 (m -# 3#)) (tst d0 (m -# 4#))
+ init_c1 = C False False (tst d1 (m -# 1#)) (tst d1 (m -# 2#)) (tst d1 (m -# 3#)) (tst d1 (m -# 4#))
+
+ tst x i
+ | tagToEnum# (i >=# 0#) = Integer.testBitBigNat x i
+ | otherwise = False
+
+ f i =
+ if tagToEnum# (i <# 18#) then
+ if tagToEnum# (i <# 12#) then
+ if tagToEnum# (i <# 4#) then
+ 12#
+ else
+ 14#
+ else
+ if tagToEnum# (i <# 14#) then
+ 12#
+ else
+ 10#
+ else
+ if tagToEnum# (i <# 22#) then
+ 9#
+ else
+ if tagToEnum# (i <# 24#) then
+ 11#
+ else
+ 12#
+
+ go !k !c0 !c1 !r = if tagToEnum# (k <# 0#) then r else go (k -# 1#) c0' c1' r'
+ where
+ h0 = cStateToH c0
+ h1 = cStateToH c1
+ u0 = if tagToEnum# (h0 <# f h1) then 0# else (if cHead c0 then -1# else 1#)
+ u1 = if tagToEnum# (h1 <# f h0) then 0# else (if cHead c1 then -1# else 1#)
+ c0' = cStateUpdate u0 c0 (tst d0 (k -# 5#))
+ c1' = cStateUpdate u1 c1 (tst d1 (k -# 5#))
+
+ r2 = ec_double p r
+
+ r' =
+ case u0 of
+ -1# ->
+ case u1 of
+ -1# -> ec_sub p r2 spt'
+ 1# -> ec_sub p r2 smt'
+ _ -> ec_sub p r2 s'
+ 1# ->
+ case u1 of
+ -1# -> ec_add p r2 smt'
+ 1# -> ec_add p r2 spt'
+ _ -> ec_add p r2 s'
+ _ ->
+ case u1 of
+ -1# -> ec_sub p r2 t'
+ 1# -> ec_add p r2 t'
+ _ -> r2
+
+data CState = C !Bool !Bool !Bool !Bool !Bool !Bool
+
+{-# INLINE cHead #-}
+cHead :: CState -> Bool
+cHead (C c0 _ _ _ _ _) = c0
+
+{-# INLINE cStateToH #-}
+cStateToH :: CState -> Int#
+cStateToH c@(C c0 _ _ _ _ _) =
+ if c0 then 31# -# cStateToInt c else cStateToInt c
+
+{-# INLINE cStateToInt #-}
+cStateToInt :: CState -> Int#
+cStateToInt (C _ c1 c2 c3 c4 c5) =
+ (dataToTag# c1 `uncheckedIShiftL#` 4#) +#
+ (dataToTag# c2 `uncheckedIShiftL#` 3#) +#
+ (dataToTag# c3 `uncheckedIShiftL#` 2#) +#
+ (dataToTag# c4 `uncheckedIShiftL#` 1#) +#
+ (dataToTag# c5)
+
+{-# INLINE cStateUpdate #-}
+cStateUpdate :: Int# -> CState -> Bool -> CState
+cStateUpdate u (C _ c1 c2 c3 c4 c5) e =
+ case u of
+ 0# -> C c1 c2 c3 c4 c5 e
+ _ -> C (complement c1) c2 c3 c4 c5 e
diff --git a/src/Cryptol/REPL/Command.hs b/src/Cryptol/REPL/Command.hs
--- a/src/Cryptol/REPL/Command.hs
+++ b/src/Cryptol/REPL/Command.hs
@@ -60,9 +60,11 @@
import qualified Cryptol.Utils.Ident as M
import qualified Cryptol.ModuleSystem.Env as M
+import qualified Cryptol.Backend.Monad as E
import Cryptol.Eval.Concrete( Concrete(..) )
import qualified Cryptol.Eval.Concrete as Concrete
-import qualified Cryptol.Eval.Monad as E
+import qualified Cryptol.Eval.Env as E
+import qualified Cryptol.Eval.Type as E
import qualified Cryptol.Eval.Value as E
import qualified Cryptol.Eval.Reference as R
import Cryptol.Testing.Random
@@ -92,6 +94,7 @@
import qualified Control.Exception as X
import Control.Monad hiding (mapM, mapM)
+import qualified Control.Monad.Catch as Ex
import Control.Monad.IO.Class(liftIO)
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
@@ -119,7 +122,7 @@
import System.Random.TF(newTFGen)
import Numeric (showFFloat)
import qualified Data.Text as T
-import Data.IORef(newIORef,readIORef)
+import Data.IORef(newIORef,readIORef,writeIORef)
import GHC.Float (log1p, expm1)
@@ -337,10 +340,7 @@
evalCmd :: String -> REPL ()
evalCmd str = do
- letEnabled <- getLetEnabled
- ri <- if letEnabled
- then replParseInput str
- else P.ExprInput <$> replParseExpr str
+ ri <- replParseInput str
case ri of
P.ExprInput expr -> do
(val,_ty) <- replEvalExpr expr
@@ -359,6 +359,9 @@
-- explicitly make this a top-level declaration, so that it will
-- be generalized if mono-binds is enabled
replEvalDecl decl
+ P.EmptyInput ->
+ -- comment or empty input does nothing
+ pure ()
printCounterexample :: CounterExampleType -> P.Expr P.PName -> [Concrete.Value] -> REPL ()
printCounterexample cexTy pexpr vs =
@@ -382,15 +385,16 @@
dumpTestsCmd outFile str =
do expr <- replParseExpr str
(val, ty) <- replEvalExpr expr
- evo <- getEvalOpts
ppopts <- getPPValOpts
testNum <- getKnownUser "tests" :: REPL Int
g <- io newTFGen
+ tenv <- E.envTypes . M.deEnv <$> getDynEnv
+ let tyv = E.evalValType tenv ty
gens <-
- case TestR.dumpableType ty of
+ case TestR.dumpableType tyv of
Nothing -> raise (TypeNotTestable ty)
Just gens -> return gens
- tests <- io $ TestR.returnTests g evo gens val testNum
+ tests <- io $ TestR.returnTests g gens val testNum
out <- forM tests $
\(args, x) ->
do argOut <- mapM (rEval . E.ppValue Concrete ppopts) args
@@ -422,76 +426,81 @@
qcCmd qcMode str =
do expr <- replParseExpr str
(val,ty) <- replEvalExpr expr
- testNum <- getKnownUser "tests"
- case testableType ty of
- Just (Just sz,tys,vss) | qcMode == QCExhaust || sz <= toInteger testNum -> do
+ testNum <- (toInteger :: Int -> Integer) <$> getKnownUser "tests"
+ tenv <- E.envTypes . M.deEnv <$> getDynEnv
+ let tyv = E.evalValType tenv ty
+ percentRef <- io $ newIORef Nothing
+ testsRef <- io $ newIORef 0
+ case testableType tyv of
+ Just (Just sz,tys,vss,_gens) | qcMode == QCExhaust || sz <= testNum -> do
rPutStrLn "Using exhaustive testing."
- let f _ [] = panic "Cryptol.REPL.Command"
- ["Exhaustive testing ran out of test cases"]
- f _ (vs : vss1) = do
- evo <- getEvalOpts
- result <- io $ evalTest evo val vs
- return (result, vss1)
- testSpec = TestSpec {
- testFn = f
- , testProp = str
- , testTotal = sz
- , testPossible = Just sz
- , testRptProgress = ppProgress
- , testClrProgress = delProgress
- , testRptFailure = ppFailure tys expr
- , testRptSuccess = do
- delTesting
- prtLn $ "Passed " ++ show sz ++ " tests."
- rPutStrLn "Q.E.D."
- }
prt testingMsg
- report <- runTests testSpec vss
+ (res,num) <-
+ Ex.catch (exhaustiveTests (\n -> ppProgress percentRef testsRef n sz)
+ val vss)
+ (\ex -> do rPutStrLn "\nTest interrupted..."
+ num <- io $ readIORef testsRef
+ let report = TestReport Pass str num (Just sz)
+ ppReport (map E.tValTy tys) expr False report
+ rPutStrLn $ interruptedExhaust num sz
+ Ex.throwM (ex :: Ex.SomeException))
+ let report = TestReport res str num (Just sz)
+ delProgress
+ delTesting
+ ppReport (map E.tValTy tys) expr True report
return [report]
- Just (sz,tys,_) | qcMode == QCRandom ->
- case TestR.testableTypeGenerators ty of
- Nothing -> raise (TypeNotTestable ty)
- Just gens -> do
- rPutStrLn "Using random testing."
- evo <- getEvalOpts
- let testSpec = TestSpec {
- testFn = \sz' g ->
- io $ TestR.runOneTest evo val gens sz' g
- , testProp = str
- , testTotal = toInteger testNum
- , testPossible = sz
- , testRptProgress = ppProgress
- , testClrProgress = delProgress
- , testRptFailure = ppFailure tys expr
- , testRptSuccess = do
- delTesting
- prtLn $ "Passed " ++ show testNum ++ " tests."
- }
- prt testingMsg
- g <- io newTFGen
- report <- runTests testSpec g
- when (isPass (reportResult report)) $
- case sz of
- Nothing -> return ()
- Just n -> rPutStrLn $ coverageString testNum n
- return [report]
+ Just (sz,tys,_,gens) | qcMode == QCRandom -> do
+ rPutStrLn "Using random testing."
+ prt testingMsg
+ g <- io newTFGen
+ (res,num) <-
+ Ex.catch (randomTests (\n -> ppProgress percentRef testsRef n testNum)
+ testNum val gens g)
+ (\ex -> do rPutStrLn "\nTest interrupted..."
+ num <- io $ readIORef testsRef
+ let report = TestReport Pass str num sz
+ ppReport (map E.tValTy tys) expr False report
+ case sz of
+ Just n -> rPutStrLn $ coverageString num n
+ _ -> return ()
+ Ex.throwM (ex :: Ex.SomeException))
+ let report = TestReport res str num sz
+ delProgress
+ delTesting
+ ppReport (map E.tValTy tys) expr False report
+ case sz of
+ Just n | isPass res -> rPutStrLn $ coverageString testNum n
+ _ -> return ()
+ return [report]
_ -> raise (TypeNotTestable ty)
where
testingMsg = "Testing... "
+ interruptedExhaust testNum sz =
+ let percent = (100.0 :: Double) * (fromInteger testNum) / fromInteger sz
+ showValNum
+ | sz > 2 ^ (20::Integer) =
+ "2^^" ++ show (lg2 sz)
+ | otherwise = show sz
+ in "Test coverage: "
+ ++ showFFloat (Just 2) percent "% ("
+ ++ show testNum ++ " of "
+ ++ showValNum
+ ++ " values)"
+
coverageString testNum sz =
- let (percent, expectedUnique) = expectedCoverage testNum sz
- showValNum
- | sz > 2 ^ (20::Integer) =
- "2^^" ++ show (lg2 sz)
- | otherwise = show sz
- in "Expected test coverage: "
- ++ showFFloat (Just 2) percent "% ("
- ++ showFFloat (Just 0) expectedUnique " of "
- ++ showValNum
- ++ " values)"
+ let (percent, expectedUnique) = expectedCoverage testNum sz
+ showValNum
+ | sz > 2 ^ (20::Integer) =
+ "2^^" ++ show (lg2 sz)
+ | otherwise = show sz
+ in "Expected test coverage: "
+ ++ showFFloat (Just 2) percent "% ("
+ ++ showFFloat (Just 0) expectedUnique " of "
+ ++ showValNum
+ ++ " values)"
totProgressWidth = 4 -- 100%
@@ -505,19 +514,35 @@
prt msg = rPutStr msg >> io (hFlush stdout)
prtLn msg = rPutStrLn msg >> io (hFlush stdout)
- ppProgress this tot = unlessBatch $
- let percent = show (div (100 * this) tot) ++ "%"
- width = length percent
- pad = replicate (totProgressWidth - width) ' '
- in prt (pad ++ percent)
+ ppProgress percentRef testsRef this tot =
+ do io $ writeIORef testsRef this
+ let percent = show (div (100 * this) tot) ++ "%"
+ width = length percent
+ pad = replicate (totProgressWidth - width) ' '
+ unlessBatch $
+ do oldPercent <- io $ readIORef percentRef
+ case oldPercent of
+ Nothing ->
+ do io $ writeIORef percentRef (Just percent)
+ prt (pad ++ percent)
+ Just p | p /= percent ->
+ do io $ writeIORef percentRef (Just percent)
+ delProgress
+ prt (pad ++ percent)
+ _ -> return ()
del n = unlessBatch
$ prt (replicate n '\BS' ++ replicate n ' ' ++ replicate n '\BS')
delTesting = del (length testingMsg)
delProgress = del totProgressWidth
+ ppReport _tys _expr isExhaustive (TestReport Pass _str testNum _testPossible) =
+ do prtLn $ "Passed " ++ show testNum ++ " tests."
+ when isExhaustive (rPutStrLn "Q.E.D.")
+ ppReport tys expr _ (TestReport failure _str _testNum _testPossible) =
+ ppFailure tys expr failure
+
ppFailure tys pexpr failure = do
- delTesting
opts <- getPPValOpts
case failure of
FailFalse vs -> do
@@ -561,7 +586,7 @@
-- situations, we expect the naive approximation @k/n@ to be very
-- close to accurate and the expected number of unique values is
-- essentially equal to the number of tests.
-expectedCoverage :: Int -> Integer -> (Double, Double)
+expectedCoverage :: Integer -> Integer -> (Double, Double)
expectedCoverage testNum sz =
-- If the Double computation has enough precision, use the
-- "with replacement" formula.
@@ -632,7 +657,7 @@
~(EnvBool yes) <- getUser "show-examples"
when yes $ printCounterexample cexType pexpr vs
- bindItVariable t e
+ void $ bindItVariable t e
AllSatResult _ -> do
panic "REPL.Command" ["Unexpected AllSAtResult for ':safe' call"]
@@ -678,7 +703,7 @@
ThmResult ts -> do
rPutStrLn (if isSat then "Unsatisfiable" else "Q.E.D.")
(t, e) <- mkSolverResult cexStr (not isSat) (Left ts)
- bindItVariable t e
+ void $ bindItVariable t e
CounterExample cexType tevs -> do
rPutStrLn "Counterexample"
@@ -691,7 +716,7 @@
~(EnvBool yes) <- getUser "show-examples"
when yes $ printCounterexample cexType pexpr vs
- bindItVariable t e
+ void $ bindItVariable t e
AllSatResult tevss -> do
rPutStrLn "Satisfiable"
@@ -717,7 +742,7 @@
when yes $ forM_ vss (printSatisfyingModel pexpr)
case (ty, exprs) of
- (t, [e]) -> bindItVariable t e
+ (t, [e]) -> void $ bindItVariable t e
(t, es ) -> bindItVariables t es
seeStats <- getUserShowProverStats
@@ -753,7 +778,8 @@
Left sbvCfg -> liftModuleCmd $ SBV.satProve sbvCfg cmd
Right w4Cfg ->
do ~(EnvBool hashConsing) <- getUser "hash-consing"
- liftModuleCmd $ W4.satProve w4Cfg hashConsing cmd
+ ~(EnvBool warnUninterp) <- getUser "warnUninterp"
+ liftModuleCmd $ W4.satProve w4Cfg hashConsing warnUninterp cmd
stas <- io (readIORef timing)
return (firstProver,res,stas)
@@ -807,7 +833,8 @@
Right w4Cfg ->
do ~(EnvBool hashConsing) <- getUser "hash-consing"
- result <- liftModuleCmd $ W4.satProveOffline w4Cfg hashConsing cmd $ \f ->
+ ~(EnvBool warnUninterp) <- getUser "warnUninterp"
+ result <- liftModuleCmd $ W4.satProveOffline w4Cfg hashConsing warnUninterp cmd $ \f ->
do displayMsg
case mfile of
Just path ->
@@ -875,7 +902,7 @@
validEvalContext schema
val <- liftModuleCmd (rethrowEvalError . R.evaluate expr)
opts <- getPPValOpts
- rPrint $ R.ppValue opts val
+ rPrint $ R.ppEValue opts val
astOfCmd :: String -> REPL ()
astOfCmd str = do
@@ -915,7 +942,7 @@
let t = T.tWord (T.tNum (toInteger len * 8))
let x = T.EProofApp (T.ETApp (T.ETApp number (T.tNum val)) t)
let expr = T.EApp f x
- bindItVariable (T.tString len) expr
+ void $ bindItVariable (T.tString len) expr
-- | Convert a 'ByteString' (big-endian) of length @n@ to an 'Integer'
-- with @8*n@ bits. This function uses a balanced binary fold to
@@ -963,12 +990,10 @@
rEval :: E.Eval a -> REPL a
-rEval m = do ev <- getEvalOpts
- io (E.runEval ev m)
+rEval m = io (E.runEval m)
rEvalRethrow :: E.Eval a -> REPL a
-rEvalRethrow m = do ev <- getEvalOpts
- io $ rethrowEvalError $ E.runEval ev m
+rEvalRethrow m = io $ rethrowEvalError $ E.runEval m
reloadCmd :: REPL ()
reloadCmd = do
@@ -1391,11 +1416,7 @@
"requires:" $$ nest 2 (vcat rs)
doShowFix (T.atFixitiy a)
-
- case T.atDoc a of
- Nothing -> pure ()
- Just d -> do rPutStrLn ""
- rPutStrLn d
+ doShowDocString (T.atDoc a)
fromTyParam =
do p <- Map.lookup name (M.ifParamTypes params)
@@ -1413,9 +1434,7 @@
doShowTyHelp nameEnv decl doc =
do rPutStrLn ""
rPrint (runDoc nameEnv (nest 4 decl))
- case doc of
- Nothing -> return ()
- Just d -> rPutStrLn "" >> rPutStrLn d
+ doShowDocString doc
doShowFix fx =
case fx of
@@ -1452,9 +1471,7 @@
doShowFix $ ifDeclFixity `mplus`
(guard ifDeclInfix >> return P.defaultFixity)
- case ifDeclDoc of
- Just str -> rPutStrLn ('\n' : str)
- Nothing -> return ()
+ doShowDocString ifDeclDoc
fromNewtype =
do _ <- Map.lookup name (M.ifNewtypes env)
@@ -1471,10 +1488,12 @@
<+> pp (T.mvpType p)
doShowFix (T.mvpFixity p)
+ doShowDocString (T.mvpDoc p)
- case T.mvpDoc p of
- Just str -> rPutStrLn ('\n' : str)
- Nothing -> return ()
+ doShowDocString doc =
+ case doc of
+ Nothing -> pure ()
+ Just d -> rPutStrLn ('\n' : T.unpack d)
showCmdHelp c [arg] | ":set" `elem` cNames c = showOptionHelp arg
showCmdHelp c _args =
@@ -1565,10 +1584,10 @@
isDefaultWarn _ = False
filterDefaults w | warnDefaulting = Just w
- filterDefaults (M.TypeCheckWarnings xs) =
+ filterDefaults (M.TypeCheckWarnings nameMap xs) =
case filter (not . isDefaultWarn . snd) xs of
[] -> Nothing
- ys -> Just (M.TypeCheckWarnings ys)
+ ys -> Just (M.TypeCheckWarnings nameMap ys)
filterDefaults w = Just w
isShadowWarn (M.SymbolShadowed {}) = True
@@ -1639,10 +1658,12 @@
let su = T.listParamSubst tys
return (def1, T.apSubst su (T.sType sig))
- val <- liftModuleCmd (rethrowEvalError . M.evalExpr def1)
+ -- add "it" to the namespace via a new declaration
+ itVar <- bindItVariable ty def1
+
+ -- evaluate the it variable
+ val <- liftModuleCmd (rethrowEvalError . M.evalExpr (T.EVar itVar))
whenDebug (rPutStrLn (dump def1))
- -- add "it" to the namespace
- bindItVariable ty def1
return (val,ty)
where
warnDefaults ts =
@@ -1669,8 +1690,9 @@
either handler (return . Just) x
-- | Creates a fresh binding of "it" to the expression given, and adds
--- it to the current dynamic environment
-bindItVariable :: T.Type -> T.Expr -> REPL ()
+-- it to the current dynamic environment. The fresh name generated
+-- is returned.
+bindItVariable :: T.Type -> T.Expr -> REPL T.Name
bindItVariable ty expr = do
freshIt <- freshName itIdent M.UserName
let schema = T.Forall { T.sVars = []
@@ -1690,6 +1712,7 @@
let nenv' = M.singletonE (P.UnQual itIdent) freshIt
`M.shadowing` M.deNames denv
setDynEnv $ denv { M.deNames = nenv' }
+ return freshIt
-- | Extend the dynamic environment with a fresh binding for "it",
@@ -1701,16 +1724,14 @@
mb <- rEval (Concrete.toExpr prims ty val)
case mb of
Nothing -> return ()
- Just expr -> bindItVariable ty expr
-
-
+ Just expr -> void $ bindItVariable ty expr
-- | Creates a fresh binding of "it" to a finite sequence of
-- expressions of the same type, and adds that sequence to the current
-- dynamic environment
bindItVariables :: T.Type -> [T.Expr] -> REPL ()
-bindItVariables ty exprs = bindItVariable seqTy seqExpr
+bindItVariables ty exprs = void $ bindItVariable seqTy seqExpr
where
len = length exprs
seqTy = T.tSeq (T.tNum len) ty
diff --git a/src/Cryptol/REPL/Monad.hs b/src/Cryptol/REPL/Monad.hs
--- a/src/Cryptol/REPL/Monad.hs
+++ b/src/Cryptol/REPL/Monad.hs
@@ -48,9 +48,6 @@
, shouldContinue
, unlessBatch
, asBatch
- , disableLet
- , enableLet
- , getLetEnabled
, validEvalContext
, updateREPLTitle
, setUpdateREPLTitle
@@ -99,7 +96,7 @@
import Cryptol.Symbolic (SatNum(..))
import Cryptol.Symbolic.SBV (SBVPortfolioException)
import Cryptol.Symbolic.What4 (W4Exception)
-import Cryptol.Eval.Monad(PPFloatFormat(..),PPFloatExp(..))
+import Cryptol.Backend.Monad(PPFloatFormat(..),PPFloatExp(..))
import qualified Cryptol.Symbolic.SBV as SBV (proverNames, setupProver, defaultProver, SBVProverConfig)
import qualified Cryptol.Symbolic.What4 as W4 (proverNames, setupProver, W4ProverConfig)
@@ -158,9 +155,6 @@
, eLogger :: Logger
-- ^ Use this to send messages to the user
- , eLetEnabled :: Bool
- -- ^ Should we allow `let` on the command line
-
, eUpdateTitle :: REPL ()
-- ^ Execute this every time we load a module.
-- This is used to change the title of terminal when loading a module.
@@ -180,7 +174,6 @@
, eModuleEnv = env
, eUserEnv = mkUserEnv userOptions
, eLogger = l
- , eLetEnabled = True
, eUpdateTitle = return ()
, eProverConfig = Left SBV.defaultProver
}
@@ -444,16 +437,6 @@
modifyRW_ $ (\ rw -> rw { eIsBatch = wasBatch })
return a
-disableLet :: REPL ()
-disableLet = modifyRW_ (\ rw -> rw { eLetEnabled = False })
-
-enableLet :: REPL ()
-enableLet = modifyRW_ (\ rw -> rw { eLetEnabled = True })
-
--- | Are let-bindings enabled in this REPL?
-getLetEnabled :: REPL Bool
-getLetEnabled = fmap eLetEnabled getRW
-
-- | Is evaluation enabled. If the currently focused module is
-- parameterized, then we cannot evalute.
validEvalContext :: T.FreeVars a => a -> REPL ()
@@ -769,6 +752,8 @@
"Choose whether to display warnings when defaulting."
, simpleOpt "warnShadowing" (EnvBool True) noCheck
"Choose whether to display warnings when shadowing symbols."
+ , simpleOpt "warnUninterp" (EnvBool True) noCheck
+ "Choose whether to issue a warning when uninterpreted functions are used to implement primitives in the symbolic simulator."
, simpleOpt "smtfile" (EnvString "-") noCheck
"The file to use for SMT-Lib scripts (for debugging or offline proving).\nUse \"-\" for stdout."
, OptionDescr "mono-binds" (EnvBool True) noCheck
diff --git a/src/Cryptol/SHA.hs b/src/Cryptol/SHA.hs
new file mode 100644
--- /dev/null
+++ b/src/Cryptol/SHA.hs
@@ -0,0 +1,564 @@
+{-# LANGUAGE BangPatterns, CPP, FlexibleInstances #-}
+-- |Pure implementations of the SHA suite of hash functions. The implementation
+-- is basically an unoptimized translation of FIPS 180-2 into Haskell. If you're
+-- looking for performance, you probably won't find it here.
+module Cryptol.SHA
+ ( SHA256State(..), SHA512State(..)
+ , SHA256Block(..), SHA512Block(..)
+
+ -- * Raw SHA block functions
+ , processSHA512Block
+ , processSHA256Block
+
+ , initialSHA224State
+ , initialSHA256State
+ , initialSHA384State
+ , initialSHA512State
+
+ -- * Internal routines included for testing
+ , toBigEndianSBS, fromBigEndianSBS
+ , calc_k
+ , padSHA1, padSHA512
+ , padSHA1Chunks, padSHA512Chunks
+ )
+ where
+
+import Data.Bits
+import Data.ByteString.Lazy(ByteString)
+import Data.Word (Word32, Word64)
+import qualified Data.ByteString.Lazy as BS
+import qualified Data.ByteString as SBS
+
+-- --------------------------------------------------------------------------
+--
+-- State Definitions and Initial States
+--
+-- --------------------------------------------------------------------------
+
+data SHA256State = SHA256S !Word32 !Word32 !Word32 !Word32
+ !Word32 !Word32 !Word32 !Word32
+
+initialSHA224State :: SHA256State
+initialSHA224State = SHA256S 0xc1059ed8 0x367cd507 0x3070dd17 0xf70e5939
+ 0xffc00b31 0x68581511 0x64f98fa7 0xbefa4fa4
+
+initialSHA256State :: SHA256State
+initialSHA256State = SHA256S 0x6a09e667 0xbb67ae85 0x3c6ef372 0xa54ff53a
+ 0x510e527f 0x9b05688c 0x1f83d9ab 0x5be0cd19
+
+data SHA512State = SHA512S !Word64 !Word64 !Word64 !Word64
+ !Word64 !Word64 !Word64 !Word64
+
+initialSHA384State :: SHA512State
+initialSHA384State = SHA512S 0xcbbb9d5dc1059ed8 0x629a292a367cd507
+ 0x9159015a3070dd17 0x152fecd8f70e5939
+ 0x67332667ffc00b31 0x8eb44a8768581511
+ 0xdb0c2e0d64f98fa7 0x47b5481dbefa4fa4
+
+initialSHA512State :: SHA512State
+initialSHA512State = SHA512S 0x6a09e667f3bcc908 0xbb67ae8584caa73b
+ 0x3c6ef372fe94f82b 0xa54ff53a5f1d36f1
+ 0x510e527fade682d1 0x9b05688c2b3e6c1f
+ 0x1f83d9abfb41bd6b 0x5be0cd19137e2179
+
+
+-- --------------------------------------------------------------------------
+--
+-- Padding
+--
+-- --------------------------------------------------------------------------
+
+padSHA1 :: ByteString -> ByteString
+padSHA1 = generic_pad 448 512 64
+
+padSHA1Chunks :: Int -> [SBS.ByteString]
+padSHA1Chunks = generic_pad_chunks 448 512 64
+
+padSHA512 :: ByteString -> ByteString
+padSHA512 = generic_pad 896 1024 128
+
+padSHA512Chunks :: Int -> [SBS.ByteString]
+padSHA512Chunks = generic_pad_chunks 896 1024 128
+
+generic_pad :: Word64 -> Word64 -> Int -> ByteString -> ByteString
+generic_pad a b lSize bs =
+ BS.fromChunks $! go 0 chunks
+ where
+ chunks = BS.toChunks bs
+
+ -- Generates the padded ByteString at the same time it computes the length
+ -- of input. If the length is computed before the computation of the hash, it
+ -- will break the lazy evaluation of the input and no longer run in constant
+ -- memory space.
+ go !len [] = generic_pad_chunks a b lSize len
+ go !len (c:cs) = c : go (len + SBS.length c) cs
+
+generic_pad_chunks :: Word64 -> Word64 -> Int -> Int -> [SBS.ByteString]
+generic_pad_chunks a b lSize len =
+ let lenBits = fromIntegral $ len * 8
+ k = calc_k a b lenBits
+ -- INVARIANT: k is necessarily > 0, and (k + 1) is a multiple of 8.
+ kBytes = (k + 1) `div` 8
+ nZeroBytes = fromIntegral $! kBytes - 1
+ padLength = toBigEndianSBS lSize lenBits
+ in [SBS.singleton 0x80, SBS.replicate nZeroBytes 0, padLength]
+
+-- Given a, b, and l, calculate the smallest k such that (l + 1 + k) mod b = a.
+calc_k :: Word64 -> Word64 -> Word64 -> Word64
+calc_k a b l =
+ if r <= -1
+ then fromIntegral r + b
+ else fromIntegral r
+ where
+ r = toInteger a - toInteger l `mod` toInteger b - 1
+
+toBigEndianSBS :: (Integral a, Bits a) => Int -> a -> SBS.ByteString
+toBigEndianSBS s val = SBS.pack $ map getBits [s - 8, s - 16 .. 0]
+ where
+ getBits x = fromIntegral $ (val `shiftR` x) .&. 0xFF
+
+fromBigEndianSBS :: (Integral a, Bits a) => SBS.ByteString -> a
+fromBigEndianSBS =
+ SBS.foldl (\ acc x -> (acc `shiftL` 8) + fromIntegral x) 0
+
+-- --------------------------------------------------------------------------
+--
+-- SHA Functions
+--
+-- --------------------------------------------------------------------------
+
+{-# SPECIALIZE ch :: Word32 -> Word32 -> Word32 -> Word32 #-}
+{-# SPECIALIZE ch :: Word64 -> Word64 -> Word64 -> Word64 #-}
+ch :: Bits a => a -> a -> a -> a
+ch x y z = (x .&. y) `xor` (complement x .&. z)
+
+{-# SPECIALIZE maj :: Word32 -> Word32 -> Word32 -> Word32 #-}
+{-# SPECIALIZE maj :: Word64 -> Word64 -> Word64 -> Word64 #-}
+maj :: Bits a => a -> a -> a -> a
+maj x y z = (x .&. (y .|. z)) .|. (y .&. z)
+-- note:
+-- the original functions is (x & y) ^ (x & z) ^ (y & z)
+-- if you fire off truth tables, this is equivalent to
+-- (x & y) | (x & z) | (y & z)
+-- which you can the use distribution on:
+-- (x & (y | z)) | (y & z)
+-- which saves us one operation.
+
+bsig256_0 :: Word32 -> Word32
+bsig256_0 x = rotateR x 2 `xor` rotateR x 13 `xor` rotateR x 22
+
+bsig256_1 :: Word32 -> Word32
+bsig256_1 x = rotateR x 6 `xor` rotateR x 11 `xor` rotateR x 25
+
+lsig256_0 :: Word32 -> Word32
+lsig256_0 x = rotateR x 7 `xor` rotateR x 18 `xor` shiftR x 3
+
+lsig256_1 :: Word32 -> Word32
+lsig256_1 x = rotateR x 17 `xor` rotateR x 19 `xor` shiftR x 10
+
+bsig512_0 :: Word64 -> Word64
+bsig512_0 x = rotateR x 28 `xor` rotateR x 34 `xor` rotateR x 39
+
+bsig512_1 :: Word64 -> Word64
+bsig512_1 x = rotateR x 14 `xor` rotateR x 18 `xor` rotateR x 41
+
+lsig512_0 :: Word64 -> Word64
+lsig512_0 x = rotateR x 1 `xor` rotateR x 8 `xor` shiftR x 7
+
+lsig512_1 :: Word64 -> Word64
+lsig512_1 x = rotateR x 19 `xor` rotateR x 61 `xor` shiftR x 6
+
+-- --------------------------------------------------------------------------
+--
+-- Message Schedules
+--
+-- --------------------------------------------------------------------------
+
+
+data SHA256Block = SHA256Block !Word32 !Word32 !Word32 !Word32 !Word32 -- 00-04
+ !Word32 !Word32 !Word32 !Word32 !Word32 -- 05-09
+ !Word32 !Word32 !Word32 !Word32 !Word32 -- 10-14
+ !Word32
+
+data SHA256Sched = SHA256Sched !Word32 !Word32 !Word32 !Word32 !Word32 -- 00-04
+ !Word32 !Word32 !Word32 !Word32 !Word32 -- 05-09
+ !Word32 !Word32 !Word32 !Word32 !Word32 -- 10-14
+ !Word32 !Word32 !Word32 !Word32 !Word32 -- 15-19
+ !Word32 !Word32 !Word32 !Word32 !Word32 -- 20-24
+ !Word32 !Word32 !Word32 !Word32 !Word32 -- 25-29
+ !Word32 !Word32 !Word32 !Word32 !Word32 -- 30-34
+ !Word32 !Word32 !Word32 !Word32 !Word32 -- 35-39
+ !Word32 !Word32 !Word32 !Word32 !Word32 -- 40-44
+ !Word32 !Word32 !Word32 !Word32 !Word32 -- 45-49
+ !Word32 !Word32 !Word32 !Word32 !Word32 -- 50-54
+ !Word32 !Word32 !Word32 !Word32 !Word32 -- 55-59
+ !Word32 !Word32 !Word32 !Word32 -- 60-63
+
+getSHA256Sched :: SHA256Block -> SHA256Sched
+getSHA256Sched (SHA256Block w00 w01 w02 w03
+ w04 w05 w06 w07
+ w08 w09 w10 w11
+ w12 w13 w14 w15) =
+ let w16 = lsig256_1 w14 + w09 + lsig256_0 w01 + w00
+ w17 = lsig256_1 w15 + w10 + lsig256_0 w02 + w01
+ w18 = lsig256_1 w16 + w11 + lsig256_0 w03 + w02
+ w19 = lsig256_1 w17 + w12 + lsig256_0 w04 + w03
+ w20 = lsig256_1 w18 + w13 + lsig256_0 w05 + w04
+ w21 = lsig256_1 w19 + w14 + lsig256_0 w06 + w05
+ w22 = lsig256_1 w20 + w15 + lsig256_0 w07 + w06
+ w23 = lsig256_1 w21 + w16 + lsig256_0 w08 + w07
+ w24 = lsig256_1 w22 + w17 + lsig256_0 w09 + w08
+ w25 = lsig256_1 w23 + w18 + lsig256_0 w10 + w09
+ w26 = lsig256_1 w24 + w19 + lsig256_0 w11 + w10
+ w27 = lsig256_1 w25 + w20 + lsig256_0 w12 + w11
+ w28 = lsig256_1 w26 + w21 + lsig256_0 w13 + w12
+ w29 = lsig256_1 w27 + w22 + lsig256_0 w14 + w13
+ w30 = lsig256_1 w28 + w23 + lsig256_0 w15 + w14
+ w31 = lsig256_1 w29 + w24 + lsig256_0 w16 + w15
+ w32 = lsig256_1 w30 + w25 + lsig256_0 w17 + w16
+ w33 = lsig256_1 w31 + w26 + lsig256_0 w18 + w17
+ w34 = lsig256_1 w32 + w27 + lsig256_0 w19 + w18
+ w35 = lsig256_1 w33 + w28 + lsig256_0 w20 + w19
+ w36 = lsig256_1 w34 + w29 + lsig256_0 w21 + w20
+ w37 = lsig256_1 w35 + w30 + lsig256_0 w22 + w21
+ w38 = lsig256_1 w36 + w31 + lsig256_0 w23 + w22
+ w39 = lsig256_1 w37 + w32 + lsig256_0 w24 + w23
+ w40 = lsig256_1 w38 + w33 + lsig256_0 w25 + w24
+ w41 = lsig256_1 w39 + w34 + lsig256_0 w26 + w25
+ w42 = lsig256_1 w40 + w35 + lsig256_0 w27 + w26
+ w43 = lsig256_1 w41 + w36 + lsig256_0 w28 + w27
+ w44 = lsig256_1 w42 + w37 + lsig256_0 w29 + w28
+ w45 = lsig256_1 w43 + w38 + lsig256_0 w30 + w29
+ w46 = lsig256_1 w44 + w39 + lsig256_0 w31 + w30
+ w47 = lsig256_1 w45 + w40 + lsig256_0 w32 + w31
+ w48 = lsig256_1 w46 + w41 + lsig256_0 w33 + w32
+ w49 = lsig256_1 w47 + w42 + lsig256_0 w34 + w33
+ w50 = lsig256_1 w48 + w43 + lsig256_0 w35 + w34
+ w51 = lsig256_1 w49 + w44 + lsig256_0 w36 + w35
+ w52 = lsig256_1 w50 + w45 + lsig256_0 w37 + w36
+ w53 = lsig256_1 w51 + w46 + lsig256_0 w38 + w37
+ w54 = lsig256_1 w52 + w47 + lsig256_0 w39 + w38
+ w55 = lsig256_1 w53 + w48 + lsig256_0 w40 + w39
+ w56 = lsig256_1 w54 + w49 + lsig256_0 w41 + w40
+ w57 = lsig256_1 w55 + w50 + lsig256_0 w42 + w41
+ w58 = lsig256_1 w56 + w51 + lsig256_0 w43 + w42
+ w59 = lsig256_1 w57 + w52 + lsig256_0 w44 + w43
+ w60 = lsig256_1 w58 + w53 + lsig256_0 w45 + w44
+ w61 = lsig256_1 w59 + w54 + lsig256_0 w46 + w45
+ w62 = lsig256_1 w60 + w55 + lsig256_0 w47 + w46
+ w63 = lsig256_1 w61 + w56 + lsig256_0 w48 + w47
+ in SHA256Sched w00 w01 w02 w03 w04 w05 w06 w07 w08 w09
+ w10 w11 w12 w13 w14 w15 w16 w17 w18 w19
+ w20 w21 w22 w23 w24 w25 w26 w27 w28 w29
+ w30 w31 w32 w33 w34 w35 w36 w37 w38 w39
+ w40 w41 w42 w43 w44 w45 w46 w47 w48 w49
+ w50 w51 w52 w53 w54 w55 w56 w57 w58 w59
+ w60 w61 w62 w63
+
+data SHA512Block = SHA512Block !Word64 !Word64 !Word64 !Word64 !Word64 -- 0- 4
+ !Word64 !Word64 !Word64 !Word64 !Word64 -- 5- 9
+ !Word64 !Word64 !Word64 !Word64 !Word64 -- 10-14
+ !Word64 -- 15
+
+data SHA512Sched = SHA512Sched !Word64 !Word64 !Word64 !Word64 !Word64 -- 0- 4
+ !Word64 !Word64 !Word64 !Word64 !Word64 -- 5- 9
+ !Word64 !Word64 !Word64 !Word64 !Word64 -- 10-14
+ !Word64 !Word64 !Word64 !Word64 !Word64 -- 15-19
+ !Word64 !Word64 !Word64 !Word64 !Word64 -- 20-24
+ !Word64 !Word64 !Word64 !Word64 !Word64 -- 25-29
+ !Word64 !Word64 !Word64 !Word64 !Word64 -- 30-34
+ !Word64 !Word64 !Word64 !Word64 !Word64 -- 35-39
+ !Word64 !Word64 !Word64 !Word64 !Word64 -- 40-44
+ !Word64 !Word64 !Word64 !Word64 !Word64 -- 45-49
+ !Word64 !Word64 !Word64 !Word64 !Word64 -- 50-54
+ !Word64 !Word64 !Word64 !Word64 !Word64 -- 55-59
+ !Word64 !Word64 !Word64 !Word64 !Word64 -- 60-64
+ !Word64 !Word64 !Word64 !Word64 !Word64 -- 65-69
+ !Word64 !Word64 !Word64 !Word64 !Word64 -- 70-74
+ !Word64 !Word64 !Word64 !Word64 !Word64 -- 75-79
+
+getSHA512Sched :: SHA512Block -> SHA512Sched
+getSHA512Sched (SHA512Block w00 w01 w02 w03
+ w04 w05 w06 w07
+ w08 w09 w10 w11
+ w12 w13 w14 w15) =
+ let w16 = lsig512_1 w14 + w09 + lsig512_0 w01 + w00
+ w17 = lsig512_1 w15 + w10 + lsig512_0 w02 + w01
+ w18 = lsig512_1 w16 + w11 + lsig512_0 w03 + w02
+ w19 = lsig512_1 w17 + w12 + lsig512_0 w04 + w03
+ w20 = lsig512_1 w18 + w13 + lsig512_0 w05 + w04
+ w21 = lsig512_1 w19 + w14 + lsig512_0 w06 + w05
+ w22 = lsig512_1 w20 + w15 + lsig512_0 w07 + w06
+ w23 = lsig512_1 w21 + w16 + lsig512_0 w08 + w07
+ w24 = lsig512_1 w22 + w17 + lsig512_0 w09 + w08
+ w25 = lsig512_1 w23 + w18 + lsig512_0 w10 + w09
+ w26 = lsig512_1 w24 + w19 + lsig512_0 w11 + w10
+ w27 = lsig512_1 w25 + w20 + lsig512_0 w12 + w11
+ w28 = lsig512_1 w26 + w21 + lsig512_0 w13 + w12
+ w29 = lsig512_1 w27 + w22 + lsig512_0 w14 + w13
+ w30 = lsig512_1 w28 + w23 + lsig512_0 w15 + w14
+ w31 = lsig512_1 w29 + w24 + lsig512_0 w16 + w15
+ w32 = lsig512_1 w30 + w25 + lsig512_0 w17 + w16
+ w33 = lsig512_1 w31 + w26 + lsig512_0 w18 + w17
+ w34 = lsig512_1 w32 + w27 + lsig512_0 w19 + w18
+ w35 = lsig512_1 w33 + w28 + lsig512_0 w20 + w19
+ w36 = lsig512_1 w34 + w29 + lsig512_0 w21 + w20
+ w37 = lsig512_1 w35 + w30 + lsig512_0 w22 + w21
+ w38 = lsig512_1 w36 + w31 + lsig512_0 w23 + w22
+ w39 = lsig512_1 w37 + w32 + lsig512_0 w24 + w23
+ w40 = lsig512_1 w38 + w33 + lsig512_0 w25 + w24
+ w41 = lsig512_1 w39 + w34 + lsig512_0 w26 + w25
+ w42 = lsig512_1 w40 + w35 + lsig512_0 w27 + w26
+ w43 = lsig512_1 w41 + w36 + lsig512_0 w28 + w27
+ w44 = lsig512_1 w42 + w37 + lsig512_0 w29 + w28
+ w45 = lsig512_1 w43 + w38 + lsig512_0 w30 + w29
+ w46 = lsig512_1 w44 + w39 + lsig512_0 w31 + w30
+ w47 = lsig512_1 w45 + w40 + lsig512_0 w32 + w31
+ w48 = lsig512_1 w46 + w41 + lsig512_0 w33 + w32
+ w49 = lsig512_1 w47 + w42 + lsig512_0 w34 + w33
+ w50 = lsig512_1 w48 + w43 + lsig512_0 w35 + w34
+ w51 = lsig512_1 w49 + w44 + lsig512_0 w36 + w35
+ w52 = lsig512_1 w50 + w45 + lsig512_0 w37 + w36
+ w53 = lsig512_1 w51 + w46 + lsig512_0 w38 + w37
+ w54 = lsig512_1 w52 + w47 + lsig512_0 w39 + w38
+ w55 = lsig512_1 w53 + w48 + lsig512_0 w40 + w39
+ w56 = lsig512_1 w54 + w49 + lsig512_0 w41 + w40
+ w57 = lsig512_1 w55 + w50 + lsig512_0 w42 + w41
+ w58 = lsig512_1 w56 + w51 + lsig512_0 w43 + w42
+ w59 = lsig512_1 w57 + w52 + lsig512_0 w44 + w43
+ w60 = lsig512_1 w58 + w53 + lsig512_0 w45 + w44
+ w61 = lsig512_1 w59 + w54 + lsig512_0 w46 + w45
+ w62 = lsig512_1 w60 + w55 + lsig512_0 w47 + w46
+ w63 = lsig512_1 w61 + w56 + lsig512_0 w48 + w47
+ w64 = lsig512_1 w62 + w57 + lsig512_0 w49 + w48
+ w65 = lsig512_1 w63 + w58 + lsig512_0 w50 + w49
+ w66 = lsig512_1 w64 + w59 + lsig512_0 w51 + w50
+ w67 = lsig512_1 w65 + w60 + lsig512_0 w52 + w51
+ w68 = lsig512_1 w66 + w61 + lsig512_0 w53 + w52
+ w69 = lsig512_1 w67 + w62 + lsig512_0 w54 + w53
+ w70 = lsig512_1 w68 + w63 + lsig512_0 w55 + w54
+ w71 = lsig512_1 w69 + w64 + lsig512_0 w56 + w55
+ w72 = lsig512_1 w70 + w65 + lsig512_0 w57 + w56
+ w73 = lsig512_1 w71 + w66 + lsig512_0 w58 + w57
+ w74 = lsig512_1 w72 + w67 + lsig512_0 w59 + w58
+ w75 = lsig512_1 w73 + w68 + lsig512_0 w60 + w59
+ w76 = lsig512_1 w74 + w69 + lsig512_0 w61 + w60
+ w77 = lsig512_1 w75 + w70 + lsig512_0 w62 + w61
+ w78 = lsig512_1 w76 + w71 + lsig512_0 w63 + w62
+ w79 = lsig512_1 w77 + w72 + lsig512_0 w64 + w63
+ in SHA512Sched w00 w01 w02 w03 w04 w05 w06 w07 w08 w09
+ w10 w11 w12 w13 w14 w15 w16 w17 w18 w19
+ w20 w21 w22 w23 w24 w25 w26 w27 w28 w29
+ w30 w31 w32 w33 w34 w35 w36 w37 w38 w39
+ w40 w41 w42 w43 w44 w45 w46 w47 w48 w49
+ w50 w51 w52 w53 w54 w55 w56 w57 w58 w59
+ w60 w61 w62 w63 w64 w65 w66 w67 w68 w69
+ w70 w71 w72 w73 w74 w75 w76 w77 w78 w79
+
+-- --------------------------------------------------------------------------
+--
+-- SHA Block Processors
+--
+-- --------------------------------------------------------------------------
+
+
+processSHA256Block :: SHA256State -> SHA256Block -> SHA256State
+processSHA256Block !s00@(SHA256S a00 b00 c00 d00 e00 f00 g00 h00) !blk = do
+ let (SHA256Sched w00 w01 w02 w03 w04 w05 w06 w07 w08 w09
+ w10 w11 w12 w13 w14 w15 w16 w17 w18 w19
+ w20 w21 w22 w23 w24 w25 w26 w27 w28 w29
+ w30 w31 w32 w33 w34 w35 w36 w37 w38 w39
+ w40 w41 w42 w43 w44 w45 w46 w47 w48 w49
+ w50 w51 w52 w53 w54 w55 w56 w57 w58 w59
+ w60 w61 w62 w63) = getSHA256Sched blk
+ s01 = step256 s00 0x428a2f98 w00
+ s02 = step256 s01 0x71374491 w01
+ s03 = step256 s02 0xb5c0fbcf w02
+ s04 = step256 s03 0xe9b5dba5 w03
+ s05 = step256 s04 0x3956c25b w04
+ s06 = step256 s05 0x59f111f1 w05
+ s07 = step256 s06 0x923f82a4 w06
+ s08 = step256 s07 0xab1c5ed5 w07
+ s09 = step256 s08 0xd807aa98 w08
+ s10 = step256 s09 0x12835b01 w09
+ s11 = step256 s10 0x243185be w10
+ s12 = step256 s11 0x550c7dc3 w11
+ s13 = step256 s12 0x72be5d74 w12
+ s14 = step256 s13 0x80deb1fe w13
+ s15 = step256 s14 0x9bdc06a7 w14
+ s16 = step256 s15 0xc19bf174 w15
+ s17 = step256 s16 0xe49b69c1 w16
+ s18 = step256 s17 0xefbe4786 w17
+ s19 = step256 s18 0x0fc19dc6 w18
+ s20 = step256 s19 0x240ca1cc w19
+ s21 = step256 s20 0x2de92c6f w20
+ s22 = step256 s21 0x4a7484aa w21
+ s23 = step256 s22 0x5cb0a9dc w22
+ s24 = step256 s23 0x76f988da w23
+ s25 = step256 s24 0x983e5152 w24
+ s26 = step256 s25 0xa831c66d w25
+ s27 = step256 s26 0xb00327c8 w26
+ s28 = step256 s27 0xbf597fc7 w27
+ s29 = step256 s28 0xc6e00bf3 w28
+ s30 = step256 s29 0xd5a79147 w29
+ s31 = step256 s30 0x06ca6351 w30
+ s32 = step256 s31 0x14292967 w31
+ s33 = step256 s32 0x27b70a85 w32
+ s34 = step256 s33 0x2e1b2138 w33
+ s35 = step256 s34 0x4d2c6dfc w34
+ s36 = step256 s35 0x53380d13 w35
+ s37 = step256 s36 0x650a7354 w36
+ s38 = step256 s37 0x766a0abb w37
+ s39 = step256 s38 0x81c2c92e w38
+ s40 = step256 s39 0x92722c85 w39
+ s41 = step256 s40 0xa2bfe8a1 w40
+ s42 = step256 s41 0xa81a664b w41
+ s43 = step256 s42 0xc24b8b70 w42
+ s44 = step256 s43 0xc76c51a3 w43
+ s45 = step256 s44 0xd192e819 w44
+ s46 = step256 s45 0xd6990624 w45
+ s47 = step256 s46 0xf40e3585 w46
+ s48 = step256 s47 0x106aa070 w47
+ s49 = step256 s48 0x19a4c116 w48
+ s50 = step256 s49 0x1e376c08 w49
+ s51 = step256 s50 0x2748774c w50
+ s52 = step256 s51 0x34b0bcb5 w51
+ s53 = step256 s52 0x391c0cb3 w52
+ s54 = step256 s53 0x4ed8aa4a w53
+ s55 = step256 s54 0x5b9cca4f w54
+ s56 = step256 s55 0x682e6ff3 w55
+ s57 = step256 s56 0x748f82ee w56
+ s58 = step256 s57 0x78a5636f w57
+ s59 = step256 s58 0x84c87814 w58
+ s60 = step256 s59 0x8cc70208 w59
+ s61 = step256 s60 0x90befffa w60
+ s62 = step256 s61 0xa4506ceb w61
+ s63 = step256 s62 0xbef9a3f7 w62
+ s64 = step256 s63 0xc67178f2 w63
+ SHA256S a64 b64 c64 d64 e64 f64 g64 h64 = s64
+ in SHA256S (a00 + a64) (b00 + b64) (c00 + c64) (d00 + d64)
+ (e00 + e64) (f00 + f64) (g00 + g64) (h00 + h64)
+
+{-# INLINE step256 #-}
+step256 :: SHA256State -> Word32 -> Word32 -> SHA256State
+step256 !(SHA256S a b c d e f g h) k w = SHA256S a' b' c' d' e' f' g' h'
+ where
+ t1 = h + bsig256_1 e + ch e f g + k + w
+ t2 = bsig256_0 a + maj a b c
+ h' = g
+ g' = f
+ f' = e
+ e' = d + t1
+ d' = c
+ c' = b
+ b' = a
+ a' = t1 + t2
+
+processSHA512Block :: SHA512State -> SHA512Block -> SHA512State
+processSHA512Block !s00@(SHA512S a00 b00 c00 d00 e00 f00 g00 h00) !blk =
+ let (SHA512Sched w00 w01 w02 w03 w04 w05 w06 w07 w08 w09
+ w10 w11 w12 w13 w14 w15 w16 w17 w18 w19
+ w20 w21 w22 w23 w24 w25 w26 w27 w28 w29
+ w30 w31 w32 w33 w34 w35 w36 w37 w38 w39
+ w40 w41 w42 w43 w44 w45 w46 w47 w48 w49
+ w50 w51 w52 w53 w54 w55 w56 w57 w58 w59
+ w60 w61 w62 w63 w64 w65 w66 w67 w68 w69
+ w70 w71 w72 w73 w74 w75 w76 w77 w78 w79) = getSHA512Sched blk
+ s01 = step512 s00 0x428a2f98d728ae22 w00
+ s02 = step512 s01 0x7137449123ef65cd w01
+ s03 = step512 s02 0xb5c0fbcfec4d3b2f w02
+ s04 = step512 s03 0xe9b5dba58189dbbc w03
+ s05 = step512 s04 0x3956c25bf348b538 w04
+ s06 = step512 s05 0x59f111f1b605d019 w05
+ s07 = step512 s06 0x923f82a4af194f9b w06
+ s08 = step512 s07 0xab1c5ed5da6d8118 w07
+ s09 = step512 s08 0xd807aa98a3030242 w08
+ s10 = step512 s09 0x12835b0145706fbe w09
+ s11 = step512 s10 0x243185be4ee4b28c w10
+ s12 = step512 s11 0x550c7dc3d5ffb4e2 w11
+ s13 = step512 s12 0x72be5d74f27b896f w12
+ s14 = step512 s13 0x80deb1fe3b1696b1 w13
+ s15 = step512 s14 0x9bdc06a725c71235 w14
+ s16 = step512 s15 0xc19bf174cf692694 w15
+ s17 = step512 s16 0xe49b69c19ef14ad2 w16
+ s18 = step512 s17 0xefbe4786384f25e3 w17
+ s19 = step512 s18 0x0fc19dc68b8cd5b5 w18
+ s20 = step512 s19 0x240ca1cc77ac9c65 w19
+ s21 = step512 s20 0x2de92c6f592b0275 w20
+ s22 = step512 s21 0x4a7484aa6ea6e483 w21
+ s23 = step512 s22 0x5cb0a9dcbd41fbd4 w22
+ s24 = step512 s23 0x76f988da831153b5 w23
+ s25 = step512 s24 0x983e5152ee66dfab w24
+ s26 = step512 s25 0xa831c66d2db43210 w25
+ s27 = step512 s26 0xb00327c898fb213f w26
+ s28 = step512 s27 0xbf597fc7beef0ee4 w27
+ s29 = step512 s28 0xc6e00bf33da88fc2 w28
+ s30 = step512 s29 0xd5a79147930aa725 w29
+ s31 = step512 s30 0x06ca6351e003826f w30
+ s32 = step512 s31 0x142929670a0e6e70 w31
+ s33 = step512 s32 0x27b70a8546d22ffc w32
+ s34 = step512 s33 0x2e1b21385c26c926 w33
+ s35 = step512 s34 0x4d2c6dfc5ac42aed w34
+ s36 = step512 s35 0x53380d139d95b3df w35
+ s37 = step512 s36 0x650a73548baf63de w36
+ s38 = step512 s37 0x766a0abb3c77b2a8 w37
+ s39 = step512 s38 0x81c2c92e47edaee6 w38
+ s40 = step512 s39 0x92722c851482353b w39
+ s41 = step512 s40 0xa2bfe8a14cf10364 w40
+ s42 = step512 s41 0xa81a664bbc423001 w41
+ s43 = step512 s42 0xc24b8b70d0f89791 w42
+ s44 = step512 s43 0xc76c51a30654be30 w43
+ s45 = step512 s44 0xd192e819d6ef5218 w44
+ s46 = step512 s45 0xd69906245565a910 w45
+ s47 = step512 s46 0xf40e35855771202a w46
+ s48 = step512 s47 0x106aa07032bbd1b8 w47
+ s49 = step512 s48 0x19a4c116b8d2d0c8 w48
+ s50 = step512 s49 0x1e376c085141ab53 w49
+ s51 = step512 s50 0x2748774cdf8eeb99 w50
+ s52 = step512 s51 0x34b0bcb5e19b48a8 w51
+ s53 = step512 s52 0x391c0cb3c5c95a63 w52
+ s54 = step512 s53 0x4ed8aa4ae3418acb w53
+ s55 = step512 s54 0x5b9cca4f7763e373 w54
+ s56 = step512 s55 0x682e6ff3d6b2b8a3 w55
+ s57 = step512 s56 0x748f82ee5defb2fc w56
+ s58 = step512 s57 0x78a5636f43172f60 w57
+ s59 = step512 s58 0x84c87814a1f0ab72 w58
+ s60 = step512 s59 0x8cc702081a6439ec w59
+ s61 = step512 s60 0x90befffa23631e28 w60
+ s62 = step512 s61 0xa4506cebde82bde9 w61
+ s63 = step512 s62 0xbef9a3f7b2c67915 w62
+ s64 = step512 s63 0xc67178f2e372532b w63
+ s65 = step512 s64 0xca273eceea26619c w64
+ s66 = step512 s65 0xd186b8c721c0c207 w65
+ s67 = step512 s66 0xeada7dd6cde0eb1e w66
+ s68 = step512 s67 0xf57d4f7fee6ed178 w67
+ s69 = step512 s68 0x06f067aa72176fba w68
+ s70 = step512 s69 0x0a637dc5a2c898a6 w69
+ s71 = step512 s70 0x113f9804bef90dae w70
+ s72 = step512 s71 0x1b710b35131c471b w71
+ s73 = step512 s72 0x28db77f523047d84 w72
+ s74 = step512 s73 0x32caab7b40c72493 w73
+ s75 = step512 s74 0x3c9ebe0a15c9bebc w74
+ s76 = step512 s75 0x431d67c49c100d4c w75
+ s77 = step512 s76 0x4cc5d4becb3e42b6 w76
+ s78 = step512 s77 0x597f299cfc657e2a w77
+ s79 = step512 s78 0x5fcb6fab3ad6faec w78
+ s80 = step512 s79 0x6c44198c4a475817 w79
+ SHA512S a80 b80 c80 d80 e80 f80 g80 h80 = s80
+ in SHA512S (a00 + a80) (b00 + b80) (c00 + c80) (d00 + d80)
+ (e00 + e80) (f00 + f80) (g00 + g80) (h00 + h80)
+
+{-# INLINE step512 #-}
+step512 :: SHA512State -> Word64 -> Word64 -> SHA512State
+step512 !(SHA512S a b c d e f g h) k w = SHA512S a' b' c' d' e' f' g' h'
+ where
+ t1 = h + bsig512_1 e + ch e f g + k + w
+ t2 = bsig512_0 a + maj a b c
+ h' = g
+ g' = f
+ f' = e
+ e' = d + t1
+ d' = c
+ c' = b
+ b' = a
+ a' = t1 + t2
diff --git a/src/Cryptol/Symbolic.hs b/src/Cryptol/Symbolic.hs
--- a/src/Cryptol/Symbolic.hs
+++ b/src/Cryptol/Symbolic.hs
@@ -9,6 +9,7 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
@@ -28,19 +29,38 @@
, finType
, unFinType
, predArgTypes
+ -- * VarShape
+ , VarShape(..)
+ , varShapeToValue
+ , freshVar
+ , computeModel
+ , FreshVarFns(..)
+ , modelPred
+ , varModelPred
+ , varToExpr
) where
+import Control.Monad (foldM)
import Data.IORef(IORef)
+import Data.List (genericReplicate)
+import Data.Ratio
+import qualified LibBF as FP
+import Cryptol.Backend
+import Cryptol.Backend.FloatHelpers(bfValue)
+
import qualified Cryptol.Eval.Concrete as Concrete
+import Cryptol.Eval.Value
import Cryptol.TypeCheck.AST
import Cryptol.Eval.Type (TValue(..), evalType)
-import Cryptol.Utils.Ident (Ident)
+import Cryptol.Utils.Ident (Ident,prelPrim,floatPrim)
import Cryptol.Utils.RecordMap
+import Cryptol.Utils.Panic
import Cryptol.Utils.PP
+
import Prelude ()
import Prelude.Compat
import Data.Time (NominalDiffTime)
@@ -155,3 +175,193 @@
FTSeq l ety -> tSeq (tNum l) (unFinType ety)
FTTuple ftys -> tTuple (unFinType <$> ftys)
FTRecord fs -> tRec (unFinType <$> fs)
+
+
+data VarShape sym
+ = VarBit (SBit sym)
+ | VarInteger (SInteger sym)
+ | VarRational (SInteger sym) (SInteger sym)
+ | VarFloat (SFloat sym)
+ | VarWord (SWord sym)
+ | VarFinSeq Integer [VarShape sym]
+ | VarTuple [VarShape sym]
+ | VarRecord (RecordMap Ident (VarShape sym))
+
+ppVarShape :: Backend sym => sym -> VarShape sym -> Doc
+ppVarShape sym (VarBit b) = ppBit sym b
+ppVarShape sym (VarInteger i) = ppInteger sym defaultPPOpts i
+ppVarShape sym (VarFloat f) = ppFloat sym defaultPPOpts f
+ppVarShape sym (VarRational n d) =
+ text "(ratio" <+> ppInteger sym defaultPPOpts n <+> ppInteger sym defaultPPOpts d <+> text ")"
+ppVarShape sym (VarWord w) = ppWord sym defaultPPOpts w
+ppVarShape sym (VarFinSeq _ xs) =
+ brackets (fsep (punctuate comma (map (ppVarShape sym) xs)))
+ppVarShape sym (VarTuple xs) =
+ parens (sep (punctuate comma (map (ppVarShape sym) xs)))
+ppVarShape sym (VarRecord fs) =
+ braces (sep (punctuate comma (map ppField (displayFields fs))))
+ where
+ ppField (f,v) = pp f <+> char '=' <+> ppVarShape sym v
+
+
+varShapeToValue :: Backend sym => sym -> VarShape sym -> GenValue sym
+varShapeToValue sym var =
+ case var of
+ VarBit b -> VBit b
+ VarInteger i -> VInteger i
+ VarRational n d -> VRational (SRational n d)
+ VarWord w -> VWord (wordLen sym w) (return (WordVal w))
+ VarFloat f -> VFloat f
+ VarFinSeq n vs -> VSeq n (finiteSeqMap sym (map (pure . varShapeToValue sym) vs))
+ VarTuple vs -> VTuple (map (pure . varShapeToValue sym) vs)
+ VarRecord fs -> VRecord (fmap (pure . varShapeToValue sym) fs)
+
+data FreshVarFns sym =
+ FreshVarFns
+ { freshBitVar :: IO (SBit sym)
+ , freshWordVar :: Integer -> IO (SWord sym)
+ , freshIntegerVar :: Maybe Integer -> Maybe Integer -> IO (SInteger sym)
+ , freshFloatVar :: Integer -> Integer -> IO (SFloat sym)
+ }
+
+freshVar :: Backend sym => FreshVarFns sym -> FinType -> IO (VarShape sym)
+freshVar fns tp = case tp of
+ FTBit -> VarBit <$> freshBitVar fns
+ FTInteger -> VarInteger <$> freshIntegerVar fns Nothing Nothing
+ FTRational -> VarRational
+ <$> freshIntegerVar fns Nothing Nothing
+ <*> freshIntegerVar fns (Just 1) Nothing
+ FTIntMod 0 -> panic "freshVariable" ["0 modulus not allowed"]
+ FTIntMod m -> VarInteger <$> freshIntegerVar fns (Just 0) (Just (m-1))
+ FTFloat e p -> VarFloat <$> freshFloatVar fns e p
+ FTSeq n FTBit | n > 0 -> VarWord <$> freshWordVar fns (toInteger n)
+ FTSeq n t -> VarFinSeq (toInteger n) <$> sequence (genericReplicate n (freshVar fns t))
+ FTTuple ts -> VarTuple <$> mapM (freshVar fns) ts
+ FTRecord fs -> VarRecord <$> traverse (freshVar fns) fs
+
+computeModel ::
+ PrimMap ->
+ [FinType] ->
+ [VarShape Concrete.Concrete] ->
+ [(Type, Expr, Concrete.Value)]
+computeModel _ [] [] = []
+computeModel primMap (t:ts) (v:vs) =
+ do let v' = varShapeToValue Concrete.Concrete v
+ let t' = unFinType t
+ let e = varToExpr primMap t v
+ let zs = computeModel primMap ts vs
+ in ((t',e,v'):zs)
+computeModel _ _ _ = panic "computeModel" ["type/value list mismatch"]
+
+
+
+modelPred ::
+ Backend sym =>
+ sym ->
+ [VarShape sym] ->
+ [VarShape Concrete.Concrete] ->
+ SEval sym (SBit sym)
+modelPred sym vs xs =
+ do ps <- mapM (varModelPred sym) (zip vs xs)
+ foldM (bitAnd sym) (bitLit sym True) ps
+
+varModelPred ::
+ Backend sym =>
+ sym ->
+ (VarShape sym, VarShape Concrete.Concrete) ->
+ SEval sym (SBit sym)
+varModelPred sym vx =
+ case vx of
+ (VarBit b, VarBit blit) ->
+ bitEq sym b (bitLit sym blit)
+
+ (VarInteger i, VarInteger ilit) ->
+ intEq sym i =<< integerLit sym ilit
+
+ (VarRational n d, VarRational nlit dlit) ->
+ do n' <- integerLit sym nlit
+ d' <- integerLit sym dlit
+ rationalEq sym (SRational n d) (SRational n' d')
+
+ (VarWord w, VarWord (Concrete.BV len wlit)) ->
+ wordEq sym w =<< wordLit sym len wlit
+
+ (VarFloat f, VarFloat flit) ->
+ fpLogicalEq sym f =<< fpExactLit sym flit
+
+ (VarFinSeq _n vs, VarFinSeq _ xs) -> modelPred sym vs xs
+ (VarTuple vs, VarTuple xs) -> modelPred sym vs xs
+ (VarRecord vs, VarRecord xs) -> modelPred sym (recordElements vs) (recordElements xs)
+ _ -> panic "varModelPred" ["variable shape mismatch!"]
+
+
+varToExpr :: PrimMap -> FinType -> VarShape Concrete.Concrete -> Expr
+varToExpr prims = go
+ where
+
+ prim n = ePrim prims (prelPrim n)
+
+ go :: FinType -> VarShape Concrete.Concrete -> Expr
+ go ty val =
+ case (ty,val) of
+ (FTRecord tfs, VarRecord vfs) ->
+ let res = zipRecords (\_lbl v t -> go t v) vfs tfs
+ in case res of
+ Left _ -> mismatch -- different fields
+ Right efs -> ERec efs
+ (FTTuple ts, VarTuple tvs) ->
+ ETuple (zipWith go ts tvs)
+
+ (FTBit, VarBit b) ->
+ prim (if b then "True" else "False")
+
+ (FTInteger, VarInteger i) ->
+ -- This works uniformly for values of type Integer or Z n
+ ETApp (ETApp (prim "number") (tNum i)) (unFinType ty)
+
+ (FTIntMod _, VarInteger i) ->
+ -- This works uniformly for values of type Integer or Z n
+ ETApp (ETApp (prim "number") (tNum i)) (unFinType ty)
+
+ (FTRational, VarRational n d) ->
+ let n' = ETApp (ETApp (prim "number") (tNum n)) tInteger
+ d' = ETApp (ETApp (prim "number") (tNum d)) tInteger
+ in EApp (EApp (prim "ratio") n') d'
+
+ (FTFloat e p, VarFloat f) ->
+ floatToExpr prims e p (bfValue f)
+
+ (FTSeq _ FTBit, VarWord (Concrete.BV _ v)) ->
+ ETApp (ETApp (prim "number") (tNum v)) (unFinType ty)
+
+ (FTSeq _ t, VarFinSeq _ svs) ->
+ EList (map (go t) svs) (unFinType t)
+
+ _ -> mismatch
+ where
+ mismatch =
+ panic "Cryptol.Symbolic.varToExpr"
+ ["type mismatch:"
+ , show (pp (unFinType ty))
+ , show (ppVarShape Concrete.Concrete val)
+ ]
+
+floatToExpr :: PrimMap -> Integer -> Integer -> FP.BigFloat -> Expr
+floatToExpr prims e p f =
+ case FP.bfToRep f of
+ FP.BFNaN -> mkP "fpNaN"
+ FP.BFRep sign num ->
+ case (sign,num) of
+ (FP.Pos, FP.Zero) -> mkP "fpPosZero"
+ (FP.Neg, FP.Zero) -> mkP "fpNegZero"
+ (FP.Pos, FP.Inf) -> mkP "fpPosInf"
+ (FP.Neg, FP.Inf) -> mkP "fpNegInf"
+ (_, FP.Num m ex) ->
+ let r = toRational m * (2 ^^ ex)
+ in EProofApp $ ePrim prims (prelPrim "fraction")
+ `ETApp` tNum (numerator r)
+ `ETApp` tNum (denominator r)
+ `ETApp` tNum (0 :: Int)
+ `ETApp` tFloat (tNum e) (tNum p)
+ where
+ mkP n = EProofApp $ ePrim prims (floatPrim n) `ETApp` (tNum e) `ETApp` (tNum p)
diff --git a/src/Cryptol/Symbolic/SBV.hs b/src/Cryptol/Symbolic/SBV.hs
--- a/src/Cryptol/Symbolic/SBV.hs
+++ b/src/Cryptol/Symbolic/SBV.hs
@@ -27,18 +27,19 @@
) where
+import Control.Applicative
import Control.Concurrent.Async
+import Control.Concurrent.MVar
import Control.Monad.IO.Class
-import Control.Monad (replicateM, when, zipWithM, foldM, forM_)
-import Control.Monad.Writer (WriterT, runWriterT, tell, lift)
-import Data.List (genericLength)
+import Control.Monad (when, foldM, forM_)
import Data.Maybe (fromMaybe)
+import qualified Data.Map as Map
import qualified Control.Exception as X
import System.Exit (ExitCode(ExitSuccess))
import LibBF(bfNaN)
-import qualified Data.SBV as SBV (sObserve)
+import qualified Data.SBV as SBV (sObserve, symbolicEnv)
import qualified Data.SBV.Internals as SBV (SBV(..))
import qualified Data.SBV.Dynamic as SBV
import Data.SBV (Timing(SaveTiming))
@@ -47,29 +48,29 @@
import qualified Cryptol.ModuleSystem.Env as M
import qualified Cryptol.ModuleSystem.Base as M
import qualified Cryptol.ModuleSystem.Monad as M
+import qualified Cryptol.ModuleSystem.Name as M
-import qualified Cryptol.Eval.Backend as Eval
+import Cryptol.Backend.SBV
+import qualified Cryptol.Backend.FloatHelpers as FH
+
import qualified Cryptol.Eval as Eval
import qualified Cryptol.Eval.Concrete as Concrete
-import Cryptol.Eval.Concrete (Concrete(..))
-import qualified Cryptol.Eval.Concrete.FloatHelpers as Concrete
-import qualified Cryptol.Eval.Monad as Eval
import qualified Cryptol.Eval.Value as Eval
import Cryptol.Eval.SBV
import Cryptol.Symbolic
+import Cryptol.TypeCheck.AST
+import Cryptol.Utils.Ident (preludeReferenceName, prelPrim, identText)
import Cryptol.Utils.Panic(panic)
import Cryptol.Utils.Logger(logPutStrLn)
import Cryptol.Utils.RecordMap
+
import Prelude ()
import Prelude.Compat
-doEval :: MonadIO m => Eval.EvalOpts -> Eval.Eval a -> m a
-doEval evo m = liftIO $ Eval.runEval evo m
-
-doSBVEval :: MonadIO m => Eval.EvalOpts -> SBVEval a -> m (SBV.SVal, a)
-doSBVEval evo m =
- (liftIO $ Eval.runEval evo (sbvEval m)) >>= \case
+doSBVEval :: MonadIO m => SBVEval a -> m (SBV.SVal, a)
+doSBVEval m =
+ (liftIO $ Eval.runEval (sbvEval m)) >>= \case
SBVError err -> liftIO (X.throwIO err)
SBVResult p x -> pure (p, x)
@@ -222,7 +223,12 @@
-- | Select the appropriate solver or solvers from the given prover command,
-- and invoke those solvers on the given symbolic value.
-runProver :: SBVProverConfig -> ProverCommand -> (String -> IO ()) -> SBV.Symbolic SBV.SVal -> IO (Maybe String, [SBV.SMTResult])
+runProver ::
+ SBVProverConfig ->
+ ProverCommand ->
+ (String -> IO ()) ->
+ SBV.Symbolic SBV.SVal ->
+ IO (Maybe String, [SBV.SMTResult])
runProver proverConfig pc@ProverCommand{..} lPutStrLn x =
do let mSatNum = case pcQueryType of
SatQuery (SomeSat n) -> Just n
@@ -231,7 +237,7 @@
SafetyQuery -> Nothing
case proverConfig of
- SBVPortfolio ps ->
+ SBVPortfolio ps ->
let ps' = [ p { SBV.transcript = pcSmtFile
, SBV.timing = SaveTiming pcProverStats
, SBV.verbose = pcVerbose
@@ -279,18 +285,17 @@
-- the main goal via a conjunction.
prepareQuery ::
Eval.EvalOpts ->
- M.ModuleEnv ->
ProverCommand ->
- IO (Either String ([FinType], SBV.Symbolic SBV.SVal))
-prepareQuery evo modEnv ProverCommand{..} =
- do let extDgs = M.allDeclGroups modEnv ++ pcExtraDecls
+ M.ModuleT IO (Either String ([FinType], SBV.Symbolic SBV.SVal))
+prepareQuery evo ProverCommand{..} =
+ do ds <- do (_mp, m) <- M.loadModuleFrom True (M.FromModule preludeReferenceName)
+ let decls = mDecls m
+ let nms = fst <$> Map.toList (M.ifDecls (M.ifPublic (M.genIface m)))
+ let ds = Map.fromList [ (prelPrim (identText (M.nameIdent nm)), EWhere (EVar nm) decls) | nm <- nms ]
+ pure ds
- -- The `tyFn` creates variables that are treated as 'forall'
- -- or 'exists' bound, depending on the sort of query we are doing.
- let tyFn = case pcQueryType of
- SatQuery _ -> existsFinType
- ProveQuery -> forallFinType
- SafetyQuery -> forallFinType
+ modEnv <- M.getModuleEnv
+ let extDgs = M.allDeclGroups modEnv ++ pcExtraDecls
-- The `addAsm` function is used to combine assumptions that
-- arise from the types of symbolic variables (e.g. Z n values
@@ -302,22 +307,29 @@
SafetyQuery -> \x y -> SBV.svOr (SBV.svNot x) y
SatQuery _ -> \x y -> SBV.svAnd x y
- let ?evalPrim = evalPrim
case predArgTypes pcQueryType pcSchema of
Left msg -> return (Left msg)
- Right ts ->
+ Right ts -> M.io $
do when pcVerbose $ logPutStrLn (Eval.evalLogger evo) "Simulating..."
pure $ Right $ (ts,
- do -- Compute the symbolic inputs, and any domain constraints needed
+ do sbvState <- SBV.symbolicEnv
+ stateMVar <- liftIO (newMVar sbvState)
+ defRelsVar <- liftIO (newMVar SBV.svTrue)
+ let sym = SBV stateMVar defRelsVar
+ let tbl = primTable sym
+ let ?evalPrim = \i -> (Right <$> Map.lookup i tbl) <|>
+ (Left <$> Map.lookup i ds)
+ -- Compute the symbolic inputs, and any domain constraints needed
-- according to their types.
- (args, asms) <- runWriterT (mapM tyFn ts)
+ args <- map (pure . varShapeToValue sym) <$>
+ liftIO (mapM (freshVar (sbvFreshFns sym)) ts)
-- Run the main symbolic computation. First we populate the
-- evaluation environment, then we compute the value, finally
-- we apply it to the symbolic inputs.
- (safety,b) <- doSBVEval evo $
- do env <- Eval.evalDecls SBV extDgs mempty
- v <- Eval.evalExpr SBV env pcExpr
- appliedVal <- foldM Eval.fromVFun v (map pure args)
+ (safety,b) <- doSBVEval $
+ do env <- Eval.evalDecls sym extDgs mempty
+ v <- Eval.evalExpr sym env pcExpr
+ appliedVal <- foldM Eval.fromVFun v args
case pcQueryType of
SafetyQuery ->
do Eval.forceValue appliedVal
@@ -335,18 +347,19 @@
-- avaliable in the resulting model.
SBV.sObserve "safety" (SBV.SBV safety' :: SBV.SBV Bool)
- return (foldr addAsm (SBV.svAnd safety' b) asms))
+ -- read any definitional relations that were asserted
+ defRels <- liftIO (readMVar defRelsVar)
+ return (addAsm defRels (SBV.svAnd safety' b)))
-- | Turn the SMT results from SBV into a @ProverResult@ that is ready for the Cryptol REPL.
-- There may be more than one result if we made a multi-sat query.
processResults ::
- Eval.EvalOpts ->
ProverCommand ->
[FinType] {- ^ Types of the symbolic inputs -} ->
[SBV.SMTResult] {- ^ Results from the solver -} ->
M.ModuleT IO ProverResult
-processResults evo ProverCommand{..} ts results =
+processResults ProverCommand{..} ts results =
do let isSat = case pcQueryType of
ProveQuery -> False
SafetyQuery -> False
@@ -385,15 +398,9 @@
-- to always be the first value in the model assignment list.
let Right (_, (safetyCV : cvs)) = SBV.getModelAssignment result
safety = SBV.cvToBool safetyCV
- (vs, _) = parseValues ts cvs
- sattys = unFinType <$> ts
- satexprs <-
- doEval evo (zipWithM (Concrete.toExpr prims) sattys vs)
- case zip3 sattys <$> (sequence satexprs) <*> pure vs of
- Nothing ->
- panic "Cryptol.Symbolic.sat"
- [ "unable to make assignment into expression" ]
- Just tevs -> return $ (safety, tevs)
+ (vs, []) = parseValues ts cvs
+ mdl = computeModel prims ts vs
+ return (safety, mdl)
-- | Execute a symbolic ':prove' or ':sat' command.
@@ -409,11 +416,11 @@
let lPutStrLn = logPutStrLn (Eval.evalLogger evo)
- M.io (prepareQuery evo modEnv pc) >>= \case
+ prepareQuery evo pc >>= \case
Left msg -> return (Nothing, ProverError msg)
Right (ts, q) ->
do (firstProver, results) <- M.io (runProver proverCfg pc lPutStrLn q)
- esatexprs <- processResults evo pc ts results
+ esatexprs <- processResults pc ts results
return (firstProver, esatexprs)
-- | Execute a symbolic ':prove' or ':sat' command when the prover is
@@ -425,18 +432,15 @@
satProveOffline :: SBVProverConfig -> ProverCommand -> M.ModuleCmd (Either String String)
satProveOffline _proverCfg pc@ProverCommand {..} =
protectStack (\msg (_,_,modEnv) -> return (Right (Left msg, modEnv), [])) $
- \(evOpts, _, modEnv) -> do
- let isSat = case pcQueryType of
- ProveQuery -> False
- SafetyQuery -> False
- SatQuery _ -> True
-
- prepareQuery evOpts modEnv pc >>= \case
- Left msg -> return (Right (Left msg, modEnv), [])
- Right (_ts, q) ->
- do smtlib <- SBV.generateSMTBenchmark isSat q
- return (Right (Right smtlib, modEnv), [])
+ \(evo, byteReader, modEnv) -> M.runModuleM (evo,byteReader,modEnv) $
+ do let isSat = case pcQueryType of
+ ProveQuery -> False
+ SafetyQuery -> False
+ SatQuery _ -> True
+ prepareQuery evo pc >>= \case
+ Left msg -> return (Left msg)
+ Right (_ts, q) -> Right <$> M.io (SBV.generateSMTBenchmark isSat q)
protectStack :: (String -> M.ModuleCmd a)
-> M.ModuleCmd a
@@ -451,7 +455,7 @@
-- | Given concrete values from the solver and a collection of finite types,
-- reconstruct Cryptol concrete values, and return any unused solver
-- values.
-parseValues :: [FinType] -> [SBV.CV] -> ([Concrete.Value], [SBV.CV])
+parseValues :: [FinType] -> [SBV.CV] -> ([VarShape Concrete.Concrete], [SBV.CV])
parseValues [] cvs = ([], cvs)
parseValues (t : ts) cvs = (v : vs, cvs'')
where (v, cvs') = parseValue t cvs
@@ -460,94 +464,60 @@
-- | Parse a single value of a finite type by consuming some number of
-- solver values. The parsed Cryptol values is returned along with
-- any solver values not consumed.
-parseValue :: FinType -> [SBV.CV] -> (Concrete.Value, [SBV.CV])
+parseValue :: FinType -> [SBV.CV] -> (VarShape Concrete.Concrete, [SBV.CV])
parseValue FTBit [] = panic "Cryptol.Symbolic.parseValue" [ "empty FTBit" ]
-parseValue FTBit (cv : cvs) = (Eval.VBit (SBV.cvToBool cv), cvs)
+parseValue FTBit (cv : cvs) = (VarBit (SBV.cvToBool cv), cvs)
parseValue FTInteger cvs =
case SBV.genParse SBV.KUnbounded cvs of
- Just (x, cvs') -> (Eval.VInteger x, cvs')
+ Just (x, cvs') -> (VarInteger x, cvs')
Nothing -> panic "Cryptol.Symbolic.parseValue" [ "no integer" ]
parseValue (FTIntMod _) cvs = parseValue FTInteger cvs
parseValue FTRational cvs =
fromMaybe (panic "Cryptol.Symbolic.parseValue" ["no rational"]) $
do (n,cvs') <- SBV.genParse SBV.KUnbounded cvs
(d,cvs'') <- SBV.genParse SBV.KUnbounded cvs'
- return (Eval.VRational (Eval.SRational n d), cvs'')
-parseValue (FTSeq 0 FTBit) cvs = (Eval.word Concrete 0 0, cvs)
+ return (VarRational n d, cvs'')
+parseValue (FTSeq 0 FTBit) cvs = (VarWord (Concrete.mkBv 0 0), cvs)
parseValue (FTSeq n FTBit) cvs =
case SBV.genParse (SBV.KBounded False n) cvs of
- Just (x, cvs') -> (Eval.word Concrete (toInteger n) x, cvs')
- Nothing -> (Eval.VWord (genericLength vs) (Eval.WordVal <$>
- (Eval.packWord Concrete (map Eval.fromVBit vs))), cvs')
- where (vs, cvs') = parseValues (replicate n FTBit) cvs
-parseValue (FTSeq n t) cvs =
- (Eval.VSeq (toInteger n) $ Eval.finiteSeqMap Concrete (map Eval.ready vs)
- , cvs'
- )
+ Just (x, cvs') -> (VarWord (Concrete.mkBv (toInteger n) x), cvs')
+ Nothing -> panic "Cryptol.Symbolic.parseValue" ["no bitvector"]
+parseValue (FTSeq n t) cvs = (VarFinSeq (toInteger n) vs, cvs')
where (vs, cvs') = parseValues (replicate n t) cvs
-parseValue (FTTuple ts) cvs = (Eval.VTuple (map Eval.ready vs), cvs')
+parseValue (FTTuple ts) cvs = (VarTuple vs, cvs')
where (vs, cvs') = parseValues ts cvs
-parseValue (FTRecord r) cvs = (Eval.VRecord r', cvs')
+parseValue (FTRecord r) cvs = (VarRecord r', cvs')
where (ns, ts) = unzip $ canonicalFields r
(vs, cvs') = parseValues ts cvs
- fs = zip ns (map Eval.ready vs)
+ fs = zip ns vs
r' = recordFromFieldsWithDisplay (displayOrder r) fs
parseValue (FTFloat e p) cvs =
- (Eval.VFloat Concrete.BF { Concrete.bfValue = bfNaN
- , Concrete.bfExpWidth = e
- , Concrete.bfPrecWidth = p
- }
+ (VarFloat FH.BF { FH.bfValue = bfNaN
+ , FH.bfExpWidth = e
+ , FH.bfPrecWidth = p
+ }
, cvs
)
-- XXX: NOT IMPLEMENTED
-inBoundsIntMod :: Integer -> Eval.SInteger SBV -> Eval.SBit SBV
-inBoundsIntMod n x =
- let z = SBV.svInteger SBV.KUnbounded 0
- n' = SBV.svInteger SBV.KUnbounded n
- in SBV.svAnd (SBV.svLessEq z x) (SBV.svLessThan x n')
-forallFinType :: FinType -> WriterT [Eval.SBit SBV] SBV.Symbolic Value
-forallFinType ty =
- case ty of
- FTBit -> Eval.VBit <$> lift forallSBool_
- FTInteger -> Eval.VInteger <$> lift forallSInteger_
- FTRational ->
- do n <- lift forallSInteger_
- d <- lift forallSInteger_
- let z = SBV.svInteger SBV.KUnbounded 0
- tell [SBV.svLessThan z d]
- return (Eval.VRational (Eval.SRational n d))
- FTFloat {} -> pure (Eval.VFloat ()) -- XXX: NOT IMPLEMENTED
- FTIntMod n -> do x <- lift forallSInteger_
- tell [inBoundsIntMod n x]
- return (Eval.VInteger x)
- FTSeq 0 FTBit -> return $ Eval.word SBV 0 0
- FTSeq n FTBit -> Eval.VWord (toInteger n) . return . Eval.WordVal <$> lift (forallBV_ n)
- FTSeq n t -> do vs <- replicateM n (forallFinType t)
- return $ Eval.VSeq (toInteger n) $ Eval.finiteSeqMap SBV (map pure vs)
- FTTuple ts -> Eval.VTuple <$> mapM (fmap pure . forallFinType) ts
- FTRecord fs -> Eval.VRecord <$> traverse (fmap pure . forallFinType) fs
+freshBoundedInt :: SBV -> Maybe Integer -> Maybe Integer -> IO SBV.SVal
+freshBoundedInt sym lo hi =
+ do x <- freshSInteger_ sym
+ case lo of
+ Just l -> addDefEqn sym (SBV.svLessEq (SBV.svInteger SBV.KUnbounded l) x)
+ Nothing -> pure ()
+ case hi of
+ Just h -> addDefEqn sym (SBV.svLessEq x (SBV.svInteger SBV.KUnbounded h))
+ Nothing -> pure ()
+ return x
-existsFinType :: FinType -> WriterT [Eval.SBit SBV] SBV.Symbolic Value
-existsFinType ty =
- case ty of
- FTBit -> Eval.VBit <$> lift existsSBool_
- FTInteger -> Eval.VInteger <$> lift existsSInteger_
- FTRational ->
- do n <- lift existsSInteger_
- d <- lift existsSInteger_
- let z = SBV.svInteger SBV.KUnbounded 0
- tell [SBV.svLessThan z d]
- return (Eval.VRational (Eval.SRational n d))
- FTFloat {} -> pure $ Eval.VFloat () -- XXX: NOT IMPLEMENTED
- FTIntMod n -> do x <- lift existsSInteger_
- tell [inBoundsIntMod n x]
- return (Eval.VInteger x)
- FTSeq 0 FTBit -> return $ Eval.word SBV 0 0
- FTSeq n FTBit -> Eval.VWord (toInteger n) . return . Eval.WordVal <$> lift (existsBV_ n)
- FTSeq n t -> do vs <- replicateM n (existsFinType t)
- return $ Eval.VSeq (toInteger n) $ Eval.finiteSeqMap SBV (map pure vs)
- FTTuple ts -> Eval.VTuple <$> mapM (fmap pure . existsFinType) ts
- FTRecord fs -> Eval.VRecord <$> traverse (fmap pure . existsFinType) fs
+sbvFreshFns :: SBV -> FreshVarFns SBV
+sbvFreshFns sym =
+ FreshVarFns
+ { freshBitVar = freshSBool_ sym
+ , freshWordVar = freshBV_ sym . fromInteger
+ , freshIntegerVar = freshBoundedInt sym
+ , freshFloatVar = \_ _ -> return () -- TODO
+ }
diff --git a/src/Cryptol/Symbolic/What4.hs b/src/Cryptol/Symbolic/What4.hs
--- a/src/Cryptol/Symbolic/What4.hs
+++ b/src/Cryptol/Symbolic/What4.hs
@@ -29,14 +29,22 @@
, W4Exception(..)
) where
+import Control.Applicative
import Control.Concurrent.Async
+import Control.Concurrent.MVar
import Control.Monad.IO.Class
import Control.Monad (when, foldM, forM_)
import qualified Control.Exception as X
import System.IO (Handle)
import Data.Time
import Data.IORef
+import Data.List (intercalate)
import Data.List.NonEmpty (NonEmpty(..))
+import qualified Data.Map as Map
+import Data.Set (Set)
+import qualified Data.Set as Set
+import Data.Text (Text)
+import qualified Data.Text as Text
import qualified Data.List.NonEmpty as NE
import System.Exit
@@ -44,21 +52,20 @@
import qualified Cryptol.ModuleSystem.Env as M
import qualified Cryptol.ModuleSystem.Base as M
import qualified Cryptol.ModuleSystem.Monad as M
+import qualified Cryptol.ModuleSystem.Name as M
+import qualified Cryptol.Backend.FloatHelpers as FH
+import Cryptol.Backend.What4
+import qualified Cryptol.Backend.What4.SFloat as W4
+
import qualified Cryptol.Eval as Eval
import qualified Cryptol.Eval.Concrete as Concrete
-import qualified Cryptol.Eval.Concrete.FloatHelpers as Concrete
-
-import qualified Cryptol.Eval.Backend as Eval
import qualified Cryptol.Eval.Value as Eval
import Cryptol.Eval.What4
-import qualified Cryptol.Eval.What4.SFloat as W4
import Cryptol.Symbolic
import Cryptol.TypeCheck.AST
-import Cryptol.Utils.Ident (Ident)
-import Cryptol.Utils.Logger(logPutStrLn)
-import Cryptol.Utils.Panic (panic)
-import Cryptol.Utils.RecordMap
+import Cryptol.Utils.Logger(logPutStrLn,logPutStr,Logger)
+import Cryptol.Utils.Ident (preludeReferenceName, prelPrim, identText)
import qualified What4.Config as W4
import qualified What4.Interface as W4
@@ -111,18 +118,15 @@
handler () = mkErr msg modEnv
-doEval :: MonadIO m => Eval.EvalOpts -> Eval.Eval a -> m a
-doEval evo m = liftIO $ Eval.runEval evo m
-
-- | Returns definitions, together with the value and it safety predicate.
doW4Eval ::
(W4.IsExprBuilder sym, MonadIO m) =>
- sym -> Eval.EvalOpts -> W4Eval sym a -> m (W4Defs sym (W4.Pred sym, a))
-doW4Eval sym evo m =
- do res <- liftIO $ Eval.runEval evo (w4Eval m sym)
- case w4Result res of
+ sym -> W4Eval sym a -> m (W4.Pred sym, a)
+doW4Eval sym m =
+ do res <- liftIO $ Eval.runEval (w4Eval m sym)
+ case res of
W4Error err -> liftIO (X.throwIO err)
- W4Result p x -> pure res { w4Result = (p,x) }
+ W4Result p x -> pure (p,x)
data AnAdapter = AnAdapter (forall st. SolverAdapter st)
@@ -201,11 +205,6 @@
data CryptolState t = CryptolState
-
--- TODO? move this?
-allDeclGroups :: M.ModuleEnv -> [DeclGroup]
-allDeclGroups = concatMap mDecls . M.loadedNonParamModules
-
setupAdapterOptions :: W4ProverConfig -> W4.ExprBuilder t CryptolState fs -> IO ()
setupAdapterOptions cfg sym =
case cfg of
@@ -217,94 +216,118 @@
W4.extendConfig (W4.solver_adapter_config_options adpt) (W4.getConfiguration sym)
+what4FreshFns :: W4.IsSymExprBuilder sym => sym -> FreshVarFns (What4 sym)
+what4FreshFns sym =
+ FreshVarFns
+ { freshBitVar = W4.freshConstant sym W4.emptySymbol W4.BaseBoolRepr
+ , freshWordVar = SW.freshBV sym W4.emptySymbol
+ , freshIntegerVar = W4.freshBoundedInt sym W4.emptySymbol
+ , freshFloatVar = W4.fpFresh sym
+ }
+
-- | Simulate and manipulate query into a form suitable to be sent
-- to a solver.
prepareQuery ::
W4.IsSymExprBuilder sym =>
- sym ->
+ What4 sym ->
ProverCommand ->
M.ModuleT IO (Either String
- ([FinType],[VarShape sym],W4.Pred sym, W4.Pred sym)
+ ([FinType],[VarShape (What4 sym)],W4.Pred sym, W4.Pred sym)
)
prepareQuery sym ProverCommand { .. } =
case predArgTypes pcQueryType pcSchema of
Left msg -> pure (Left msg)
Right ts ->
- do args <- liftIO (mapM (freshVariable sym) ts)
- res <- simulate args
+ do args <- liftIO (mapM (freshVar (what4FreshFns (w4 sym))) ts)
+ (safety,b) <- simulate args
liftIO
- do -- add the collected definitions to the goal
- let (safety,prop') = w4Result res
- b <- W4.andPred sym (w4Defs res) prop'
+ do -- Ignore the safety condition if the flag is set
+ let safety' = if pcIgnoreSafety then W4.truePred (w4 sym) else safety
- -- Ignore the safety condition if the flag is set
- let safety' = if pcIgnoreSafety then W4.truePred sym else safety
+ defs <- readMVar (w4defs sym)
Right <$>
case pcQueryType of
ProveQuery ->
- do q <- W4.notPred sym =<< W4.andPred sym safety' b
- pure (ts,args,safety',q)
+ do q <- W4.notPred (w4 sym) =<< W4.andPred (w4 sym) safety' b
+ q' <- W4.andPred (w4 sym) defs q
+ pure (ts,args,safety',q')
SafetyQuery ->
- do q <- W4.notPred sym safety
- pure (ts,args,safety,q)
+ do q <- W4.notPred (w4 sym) safety
+ q' <- W4.andPred (w4 sym) defs q
+ pure (ts,args,safety,q')
SatQuery _ ->
- do q <- W4.andPred sym safety' b
- pure (ts,args,safety',q)
+ do q <- W4.andPred (w4 sym) safety' b
+ q' <- W4.andPred (w4 sym) defs q
+ pure (ts,args,safety',q')
where
simulate args =
do let lPutStrLn = M.withLogger logPutStrLn
when pcVerbose (lPutStrLn "Simulating...")
- evo <- M.getEvalOpts
+
+ ds <- do (_mp, m) <- M.loadModuleFrom True (M.FromModule preludeReferenceName)
+ let decls = mDecls m
+ let nms = fst <$> Map.toList (M.ifDecls (M.ifPublic (M.genIface m)))
+ let ds = Map.fromList [ (prelPrim (identText (M.nameIdent nm)), EWhere (EVar nm) decls) | nm <- nms ]
+ pure ds
+
+ let tbl = primTable sym
+ let ?evalPrim = \i -> (Right <$> Map.lookup i tbl) <|>
+ (Left <$> Map.lookup i ds)
+
modEnv <- M.getModuleEnv
- doW4Eval sym evo
- do let ?evalPrim = evalPrim sym
- let extDgs = allDeclGroups modEnv ++ pcExtraDecls
- env <- Eval.evalDecls (What4 sym) extDgs mempty
- v <- Eval.evalExpr (What4 sym) env pcExpr
+ let extDgs = M.allDeclGroups modEnv ++ pcExtraDecls
+
+ doW4Eval (w4 sym)
+ do env <- Eval.evalDecls sym extDgs mempty
+ v <- Eval.evalExpr sym env pcExpr
appliedVal <-
- foldM Eval.fromVFun v (map (pure . varToSymValue sym) args)
+ foldM Eval.fromVFun v (map (pure . varShapeToValue sym) args)
case pcQueryType of
SafetyQuery ->
do Eval.forceValue appliedVal
- pure (W4.truePred sym)
+ pure (W4.truePred (w4 sym))
_ -> pure (Eval.fromVBit appliedVal)
-
-
-
satProve ::
W4ProverConfig ->
- Bool ->
+ Bool {- ^ hash consing -} ->
+ Bool {- ^ warn on uninterpreted functions -} ->
ProverCommand ->
M.ModuleCmd (Maybe String, ProverResult)
-satProve solverCfg hashConsing ProverCommand {..} =
+satProve solverCfg hashConsing warnUninterp ProverCommand {..} =
protectStack proverError \(evo, byteReader, modEnv) ->
M.runModuleM (evo, byteReader, modEnv)
- do sym <- liftIO makeSym
+ do w4sym <- liftIO makeSym
+ defVar <- liftIO (newMVar (W4.truePred w4sym))
+ funVar <- liftIO (newMVar mempty)
+ uninterpWarnVar <- liftIO (newMVar mempty)
+ let sym = What4 w4sym defVar funVar uninterpWarnVar
logData <- M.withLogger doLog ()
start <- liftIO getCurrentTime
query <- prepareQuery sym ProverCommand { .. }
primMap <- M.getPrimMap
+ when warnUninterp
+ (M.withLogger printUninterpWarn =<< liftIO (readMVar uninterpWarnVar))
liftIO
- do result <- runProver sym evo logData primMap query
+ do result <- runProver sym logData primMap query
end <- getCurrentTime
writeIORef pcProverStats (diffUTCTime end start)
return result
where
makeSym =
- do sym <- W4.newExprBuilder W4.FloatIEEERepr
- CryptolState
- globalNonceGenerator
- setupAdapterOptions solverCfg sym
- when hashConsing (W4.startCaching sym)
- pure sym
+ do w4sym <- W4.newExprBuilder W4.FloatIEEERepr
+ CryptolState
+ globalNonceGenerator
+ setupAdapterOptions solverCfg w4sym
+ when hashConsing (W4.startCaching w4sym)
+ pure w4sym
doLog lg () =
pure
@@ -313,46 +336,60 @@
, logReason = "solver query"
}
- runProver sym evo logData primMap q =
+ runProver sym logData primMap q =
case q of
Left msg -> pure (Nothing, ProverError msg)
Right (ts,args,safety,query) ->
case pcQueryType of
ProveQuery ->
- singleQuery sym solverCfg evo primMap logData ts args
+ singleQuery sym solverCfg primMap logData ts args
(Just safety) query
SafetyQuery ->
- singleQuery sym solverCfg evo primMap logData ts args
+ singleQuery sym solverCfg primMap logData ts args
(Just safety) query
SatQuery num ->
- multiSATQuery sym solverCfg evo primMap logData ts args
+ multiSATQuery sym solverCfg primMap logData ts args
query num
-
+printUninterpWarn :: Logger -> Set Text -> IO ()
+printUninterpWarn lg uninterpWarns =
+ case Set.toList uninterpWarns of
+ [] -> pure ()
+ [x] -> logPutStrLn lg ("[Warning] Uninterpreted functions used to represent " ++ Text.unpack x ++ " operations.")
+ xs -> logPutStr lg $ unlines
+ [ "[Warning] Uninterpreted functions used to represent the following operations:"
+ , " " ++ intercalate ", " (map Text.unpack xs) ]
satProveOffline ::
W4ProverConfig ->
- Bool ->
+ Bool {- ^ hash consing -} ->
+ Bool {- ^ warn on uninterpreted functions -} ->
ProverCommand ->
((Handle -> IO ()) -> IO ()) ->
M.ModuleCmd (Maybe String)
-satProveOffline (W4Portfolio (p:|_)) hashConsing cmd outputContinuation =
- satProveOffline (W4ProverConfig p) hashConsing cmd outputContinuation
+satProveOffline (W4Portfolio (p:|_)) hashConsing warnUninterp cmd outputContinuation =
+ satProveOffline (W4ProverConfig p) hashConsing warnUninterp cmd outputContinuation
-satProveOffline (W4ProverConfig (AnAdapter adpt)) hashConsing ProverCommand {..} outputContinuation =
+satProveOffline (W4ProverConfig (AnAdapter adpt)) hashConsing warnUninterp ProverCommand {..} outputContinuation =
protectStack onError \(evo,byteReader,modEnv) ->
M.runModuleM (evo,byteReader,modEnv)
- do sym <- liftIO makeSym
+ do w4sym <- liftIO makeSym
+ defVar <- liftIO (newMVar (W4.truePred w4sym))
+ funVar <- liftIO (newMVar mempty)
+ uninterpWarnVar <- liftIO (newMVar mempty)
+ let sym = What4 w4sym defVar funVar uninterpWarnVar
ok <- prepareQuery sym ProverCommand { .. }
+ when warnUninterp
+ (M.withLogger printUninterpWarn =<< liftIO (readMVar uninterpWarnVar))
liftIO
case ok of
Left msg -> return (Just msg)
Right (_ts,_args,_safety,query) ->
do outputContinuation
- (\hdl -> solver_adapter_write_smt2 adpt sym hdl [query])
+ (\hdl -> solver_adapter_write_smt2 adpt w4sym hdl [query])
return Nothing
where
makeSym =
@@ -373,30 +410,30 @@
multiSATQuery ::
sym ~ W4.ExprBuilder t CryptolState fm =>
- sym ->
+ What4 sym ->
W4ProverConfig ->
- Eval.EvalOpts ->
PrimMap ->
W4.LogData ->
[FinType] ->
- [VarShape sym] ->
+ [VarShape (What4 sym)] ->
W4.Pred sym ->
SatNum ->
IO (Maybe String, ProverResult)
-multiSATQuery sym solverCfg evo primMap logData ts args query (SomeSat n) | n <= 1 =
- singleQuery sym solverCfg evo primMap logData ts args Nothing query
+multiSATQuery sym solverCfg primMap logData ts args query (SomeSat n) | n <= 1 =
+ singleQuery sym solverCfg primMap logData ts args Nothing query
-multiSATQuery _sym (W4Portfolio _) _evo _primMap _logData _ts _args _query _satNum =
+multiSATQuery _sym (W4Portfolio _) _primMap _logData _ts _args _query _satNum =
fail "What4 portfolio solver cannot be used for multi SAT queries"
-multiSATQuery sym (W4ProverConfig (AnAdapter adpt)) evo primMap logData ts args query satNum0 =
- do pres <- W4.solver_adapter_check_sat adpt sym logData [query] $ \res ->
+multiSATQuery sym (W4ProverConfig (AnAdapter adpt)) primMap logData ts args query satNum0 =
+ do pres <- W4.solver_adapter_check_sat adpt (w4 sym) logData [query] $ \res ->
case res of
W4.Unknown -> return (Left (ProverError "Solver returned UNKNOWN"))
W4.Unsat _ -> return (Left (ThmResult (map unFinType ts)))
W4.Sat (evalFn,_) ->
- do model <- computeModel evo primMap evalFn ts args
- blockingPred <- computeBlockingPred sym evalFn args
+ do xs <- mapM (varShapeToConcrete evalFn) args
+ let model = computeModel primMap ts xs
+ blockingPred <- computeBlockingPred sym args xs
return (Right (model, blockingPred))
case pres of
@@ -409,22 +446,24 @@
computeMoreModels _qs (SomeSat n) | n <= 0 = return [] -- should never happen...
computeMoreModels qs (SomeSat n) | n <= 1 = -- final model
- W4.solver_adapter_check_sat adpt sym logData qs $ \res ->
+ W4.solver_adapter_check_sat adpt (w4 sym) logData qs $ \res ->
case res of
W4.Unknown -> return []
W4.Unsat _ -> return []
W4.Sat (evalFn,_) ->
- do model <- computeModel evo primMap evalFn ts args
+ do xs <- mapM (varShapeToConcrete evalFn) args
+ let model = computeModel primMap ts xs
return [model]
computeMoreModels qs satNum =
- do pres <- W4.solver_adapter_check_sat adpt sym logData qs $ \res ->
+ do pres <- W4.solver_adapter_check_sat adpt (w4 sym) logData qs $ \res ->
case res of
W4.Unknown -> return Nothing
W4.Unsat _ -> return Nothing
W4.Sat (evalFn,_) ->
- do model <- computeModel evo primMap evalFn ts args
- blockingPred <- computeBlockingPred sym evalFn args
+ do xs <- mapM (varShapeToConcrete evalFn) args
+ let model = computeModel primMap ts xs
+ blockingPred <- computeBlockingPred sym args xs
return (Just (model, blockingPred))
case pres of
@@ -434,19 +473,18 @@
singleQuery ::
sym ~ W4.ExprBuilder t CryptolState fm =>
- sym ->
+ What4 sym ->
W4ProverConfig ->
- Eval.EvalOpts ->
PrimMap ->
W4.LogData ->
[FinType] ->
- [VarShape sym] ->
+ [VarShape (What4 sym)] ->
Maybe (W4.Pred sym) {- ^ optional safety predicate. Nothing = SAT query -} ->
W4.Pred sym ->
IO (Maybe String, ProverResult)
-singleQuery sym (W4Portfolio ps) evo primMap logData ts args msafe query =
- do as <- mapM async [ singleQuery sym (W4ProverConfig p) evo primMap logData ts args msafe query
+singleQuery sym (W4Portfolio ps) primMap logData ts args msafe query =
+ do as <- mapM async [ singleQuery sym (W4ProverConfig p) primMap logData ts args msafe query
| p <- NE.toList ps
]
waitForResults [] as
@@ -465,13 +503,14 @@
do forM_ others (\a -> X.throwTo (asyncThreadId a) ExitSuccess)
return r
-singleQuery sym (W4ProverConfig (AnAdapter adpt)) evo primMap logData ts args msafe query =
- do pres <- W4.solver_adapter_check_sat adpt sym logData [query] $ \res ->
+singleQuery sym (W4ProverConfig (AnAdapter adpt)) primMap logData ts args msafe query =
+ do pres <- W4.solver_adapter_check_sat adpt (w4 sym) logData [query] $ \res ->
case res of
W4.Unknown -> return (ProverError "Solver returned UNKNOWN")
W4.Unsat _ -> return (ThmResult (map unFinType ts))
W4.Sat (evalFn,_) ->
- do model <- computeModel evo primMap evalFn ts args
+ do xs <- mapM (varShapeToConcrete evalFn) args
+ let model = computeModel primMap ts xs
case msafe of
Just s ->
do s' <- W4.groundEval evalFn s
@@ -484,138 +523,33 @@
computeBlockingPred ::
sym ~ W4.ExprBuilder t CryptolState fm =>
- sym ->
- W4.GroundEvalFn t ->
- [VarShape sym] ->
- IO (W4.Pred sym)
-computeBlockingPred sym evalFn vs =
- do ps <- mapM (varBlockingPred sym evalFn) vs
- foldM (W4.orPred sym) (W4.falsePred sym) ps
-
-varBlockingPred ::
- sym ~ W4.ExprBuilder t CryptolState fm =>
- sym ->
- W4.GroundEvalFn t ->
- VarShape sym ->
+ What4 sym ->
+ [VarShape (What4 sym)] ->
+ [VarShape Concrete.Concrete] ->
IO (W4.Pred sym)
-varBlockingPred sym evalFn v =
- case v of
- VarBit b ->
- do blit <- W4.groundEval evalFn b
- W4.notPred sym =<< W4.eqPred sym b (W4.backendPred sym blit)
- VarInteger i ->
- do ilit <- W4.groundEval evalFn i
- W4.notPred sym =<< W4.intEq sym i =<< W4.intLit sym ilit
- VarRational n d ->
- do n' <- W4.intLit sym =<< W4.groundEval evalFn n
- d' <- W4.intLit sym =<< W4.groundEval evalFn d
- x <- W4.intMul sym n d'
- y <- W4.intMul sym n' d
- W4.notPred sym =<< W4.intEq sym x y
- VarWord SW.ZBV -> return (W4.falsePred sym)
- VarWord (SW.DBV w) ->
- do wlit <- W4.groundEval evalFn w
- W4.notPred sym =<< W4.bvEq sym w =<< W4.bvLit sym (W4.bvWidth w) wlit
-
- VarFloat (W4.SFloat f)
- | fr@(W4.FloatingPointPrecisionRepr e p) <- sym `W4.fpReprOf` f
- , let wid = W4.addNat e p
- , Just W4.LeqProof <- W4.isPosNat wid ->
- do bits <- W4.groundEval evalFn f
- bv <- W4.bvLit sym wid bits
- constF <- W4.floatFromBinary sym fr bv
- -- NOTE: we are using logical equality here
- W4.notPred sym =<< W4.floatEq sym f constF
- | otherwise -> panic "varBlockingPred" [ "1 >= 2 ???" ]
-
- VarFinSeq _n vs -> computeBlockingPred sym evalFn vs
- VarTuple vs -> computeBlockingPred sym evalFn vs
- VarRecord fs -> computeBlockingPred sym evalFn (recordElements fs)
-
-computeModel ::
- Eval.EvalOpts ->
- PrimMap ->
- W4.GroundEvalFn t ->
- [FinType] ->
- [VarShape (W4.ExprBuilder t CryptolState fm)] ->
- IO [(Type, Expr, Concrete.Value)]
-computeModel _ _ _ [] [] = return []
-computeModel evo primMap evalFn (t:ts) (v:vs) =
- do v' <- varToConcreteValue evalFn v
- let t' = unFinType t
- e <- doEval evo (Concrete.toExpr primMap t' v') >>= \case
- Nothing -> panic "computeModel" ["could not compute counterexample expression"]
- Just e -> pure e
- zs <- computeModel evo primMap evalFn ts vs
- return ((t',e,v'):zs)
-computeModel _ _ _ _ _ = panic "computeModel" ["type/value list mismatch"]
-
-
-data VarShape sym
- = VarBit (W4.Pred sym)
- | VarInteger (W4.SymInteger sym)
- | VarRational (W4.SymInteger sym) (W4.SymInteger sym)
- | VarFloat (W4.SFloat sym)
- | VarWord (SW.SWord sym)
- | VarFinSeq Int [VarShape sym]
- | VarTuple [VarShape sym]
- | VarRecord (RecordMap Ident (VarShape sym))
-
-freshVariable :: W4.IsSymExprBuilder sym => sym -> FinType -> IO (VarShape sym)
-freshVariable sym ty =
- case ty of
- FTBit -> VarBit <$> W4.freshConstant sym W4.emptySymbol W4.BaseBoolRepr
- FTInteger -> VarInteger <$> W4.freshConstant sym W4.emptySymbol W4.BaseIntegerRepr
- FTRational -> VarRational
- <$> W4.freshConstant sym W4.emptySymbol W4.BaseIntegerRepr
- <*> W4.freshBoundedInt sym W4.emptySymbol (Just 1) Nothing
- FTIntMod 0 -> panic "freshVariable" ["0 modulus not allowed"]
- FTIntMod n -> VarInteger <$> W4.freshBoundedInt sym W4.emptySymbol (Just 0) (Just (n-1))
- FTFloat e p -> VarFloat <$> W4.fpFresh sym e p
- FTSeq n FTBit -> VarWord <$> SW.freshBV sym W4.emptySymbol (toInteger n)
- FTSeq n t -> VarFinSeq n <$> sequence (replicate n (freshVariable sym t))
- FTTuple ts -> VarTuple <$> mapM (freshVariable sym) ts
- FTRecord fs -> VarRecord <$> traverse (freshVariable sym) fs
-
-varToSymValue :: W4.IsExprBuilder sym => sym -> VarShape sym -> Value sym
-varToSymValue sym var =
- case var of
- VarBit b -> Eval.VBit b
- VarInteger i -> Eval.VInteger i
- VarRational n d -> Eval.VRational (Eval.SRational n d)
- VarWord w -> Eval.VWord (SW.bvWidth w) (return (Eval.WordVal w))
- VarFloat f -> Eval.VFloat f
- VarFinSeq n vs -> Eval.VSeq (toInteger n) (Eval.finiteSeqMap (What4 sym) (map (pure . varToSymValue sym) vs))
- VarTuple vs -> Eval.VTuple (map (pure . varToSymValue sym) vs)
- VarRecord fs -> Eval.VRecord (fmap (pure . varToSymValue sym) fs)
+computeBlockingPred sym vs xs =
+ do res <- doW4Eval (w4 sym) (modelPred sym vs xs)
+ W4.notPred (w4 sym) (snd res)
-varToConcreteValue ::
+varShapeToConcrete ::
W4.GroundEvalFn t ->
- VarShape (W4.ExprBuilder t CryptolState fm) ->
- IO Concrete.Value
-varToConcreteValue evalFn v =
+ VarShape (What4 (W4.ExprBuilder t CryptolState fm)) ->
+ IO (VarShape Concrete.Concrete)
+varShapeToConcrete evalFn v =
case v of
- VarBit b -> Eval.VBit <$> W4.groundEval evalFn b
- VarInteger i -> Eval.VInteger <$> W4.groundEval evalFn i
- VarRational n d ->
- Eval.VRational <$> (Eval.SRational <$> W4.groundEval evalFn n <*> W4.groundEval evalFn d)
- VarWord SW.ZBV ->
- pure (Eval.VWord 0 (pure (Eval.WordVal (Concrete.mkBv 0 0))))
+ VarBit b -> VarBit <$> W4.groundEval evalFn b
+ VarInteger i -> VarInteger <$> W4.groundEval evalFn i
+ VarRational n d -> VarRational <$> W4.groundEval evalFn n <*> W4.groundEval evalFn d
+ VarWord SW.ZBV -> pure (VarWord (Concrete.mkBv 0 0))
VarWord (SW.DBV x) ->
- do let w = W4.intValue (W4.bvWidth x)
- Eval.VWord w . pure . Eval.WordVal . Concrete.mkBv w . BV.asUnsigned <$> W4.groundEval evalFn x
+ let w = W4.intValue (W4.bvWidth x)
+ in VarWord . Concrete.mkBv w . BV.asUnsigned <$> W4.groundEval evalFn x
VarFloat fv@(W4.SFloat f) ->
do let (e,p) = W4.fpSize fv
- bits <- W4.groundEval evalFn f
- pure $ Eval.VFloat $ Concrete.floatFromBits e p $ BV.asUnsigned bits
-
+ VarFloat . FH.floatFromBits e p . BV.asUnsigned <$> W4.groundEval evalFn f
VarFinSeq n vs ->
- do vs' <- mapM (varToConcreteValue evalFn) vs
- pure (Eval.VSeq (toInteger n) (Eval.finiteSeqMap Concrete.Concrete (map pure vs')))
+ VarFinSeq n <$> mapM (varShapeToConcrete evalFn) vs
VarTuple vs ->
- do vs' <- mapM (varToConcreteValue evalFn) vs
- pure (Eval.VTuple (map pure vs'))
+ VarTuple <$> mapM (varShapeToConcrete evalFn) vs
VarRecord fs ->
- do fs' <- traverse (varToConcreteValue evalFn) fs
- pure (Eval.VRecord (fmap pure fs'))
-
+ VarRecord <$> traverse (varShapeToConcrete evalFn) fs
diff --git a/src/Cryptol/Testing/Random.hs b/src/Cryptol/Testing/Random.hs
--- a/src/Cryptol/Testing/Random.hs
+++ b/src/Cryptol/Testing/Random.hs
@@ -9,33 +9,40 @@
-- This module generates random values for Cryptol types.
{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE TypeFamilies #-}
-module Cryptol.Testing.Random where
+module Cryptol.Testing.Random
+( Gen
+, randomValue
+, dumpableType
+, testableType
+, TestReport(..)
+, TestResult(..)
+, isPass
+, returnTests
+, exhaustiveTests
+, randomTests
+) where
import qualified Control.Exception as X
import Control.Monad (join, liftM2)
+import Control.Monad.IO.Class (MonadIO(..))
import Data.Ratio ((%))
-import Data.Bits ( (.&.), shiftR )
import Data.List (unfoldr, genericTake, genericIndex, genericReplicate)
import qualified Data.Sequence as Seq
import System.Random (RandomGen, split, random, randomR)
-import System.Random.TF.Gen (seedTFGen)
-import Cryptol.Eval.Backend (Backend(..), SRational(..))
-import Cryptol.Eval.Concrete.Value
-import Cryptol.Eval.Monad (ready,runEval,EvalOpts,Eval,EvalError(..))
-import Cryptol.Eval.Type (TValue(..), tValTy)
+import Cryptol.Backend (Backend(..), SRational(..))
+import Cryptol.Backend.Monad (runEval,Eval,EvalError(..))
+import Cryptol.Backend.Concrete
+
+import Cryptol.Eval.Type (TValue(..))
import Cryptol.Eval.Value (GenValue(..),SeqMap(..), WordValue(..),
ppValue, defaultPPOpts, finiteSeqMap)
-import Cryptol.Eval.Generic (zeroV)
-import Cryptol.TypeCheck.AST (Type(..), TCon(..), TC(..), tNoUser, tIsFun
- , tIsNum )
-import Cryptol.TypeCheck.SimpType(tRebuild')
-
import Cryptol.Utils.Ident (Ident)
import Cryptol.Utils.Panic (panic)
import Cryptol.Utils.RecordMap
@@ -43,6 +50,8 @@
type Gen g x = Integer -> g -> (SEval x (GenValue x), g)
+type Value = GenValue Concrete
+
{- | Apply a testable value to some randomly-generated arguments.
Returns @Nothing@ if the function returned @True@, or
@Just counterexample@ if it returned @False@.
@@ -51,34 +60,32 @@
the supplied value, otherwise we'll panic.
-}
runOneTest :: RandomGen g
- => EvalOpts -- ^ how to evaluate things
- -> Value -- ^ Function under test
+ => Value -- ^ Function under test
-> [Gen g Concrete] -- ^ Argument generators
-> Integer -- ^ Size
-> g
-> IO (TestResult, g)
-runOneTest evOpts fun argGens sz g0 = do
+runOneTest fun argGens sz g0 = do
let (args, g1) = foldr mkArg ([], g0) argGens
mkArg argGen (as, g) = let (a, g') = argGen sz g in (a:as, g')
- args' <- runEval evOpts (sequence args)
- result <- evalTest evOpts fun args'
+ args' <- runEval (sequence args)
+ result <- evalTest fun args'
return (result, g1)
returnOneTest :: RandomGen g
- => EvalOpts -- ^ How to evaluate things
- -> Value -- ^ Function to be used to calculate tests
+ => Value -- ^ Function to be used to calculate tests
-> [Gen g Concrete] -- ^ Argument generators
-> Integer -- ^ Size
-> g -- ^ Initial random state
-> IO ([Value], Value, g) -- ^ Arguments, result, and new random state
-returnOneTest evOpts fun argGens sz g0 =
+returnOneTest fun argGens sz g0 =
do let (args, g1) = foldr mkArg ([], g0) argGens
mkArg argGen (as, g) = let (a, g') = argGen sz g in (a:as, g')
- args' <- runEval evOpts (sequence args)
- result <- runEval evOpts (go fun args')
+ args' <- runEval (sequence args)
+ result <- runEval (go fun args')
return (args', result, g1)
where
- go (VFun f) (v : vs) = join (go <$> (f (ready v)) <*> pure vs)
+ go (VFun f) (v : vs) = join (go <$> (f (pure v)) <*> pure vs)
go (VFun _) [] = panic "Cryptol.Testing.Random" ["Not enough arguments to function while generating tests"]
go _ (_ : _) = panic "Cryptol.Testing.Random" ["Too many arguments to function while generating tests"]
go v [] = return v
@@ -87,93 +94,63 @@
-- | Return a collection of random tests.
returnTests :: RandomGen g
=> g -- ^ The random generator state
- -> EvalOpts -- ^ How to evaluate things
-> [Gen g Concrete] -- ^ Generators for the function arguments
-> Value -- ^ The function itself
-> Int -- ^ How many tests?
-> IO [([Value], Value)] -- ^ A list of pairs of random arguments and computed outputs
-returnTests g evo gens fun num = go gens g 0
+returnTests g gens fun num = go gens g 0
where
go args g0 n
| n >= num = return []
| otherwise =
do let sz = toInteger (div (100 * (1 + n)) num)
- (inputs, output, g1) <- returnOneTest evo fun args sz g0
+ (inputs, output, g1) <- returnOneTest fun args sz g0
more <- go args g1 (n + 1)
return ((inputs, output) : more)
{- | Given a (function) type, compute generators for the function's
-arguments. This is like 'testableTypeGenerators', but allows the result to be
-any finite type instead of just @Bit@. -}
-dumpableType :: forall g. RandomGen g => Type -> Maybe [Gen g Concrete]
+arguments. -}
+dumpableType :: forall g. RandomGen g => TValue -> Maybe [Gen g Concrete]
+dumpableType (TVFun t1 t2) =
+ do g <- randomValue Concrete t1
+ as <- dumpableType t2
+ return (g : as)
dumpableType ty =
- case tIsFun ty of
- Just (t1, t2) ->
- do g <- randomValue Concrete t1
- as <- testableTypeGenerators t2
- return (g : as)
- Nothing ->
- do (_ :: Gen g Concrete) <- randomValue Concrete ty
- return []
-
-{- | Given a (function) type, compute generators for
-the function's arguments. Currently we do not support polymorphic functions.
-In principle, we could apply these to random types, and test the results. -}
-testableTypeGenerators :: RandomGen g => Type -> Maybe [Gen g Concrete]
-testableTypeGenerators ty =
- case tNoUser ty of
- TCon (TC TCFun) [t1,t2] ->
- do g <- randomValue Concrete t1
- as <- testableTypeGenerators t2
- return (g : as)
- TCon (TC TCBit) [] -> return []
- _ -> Nothing
+ do (_ :: Gen g Concrete) <- randomValue Concrete ty
+ return []
{-# SPECIALIZE randomValue ::
- RandomGen g => Concrete -> Type -> Maybe (Gen g Concrete)
+ RandomGen g => Concrete -> TValue -> Maybe (Gen g Concrete)
#-}
{- | A generator for values of the given type. This fails if we are
given a type that lacks a suitable random value generator. -}
-randomValue :: (Backend sym, RandomGen g) => sym -> Type -> Maybe (Gen g sym)
+randomValue :: (Backend sym, RandomGen g) => sym -> TValue -> Maybe (Gen g sym)
randomValue sym ty =
case ty of
- TCon tc ts ->
- case (tc, map (tRebuild' False) ts) of
- (TC TCBit, []) -> Just (randomBit sym)
-
- (TC TCInteger, []) -> Just (randomInteger sym)
-
- (TC TCRational, []) -> Just (randomRational sym)
-
- (TC TCIntMod, [TCon (TC (TCNum n)) []]) ->
- do return (randomIntMod sym n)
-
- (TC TCFloat, [e',p']) | Just e <- tIsNum e', Just p <- tIsNum p' ->
- return (randomFloat sym e p)
-
- (TC TCSeq, [TCon (TC TCInf) [], el]) ->
- do mk <- randomValue sym el
- return (randomStream mk)
-
- (TC TCSeq, [TCon (TC (TCNum n)) [], TCon (TC TCBit) []]) ->
- return (randomWord sym n)
-
- (TC TCSeq, [TCon (TC (TCNum n)) [], el]) ->
- do mk <- randomValue sym el
- return (randomSequence n mk)
-
- (TC (TCTuple _), els) ->
- do mks <- mapM (randomValue sym) els
- return (randomTuple mks)
-
- _ -> Nothing
+ TVBit -> Just (randomBit sym)
+ TVInteger -> Just (randomInteger sym)
+ TVRational -> Just (randomRational sym)
+ TVIntMod m -> Just (randomIntMod sym m)
+ TVFloat e p -> Just (randomFloat sym e p)
+ TVSeq n TVBit -> Just (randomWord sym n)
+ TVSeq n el ->
+ do mk <- randomValue sym el
+ return (randomSequence n mk)
+ TVStream el ->
+ do mk <- randomValue sym el
+ return (randomStream mk)
+ TVTuple els ->
+ do mks <- mapM (randomValue sym) els
+ return (randomTuple mks)
+ TVRec fs ->
+ do gs <- traverse (randomValue sym) fs
+ return (randomRecord gs)
- TVar _ -> Nothing
- TUser _ _ t -> randomValue sym t
- TRec fs -> do gs <- traverse (randomValue sym) fs
- return (randomRecord gs)
+ TVArray{} -> Nothing
+ TVFun{} -> Nothing
+ TVAbstract{} -> Nothing
{-# INLINE randomBit #-}
@@ -294,27 +271,7 @@
--- Random Values ---------------------------------------------------------------
-{-# SPECIALIZE randomV ::
- Concrete -> TValue -> Integer -> SEval Concrete (GenValue Concrete)
- #-}
-
--- | Produce a random value with the given seed. If we do not support
--- making values of the given type, return zero of that type.
--- TODO: do better than returning zero
-randomV :: Backend sym => sym -> TValue -> Integer -> SEval sym (GenValue sym)
-randomV sym ty seed =
- case randomValue sym (tValTy ty) of
- Nothing -> zeroV sym ty
- Just gen ->
- -- unpack the seed into four Word64s
- let mask64 = 0xFFFFFFFFFFFFFFFF
- unpack s = fromInteger (s .&. mask64) : unpack (s `shiftR` 64)
- [a, b, c, d] = take 4 (unpack seed)
- in fst $ gen 100 $ seedTFGen (a, b, c, d)
-
-
-- | A test result is either a pass, a failure due to evaluating to
-- @False@, or a failure due to an exception raised during evaluation
data TestResult
@@ -330,18 +287,18 @@
-- Note that this function assumes that the values come from a call to
-- `testableType` (i.e., things are type-correct). We run in the IO
-- monad in order to catch any @EvalError@s.
-evalTest :: EvalOpts -> Value -> [Value] -> IO TestResult
-evalTest evOpts v0 vs0 = run `X.catch` handle
+evalTest :: Value -> [Value] -> IO TestResult
+evalTest v0 vs0 = run `X.catch` handle
where
run = do
- result <- runEval evOpts (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] -> Eval Bool
- go (VFun f) (v : vs) = join (go <$> (f (ready v)) <*> return vs)
+ go (VFun f) (v : vs) = join (go <$> (f (pure v)) <*> return vs)
go (VFun _) [] = panic "Not enough arguments while applying function"
[]
go (VBit b) [] = return b
@@ -353,113 +310,87 @@
, "Arguments:"
] ++ map show vsdocs
-{- | Given a (function) type, compute all possible inputs for it.
-We also return the types of the arguments and
-the total number of test (i.e., the length of the outer list. -}
-testableType :: Type -> Maybe (Maybe Integer, [Type], [[Value]])
-testableType ty =
- case tNoUser ty of
- TCon (TC TCFun) [t1,t2] ->
- do let sz = typeSize t1
- (tot,ts,vss) <- testableType t2
- return (liftM2 (*) sz tot, t1:ts, [ v : vs | v <- typeValues t1, vs <- vss ])
- TCon (TC TCBit) [] -> return (Just 1, [], [[]])
- _ -> Nothing
+{- | Given a (function) type, compute data necessary for
+ random or exhaustive testing.
+ The first returned component is a count of the number of
+ possible input test vectors, if the input types are finite.
+ The second component is a list of all the types of the function
+ inputs. The third component is a list of all input test vectors
+ for exhaustive testing. This will be empty unless the
+ input types are finite. The final argument is a list of generators
+ for the inputs of the function.
+
+ This function will return @Nothing@ if the input type does not
+ eventually return @Bit@, or if we cannot compute a generator
+ for one of the inputs.
+-}
+testableType :: RandomGen g =>
+ TValue ->
+ Maybe (Maybe Integer, [TValue], [[Value]], [Gen g Concrete])
+testableType (TVFun t1 t2) =
+ do let sz = typeSize t1
+ g <- randomValue Concrete t1
+ (tot,ts,vss,gs) <- testableType t2
+ let tot' = liftM2 (*) sz tot
+ let vss' = [ v : vs | v <- typeValues t1, vs <- vss ]
+ return (tot', t1:ts, vss', g:gs)
+testableType TVBit = return (Just 1, [], [[]], [])
+testableType _ = Nothing
+
{- | Given a fully-evaluated type, try to compute the number of values in it.
Returns `Nothing` for infinite types, user-defined types, polymorphic types,
and, currently, function spaces. Of course, we can easily compute the
sizes of function spaces, but we can't easily enumerate their inhabitants. -}
-typeSize :: Type -> Maybe Integer
-typeSize ty =
- case ty of
- TVar _ -> Nothing
- TUser _ _ t -> typeSize t
- TRec fs -> product <$> traverse typeSize fs
- TCon (TC tc) ts ->
- case (tc, ts) of
- (TCNum _, _) -> Nothing
- (TCInf, _) -> Nothing
- (TCBit, _) -> Just 2
- (TCInteger, _) -> Nothing
- (TCRational, _) -> Nothing
- (TCIntMod, [sz]) -> case tNoUser sz of
- TCon (TC (TCNum n)) _ -> Just n
- _ -> Nothing
- (TCIntMod, _) -> Nothing
- (TCFloat {}, _) -> Nothing
- (TCArray, _) -> Nothing
- (TCSeq, [sz,el]) -> case tNoUser sz of
- TCon (TC (TCNum n)) _ -> (^ n) <$> typeSize el
- _ -> Nothing
- (TCSeq, _) -> Nothing
- (TCFun, _) -> Nothing
- (TCTuple _, els) -> product <$> mapM typeSize els
- (TCAbstract _, _) -> Nothing
- (TCNewtype _, _) -> Nothing
-
- TCon _ _ -> Nothing
-
+typeSize :: TValue -> Maybe Integer
+typeSize ty = case ty of
+ TVBit -> Just 2
+ TVInteger -> Nothing
+ TVRational -> Nothing
+ TVIntMod n -> Just n
+ TVFloat{} -> Nothing -- TODO?
+ TVArray{} -> Nothing
+ TVStream{} -> Nothing
+ TVSeq n el -> (^ n) <$> typeSize el
+ TVTuple els -> product <$> mapM typeSize els
+ TVRec fs -> product <$> traverse typeSize fs
+ TVFun{} -> Nothing
+ TVAbstract{} -> Nothing
{- | Returns all the values in a type. Returns an empty list of values,
for types where 'typeSize' returned 'Nothing'. -}
-typeValues :: Type -> [Value]
+typeValues :: TValue -> [Value]
typeValues ty =
case ty of
- TVar _ -> []
- TUser _ _ t -> typeValues t
- TRec fs -> [ VRecord (fmap ready xs)
- | xs <- traverse typeValues fs
- ]
- TCon (TC tc) ts ->
- case tc of
- TCNum _ -> []
- TCInf -> []
- TCBit -> [ VBit False, VBit True ]
- TCInteger -> []
- TCRational -> []
- TCIntMod ->
- case map tNoUser ts of
- [ TCon (TC (TCNum n)) _ ] | 0 < n ->
- [ VInteger x | x <- [ 0 .. n - 1 ] ]
- _ -> []
- TCFloat {} -> []
- TCArray -> []
- TCSeq ->
- case map tNoUser ts of
- [ TCon (TC (TCNum n)) _, TCon (TC TCBit) [] ] ->
- [ VWord n (ready (WordVal (BV n x))) | x <- [ 0 .. 2^n - 1 ] ]
-
- [ TCon (TC (TCNum n)) _, t ] ->
- [ VSeq n (finiteSeqMap Concrete (map ready xs))
- | xs <- sequence $ genericReplicate n
- $ typeValues t ]
- _ -> []
-
-
- TCFun -> [] -- We don't generate function values.
- TCTuple _ -> [ VTuple (map ready xs)
- | xs <- sequence (map typeValues ts)
- ]
- TCAbstract _ -> []
- TCNewtype _ -> []
-
- TCon _ _ -> []
+ TVBit -> [ VBit False, VBit True ]
+ TVInteger -> []
+ TVRational -> []
+ TVIntMod n -> [ VInteger x | x <- [ 0 .. (n-1) ] ]
+ TVFloat{} -> [] -- TODO?
+ TVArray{} -> []
+ TVStream{} -> []
+ TVSeq n TVBit ->
+ [ VWord n (pure (WordVal (BV n x)))
+ | x <- [ 0 .. 2^n - 1 ]
+ ]
+ TVSeq n el ->
+ [ VSeq n (finiteSeqMap Concrete (map pure xs))
+ | xs <- sequence (genericReplicate n (typeValues el))
+ ]
+ TVTuple ts ->
+ [ VTuple (map pure xs)
+ | xs <- sequence (map typeValues ts)
+ ]
+ TVRec fs ->
+ [ VRecord (fmap pure xs)
+ | xs <- traverse typeValues fs
+ ]
+ TVFun{} -> []
+ TVAbstract{} -> []
--------------------------------------------------------------------------------
-- Driver function
-data TestSpec m s = TestSpec {
- testFn :: Integer -> s -> m (TestResult, s)
- , testProp :: String -- ^ The property as entered by the user
- , testTotal :: Integer
- , testPossible :: Maybe Integer -- ^ Nothing indicates infinity
- , testRptProgress :: Integer -> Integer -> m ()
- , testClrProgress :: m ()
- , testRptFailure :: TestResult -> m ()
- , testRptSuccess :: m ()
- }
-
data TestReport = TestReport {
reportResult :: TestResult
, reportProp :: String -- ^ The property as entered by the user
@@ -467,19 +398,36 @@
, reportTestsPossible :: Maybe Integer
}
-runTests :: Monad m => TestSpec m s -> s -> m TestReport
-runTests TestSpec {..} st0 = go 0 st0
+exhaustiveTests :: MonadIO m =>
+ (Integer -> m ()) {- ^ progress callback -} ->
+ Value {- ^ function under test -} ->
+ [[Value]] {- ^ exhaustive set of test values -} ->
+ m (TestResult, Integer)
+exhaustiveTests ppProgress val = go 0
where
- go testNum _ | testNum >= testTotal = do
- testRptSuccess
- return $ TestReport Pass testProp testNum testPossible
- go testNum st =
- do testRptProgress testNum testTotal
- res <- testFn (div (100 * (1 + testNum)) testTotal) st
- testClrProgress
- case res of
- (Pass, st') -> do -- delProgress -- unnecessary?
- go (testNum + 1) st'
- (failure, _st') -> do
- testRptFailure failure
- return $ TestReport failure testProp testNum testPossible
+ go !testNum [] = return (Pass, testNum)
+ go !testNum (vs:vss) =
+ do ppProgress testNum
+ res <- liftIO (evalTest val vs)
+ case res of
+ Pass -> go (testNum+1) vss
+ failure -> return (failure, testNum)
+
+randomTests :: (MonadIO m, RandomGen g) =>
+ (Integer -> m ()) {- ^ progress callback -} ->
+ Integer {- ^ Maximum number of tests to run -} ->
+ Value {- ^ function under test -} ->
+ [Gen g Concrete] {- ^ input value generators -} ->
+ g {- ^ Inital random generator -} ->
+ m (TestResult, Integer)
+randomTests ppProgress maxTests val gens = go 0
+ where
+ go !testNum g
+ | testNum >= maxTests = return (Pass, testNum)
+ | otherwise =
+ do ppProgress testNum
+ let sz' = div (100 * (1 + testNum)) maxTests
+ (res, g') <- liftIO (runOneTest val gens sz' g)
+ case res of
+ Pass -> go (testNum+1) g'
+ failure -> return (failure, testNum)
diff --git a/src/Cryptol/Transform/AddModParams.hs b/src/Cryptol/Transform/AddModParams.hs
--- a/src/Cryptol/Transform/AddModParams.hs
+++ b/src/Cryptol/Transform/AddModParams.hs
@@ -234,7 +234,7 @@
ETuple es -> ETuple (inst ps es)
ERec fs -> ERec (fmap (inst ps) fs)
ESel e s -> ESel (inst ps e) s
- ESet e s v -> ESet (inst ps e) s (inst ps v)
+ ESet ty e s v -> ESet (inst ps ty) (inst ps e) s (inst ps v)
EIf e1 e2 e3 -> EIf (inst ps e1) (inst ps e2) (inst ps e3)
EComp t1 t2 e ms -> EComp (inst ps t1) (inst ps t2)
diff --git a/src/Cryptol/Transform/MonoValues.hs b/src/Cryptol/Transform/MonoValues.hs
--- a/src/Cryptol/Transform/MonoValues.hs
+++ b/src/Cryptol/Transform/MonoValues.hs
@@ -183,7 +183,7 @@
ETuple es -> ETuple <$> mapM go es
ERec fs -> ERec <$> traverse go fs
ESel e s -> ESel <$> go e <*> return s
- ESet e s v -> ESet <$> go e <*> return s <*> go v
+ ESet ty e s v -> ESet ty <$> go e <*> return s <*> go v
EIf e1 e2 e3 -> EIf <$> go e1 <*> go e2 <*> go e3
EComp len t e mss -> EComp len t <$> go e <*> mapM (mapM (rewM rews)) mss
diff --git a/src/Cryptol/Transform/Specialize.hs b/src/Cryptol/Transform/Specialize.hs
--- a/src/Cryptol/Transform/Specialize.hs
+++ b/src/Cryptol/Transform/Specialize.hs
@@ -74,7 +74,7 @@
ETuple es -> ETuple <$> traverse specializeExpr es
ERec fs -> ERec <$> traverse specializeExpr fs
ESel e s -> ESel <$> specializeExpr e <*> pure s
- ESet e s v -> ESet <$> specializeExpr e <*> pure s <*> specializeExpr v
+ ESet ty e s v -> ESet ty <$> specializeExpr e <*> pure s <*> specializeExpr v
EIf e1 e2 e3 -> EIf <$> specializeExpr e1 <*> specializeExpr e2 <*> specializeExpr e3
EComp len t e mss -> EComp len t <$> specializeExpr e <*> traverse (traverse specializeMatch) mss
-- Bindings within list comprehensions always have monomorphic types.
diff --git a/src/Cryptol/TypeCheck.hs b/src/Cryptol/TypeCheck.hs
--- a/src/Cryptol/TypeCheck.hs
+++ b/src/Cryptol/TypeCheck.hs
@@ -21,6 +21,10 @@
, Warning(..)
, ppWarning
, ppError
+ , WithNames(..)
+ , NameMap
+ , ppNamedWarning
+ , ppNamedError
) where
import Cryptol.ModuleSystem.Name
@@ -43,6 +47,7 @@
import Cryptol.TypeCheck.Solve(proveModuleTopLevel)
import Cryptol.TypeCheck.CheckModuleInstance(checkModuleInstance)
import Cryptol.TypeCheck.Monad(withParamType,withParameterConstraints)
+import Cryptol.TypeCheck.PP(WithNames(..),NameMap)
import Cryptol.Utils.Ident (exprModName,packIdent)
import Cryptol.Utils.PP
import Cryptol.Utils.Panic(panic)
@@ -58,12 +63,11 @@
IO (InferOutput Module) {- ^ new version of instance -}
tcModuleInst func m inp = runInferM inp
$ do x <- inferModule m
- y <- checkModuleInstance func x
flip (foldr withParamType) (mParamTypes x) $
withParameterConstraints (mParamConstraints x) $
- proveModuleTopLevel
-
- return y
+ do y <- checkModuleInstance func x
+ proveModuleTopLevel
+ pure y
tcExpr :: P.Expr Name -> InferInput -> IO (InferOutput (Expr,Schema))
tcExpr e0 inp = runInferM inp
@@ -121,5 +125,14 @@
ppError :: (Range,Error) -> Doc
ppError (r,w) = text "[error] at" <+> pp r <.> colon $$ nest 2 (pp w)
+
+
+ppNamedWarning :: NameMap -> (Range,Warning) -> Doc
+ppNamedWarning nm (r,w) =
+ text "[warning] at" <+> pp r <.> colon $$ nest 2 (pp (WithNames w nm))
+
+ppNamedError :: NameMap -> (Range,Error) -> Doc
+ppNamedError nm (r,e) =
+ text "[error] at" <+> pp r <.> colon $$ nest 2 (pp (WithNames e nm))
diff --git a/src/Cryptol/TypeCheck/AST.hs b/src/Cryptol/TypeCheck/AST.hs
--- a/src/Cryptol/TypeCheck/AST.hs
+++ b/src/Cryptol/TypeCheck/AST.hs
@@ -25,7 +25,6 @@
, Pragma(..)
, Fixity(..)
, PrimMap(..)
- , TCErrorMessage(..)
, module Cryptol.TypeCheck.Type
) where
@@ -47,6 +46,7 @@
import Data.Map (Map)
import qualified Data.Map as Map
import qualified Data.IntMap as IntMap
+import Data.Text (Text)
-- | A Cryptol module.
@@ -80,7 +80,7 @@
-- This is used when we move parameters from the module
-- level to individual declarations
-- (type synonyms in particular)
- , mtpDoc :: Maybe String
+ , mtpDoc :: Maybe Text
} deriving (Show,Generic,NFData)
mtpParam :: ModTParam -> TParam
@@ -97,7 +97,7 @@
data ModVParam = ModVParam
{ mvpName :: Name
, mvpType :: Schema
- , mvpDoc :: Maybe String
+ , mvpDoc :: Maybe Text
, mvpFixity :: Maybe Fixity
} deriving (Show,Generic,NFData)
@@ -106,7 +106,8 @@
| ETuple [Expr] -- ^ Tuple value
| ERec (RecordMap Ident Expr) -- ^ Record value
| ESel Expr Selector -- ^ Elimination for tuple/record/list
- | ESet Expr Selector Expr -- ^ Change the value of a field.
+ | ESet Type Expr Selector Expr -- ^ Change the value of a field.
+ -- The included type gives the type of the record being updated
| EIf Expr Expr Expr -- ^ If-then-else
| EComp Type Type Expr [[Match]]
@@ -167,7 +168,7 @@
, dPragmas :: [Pragma]
, dInfix :: !Bool
, dFixity :: Maybe Fixity
- , dDoc :: Maybe String
+ , dDoc :: Maybe Text
} deriving (Generic, NFData, Show)
data DeclDef = DPrim
@@ -211,7 +212,7 @@
ESel e sel -> ppWP 4 e <+> text "." <.> pp sel
- ESet e sel v -> braces (pp e <+> "|" <+> pp sel <+> "=" <+> pp v)
+ ESet _ty e sel v -> braces (pp e <+> "|" <+> pp sel <+> "=" <+> pp v)
EIf e1 e2 e3 -> optParens (prec > 0)
$ sep [ text "if" <+> ppW e1
@@ -250,7 +251,7 @@
$ ppWP 3 e <+> text "<>"
ETApp e t -> optParens (prec > 3)
- $ ppWP 3 e <+> ppWP 4 t
+ $ ppWP 3 e <+> ppWP 5 t
EWhere e ds -> optParens (prec > 0)
( ppW e $$ text "where"
@@ -374,4 +375,3 @@
-- XXX: Print abstarct types/functions
vcat (map (ppWithNames (addTNames mps nm)) mDecls)
where mps = map mtpParam (Map.elems mParamTypes)
-
diff --git a/src/Cryptol/TypeCheck/CheckModuleInstance.hs b/src/Cryptol/TypeCheck/CheckModuleInstance.hs
--- a/src/Cryptol/TypeCheck/CheckModuleInstance.hs
+++ b/src/Cryptol/TypeCheck/CheckModuleInstance.hs
@@ -13,7 +13,6 @@
import Cryptol.TypeCheck.Infer
import Cryptol.TypeCheck.Subst
import Cryptol.TypeCheck.Error
-import Cryptol.Utils.PP
import Cryptol.Utils.Panic
@@ -61,10 +60,12 @@
tParams = Map.fromList [ (tpId x, x) | x0 <- Map.elems (mParamTypes inst)
, let x = mtpParam x0 ]
- tpId x = case tpName x of
- Just n -> nameIdent n
+ tpName' x = case tpName x of
+ Just n -> n
Nothing -> panic "inferModuleInstance.tpId" ["Missing name"]
+ tpId = nameIdent . tpName'
+
-- Find a definition for a given type parameter
checkTParamDefined tp0 =
let tp = mtpParam tp0
@@ -78,15 +79,16 @@
case Map.lookup x tParams of
Just tp1 -> checkTP tp tp1
Nothing ->
- do recordError $ ErrorMsg $
- text "Missing definition for type parameter:" <+> pp x
+ do let x' = Located { thing = x,
+ srcRange = nameLoc (tpName' tp) }
+ recordError (MissingModTParam x')
return (tp, TVar (TVBound tp)) -- hm, maybe just stop!
-- Check that a type parameter defined as a type synonym is OK
checkTySynDef tp ts =
do let k1 = kindOf tp
k2 = kindOf ts
- unless (k1 == k2) (recordError (KindMismatch k1 k2))
+ unless (k1 == k2) (recordError (KindMismatch Nothing k1 k2))
let nm = tsName ts
src = CtPartialTypeFun nm
@@ -104,7 +106,7 @@
checkNewTyDef tp nt =
do let k1 = kindOf tp
k2 = kindOf nt
- unless (k1 == k2) (recordError (KindMismatch k1 k2))
+ unless (k1 == k2) (recordError (KindMismatch Nothing k1 k2))
let nm = ntName nt
src = CtPartialTypeFun nm
@@ -116,7 +118,7 @@
checkTP tp tp1 =
do let k1 = kindOf tp
k2 = kindOf tp1
- unless (k1 == k2) (recordError (KindMismatch k1 k2))
+ unless (k1 == k2) (recordError (KindMismatch Nothing k1 k2))
return (tp, TVar (TVBound tp1))
@@ -148,9 +150,9 @@
case Map.lookup (nameIdent x) valMap of
Just (n,sD) -> do e <- makeValParamDef n sD (apSubst su sP)
return (x,e)
- Nothing -> do recordError $ ErrorMsg
- $ text "Mising definition for value parameter"
- <+> pp x
+ Nothing -> do recordError (MissingModVParam
+ Located { thing = nameIdent x
+ , srcRange = nameLoc x })
return (x, panic "checkValParams" ["Should not use this"])
diff --git a/src/Cryptol/TypeCheck/Default.hs b/src/Cryptol/TypeCheck/Default.hs
--- a/src/Cryptol/TypeCheck/Default.hs
+++ b/src/Cryptol/TypeCheck/Default.hs
@@ -6,7 +6,6 @@
import Data.Maybe(mapMaybe)
import Data.List((\\),nub)
import Control.Monad(guard,mzero)
-import Control.Applicative((<|>))
import Cryptol.TypeCheck.Type
import Cryptol.TypeCheck.SimpType(tMax)
@@ -16,7 +15,6 @@
import Cryptol.TypeCheck.Solver.SMT(Solver,tryGetModel,shrinkModel)
import Cryptol.Utils.Panic(panic)
-
--------------------------------------------------------------------------------
-- | We default constraints of the form @Literal t a@ and @FLiteral m n r a@.
@@ -35,39 +33,44 @@
where
gSet = goalsFromList gs
allProps = saturatedPropSet gSet
- flitCandidates = flitDefaultCandidates gSet
+ has p a = Set.member (p (TVar a)) allProps
tryDefVar a =
- -- we do this first because if we have both a Literand and an FLiteral
- -- constraint we should use Rational
- Map.lookup a flitCandidates
- <|>
- do _gt <- Map.lookup a (literalGoals gSet)
- defT <- if Set.member (pLogic (TVar a)) allProps then
- mzero
- else if Set.member (pField (TVar a)) allProps then
- pure tRational
- else
- pure tInteger
- let d = tvInfo a
- w = DefaultingTo d defT
- guard (not (Set.member a (fvs defT))) -- Currently shouldn't happen
- -- but future proofing.
- -- XXX: Make sure that `defT` has only variables that `a` is allowed
- -- to depend on
- return ((a,defT),w)
+ -- If there is an `FLiteral` constraint we use that for defaulting.
+ case Map.lookup a (flitDefaultCandidates gSet) of
+ Just m -> m
-flitDefaultCandidates :: Goals -> Map TVar ((TVar,Type),Warning)
+ -- Otherwise we try to use a `Literal`
+ Nothing ->
+ do _gt <- Map.lookup a (literalGoals gSet)
+ defT <- if has pLogic a then mzero
+ else if has pField a && not (has pIntegral a)
+ then pure tRational
+ else if not (has pField a) then pure tInteger
+ else mzero
+ let d = tvInfo a
+ w = DefaultingTo d defT
+ guard (not (Set.member a (fvs defT))) -- Currently shouldn't happen
+ -- but future proofing.
+ -- XXX: Make sure that `defT` has only variables that `a` is allowed
+ -- to depend on
+ return ((a,defT),w)
+
+
+flitDefaultCandidates :: Goals -> Map TVar (Maybe ((TVar,Type),Warning))
flitDefaultCandidates gs =
Map.fromList (mapMaybe flitCandidate (Set.toList (goalSet gs)))
where
+ allProps = saturatedPropSet gs
+ has p a = Set.member (p (TVar a)) allProps
+
flitCandidate g =
do (_,_,_,x) <- pIsFLiteral (goal g)
a <- tIsVar x
- guard (not (Set.member (pLogic (TVar a)) (saturatedPropSet gs)))
- let defT = tRational
- let w = DefaultingTo (tvInfo a) defT
- pure (a, ((a,defT),w))
+ pure (a, do guard (not (has pLogic a) && not (has pIntegral a))
+ let defT = tRational
+ let w = DefaultingTo (tvInfo a) defT
+ pure ((a,defT),w))
--------------------------------------------------------------------------------
diff --git a/src/Cryptol/TypeCheck/Depends.hs b/src/Cryptol/TypeCheck/Depends.hs
--- a/src/Cryptol/TypeCheck/Depends.hs
+++ b/src/Cryptol/TypeCheck/Depends.hs
@@ -27,16 +27,17 @@
import Data.Map (Map)
import qualified Data.Map as Map
import qualified Data.Set as Set
+import Data.Text (Text)
data TyDecl =
- TS (P.TySyn Name) (Maybe String) -- ^ Type synonym
- | NT (P.Newtype Name) (Maybe String) -- ^ Newtype
- | AT (P.ParameterType Name) (Maybe String) -- ^ Parameter type
- | PS (P.PropSyn Name) (Maybe String) -- ^ Property synonym
- | PT (P.PrimType Name) (Maybe String) -- ^ A primitive/abstract typee
+ TS (P.TySyn Name) (Maybe Text) -- ^ Type synonym
+ | NT (P.Newtype Name) (Maybe Text) -- ^ Newtype
+ | AT (P.ParameterType Name) (Maybe Text) -- ^ Parameter type
+ | PS (P.PropSyn Name) (Maybe Text) -- ^ Property synonym
+ | PT (P.PrimType Name) (Maybe Text) -- ^ A primitive/abstract typee
deriving Show
-setDocString :: Maybe String -> TyDecl -> TyDecl
+setDocString :: Maybe Text -> TyDecl -> TyDecl
setDocString x d =
case d of
TS a _ -> TS a x
diff --git a/src/Cryptol/TypeCheck/Error.hs b/src/Cryptol/TypeCheck/Error.hs
--- a/src/Cryptol/TypeCheck/Error.hs
+++ b/src/Cryptol/TypeCheck/Error.hs
@@ -1,13 +1,13 @@
{-# Language FlexibleInstances, DeriveGeneric, DeriveAnyClass #-}
{-# Language OverloadedStrings #-}
+{-# Language Safe #-}
module Cryptol.TypeCheck.Error where
-
import qualified Data.IntMap as IntMap
import qualified Data.Set as Set
import Control.DeepSeq(NFData)
import GHC.Generics(Generic)
-import Data.List((\\),sortBy,groupBy,minimumBy)
+import Data.List((\\),sortBy,groupBy,partition)
import Data.Function(on)
import qualified Cryptol.Parser.AST as P
@@ -23,43 +23,49 @@
cleanupErrors :: [(Range,Error)] -> [(Range,Error)]
cleanupErrors = dropErrorsFromSameLoc
. sortBy (compare `on` (cmpR . fst)) -- order errors
- . dropSumbsumed
+ . dropSubsumed []
where
-- pick shortest error from each location.
- dropErrorsFromSameLoc = map chooseBestError
+ dropErrorsFromSameLoc = concatMap chooseBestError
. groupBy ((==) `on` fst)
- addErrorSize (r,e) = (length (show (pp e)), (r,e))
- chooseBestError = snd . minimumBy (compare `on` fst) . map addErrorSize
+ addErrorRating (r,e) = (errorImportance e, (r,e))
+ chooseBestError = map snd
+ . head
+ . groupBy ((==) `on` fst)
+ . sortBy (flip compare `on` fst)
+ . map addErrorRating
- cmpR r = ( source r -- Frist by file
+ cmpR r = ( source r -- First by file
, from r -- Then starting position
, to r -- Finally end position
)
- dropSumbsumed xs =
+ dropSubsumed survived xs =
case xs of
- (r,e) : rest -> (r,e) :
- dropSumbsumed (filter (not .subsumes e . snd) rest)
- [] -> []
+ err : rest ->
+ let keep e = not (subsumes err e)
+ in dropSubsumed (err : filter keep survived) (filter keep rest)
+ [] -> survived
-- | Should the first error suppress the next one.
-subsumes :: Error -> Error -> Bool
-subsumes (NotForAll x _) (NotForAll y _) = x == y
+subsumes :: (Range,Error) -> (Range,Error) -> Bool
+subsumes (_,NotForAll _ x _) (_,NotForAll _ y _) = x == y
+subsumes (r1,KindMismatch {}) (r2,err) =
+ case err of
+ KindMismatch {} -> r1 == r2
+ _ -> True
subsumes _ _ = False
data Warning = DefaultingKind (P.TParam Name) P.Kind
| DefaultingWildType P.Kind
- | DefaultingTo TVarInfo Type
+ | DefaultingTo !TVarInfo Type
deriving (Show, Generic, NFData)
-- | Various errors that might happen during type checking/inference
-data Error = ErrorMsg Doc
- -- ^ Just say this
-
- | KindMismatch Kind Kind
+data Error = KindMismatch (Maybe TypeSource) Kind Kind
-- ^ Expected kind, inferred kind
| TooManyTypeParams Int Kind
@@ -78,17 +84,20 @@
| RecursiveTypeDecls [Name]
-- ^ The type synonym declarations are recursive
- | TypeMismatch Type Type
+ | TypeMismatch TypeSource Type Type
-- ^ Expected type, inferred type
- | RecursiveType Type Type
+ | RecursiveType TypeSource Type Type
-- ^ Unification results in a recursive type
- | UnsolvedGoals (Maybe TCErrorMessage) [Goal]
- -- ^ A constraint that we could not solve
- -- If we have `TCErrorMess` than the goal is impossible
- -- for the given reason
+ | UnsolvedGoals [Goal]
+ -- ^ A constraint that we could not solve, usually because
+ -- there are some left-over variables that we could not infer.
+ | UnsolvableGoals [Goal]
+ -- ^ A constraint that we could not solve and we know
+ -- it is impossible to do it.
+
| UnsolvedDelayedCt DelayedCt
-- ^ A constraint (with context) that we could not solve
@@ -96,11 +105,11 @@
-- ^ Type wild cards are not allowed in this context
-- (e.g., definitions of type synonyms).
- | TypeVariableEscaped Type [TParam]
+ | TypeVariableEscaped TypeSource Type [TParam]
-- ^ Unification variable depends on quantified variables
-- that are not in scope.
- | NotForAll TVar Type
+ | NotForAll TypeSource TVar Type
-- ^ Quantified type variables (of kind *) need to
-- match the given type, so it does not work for all types.
@@ -118,14 +127,65 @@
-- ^ Could not determine the value of a numeric type variable,
-- but we know it must be at least as large as the given type
-- (or unconstrained, if Nothing).
+
+ | UndefinedExistVar Name
+ | TypeShadowing String Name String
+ | MissingModTParam (Located Ident)
+ | MissingModVParam (Located Ident)
deriving (Show, Generic, NFData)
+-- | When we have multiple errors on the same location, we show only the
+-- ones with the has highest rating according to this function.
+errorImportance :: Error -> Int
+errorImportance err =
+ case err of
+ KindMismatch {} -> 10
+ TyVarWithParams {} -> 9
+ TypeMismatch {} -> 8
+ RecursiveType {} -> 7
+ NotForAll {} -> 6
+ TypeVariableEscaped {} -> 5
+
+ UndefinedExistVar {} -> 10
+ TypeShadowing {} -> 2
+ MissingModTParam {} -> 10
+ MissingModVParam {} -> 10
+
+
+ CannotMixPositionalAndNamedTypeParams {} -> 8
+ TooManyTypeParams {} -> 8
+ TooFewTyParams {} -> 8
+ TooManyPositionalTypeParams {} -> 8
+ UndefinedTypeParameter {} -> 8
+ RepeatedTypeParameter {} -> 8
+
+ TooManyTySynParams {} -> 8
+ UnexpectedTypeWildCard {} -> 8
+
+ RecursiveTypeDecls {} -> 9
+
+ UnsolvableGoals g
+ | any tHasErrors (map goal g) -> 0
+ | otherwise -> 4
+
+ UnsolvedGoals g
+ | any tHasErrors (map goal g) -> 0
+ | otherwise -> 4
+
+ UnsolvedDelayedCt dt
+ | any tHasErrors (map goal (dctGoals dt)) -> 0
+ | otherwise -> 3
+
+ AmbiguousSize {} -> 2
+
+
+
instance TVars Warning where
apSubst su warn =
case warn of
DefaultingKind {} -> warn
DefaultingWildType {} -> warn
- DefaultingTo d ty -> DefaultingTo d (apSubst su ty)
+ DefaultingTo d ty -> DefaultingTo d $! (apSubst su ty)
instance FVS Warning where
fvs warn =
@@ -137,52 +197,63 @@
instance TVars Error where
apSubst su err =
case err of
- ErrorMsg _ -> err
KindMismatch {} -> err
TooManyTypeParams {} -> err
TyVarWithParams -> err
TooManyTySynParams {} -> err
TooFewTyParams {} -> err
RecursiveTypeDecls {} -> err
- TypeMismatch t1 t2 -> TypeMismatch (apSubst su t1) (apSubst su t2)
- RecursiveType t1 t2 -> RecursiveType (apSubst su t1) (apSubst su t2)
- UnsolvedGoals x gs -> UnsolvedGoals x (apSubst su gs)
- UnsolvedDelayedCt g -> UnsolvedDelayedCt (apSubst su g)
+ TypeMismatch src t1 t2 -> TypeMismatch src !$ (apSubst su t1) !$ (apSubst su t2)
+ RecursiveType src t1 t2 -> RecursiveType src !$ (apSubst su t1) !$ (apSubst su t2)
+ UnsolvedGoals gs -> UnsolvedGoals !$ apSubst su gs
+ UnsolvableGoals gs -> UnsolvableGoals !$ apSubst su gs
+ UnsolvedDelayedCt g -> UnsolvedDelayedCt !$ (apSubst su g)
UnexpectedTypeWildCard -> err
- TypeVariableEscaped t xs -> TypeVariableEscaped (apSubst su t) xs
- NotForAll x t -> NotForAll x (apSubst su t)
+ TypeVariableEscaped src t xs ->
+ TypeVariableEscaped src !$ (apSubst su t) .$ xs
+ NotForAll src x t -> NotForAll src x !$ (apSubst su t)
TooManyPositionalTypeParams -> err
CannotMixPositionalAndNamedTypeParams -> err
UndefinedTypeParameter {} -> err
RepeatedTypeParameter {} -> err
- AmbiguousSize x t -> AmbiguousSize x (apSubst su t)
+ AmbiguousSize x t -> AmbiguousSize x !$ (apSubst su t)
+ UndefinedExistVar {} -> err
+ TypeShadowing {} -> err
+ MissingModTParam {} -> err
+ MissingModVParam {} -> err
+
+
instance FVS Error where
fvs err =
case err of
- ErrorMsg {} -> Set.empty
KindMismatch {} -> Set.empty
TooManyTypeParams {} -> Set.empty
TyVarWithParams -> Set.empty
TooManyTySynParams {} -> Set.empty
TooFewTyParams {} -> Set.empty
RecursiveTypeDecls {} -> Set.empty
- TypeMismatch t1 t2 -> fvs (t1,t2)
- RecursiveType t1 t2 -> fvs (t1,t2)
- UnsolvedGoals _ gs -> fvs gs
+ TypeMismatch _ t1 t2 -> fvs (t1,t2)
+ RecursiveType _ t1 t2 -> fvs (t1,t2)
+ UnsolvedGoals gs -> fvs gs
+ UnsolvableGoals gs -> fvs gs
UnsolvedDelayedCt g -> fvs g
UnexpectedTypeWildCard -> Set.empty
- TypeVariableEscaped t xs -> fvs t `Set.union`
+ TypeVariableEscaped _ t xs-> fvs t `Set.union`
Set.fromList (map TVBound xs)
- NotForAll x t -> Set.insert x (fvs t)
+ NotForAll _ x t -> Set.insert x (fvs t)
TooManyPositionalTypeParams -> Set.empty
CannotMixPositionalAndNamedTypeParams -> Set.empty
UndefinedTypeParameter {} -> Set.empty
RepeatedTypeParameter {} -> Set.empty
AmbiguousSize _ t -> fvs t
+ UndefinedExistVar {} -> Set.empty
+ TypeShadowing {} -> Set.empty
+ MissingModTParam {} -> Set.empty
+ MissingModVParam {} -> Set.empty
instance PP Warning where
ppPrec = ppWithNamesPrec IntMap.empty
@@ -208,26 +279,28 @@
instance PP (WithNames Error) where
ppPrec _ (WithNames err names) =
case err of
- ErrorMsg msg ->
- addTVarsDescsAfter names err
- msg
- RecursiveType t1 t2 ->
+ RecursiveType src t1 t2 ->
addTVarsDescsAfter names err $
- nested "Matching would result in an infinite type."
- ("The type: " <+> ppWithNames names t1 $$
- "occurs in:" <+> ppWithNames names t2)
+ nested "Matching would result in an infinite type." $
+ vcat [ "The type: " <+> ppWithNames names t1
+ , "occurs in:" <+> ppWithNames names t2
+ , "When checking" <+> pp src
+ ]
UnexpectedTypeWildCard ->
addTVarsDescsAfter names err $
nested "Wild card types are not allowed in this context"
"(e.g., they cannot be used in type synonyms)."
- KindMismatch k1 k2 ->
+ KindMismatch mbsrc k1 k2 ->
addTVarsDescsAfter names err $
- nested "Incorrect type form."
- ("Expected:" <+> cppKind k1 $$
- "Inferred:" <+> cppKind k2)
+ nested "Incorrect type form." $
+ vcat [ "Expected:" <+> cppKind k1
+ , "Inferred:" <+> cppKind k2
+ , kindMismatchHint k1 k2
+ , maybe empty (\src -> "When checking" <+> pp src) mbsrc
+ ]
TooManyTypeParams extra k ->
addTVarsDescsAfter names err $
@@ -256,24 +329,18 @@
nested "Recursive type declarations:"
(fsep $ punctuate comma $ map nm ts)
- TypeMismatch t1 t2 ->
+ TypeMismatch src t1 t2 ->
addTVarsDescsAfter names err $
- nested "Type mismatch:"
- ("Expected type:" <+> ppWithNames names t1 $$
- "Inferred type:" <+> ppWithNames names t2 $$
- mismatchHint t1 t2)
+ nested "Type mismatch:" $
+ vcat [ "Expected type:" <+> ppWithNames names t1
+ , "Inferred type:" <+> ppWithNames names t2
+ , mismatchHint t1 t2
+ , "When checking" <+> pp src
+ ]
- UnsolvedGoals imp gs
- | Just msg <- imp ->
- addTVarsDescsAfter names err $
- nested "Unsolvable constraints:" $
- let reason = ["Reason:" <+> text (tcErrorMessage msg)]
- unErr g = case tIsError (goal g) of
- Just (_,p) -> g { goal = p }
- Nothing -> g
- in
- bullets (map (ppWithNames names) (map unErr gs) ++ reason)
+ UnsolvableGoals gs -> explainUnsolvable names gs
+ UnsolvedGoals gs
| noUni ->
addTVarsDescsAfter names err $
nested "Unsolved constraints:" $
@@ -294,18 +361,22 @@
nested "while validating user-specified signature" $
ppWithNames names g
- TypeVariableEscaped t xs ->
+ TypeVariableEscaped src t xs ->
addTVarsDescsAfter names err $
nested ("The type" <+> ppWithNames names t <+>
- "is not sufficiently polymorphic.")
- ("It cannot depend on quantified variables:" <+>
- sep (punctuate comma (map (ppWithNames names) xs)))
+ "is not sufficiently polymorphic.") $
+ vcat [ "It cannot depend on quantified variables:" <+>
+ sep (punctuate comma (map (ppWithNames names) xs))
+ , "When checking" <+> pp src
+ ]
- NotForAll x t ->
+ NotForAll src x t ->
addTVarsDescsAfter names err $
- nested "Inferred type is not sufficiently polymorphic."
- ("Quantified variable:" <+> ppWithNames names x $$
- "cannot match type:" <+> ppWithNames names t)
+ nested "Inferred type is not sufficiently polymorphic." $
+ vcat [ "Quantified variable:" <+> ppWithNames names x
+ , "cannot match type:" <+> ppWithNames names t
+ , "When checking" <+> pp src
+ ]
TooManyPositionalTypeParams ->
addTVarsDescsAfter names err $
@@ -332,6 +403,18 @@
Nothing -> empty
in addTVarsDescsAfter names err ("Ambiguous numeric type:" <+> pp (tvarDesc x) $$ sizeMsg)
+ UndefinedExistVar x -> "Undefined type" <+> quotes (pp x)
+ TypeShadowing this new that ->
+ "Type" <+> text this <+> quotes (pp new) <+>
+ "shadowing an existing" <+> text that <+> "with the same name."
+ MissingModTParam x ->
+ "Missing definition for type parameter" <+> quotes (pp (thing x))
+ MissingModVParam x ->
+ "Missing definition for value parameter" <+> quotes (pp (thing x))
+
+
+
+
where
bullets xs = vcat [ "•" <+> d | d <- xs ]
@@ -342,6 +425,11 @@
nm x = text "`" <.> pp x <.> text "`"
+ kindMismatchHint k1 k2 =
+ case (k1,k2) of
+ (KType,KProp) -> "Possibly due to a missing `=>`"
+ _ -> empty
+
mismatchHint (TRec fs1) (TRec fs2) =
hint "Missing" missing $$ hint "Unexpected" extra
where
@@ -353,3 +441,133 @@
mismatchHint _ _ = mempty
noUni = Set.null (Set.filter isFreeTV (fvs err))
+
+
+
+explainUnsolvable :: NameMap -> [Goal] -> Doc
+explainUnsolvable names gs =
+ addTVarsDescsAfter names gs (bullets (map explain gs))
+
+ where
+ bullets xs = vcat [ "•" <+> d | d <- xs ]
+
+
+
+ explain g =
+ let useCtr = "Unsolvable constraint:" $$
+ nest 2 (ppWithNames names g)
+
+ in
+ case tNoUser (goal g) of
+ TCon (PC pc) ts ->
+ let tys = [ backticks (ppWithNames names t) | t <- ts ]
+ doc1 : _ = tys
+ custom msg = msg $$
+ nest 2 (text "arising from" $$
+ pp (goalSource g) $$
+ text "at" <+> pp (goalRange g))
+ in
+ case pc of
+ PEqual -> useCtr
+ PNeq -> useCtr
+ PGeq -> useCtr
+ PFin -> useCtr
+ PPrime -> useCtr
+
+ PHas sel ->
+ custom ("Type" <+> doc1 <+> "does not have field" <+> f
+ <+> "of type" <+> (tys !! 1))
+ where f = case sel of
+ P.TupleSel n _ -> int n
+ P.RecordSel fl _ -> backticks (pp fl)
+ P.ListSel n _ -> int n
+
+ PZero ->
+ custom ("Type" <+> doc1 <+> "does not have `zero`")
+
+ PLogic ->
+ custom ("Type" <+> doc1 <+> "does not support logical operations.")
+
+ PRing ->
+ custom ("Type" <+> doc1 <+> "does not support ring operations.")
+
+ PIntegral ->
+ custom (doc1 <+> "is not an integral type.")
+
+ PField ->
+ custom ("Type" <+> doc1 <+> "does not support field operations.")
+
+ PRound ->
+ custom ("Type" <+> doc1 <+> "does not support rounding operations.")
+
+ PEq ->
+ custom ("Type" <+> doc1 <+> "does not support equality.")
+
+ PCmp ->
+ custom ("Type" <+> doc1 <+> "does not support comparisons.")
+
+ PSignedCmp ->
+ custom ("Type" <+> doc1 <+> "does not support signed comparisons.")
+
+ PLiteral ->
+ let doc2 = tys !! 1
+ in custom (doc1 <+> "is not a valid literal of type" <+> doc2)
+
+ PFLiteral ->
+ case ts of
+ ~[m,n,_r,_a] ->
+ let frac = backticks (ppWithNamesPrec names 4 m <> "/" <>
+ ppWithNamesPrec names 4 n)
+ ty = tys !! 3
+ in custom (frac <+> "is not a valid literal of type" <+> ty)
+
+ PValidFloat ->
+ case ts of
+ ~[e,p] ->
+ custom ("Unsupported floating point parameters:" $$
+ nest 2 ("exponent =" <+> ppWithNames names e $$
+ "precision =" <+> ppWithNames names p))
+
+
+ PAnd -> useCtr
+ PTrue -> useCtr
+
+ _ -> useCtr
+
+
+
+
+-- | This picks the names to use when showing errors and warnings.
+computeFreeVarNames :: [(Range,Warning)] -> [(Range,Error)] -> NameMap
+computeFreeVarNames warns errs =
+ mkMap numRoots numVaras `IntMap.union` mkMap otherRoots otherVars
+
+ {- XXX: Currently we pick the names based on the unique of the variable:
+ smaller uniques get an earlier name (e.g., 100 might get `a` and 200 `b`)
+ This may still lead to changes in the names if the uniques got reordred
+ for some reason. A more stable approach might be to order the variables
+ on their location in the error/warning, but that's quite a bit more code
+ so for now we just go with the simple approximation. -}
+
+ where
+ mkName x v = (tvUnique x, v)
+ mkMap roots vs = IntMap.fromList (zipWith mkName vs (variants roots))
+
+ (numVaras,otherVars) = partition ((== KNum) . kindOf)
+ $ Set.toList
+ $ Set.filter isFreeTV
+ $ fvs (map snd warns, map snd errs)
+
+ otherRoots = [ "a", "b", "c", "d" ]
+ numRoots = [ "m", "n", "u", "v" ]
+
+ useUnicode = True
+
+ suff n
+ | n < 10 && useUnicode = [toEnum (0x2080 + n)]
+ | otherwise = show n
+
+ variant n x = if n == 0 then x else x ++ suff n
+
+ variants roots = [ variant n r | n <- [ 0 .. ], r <- roots ]
+
diff --git a/src/Cryptol/TypeCheck/Infer.hs b/src/Cryptol/TypeCheck/Infer.hs
--- a/src/Cryptol/TypeCheck/Infer.hs
+++ b/src/Cryptol/TypeCheck/Infer.hs
@@ -45,7 +45,6 @@
import Cryptol.TypeCheck.Subst (listSubst,apSubst,(@@),isEmptySubst)
import Cryptol.Utils.Ident
import Cryptol.Utils.Panic(panic)
-import Cryptol.Utils.PP
import Cryptol.Utils.RecordMap
import qualified Data.Map as Map
@@ -117,19 +116,19 @@
P.ECNum num info ->
number $ [ ("val", P.TNum num) ] ++ case info of
- P.BinLit n -> [ ("rep", tBits (1 * toInteger n)) ]
- P.OctLit n -> [ ("rep", tBits (3 * toInteger n)) ]
- P.HexLit n -> [ ("rep", tBits (4 * toInteger n)) ]
- P.DecLit -> [ ]
+ P.BinLit _ n -> [ ("rep", tBits (1 * toInteger n)) ]
+ P.OctLit _ n -> [ ("rep", tBits (3 * toInteger n)) ]
+ P.HexLit _ n -> [ ("rep", tBits (4 * toInteger n)) ]
+ P.DecLit _ -> [ ]
P.PolyLit _n -> [ ("rep", P.TSeq P.TWild P.TBit) ]
P.ECFrac fr info ->
let arg f = P.PosInst (P.TNum (f fr))
rnd = P.PosInst (P.TNum (case info of
- P.DecFrac -> 0
- P.BinFrac -> 1
- P.OctFrac -> 1
- P.HexFrac -> 1))
+ P.DecFrac _ -> 0
+ P.BinFrac _ -> 1
+ P.OctFrac _ -> 1
+ P.HexFrac _ -> 1))
in P.EAppT fracPrim [ arg numerator, arg denominator, rnd ]
P.ECChar c ->
@@ -143,7 +142,7 @@
-- | Infer the type of an expression with an explicit instantiation.
-appTys :: P.Expr Name -> [TypeArg] -> Type -> InferM Expr
+appTys :: P.Expr Name -> [TypeArg] -> TypeWithSource -> InferM Expr
appTys expr ts tGoal =
case expr of
P.EVar x ->
@@ -221,7 +220,7 @@
-- | Infer the type of an expression, and translate it to a fully elaborated
-- core term.
-checkE :: P.Expr Name -> Type -> InferM Expr
+checkE :: P.Expr Name -> TypeWithSource -> InferM Expr
checkE expr tGoal =
case expr of
P.EVar x ->
@@ -245,7 +244,7 @@
do prim <- mkPrim "generate"
checkE (P.EApp prim e) tGoal
- P.ELit l@(P.ECNum _ P.DecLit) ->
+ P.ELit l@(P.ECNum _ (P.DecLit _)) ->
do e <- desugarLiteral l
-- NOTE: When 'l' is a decimal literal, 'desugarLiteral' does
-- not generate an instantiation for the 'rep' type argument
@@ -254,7 +253,7 @@
-- generating an unnecessary unification variable.
loc <- curRange
let arg = TypeArg { tyArgName = Just (Located loc (packIdent "rep"))
- , tyArgType = Checked tGoal
+ , tyArgType = Checked (twsType tGoal)
}
appTys e [arg] tGoal
@@ -262,31 +261,35 @@
P.ETuple es ->
do etys <- expectTuple (length es) tGoal
- es' <- zipWithM checkE es etys
+ let mkTGoal n t = WithSource t (TypeOfTupleField n)
+ es' <- zipWithM checkE es (zipWith mkTGoal [1..] etys)
return (ETuple es')
P.ERecord fs ->
do es <- expectRec fs tGoal
- es' <- traverse (uncurry checkE) es
+ let checkField f (e,t) = checkE e (WithSource t (TypeOfRecordField f))
+ es' <- traverseRecordMap checkField es
return (ERec es')
P.EUpd x fs -> checkRecUpd x fs tGoal
P.ESel e l ->
- do t <- newType (selSrc l) KType
- e' <- checkE e t
- f <- newHasGoal l t tGoal
+ do let src = selSrc l
+ t <- newType src KType
+ e' <- checkE e (WithSource t src)
+ f <- newHasGoal l t (twsType tGoal)
return (hasDoSelect f e')
P.EList [] ->
do (len,a) <- expectSeq tGoal
- expectFin 0 len
+ expectFin 0 (WithSource len LenOfSeq)
return (EList [] a)
P.EList es ->
do (len,a) <- expectSeq tGoal
- expectFin (length es) len
- es' <- mapM (`checkE` a) es
+ expectFin (length es) (WithSource len LenOfSeq)
+ let checkElem e = checkE e (WithSource a TypeOfSeqElement)
+ es' <- mapM checkElem es
return (EList es' a)
P.EFromTo t1 mbt2 t3 mety ->
@@ -322,22 +325,25 @@
do (mss', dss, ts) <- unzip3 `fmap` zipWithM inferCArm [ 1 .. ] mss
(len,a) <- expectSeq tGoal
- newGoals CtComprehension =<< unify len =<< smallest ts
+ inferred <- smallest ts
+ ctrs <- unify (WithSource len LenOfSeq) inferred
+ newGoals CtComprehension ctrs
ds <- combineMaps dss
- e' <- withMonoTypes ds (checkE e a)
+ e' <- withMonoTypes ds (checkE e (WithSource a TypeOfSeqElement))
return (EComp len a e' mss')
P.EAppT e fs -> appTys e (map uncheckedTypeArg fs) tGoal
P.EApp e1 e2 ->
- do t1 <- newType (TypeOfArg Nothing) KType
- e1' <- checkE e1 (tFun t1 tGoal)
- e2' <- checkE e2 t1
+ do let argSrc = TypeOfArg noArgDescr
+ t1 <- newType argSrc KType
+ e1' <- checkE e1 (WithSource (tFun t1 (twsType tGoal)) FunApp)
+ e2' <- checkE e2 (WithSource t1 argSrc)
return (EApp e1' e2')
P.EIf e1 e2 e3 ->
- do e1' <- checkE e1 tBit
+ do e1' <- checkE e1 (WithSource tBit TypeOfIfCondExpr)
e2' <- checkE e2 tGoal
e3' <- checkE e3 tGoal
return (EIf e1' e2' e3')
@@ -348,7 +354,7 @@
P.ETyped e t ->
do tSig <- checkTypeOfKind t KType
- e' <- checkE e tSig
+ e' <- checkE e (WithSource tSig TypeFromUserAnnotation)
checkHasType tSig tGoal
return e'
@@ -360,7 +366,7 @@
P.Named { name = Located l (packIdent "val")
, value = t }]) tGoal
- P.EFun ps e -> checkFun (text "anonymous function") ps e tGoal
+ P.EFun ps e -> checkFun Nothing ps e tGoal
P.ELocated e r -> inRange r (checkE e tGoal)
@@ -373,13 +379,8 @@
P.EParens e -> checkE e tGoal
-selSrc :: P.Selector -> TVarSource
-selSrc l = case l of
- RecordSel la _ -> TypeOfRecordField la
- TupleSel n _ -> TypeOfTupleField n
- ListSel _ _ -> TypeOfSeqElement
-
-checkRecUpd :: Maybe (P.Expr Name) -> [ P.UpdField Name ] -> Type -> InferM Expr
+checkRecUpd ::
+ Maybe (P.Expr Name) -> [ P.UpdField Name ] -> TypeWithSource -> InferM Expr
checkRecUpd mb fs tGoal =
case mb of
@@ -400,21 +401,24 @@
[l] ->
case how of
P.UpdSet ->
- do ft <- newType (selSrc s) KType
- v1 <- checkE v ft
- d <- newHasGoal s tGoal ft
+ do let src = selSrc s
+ ft <- newType src KType
+ v1 <- checkE v (WithSource ft src)
+ d <- newHasGoal s (twsType tGoal) ft
pure (hasDoSet d e v1)
P.UpdFun ->
- do ft <- newType (selSrc s) KType
- v1 <- checkE v (tFun ft ft)
- d <- newHasGoal s tGoal ft
+ do let src = selSrc s
+ ft <- newType src KType
+ v1 <- checkE v (WithSource (tFun ft ft) src)
+ -- XXX: ^ may be used a different src?
+ d <- newHasGoal s (twsType tGoal) ft
tmp <- newParamName (packIdent "rf")
let e' = EVar tmp
pure $ hasDoSet d e' (EApp v1 (hasDoSelect d e'))
`EWhere`
[ NonRecursive
Decl { dName = tmp
- , dSignature = tMono tGoal
+ , dSignature = tMono (twsType tGoal)
, dDefinition = DExpr e
, dPragmas = []
, dInfix = False
@@ -428,24 +432,24 @@
]
-expectSeq :: Type -> InferM (Type,Type)
-expectSeq ty =
+expectSeq :: TypeWithSource -> InferM (Type,Type)
+expectSeq tGoal@(WithSource ty src) =
case ty of
TUser _ _ ty' ->
- expectSeq ty'
+ expectSeq (WithSource ty' src)
TCon (TC TCSeq) [a,b] ->
return (a,b)
TVar _ ->
do tys@(a,b) <- genTys
- newGoals CtExactType =<< unify ty (tSeq a b)
+ newGoals CtExactType =<< unify tGoal (tSeq a b)
return tys
_ ->
do tys@(a,b) <- genTys
- recordError (TypeMismatch ty (tSeq a b))
+ recordError (TypeMismatch src ty (tSeq a b))
return tys
where
genTys =
@@ -454,36 +458,39 @@
return (a,b)
-expectTuple :: Int -> Type -> InferM [Type]
-expectTuple n ty =
+expectTuple :: Int -> TypeWithSource -> InferM [Type]
+expectTuple n tGoal@(WithSource ty src) =
case ty of
TUser _ _ ty' ->
- expectTuple n ty'
+ expectTuple n (WithSource ty' src)
TCon (TC (TCTuple n')) tys | n == n' ->
return tys
TVar _ ->
do tys <- genTys
- newGoals CtExactType =<< unify ty (tTuple tys)
+ newGoals CtExactType =<< unify tGoal (tTuple tys)
return tys
_ ->
do tys <- genTys
- recordError (TypeMismatch ty (tTuple tys))
+ recordError (TypeMismatch src ty (tTuple tys))
return tys
where
genTys =forM [ 0 .. n - 1 ] $ \ i -> newType (TypeOfTupleField i) KType
-expectRec :: RecordMap Ident (Range, a) -> Type -> InferM (RecordMap Ident (a, Type))
-expectRec fs ty =
+expectRec ::
+ RecordMap Ident (Range, a) ->
+ TypeWithSource ->
+ InferM (RecordMap Ident (a, Type))
+expectRec fs tGoal@(WithSource ty src) =
case ty of
TUser _ _ ty' ->
- expectRec fs ty'
+ expectRec fs (WithSource ty' src)
TRec ls
| Right r <- zipRecords (\_ (_rng,v) t -> (v,t)) fs ls -> pure r
@@ -496,27 +503,26 @@
fs
let tys = fmap snd res
case ty of
- TVar TVFree{} -> do ps <- unify ty (TRec tys)
+ TVar TVFree{} -> do ps <- unify tGoal (TRec tys)
newGoals CtExactType ps
- _ -> recordError (TypeMismatch ty (TRec tys))
+ _ -> recordError (TypeMismatch src ty (TRec tys))
return res
-expectFin :: Int -> Type -> InferM ()
-expectFin n ty =
+expectFin :: Int -> TypeWithSource -> InferM ()
+expectFin n tGoal@(WithSource ty src) =
case ty of
TUser _ _ ty' ->
- expectFin n ty'
+ expectFin n (WithSource ty' src)
TCon (TC (TCNum n')) [] | toInteger n == n' ->
return ()
- _ ->
- do newGoals CtExactType =<< unify ty (tNum n)
+ _ -> newGoals CtExactType =<< unify tGoal (tNum n)
-expectFun :: Int -> Type -> InferM ([Type],Type)
-expectFun = go []
+expectFun :: Maybe Name -> Int -> TypeWithSource -> InferM ([Type],Type)
+expectFun mbN n (WithSource ty0 src) = go [] n ty0
where
go tys arity ty
@@ -533,37 +539,38 @@
do args <- genArgs arity
res <- newType TypeOfRes KType
case ty of
- TVar TVFree{} -> do ps <- unify ty (foldr tFun res args)
- newGoals CtExactType ps
- _ -> recordError (TypeMismatch ty (foldr tFun res args))
+ TVar TVFree{} ->
+ do ps <- unify (WithSource ty src) (foldr tFun res args)
+ newGoals CtExactType ps
+ _ -> recordError (TypeMismatch src ty (foldr tFun res args))
return (reverse tys ++ args, res)
| otherwise =
return (reverse tys, ty)
genArgs arity = forM [ 1 .. arity ] $
- \ ix -> newType (TypeOfArg (Just ix)) KType
+ \ ix -> newType (TypeOfArg (ArgDescr mbN (Just ix))) KType
-checkHasType :: Type -> Type -> InferM ()
-checkHasType inferredType givenType =
- do ps <- unify givenType inferredType
+checkHasType :: Type -> TypeWithSource -> InferM ()
+checkHasType inferredType tGoal =
+ do ps <- unify tGoal inferredType
case ps of
[] -> return ()
_ -> newGoals CtExactType ps
-checkFun :: Doc -> [P.Pattern Name] -> P.Expr Name -> Type -> InferM Expr
+checkFun ::
+ Maybe Name -> [P.Pattern Name] -> P.Expr Name -> TypeWithSource -> InferM Expr
checkFun _ [] e tGoal = checkE e tGoal
-checkFun desc ps e tGoal =
+checkFun fun ps e tGoal =
inNewScope $
- do let descs = [ text "type of" <+> ordinal n <+> text "argument"
- <+> text "of" <+> desc | n <- [ 1 :: Int .. ] ]
+ do let descs = [ TypeOfArg (ArgDescr fun (Just n)) | n <- [ 1 :: Int .. ] ]
- (tys,tRes) <- expectFun (length ps) tGoal
- largs <- sequence (zipWith3 checkP descs ps tys)
+ (tys,tRes) <- expectFun fun (length ps) tGoal
+ largs <- sequence (zipWith checkP ps (zipWith WithSource tys descs))
let ds = Map.fromList [ (thing x, x { thing = t }) | (x,t) <- zip largs tys ]
- e1 <- withMonoTypes ds (checkE e tRes)
+ e1 <- withMonoTypes ds (checkE e (WithSource tRes TypeOfRes))
let args = [ (thing x, t) | (x,t) <- zip largs tys ]
return (foldr (\(x,t) b -> EAbs x t b) e1 args)
@@ -577,20 +584,20 @@
newGoals CtComprehension [ a =#= foldr1 tMin ts ]
return a
-checkP :: Doc -> P.Pattern Name -> Type -> InferM (Located Name)
-checkP desc p tGoal =
- do (x, t) <- inferP desc p
+checkP :: P.Pattern Name -> TypeWithSource -> InferM (Located Name)
+checkP p tGoal@(WithSource _ src) =
+ do (x, t) <- inferP p
ps <- unify tGoal (thing t)
- let rng = fromMaybe emptyRange $ getLoc p
- let mkErr = recordError . UnsolvedGoals Nothing . (:[])
- . Goal (CtPattern desc) rng
+ let rng = fromMaybe emptyRange (getLoc p)
+ let mkErr = recordError . UnsolvedGoals . (:[])
+ . Goal (CtPattern src) rng
mapM_ mkErr ps
return (Located (srcRange t) x)
{-| Infer the type of a pattern. Assumes that the pattern will be just
a variable. -}
-inferP :: Doc -> P.Pattern Name -> InferM (Name, Located Type)
-inferP desc pat =
+inferP :: P.Pattern Name -> InferM (Name, Located Type)
+inferP pat =
case pat of
P.PVar x0 ->
@@ -599,7 +606,7 @@
P.PTyped p t ->
do tSig <- checkTypeOfKind t KType
- ln <- checkP desc p tSig
+ ln <- checkP p (WithSource tSig TypeFromUserAnnotation)
return (thing ln, ln { thing = tSig })
_ -> tcPanic "inferP" [ "Unexpected pattern:", show pat ]
@@ -609,9 +616,9 @@
-- | 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 "a value bound by a generator in a comprehension") p
+ do (x,t) <- inferP p
n <- newType LenOfCompGen KNum
- e' <- checkE e (tSeq n (thing t))
+ e' <- checkE e (WithSource (tSeq n (thing t)) GeneratorOfListComp)
return (From x n (thing t) e', x, t, n)
inferMatch (P.MatchLet b)
@@ -645,7 +652,7 @@
-- | @inferBinds isTopLevel isRec binds@ performs inference for a
-- strongly-connected component of 'P.Bind's.
-- If any of the members of the recursive group are already marked
--- as monomorphic, then we don't do generalzation.
+-- as monomorphic, then we don't do generalization.
-- If @isTopLevel@ is true,
-- any bindings without type signatures will be generalized. If it is
-- false, and the mono-binds flag is enabled, no bindings without type
@@ -857,7 +864,9 @@
P.DPrim -> panic "checkMonoB" ["Primitive with no signature?"]
P.DExpr e ->
- do e1 <- checkFun (pp (thing (P.bName b))) (P.bParams b) e t
+ do let nm = thing (P.bName b)
+ let tGoal = WithSource t (DefinitionOf nm)
+ e1 <- checkFun (Just nm) (P.bParams b) e tGoal
let f = thing (P.bName b)
return Decl { dName = f
, dSignature = Forall [] [] t
@@ -887,12 +896,16 @@
inRangeMb (getLoc b) $
withTParams as $
do (e1,cs0) <- collectGoals $
- do e1 <- checkFun (pp (thing (P.bName b))) (P.bParams b) e0 t0
+ do let nm = thing (P.bName b)
+ tGoal = WithSource t0 (DefinitionOf nm)
+ e1 <- checkFun (Just nm) (P.bParams b) e0 tGoal
addGoals validSchema
() <- simplifyAllConstraints -- XXX: using `asmps` also?
return e1
- cs <- applySubstGoals cs0
+ asmps1 <- applySubstPreds asmps0
+ cs <- applySubstGoals cs0
+
let findKeep vs keep todo =
let stays (_,cvs) = not $ Set.null $ Set.intersection vs cvs
(yes,perhaps) = partition stays todo
@@ -901,12 +914,14 @@
[] -> (keep,map fst todo)
_ -> findKeep (Set.unions (vs:newVars)) (stayPs ++ keep) perhaps
- let (stay,leave) = findKeep (Set.fromList (map tpVar as)) []
+ let -- if a goal mentions any of these variables, we'll commit to
+ -- solving it now.
+ stickyVars = Set.fromList (map tpVar as) `Set.union` fvs asmps1
+ (stay,leave) = findKeep stickyVars []
[ (c, fvs c) | c <- cs ]
addGoals leave
- asmps1 <- applySubstPreds asmps0
su <- proveImplication (Just (thing (P.bName b))) as asmps1 stay
extendSubst su
diff --git a/src/Cryptol/TypeCheck/InferTypes.hs b/src/Cryptol/TypeCheck/InferTypes.hs
--- a/src/Cryptol/TypeCheck/InferTypes.hs
+++ b/src/Cryptol/TypeCheck/InferTypes.hs
@@ -176,12 +176,20 @@
| CtDefaulting -- ^ Just defaulting on the command line
| CtPartialTypeFun Name -- ^ Use of a partial type function.
| CtImprovement
- | CtPattern Doc -- ^ Constraints arising from type-checking patterns
+ | CtPattern TypeSource -- ^ Constraints arising from type-checking patterns
| CtModuleInstance ModName -- ^ Instantiating a parametrized module
deriving (Show, Generic, NFData)
+selSrc :: Selector -> TypeSource
+selSrc l = case l of
+ RecordSel la _ -> TypeOfRecordField la
+ TupleSel n _ -> TypeOfTupleField n
+ ListSel _ _ -> TypeOfSeqElement
+
+
+
instance TVars ConstraintSource where
apSubst su src =
case src of
@@ -300,7 +308,7 @@
CtDefaulting -> "defaulting"
CtPartialTypeFun f -> "use of partial type function" <+> pp f
CtImprovement -> "examination of collected goals"
- CtPattern desc -> "checking a pattern:" <+> desc
+ CtPattern ad -> "checking a pattern:" <+> pp ad
CtModuleInstance n -> "module instantiation" <+> pp n
ppUse :: Expr -> Doc
@@ -308,6 +316,7 @@
case expr of
EVar (isPrelPrim -> Just prim)
| prim == "number" -> "literal or demoted expression"
+ | prim == "fraction" -> "fractional literal"
| prim == "infFrom" -> "infinite enumeration"
| prim == "infFromThen" -> "infinite enumeration (with step)"
| prim == "fromTo" -> "finite enumeration"
diff --git a/src/Cryptol/TypeCheck/Instantiate.hs b/src/Cryptol/TypeCheck/Instantiate.hs
--- a/src/Cryptol/TypeCheck/Instantiate.hs
+++ b/src/Cryptol/TypeCheck/Instantiate.hs
@@ -50,12 +50,12 @@
-checkTyParam :: TVarSource -> Kind -> MaybeCheckedType -> InferM Type
+checkTyParam :: TypeSource -> Kind -> MaybeCheckedType -> InferM Type
checkTyParam src k mb =
case mb of
Checked t
| k == k' -> pure t
- | otherwise -> do recordError (KindMismatch k k')
+ | otherwise -> do recordError (KindMismatch (Just src) k k')
newType src k
where k' = kindOf t
Unchecked t -> checkType t (Just k)
@@ -203,5 +203,7 @@
checkInst :: (TParam, Type) -> InferM [Prop]
checkInst (tp, ty)
| Set.notMember tp bounds = return []
- | otherwise = unify (TVar (tpVar tp)) ty
+ | otherwise = let a = tpVar tp
+ src = tvarDesc (tvInfo a)
+ in unify (WithSource (TVar a) src) ty
diff --git a/src/Cryptol/TypeCheck/Kind.hs b/src/Cryptol/TypeCheck/Kind.hs
--- a/src/Cryptol/TypeCheck/Kind.hs
+++ b/src/Cryptol/TypeCheck/Kind.hs
@@ -36,6 +36,7 @@
import Data.List(sortBy,groupBy)
import Data.Maybe(fromMaybe)
import Data.Function(on)
+import Data.Text (Text)
import Control.Monad(unless,forM,when)
@@ -66,7 +67,7 @@
-- | Check a module parameter declarations. Nothing much to check,
-- we just translate from one syntax to another.
-checkParameterType :: P.ParameterType Name -> Maybe String -> InferM ModTParam
+checkParameterType :: P.ParameterType Name -> Maybe Text -> InferM ModTParam
checkParameterType a mbDoc =
do let k = cvtK (P.ptKind a)
n = thing (P.ptName a)
@@ -75,7 +76,7 @@
-- | Check a type-synonym declaration.
-checkTySyn :: P.TySyn Name -> Maybe String -> InferM TySyn
+checkTySyn :: P.TySyn Name -> Maybe Text -> InferM TySyn
checkTySyn (P.TySyn x _ as t) mbD =
do ((as1,t1),gs) <- collectGoals
$ inRange (srcRange x)
@@ -91,7 +92,7 @@
}
-- | Check a constraint-synonym declaration.
-checkPropSyn :: P.PropSyn Name -> Maybe String -> InferM TySyn
+checkPropSyn :: P.PropSyn Name -> Maybe Text -> InferM TySyn
checkPropSyn (P.PropSyn x _ as ps) mbD =
do ((as1,t1),gs) <- collectGoals
$ inRange (srcRange x)
@@ -108,7 +109,7 @@
-- | Check a newtype declaration.
-- XXX: Do something with constraints.
-checkNewtype :: P.Newtype Name -> Maybe String -> InferM Newtype
+checkNewtype :: P.Newtype Name -> Maybe Text -> InferM Newtype
checkNewtype (P.Newtype x as fs) mbD =
do ((as1,fs1),gs) <- collectGoals $
inRange (srcRange x) $
@@ -128,7 +129,7 @@
, ntDoc = mbD
}
-checkPrimType :: P.PrimType Name -> Maybe String -> InferM AbstractType
+checkPrimType :: P.PrimType Name -> Maybe Text -> InferM AbstractType
checkPrimType p mbD =
do let (as,cs) = P.primTCts p
(as',cs') <- withTParams NoWildCards (TPOther . Just) as $
@@ -302,7 +303,7 @@
do let ty = tpVar (mtpParam a)
(ts1,k1) <- appTy ts (kindOf ty)
case k of
- Just ks | ks /= k1 -> kRecordError $ KindMismatch ks k1
+ Just ks | ks /= k1 -> kRecordError $ KindMismatch Nothing ks k1
_ -> return ()
unless (null ts1) $
@@ -405,7 +406,7 @@
-> Kind -- ^ Inferred kind
-> KindM Type -- ^ A type consistent with expectations.
checkKind _ (Just k1) k2
- | k1 /= k2 = do kRecordError (KindMismatch k1 k2)
+ | k1 /= k2 = do kRecordError (KindMismatch Nothing k1 k2)
kNewType TypeErrorPlaceHolder k1
checkKind t _ _ = return t
diff --git a/src/Cryptol/TypeCheck/Monad.hs b/src/Cryptol/TypeCheck/Monad.hs
--- a/src/Cryptol/TypeCheck/Monad.hs
+++ b/src/Cryptol/TypeCheck/Monad.hs
@@ -6,6 +6,7 @@
-- Stability : provisional
-- Portability : portable
{-# LANGUAGE Safe #-}
+{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE RecordWildCards #-}
@@ -26,11 +27,13 @@
import Cryptol.TypeCheck.Subst
import Cryptol.TypeCheck.Unify(mgu, runResult, UnificationError(..))
import Cryptol.TypeCheck.InferTypes
-import Cryptol.TypeCheck.Error(Warning(..),Error(..),cleanupErrors)
-import Cryptol.TypeCheck.PP (brackets, commaSep)
+import Cryptol.TypeCheck.Error( Warning(..),Error(..)
+ , cleanupErrors, computeFreeVarNames
+ )
import qualified Cryptol.TypeCheck.SimpleSolver as Simple
import qualified Cryptol.TypeCheck.Solver.SMT as SMT
-import Cryptol.Utils.PP(pp, (<+>), text, quotes)
+import Cryptol.TypeCheck.PP(NameMap)
+import Cryptol.Utils.PP(pp, (<+>), text,commaSep,brackets)
import Cryptol.Utils.Ident(Ident)
import Cryptol.Utils.Panic(panic)
@@ -48,7 +51,6 @@
import Data.IORef
-
import GHC.Generics (Generic)
import Control.DeepSeq
@@ -98,10 +100,10 @@
-- | The results of type inference.
data InferOutput a
- = InferFailed [(Range,Warning)] [(Range,Error)]
+ = InferFailed NameMap [(Range,Warning)] [(Range,Error)]
-- ^ We found some errors
- | InferOK [(Range,Warning)] NameSeeds Supply a
+ | InferOK NameMap [(Range,Warning)] NameSeeds Supply a
-- ^ Type inference was successful.
@@ -113,7 +115,7 @@
runInferM :: TVars a => InferInput -> InferM a -> IO (InferOutput a)
runInferM info (IM m) = SMT.withSolver (inpSolverConfig info) $ \solver ->
- do coutner <- newIORef 0
+ do counter <- newIORef 0
rec ro <- return RO { iRange = inpRange info
, iVars = Map.map ExtVar (inpVars info)
, iTVars = []
@@ -128,7 +130,7 @@
, iMonoBinds = inpMonoBinds info
, iSolver = solver
, iPrimNames = inpPrimNames info
- , iSolveCounter = coutner
+ , iSolveCounter = counter
}
(result, finalRW) <- runStateT rw
@@ -136,27 +138,32 @@
let theSu = iSubst finalRW
defSu = defaultingSubst theSu
- warns = [(r,apSubst theSu w) | (r,w) <- iWarnings finalRW ]
+ warns = fmap' (fmap' (apSubst theSu)) (iWarnings finalRW)
case iErrors finalRW of
[] ->
case (iCts finalRW, iHasCts finalRW) of
(cts,[])
- | nullGoals cts
- -> return $ InferOK warns
+ | nullGoals cts -> inferOk warns
(iNameSeeds finalRW)
(iSupply finalRW)
(apSubst defSu result)
- (cts,has) -> return $ InferFailed warns
- $ cleanupErrors
+ (cts,has) ->
+ inferFailed warns
[ ( goalRange g
- , UnsolvedGoals Nothing [apSubst theSu g]
+ , UnsolvedGoals [apSubst theSu g]
) | g <- fromGoals cts ++ map hasGoal has
]
- errs -> return $ InferFailed warns
- $ cleanupErrors [(r,apSubst theSu e) | (r,e) <- errs]
+ errs -> inferFailed warns [(r,apSubst theSu e) | (r,e) <- errs]
+
where
+ inferOk ws a b c = pure (InferOK (computeFreeVarNames ws []) ws a b c)
+ inferFailed ws es =
+ let es1 = cleanupErrors es
+ in pure (InferFailed (computeFreeVarNames ws es1) ws es1)
+
+
mkExternal x = (IsExternal, x)
rw = RW { iErrors = []
, iWarnings = []
@@ -390,8 +397,8 @@
simpGoal :: Goal -> InferM [Goal]
simpGoal g =
case Simple.simplify mempty (goal g) of
- p | Just (e,t) <- tIsError p ->
- do recordError $ UnsolvedGoals (Just e) [g { goal = t }]
+ p | Just t <- tIsError p ->
+ do recordError $ UnsolvableGoals [g { goal = t }]
return []
| ps <- pSplitAnd p -> return [ g { goal = pr } | pr <- ps ]
@@ -453,12 +460,12 @@
in (x, s { seedGoal = x + 1})
-- | Generate a new free type variable.
-newTVar :: TVarSource -> Kind -> InferM TVar
+newTVar :: TypeSource -> Kind -> InferM TVar
newTVar src k = newTVar' src Set.empty k
-- | Generate a new free type variable that depends on these additional
-- type parameters.
-newTVar' :: TVarSource -> Set TParam -> Kind -> InferM TVar
+newTVar' :: TypeSource -> Set TParam -> Kind -> InferM TVar
newTVar' src extraBound k =
do r <- curRange
bound <- getBoundInScope
@@ -485,7 +492,7 @@
-- | Generate an unknown type. The doc is a note about what is this type about.
-newType :: TVarSource -> Kind -> InferM Type
+newType :: TypeSource -> Kind -> InferM Type
newType src k = TVar `fmap` newTVar src k
@@ -494,8 +501,8 @@
-- | Record that the two types should be syntactically equal.
-unify :: Type -> Type -> InferM [Prop]
-unify t1 t2 =
+unify :: TypeWithSource -> Type -> InferM [Prop]
+unify (WithSource t1 src) t2 =
do t1' <- applySubst t1
t2' <- applySubst t2
let ((su1, ps), errs) = runResult (mgu t1' t2')
@@ -503,12 +510,12 @@
let toError :: UnificationError -> Error
toError err =
case err of
- UniTypeLenMismatch _ _ -> TypeMismatch t1' t2'
- UniTypeMismatch s1 s2 -> TypeMismatch s1 s2
- UniKindMismatch k1 k2 -> KindMismatch k1 k2
- UniRecursive x t -> RecursiveType (TVar x) t
- UniNonPolyDepends x vs -> TypeVariableEscaped (TVar x) vs
- UniNonPoly x t -> NotForAll x t
+ UniTypeLenMismatch _ _ -> TypeMismatch src t1' t2'
+ UniTypeMismatch s1 s2 -> TypeMismatch src s1 s2
+ UniKindMismatch k1 k2 -> KindMismatch (Just src) k1 k2
+ UniRecursive x t -> RecursiveType src (TVar x) t
+ UniNonPolyDepends x vs -> TypeVariableEscaped src (TVar x) vs
+ UniNonPoly x t -> NotForAll src x t
case errs of
[] -> return ps
_ -> do mapM_ (recordError . toError) errs
@@ -636,9 +643,7 @@
Nothing ->
case scopes of
[] ->
- do recordError $ ErrorMsg
- $ text "Undefined type" <+> quotes (pp x)
- <+> text (show x)
+ do recordError (UndefinedExistVar x)
newType TypeErrorPlaceHolder k
sc : more ->
@@ -709,10 +714,7 @@
case shadowed of
Nothing -> return ()
Just that ->
- recordError $ ErrorMsg $
- text "Type" <+> text this <+> quotes (pp new) <+>
- text "shadows an existing" <+>
- text that <+> text "with the same name."
+ recordError (TypeShadowing this new that)
@@ -891,7 +893,7 @@
-- NOTE: We do not simplify these, because we end up with bottom.
-- See `Kind.hs`
-- XXX: Perhaps we can avoid the recursion?
-kNewType :: TVarSource -> Kind -> KindM Type
+kNewType :: TypeSource -> Kind -> KindM Type
kNewType src k =
do tps <- KM $ do vs <- asks lazyTParams
return $ Set.fromList (Map.elems vs)
diff --git a/src/Cryptol/TypeCheck/Parseable.hs b/src/Cryptol/TypeCheck/Parseable.hs
--- a/src/Cryptol/TypeCheck/Parseable.hs
+++ b/src/Cryptol/TypeCheck/Parseable.hs
@@ -35,7 +35,7 @@
showParseable (ETuple es) = parens (text "ETuple" <+> showParseable es)
showParseable (ERec ides) = parens (text "ERec" <+> showParseable (canonicalFields ides))
showParseable (ESel e s) = parens (text "ESel" <+> showParseable e <+> showParseable s)
- showParseable (ESet e s v) = parens (text "ESet" <+>
+ showParseable (ESet _ty e s v) = parens (text "ESet" <+>
showParseable e <+> showParseable s
<+> showParseable v)
showParseable (EIf c t f) = parens (text "EIf" <+> showParseable c $$ showParseable t $$ showParseable f)
diff --git a/src/Cryptol/TypeCheck/Sanity.hs b/src/Cryptol/TypeCheck/Sanity.hs
--- a/src/Cryptol/TypeCheck/Sanity.hs
+++ b/src/Cryptol/TypeCheck/Sanity.hs
@@ -159,13 +159,14 @@
do fs1 <- traverse exprType fs
return $ tMono $ TRec fs1
- ESet e x v -> do ty <- exprType e
- expe <- checkHas ty x
- has <- exprType v
- unless (same expe has) $
- reportError $
- TypeMismatch "ESet" (tMono expe) (tMono has)
- return (tMono ty)
+ ESet _ e x v ->
+ do ty <- exprType e
+ expe <- checkHas ty x
+ has <- exprType v
+ unless (same expe has) $
+ reportError $
+ TypeMismatch "ESet" (tMono expe) (tMono has)
+ return (tMono ty)
ESel e sel -> do ty <- exprType e
ty1 <- checkHas ty sel
diff --git a/src/Cryptol/TypeCheck/SimpType.hs b/src/Cryptol/TypeCheck/SimpType.hs
--- a/src/Cryptol/TypeCheck/SimpType.hs
+++ b/src/Cryptol/TypeCheck/SimpType.hs
@@ -108,7 +108,7 @@
tSub :: Type -> Type -> Type
tSub x y
| Just t <- tOp TCSub (op2 nSub) [x,y] = t
- | tIsInf y = tError (tf2 TCSub x y) "cannot subtract `inf`."
+ | tIsInf y = tError (tf2 TCSub x y)
| Just 0 <- yNum = x
| Just k <- yNum
, TCon (TF TCAdd) [a,b] <- tNoUser x
@@ -165,34 +165,34 @@
tDiv :: Type -> Type -> Type
tDiv x y
| Just t <- tOp TCDiv (op2 nDiv) [x,y] = t
- | tIsInf x = bad "Cannot divide `inf`"
- | Just 0 <- tIsNum y = bad "Cannot divide by 0"
+ | tIsInf x = bad
+ | Just 0 <- tIsNum y = bad
| otherwise = tf2 TCDiv x y
where bad = tError (tf2 TCDiv x y)
tMod :: Type -> Type -> Type
tMod x y
| Just t <- tOp TCMod (op2 nMod) [x,y] = t
- | tIsInf x = bad "Cannot compute remainder of `inf`"
- | Just 0 <- tIsNum y = bad "Cannot divide modulo 0"
+ | tIsInf x = bad
+ | Just 0 <- tIsNum y = bad
| otherwise = tf2 TCMod x y
where bad = tError (tf2 TCMod x y)
tCeilDiv :: Type -> Type -> Type
tCeilDiv x y
| Just t <- tOp TCCeilDiv (op2 nCeilDiv) [x,y] = t
- | tIsInf x = bad "CeilDiv of `inf`"
- | tIsInf y = bad "CeilDiv by `inf`"
- | Just 0 <- tIsNum y = bad "CeilDiv by 0"
+ | tIsInf x = bad
+ | tIsInf y = bad
+ | Just 0 <- tIsNum y = bad
| otherwise = tf2 TCCeilDiv x y
where bad = tError (tf2 TCCeilDiv x y)
tCeilMod :: Type -> Type -> Type
tCeilMod x y
| Just t <- tOp TCCeilMod (op2 nCeilMod) [x,y] = t
- | tIsInf x = bad "CeilMod of `inf`"
- | tIsInf y = bad "CeilMod by `inf`"
- | Just 0 <- tIsNum x = bad "CeilMod to size 0"
+ | tIsInf x = bad
+ | tIsInf y = bad
+ | Just 0 <- tIsNum x = bad
| otherwise = tf2 TCCeilMod x y
where bad = tError (tf2 TCCeilMod x y)
@@ -304,12 +304,15 @@
op3 f ~[x,y,z] = f x y z
-- | Common checks: check for error, or simple full evaluation.
+-- We assume that input kinds and the result kind are the same (i.e., Nat)
tOp :: TFun -> ([Nat'] -> Maybe Nat') -> [Type] -> Maybe Type
tOp tf f ts
- | Just (TCErrorMessage e,t) <- msum (map tIsError ts) = Just (tError t e)
+ | Just t <- msum (map tIsError ts) = Just (tError t)
+ -- assumes result kind the same as input kind
+
| Just xs <- mapM tIsNat' ts =
Just $ case f xs of
- Nothing -> tError (TCon (TF tf) (map tNat' xs)) "invalid type"
+ Nothing -> tError (TCon (TF tf) (map tNat' xs))
Just n -> tNat' n
| otherwise = Nothing
diff --git a/src/Cryptol/TypeCheck/SimpleSolver.hs b/src/Cryptol/TypeCheck/SimpleSolver.hs
--- a/src/Cryptol/TypeCheck/SimpleSolver.hs
+++ b/src/Cryptol/TypeCheck/SimpleSolver.hs
@@ -5,7 +5,7 @@
( tSub, tMul, tDiv, tMod, tExp, tMin, 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.Numeric(cryIsEqual, cryIsNotEqual, cryIsGeq, cryIsPrime)
import Cryptol.TypeCheck.Solver.Class
( solveZeroInst, solveLogicInst, solveRingInst
, solveIntegralInst, solveFieldInst, solveRoundInst
@@ -21,8 +21,10 @@
simplify :: Ctxt -> Prop -> Prop
simplify ctxt p =
case simplifyStep ctxt p of
- Unsolvable (TCErrorMessage e) -> tError p e
- Unsolved -> dbg msg p
+ Unsolvable -> case tIsError p of
+ Nothing -> tError p
+ _ -> p
+ Unsolved -> dbg msg p
where msg = text "unsolved:" <+> pp p
SolvedIf ps -> dbg msg $ pAnd (map (simplify ctxt) ps)
where msg = case ps of
@@ -56,6 +58,7 @@
TCon (PC PFLiteral) [t1,t2,t3,t4] -> solveFLiteralInst t1 t2 t3 t4
TCon (PC PValidFloat) [t1,t2] -> solveValidFloat t1 t2
+ TCon (PC PPrime) [ty] -> cryIsPrime ctxt ty
TCon (PC PFin) [ty] -> cryIsFinType ctxt ty
TCon (PC PEqual) [t1,t2] -> cryIsEqual ctxt t1 t2
diff --git a/src/Cryptol/TypeCheck/Solve.hs b/src/Cryptol/TypeCheck/Solve.hs
--- a/src/Cryptol/TypeCheck/Solve.hs
+++ b/src/Cryptol/TypeCheck/Solve.hs
@@ -37,18 +37,18 @@
import Control.Applicative ((<|>))
import Control.Monad(mzero)
+import Data.Map (Map)
import qualified Data.Map as Map
import Data.Set ( Set )
import qualified Data.Set as Set
import Data.List(partition)
-import Data.Maybe(listToMaybe)
+import Data.Maybe(listToMaybe,fromMaybe)
-quickSolverIO :: Ctxt -> [Goal] ->
- IO (Either (TCErrorMessage,Goal) (Subst,[Goal]))
+quickSolverIO :: Ctxt -> [Goal] -> IO (Either Error (Subst,[Goal]))
quickSolverIO _ [] = return (Right (emptySubst, []))
quickSolverIO ctxt gs =
case quickSolver ctxt gs of
@@ -73,7 +73,7 @@
quickSolver :: Ctxt -- ^ Facts we can know
-> [Goal] -- ^ Need to solve these
- -> Either (TCErrorMessage,Goal) (Subst,[Goal])
+ -> Either Error (Subst,[Goal])
-- ^ Left: contradicting goals,
-- Right: inferred types, unsolved goals.
quickSolver ctxt gs0 = go emptySubst [] gs0
@@ -81,32 +81,70 @@
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)
+ case matchMaybe (findImprovement noIncompatible unsolved) of
+ Nothing -> Right (su,unsolved)
+ Just imp ->
+ case imp of
+ Right (newSu, subs) ->
+ go (newSu @@ su) [] (subs ++ apSubst newSu unsolved)
+ Left err -> Left err
go su unsolved (g : gs)
| Set.member (goal g) (saturatedAsmps ctxt) = go su unsolved gs
go su unsolved (g : gs) =
case Simplify.simplifyStep ctxt (goal g) of
- Unsolvable e -> Left (e,g)
+ Unsolvable -> Left (UnsolvableGoals [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) =
+ findImprovement inc [] =
+ do let bad = Map.intersectionWith (,) (integralTVars inc) (fracTVars inc)
+ case Map.minView bad of
+ Just ((g1,g2),_) -> pure $ Left $ UnsolvableGoals [g1,g2]
+ Nothing -> mzero
+
+ findImprovement inc (g : gs) =
do (su,ps) <- improveProp False ctxt (goal g)
- return (su, [ g { goal = p } | p <- ps ])
- <|> findImprovement gs
+ return (Right (su, [ g { goal = p } | p <- ps ]))
+ <|>
+ findImprovement (addIncompatible g inc) gs
+--------------------------------------------------------------------------------
+-- Look for type variable with incompatible constraints
+data Incompatible = Incompatible
+ { integralTVars :: Map TVar Goal -- ^ Integral a
+ , fracTVars :: Map TVar Goal -- ^ Field a or FLiteral
+ }
+noIncompatible :: Incompatible
+noIncompatible = Incompatible
+ { integralTVars = Map.empty
+ , fracTVars = Map.empty
+ }
+addIncompatible :: Goal -> Incompatible -> Incompatible
+addIncompatible g i =
+ fromMaybe i $
+ do tv <- tIsVar =<< pIsIntegral (goal g)
+ pure i { integralTVars = Map.insert tv g (integralTVars i) }
+ <|>
+ do tv <- tIsVar =<< pIsField (goal g)
+ pure i { fracTVars = Map.insert tv g (fracTVars i) }
+ <|>
+ do (_,_,_,t) <- pIsFLiteral (goal g)
+ tv <- tIsVar t
+ pure i { fracTVars = Map.insert tv g (fracTVars i) }
+
+
+
+
+
--------------------------------------------------------------------------------
@@ -118,7 +156,7 @@
case mb of
Nothing -> return Nothing
Just numBinds -> return $
- do optss <- mapM tryDefVar otherVs
+ do let optss = map tryDefVar otherVs
su <- listToMaybe
[ binds | nonSu <- sequence optss
, let binds = nonSu ++ numBinds
@@ -144,17 +182,23 @@
fLitGoals = flitDefaultCandidates gSet
- tryDefVar a =
- do ((_,t),_) <- Map.lookup (TVBound a) fLitGoals
- pure [(a, t)]
- <|>
- do let a' = TVBound a
- gt <- Map.lookup a' (literalGoals gSet)
- let ok p = not (Set.member a' (fvs p))
- return [ (a,t) | t <- [ tInteger, tBit, tWord (tWidth (goal gt)) ]
- , ok t ]
+ tryDefVar :: TParam -> [(TParam, Type)]
+ tryDefVar a
+ -- REPL defaulting for floating-point literals
+ | Just m <- Map.lookup (TVBound a) fLitGoals
+ = case m of
+ Just ((_,t),_) -> [(a,t)]
+ Nothing -> []
+ -- REPL defaulting for integer literals
+ | Just gt <- Map.lookup (TVBound a) (literalGoals gSet)
+ = let ok p = not (Set.member (TVBound a) (fvs p)) in
+ [ (a,t) | t <- [ tInteger, tWord (tWidth (goal gt)) ]
+ , ok t ]
+ -- REPL defaulting for variables unconstrained by a literal constraint
+ | otherwise = [ (a,t) | t <- [tInteger, tRational, tBit] ]
+
appExpr tys = foldl (\e1 _ -> EProofApp e1)
(foldl ETApp expr tys)
(sProps sch)
@@ -185,7 +229,7 @@
[] -> return ()
_ ->
case quickSolver mempty gs of
- Left (msg,badG) -> recordError (UnsolvedGoals (Just msg) [badG])
+ Left err -> recordError err
Right (su,gs1) ->
do extendSubst su
addGoals gs1
@@ -255,7 +299,7 @@
do let ctxt = buildSolverCtxt asmps
res <- quickSolverIO ctxt gs
case res of
- Left (msg,bad) -> return (Left [UnsolvedGoals (Just msg) [bad]], emptySubst)
+ Left erro -> return (Left [erro], emptySubst)
Right (su,[]) -> return (Right [], su)
Right (su,gs1) ->
do gs2 <- proveImp s asmps gs1
@@ -319,10 +363,12 @@
buildSolverCtxt :: [Prop] -> Ctxt
buildSolverCtxt ps0 =
- SolverCtxt
- { intervals = assumptionIntervals mempty ps0
- , saturatedAsmps = saturateProps mempty ps0
- }
+ let ps = saturateProps mempty ps0
+ ivals = assumptionIntervals mempty (Set.toList ps)
+ in SolverCtxt
+ { intervals = ivals
+ , saturatedAsmps = ps
+ }
where
saturateProps gs [] = gs
diff --git a/src/Cryptol/TypeCheck/Solver/Class.hs b/src/Cryptol/TypeCheck/Solver/Class.hs
--- a/src/Cryptol/TypeCheck/Solver/Class.hs
+++ b/src/Cryptol/TypeCheck/Solver/Class.hs
@@ -8,7 +8,7 @@
--
-- Solving class constraints.
-{-# LANGUAGE PatternGuards, OverloadedStrings #-}
+{-# LANGUAGE PatternGuards #-}
module Cryptol.TypeCheck.Solver.Class
( solveZeroInst
, solveLogicInst
@@ -29,7 +29,6 @@
import Cryptol.TypeCheck.Type
import Cryptol.TypeCheck.SimpType (tAdd,tWidth)
import Cryptol.TypeCheck.Solver.Types
-import Cryptol.TypeCheck.PP
import Cryptol.Utils.RecordMap
{- | This places constraints on the floating point numbers that
@@ -69,7 +68,7 @@
solveZeroInst ty = case tNoUser ty of
-- Zero Error -> fails
- TCon (TError _ e) _ -> Unsolvable e
+ TCon (TError {}) _ -> Unsolvable
-- Zero Bit
TCon (TC TCBit) [] -> SolvedIf []
@@ -107,30 +106,22 @@
solveLogicInst ty = case tNoUser ty of
-- Logic Error -> fails
- TCon (TError _ e) _ -> Unsolvable e
+ TCon (TError {}) _ -> Unsolvable
-- Logic Bit
TCon (TC TCBit) [] -> SolvedIf []
-- Logic Integer fails
- TCon (TC TCInteger) [] ->
- Unsolvable $
- TCErrorMessage "Type 'Integer' does not support logical operations."
+ TCon (TC TCInteger) [] -> Unsolvable
-- Logic (Z n) fails
- TCon (TC TCIntMod) [_] ->
- Unsolvable $
- TCErrorMessage "Type 'Z' does not support logical operations."
+ TCon (TC TCIntMod) [_] -> Unsolvable
-- Logic Rational fails
- TCon (TC TCRational) [] ->
- Unsolvable $
- TCErrorMessage "Type 'Rational' does not support logical operations."
+ TCon (TC TCRational) [] -> Unsolvable
-- Logic (Float e p) fails
- TCon (TC TCFloat) [_, _] ->
- Unsolvable $
- TCErrorMessage "Type 'Float' does not support logical operations."
+ TCon (TC TCFloat) [_, _] -> Unsolvable
-- Logic a => Logic [n]a
TCon (TC TCSeq) [_, a] -> SolvedIf [ pLogic a ]
@@ -146,12 +137,13 @@
_ -> Unsolved
+
-- | Solve a Ring constraint by instance, if possible.
solveRingInst :: Type -> Solved
solveRingInst ty = case tNoUser ty of
-- Ring Error -> fails
- TCon (TError _ e) _ -> Unsolvable e
+ TCon (TError {}) _ -> Unsolvable
-- Ring [n]e
TCon (TC TCSeq) [n, e] -> solveRingSeq n e
@@ -163,8 +155,7 @@
TCon (TC (TCTuple _)) es -> SolvedIf [ pRing e | e <- es ]
-- Ring Bit fails
- TCon (TC TCBit) [] ->
- Unsolvable $ TCErrorMessage "Type 'Bit' does not support ring operations."
+ TCon (TC TCBit) [] -> Unsolvable
-- Ring Integer
TCon (TC TCInteger) [] -> SolvedIf []
@@ -209,11 +200,10 @@
solveIntegralInst ty = case tNoUser ty of
-- Integral Error -> fails
- TCon (TError _ e) _ -> Unsolvable e
+ TCon (TError {}) _ -> Unsolvable
-- Integral Bit fails
- TCon (TC TCBit) [] ->
- Unsolvable $ TCErrorMessage "Type 'Bit' is not an integral type."
+ TCon (TC TCBit) [] -> Unsolvable
-- Integral Integer
TCon (TC TCInteger) [] -> SolvedIf []
@@ -223,13 +213,11 @@
case tNoUser elTy of
TCon (TC TCBit) [] -> SolvedIf [ pFin n ]
TVar _ -> Unsolved
- _ -> Unsolvable $ TCErrorMessage $ show
- $ "Type" <+> quotes (pp ty) <+> "is not an integral type."
+ _ -> Unsolvable
TVar _ -> Unsolved
- _ -> Unsolvable $ TCErrorMessage $ show
- $ "Type" <+> quotes (pp ty) <+> "is not an integral type."
+ _ -> Unsolvable
-- | Solve a Field constraint by instance, if possible.
@@ -237,17 +225,13 @@
solveFieldInst ty = case tNoUser ty of
-- Field Error -> fails
- TCon (TError _ e) _ -> Unsolvable e
+ TCon (TError {}) _ -> Unsolvable
-- Field Bit fails
- TCon (TC TCBit) [] ->
- Unsolvable $
- TCErrorMessage "Type 'Bit' does not support field operations."
+ TCon (TC TCBit) [] -> Unsolvable
-- Field Integer fails
- TCon (TC TCInteger) [] ->
- Unsolvable $
- TCErrorMessage "Type 'Integer' does not support field operations."
+ TCon (TC TCInteger) [] -> Unsolvable
-- Field Rational
TCon (TC TCRational) [] -> SolvedIf []
@@ -257,31 +241,20 @@
-- Field Real
- -- Field (Z n) fails for now (to be added later with a 'prime n' requirement)
- TCon (TC TCIntMod) [_] ->
- Unsolvable $
- TCErrorMessage "Type 'Z' does not support field operations."
--- TCon (TC TCIntMod) [n] -> SolvedIf [ pFin n, n >== tOne, pPrime n ]
+ -- Field (Z n)
+ TCon (TC TCIntMod) [n] -> SolvedIf [ pPrime n ]
-- Field ([n]a) fails
- TCon (TC TCSeq) [_, _] ->
- Unsolvable $
- TCErrorMessage "Sequence types do not support field operations."
+ TCon (TC TCSeq) [_, _] -> Unsolvable
-- Field (a -> b) fails
- TCon (TC TCFun) [_, _] ->
- Unsolvable $
- TCErrorMessage "Function types do not support field operations."
+ TCon (TC TCFun) [_, _] -> Unsolvable
-- Field (a, b, ...) fails
- TCon (TC (TCTuple _)) _ ->
- Unsolvable $
- TCErrorMessage "Tuple types do not support field operations."
+ TCon (TC (TCTuple _)) _ -> Unsolvable
-- Field {x : a, y : b, ...} fails
- TRec _ ->
- Unsolvable $
- TCErrorMessage "Record types do not support field operations."
+ TRec _ -> Unsolvable
_ -> Unsolved
@@ -291,22 +264,16 @@
solveRoundInst ty = case tNoUser ty of
-- Round Error -> fails
- TCon (TError _ e) _ -> Unsolvable e
+ TCon (TError {}) _ -> Unsolvable
-- Round Bit fails
- TCon (TC TCBit) [] ->
- Unsolvable $
- TCErrorMessage "Type 'Bit' does not support rounding operations."
+ TCon (TC TCBit) [] -> Unsolvable
-- Round Integer fails
- TCon (TC TCInteger) [] ->
- Unsolvable $
- TCErrorMessage "Type 'Integer' does not support rounding operations."
+ TCon (TC TCInteger) [] -> Unsolvable
-- Round (Z n) fails
- TCon (TC TCIntMod) [_] ->
- Unsolvable $
- TCErrorMessage "Type 'Z' does not support rounding operations."
+ TCon (TC TCIntMod) [_] -> Unsolvable
-- Round Rational
TCon (TC TCRational) [] -> SolvedIf []
@@ -317,24 +284,16 @@
-- Round Real
-- Round ([n]a) fails
- TCon (TC TCSeq) [_, _] ->
- Unsolvable $
- TCErrorMessage "Sequence types do not support rounding operations."
+ TCon (TC TCSeq) [_, _] -> Unsolvable
-- Round (a -> b) fails
- TCon (TC TCFun) [_, _] ->
- Unsolvable $
- TCErrorMessage "Function types do not support rounding operations."
+ TCon (TC TCFun) [_, _] -> Unsolvable
-- Round (a, b, ...) fails
- TCon (TC (TCTuple _)) _ ->
- Unsolvable $
- TCErrorMessage "Tuple types do not support rounding operations."
+ TCon (TC (TCTuple _)) _ -> Unsolvable
-- Round {x : a, y : b, ...} fails
- TRec _ ->
- Unsolvable $
- TCErrorMessage "Record types do not support rounding operations."
+ TRec _ -> Unsolvable
_ -> Unsolved
@@ -345,7 +304,7 @@
solveEqInst ty = case tNoUser ty of
-- Eq Error -> fails
- TCon (TError _ e) _ -> Unsolvable e
+ TCon (TError {}) _ -> Unsolvable
-- eq Bit
TCon (TC TCBit) [] -> SolvedIf []
@@ -369,8 +328,7 @@
TCon (TC (TCTuple _)) es -> SolvedIf (map pEq es)
-- Eq (a -> b) fails
- TCon (TC TCFun) [_,_] ->
- Unsolvable $ TCErrorMessage "Function types do not support comparisons."
+ TCon (TC TCFun) [_,_] -> Unsolvable
-- (Eq a, Eq b) => Eq { x:a, y:b }
TRec fs -> SolvedIf [ pEq e | e <- recordElements fs ]
@@ -383,7 +341,7 @@
solveCmpInst ty = case tNoUser ty of
-- Cmp Error -> fails
- TCon (TError _ e) _ -> Unsolvable e
+ TCon (TError {}) _ -> Unsolvable
-- Cmp Bit
TCon (TC TCBit) [] -> SolvedIf []
@@ -395,8 +353,7 @@
TCon (TC TCRational) [] -> SolvedIf []
-- Cmp (Z n) fails
- TCon (TC TCIntMod) [_] ->
- Unsolvable $ TCErrorMessage "Type 'Z' does not support order comparisons."
+ TCon (TC TCIntMod) [_] -> Unsolvable
-- ValidFloat e p => Cmp (Float e p)
TCon (TC TCFloat) [e,p] -> SolvedIf [ pValidFloat e p ]
@@ -408,8 +365,7 @@
TCon (TC (TCTuple _)) es -> SolvedIf (map pCmp es)
-- Cmp (a -> b) fails
- TCon (TC TCFun) [_,_] ->
- Unsolvable $ TCErrorMessage "Function types do not support order comparisons."
+ TCon (TC TCFun) [_,_] -> Unsolvable
-- (Cmp a, Cmp b) => Cmp { x:a, y:b }
TRec fs -> SolvedIf [ pCmp e | e <- recordElements fs ]
@@ -437,32 +393,22 @@
solveSignedCmpInst ty = case tNoUser ty of
-- SignedCmp Error -> fails
- TCon (TError _ e) _ -> Unsolvable e
+ TCon (TError {}) _ -> Unsolvable
-- SignedCmp Bit fails
- TCon (TC TCBit) [] ->
- Unsolvable $
- TCErrorMessage "Type 'Bit' does not support signed comparisons."
+ TCon (TC TCBit) [] -> Unsolvable
-- SignedCmp Integer fails
- TCon (TC TCInteger) [] ->
- Unsolvable $
- TCErrorMessage "Type 'Integer' does not support signed comparisons."
+ TCon (TC TCInteger) [] -> Unsolvable
-- SignedCmp (Z n) fails
- TCon (TC TCIntMod) [_] ->
- Unsolvable $
- TCErrorMessage "Type 'Z' does not support signed comparisons."
+ TCon (TC TCIntMod) [_] -> Unsolvable
-- SignedCmp Rational fails
- TCon (TC TCRational) [] ->
- Unsolvable $
- TCErrorMessage "Type 'Rational' does not support signed comparisons."
+ TCon (TC TCRational) [] -> Unsolvable
-- SignedCmp (Float e p) fails
- TCon (TC TCFloat) [_, _] ->
- Unsolvable $
- TCErrorMessage "Type 'Float' does not support signed comparisons."
+ TCon (TC TCFloat) [_, _] -> Unsolvable
-- SignedCmp for sequences
TCon (TC TCSeq) [n,a] -> solveSignedCmpSeq n a
@@ -471,9 +417,7 @@
TCon (TC (TCTuple _)) es -> SolvedIf (map pSignedCmp es)
-- SignedCmp (a -> b) fails
- TCon (TC TCFun) [_,_] ->
- Unsolvable $
- TCErrorMessage "Function types do not support signed comparisons."
+ TCon (TC TCFun) [_,_] -> Unsolvable
-- (SignedCmp a, SignedCmp b) => SignedCmp { x:a, y:b }
TRec fs -> SolvedIf [ pSignedCmp e | e <- recordElements fs ]
@@ -484,19 +428,16 @@
-- | Solving fractional literal constraints.
solveFLiteralInst :: Type -> Type -> Type -> Type -> Solved
solveFLiteralInst numT denT rndT ty
- | TCon (TError _ e) _ <- tNoUser numT = Unsolvable e
- | TCon (TError _ e) _ <- tNoUser denT = Unsolvable e
- | tIsInf numT || tIsInf denT || tIsInf rndT =
- Unsolvable $ TCErrorMessage $ "Fractions may not use `inf`"
- | Just 0 <- tIsNum denT =
- Unsolvable $ TCErrorMessage
- $ "Fractions may not have 0 as the denominator."
+ | TCon (TError {}) _ <- tNoUser numT = Unsolvable
+ | TCon (TError {}) _ <- tNoUser denT = Unsolvable
+ | tIsInf numT || tIsInf denT || tIsInf rndT = Unsolvable
+ | Just 0 <- tIsNum denT = Unsolvable
| otherwise =
case tNoUser ty of
TVar {} -> Unsolved
- TCon (TError _ e) _ -> Unsolvable e
+ TCon (TError {}) _ -> Unsolvable
TCon (TC TCRational) [] ->
SolvedIf [ pFin numT, pFin denT, denT >== tOne ]
@@ -512,25 +453,25 @@
, Just d <- tIsNum denT
-> case FP.bfDiv opts (FP.bfFromInteger n) (FP.bfFromInteger d) of
(_, FP.Ok) -> SolvedIf []
- _ -> Unsolvable $ TCErrorMessage
- $ show n ++ "/" ++ show d ++ " cannot be " ++
- "represented in " ++ show (pp ty)
+ _ -> Unsolvable
| otherwise -> Unsolved
- _ -> Unsolvable $ TCErrorMessage $ show
- $ "Type" <+> quotes (pp ty) <+> "does not support fractional literals."
+ _ -> Unsolvable
-- | Solve Literal constraints.
solveLiteralInst :: Type -> Type -> Solved
solveLiteralInst val ty
- | TCon (TError _ e) _ <- tNoUser val = Unsolvable e
+ | TCon (TError {}) _ <- tNoUser val = Unsolvable
| otherwise =
case tNoUser ty of
-- Literal n Error -> fails
- TCon (TError _ e) _ -> Unsolvable e
+ TCon (TError {}) _ -> Unsolvable
+ -- (1 >= val) => Literal val Bit
+ TCon (TC TCBit) [] -> SolvedIf [ tOne >== val ]
+
-- (fin val) => Literal val Integer
TCon (TC TCInteger) [] -> SolvedIf [ pFin val ]
@@ -544,9 +485,7 @@
let bf = FP.bfFromInteger n
in case FP.bfRoundFloat opts bf of
(bf1,FP.Ok) | bf == bf1 -> SolvedIf []
- _ -> Unsolvable $ TCErrorMessage
- $ show n ++ " cannot be " ++
- "represented in " ++ show (pp ty)
+ _ -> Unsolvable
| otherwise -> Unsolved
@@ -565,7 +504,6 @@
TVar _ -> Unsolved
- _ -> Unsolvable $ TCErrorMessage $ show
- $ "Type" <+> quotes (pp ty) <+> "does not support integer literals."
+ _ -> Unsolvable
diff --git a/src/Cryptol/TypeCheck/Solver/Numeric.hs b/src/Cryptol/TypeCheck/Solver/Numeric.hs
--- a/src/Cryptol/TypeCheck/Solver/Numeric.hs
+++ b/src/Cryptol/TypeCheck/Solver/Numeric.hs
@@ -1,15 +1,18 @@
-{-# LANGUAGE Safe, PatternGuards, MultiWayIf #-}
+{-# LANGUAGE PatternGuards, MagicHash, MultiWayIf, TypeOperators #-}
module Cryptol.TypeCheck.Solver.Numeric
- ( cryIsEqual, cryIsNotEqual, cryIsGeq
+ ( cryIsEqual, cryIsNotEqual, cryIsGeq, cryIsPrime, primeTable
) where
import Control.Applicative(Alternative(..))
import Control.Monad (guard,mzero)
import qualified Control.Monad.Fail as Fail
import Data.List (sortBy)
+import Data.MemoTrie
+import qualified GHC.Integer.GMP.Internals as Integer
+
+
import Cryptol.Utils.Patterns
-import Cryptol.TypeCheck.PP
import Cryptol.TypeCheck.Type hiding (tMul)
import Cryptol.TypeCheck.TypePat
import Cryptol.TypeCheck.Solver.Types
@@ -30,7 +33,7 @@
cryIsEqual :: Ctxt -> Type -> Type -> Solved
cryIsEqual ctxt t1 t2 =
matchDefault Unsolved $
- (pBin PEqual (==) t1 t2)
+ (pBin (==) t1 t2)
<|> (aNat' t1 >>= tryEqK ctxt t2)
<|> (aNat' t2 >>= tryEqK ctxt t1)
<|> (aTVar t1 >>= tryEqVar t2)
@@ -49,13 +52,13 @@
-- | Try to solve @t1 /= t2@
cryIsNotEqual :: Ctxt -> Type -> Type -> Solved
-cryIsNotEqual _i t1 t2 = matchDefault Unsolved (pBin PNeq (/=) t1 t2)
+cryIsNotEqual _i t1 t2 = matchDefault Unsolved (pBin (/=) t1 t2)
-- | Try to solve @t1 >= t2@
cryIsGeq :: Ctxt -> Type -> Type -> Solved
cryIsGeq i t1 t2 =
matchDefault Unsolved $
- (pBin PGeq (>=) t1 t2)
+ (pBin (>=) t1 t2)
<|> (aNat' t1 >>= tryGeqKThan i t2)
<|> (aNat' t2 >>= tryGeqThanK i t1)
<|> (aTVar t2 >>= tryGeqThanVar i t1)
@@ -72,18 +75,41 @@
-- XXX: max t 10 >= 2 --> True
-- XXX: max t 2 >= 10 --> a >= 10
+{-# NOINLINE primeTable #-}
+primeTable :: Integer :->: Bool
+primeTable = trie isPrime
+ where
+ isPrime i =
+ case Integer.testPrimeInteger i 25# of
+ 0# -> False
+ _ -> True
+
+cryIsPrime :: Ctxt -> Type -> Solved
+cryIsPrime _varInfo ty =
+ case tNoUser ty of
+
+ TCon (TC tc) []
+ | TCNum n <- tc ->
+ if untrie primeTable n then
+ SolvedIf []
+ else
+ Unsolvable
+
+ | TCInf <- tc -> Unsolvable
+
+ _ -> Unsolved
+
+
-- | Try to solve something by evaluation.
-pBin :: PC -> (Nat' -> Nat' -> Bool) -> Type -> Type -> Match Solved
-pBin tf p t1 t2 =
- Unsolvable <$> anError KNum t1
- <|> Unsolvable <$> anError KNum t2
- <|> (do x <- aNat' t1
- y <- aNat' t2
- return $ if p x y
- then SolvedIf []
- else Unsolvable $ TCErrorMessage
- $ "It is not the case that " ++
- show (pp (TCon (PC tf) [ tNat' x, tNat' y ])))
+pBin :: (Nat' -> Nat' -> Bool) -> Type -> Type -> Match Solved
+pBin p t1 t2
+ | Just _ <- tIsError t1 = pure Unsolvable
+ | Just _ <- tIsError t2 = pure Unsolvable
+ | otherwise = do x <- aNat' t1
+ y <- aNat' t2
+ return $ if p x y
+ then SolvedIf []
+ else Unsolvable
--------------------------------------------------------------------------------
@@ -151,8 +177,7 @@
k2 <- aNat t2
return $ if k1 >= k2
then SolvedIf [ b >== t2 ]
- else Unsolvable $ TCErrorMessage $
- show k1 ++ " can't be greater than " ++ show k2
+ else Unsolvable
--------------------------------------------------------------------------------
@@ -297,9 +322,6 @@
case nSub lk rk of
-- NOTE: (Inf - Inf) shouldn't be possible
Nothing -> Unsolvable
- $ TCErrorMessage
- $ "Adding " ++ showNat' rk ++ " will always exceed "
- ++ showNat' lk
Just r -> SolvedIf [ b =#= tNat' r ]
<|>
@@ -322,9 +344,7 @@
(Nat 0, Inf) -> SolvedIf [ b =#= tZero ]
-- Inf * t = K ~~~> ERR (K /= 0)
- (Nat k, Inf) -> Unsolvable
- $ TCErrorMessage
- $ show k ++ " != inf * anything"
+ (Nat _k, Inf) -> Unsolvable
(Nat lk', Nat rk')
-- 0 * t = K2 ~~> K2 = 0
@@ -333,10 +353,7 @@
-- K1 * t = K2 ~~> t = K2/K1
| (q,0) <- divMod lk' rk' -> SolvedIf [ b =#= tNum q ]
- | otherwise ->
- Unsolvable
- $ TCErrorMessage
- $ showNat' lk ++ " != " ++ showNat' rk ++ " * anything"
+ | otherwise -> Unsolvable
<|>
-- K1 == K2 ^^ t ~~> t = logBase K2 K1
@@ -344,8 +361,7 @@
return $ case lk of
Inf | rk > 1 -> SolvedIf [ b =#= tInf ]
Nat n | Just (a,True) <- genLog n rk -> SolvedIf [ b =#= tNum a]
- _ -> Unsolvable $ TCErrorMessage
- $ show rk ++ " ^^ anything != " ++ showNat' lk
+ _ -> Unsolvable
-- XXX: Min, Max, etx
-- 2 = min (10,y) --> y = 2
@@ -471,6 +487,3 @@
-showNat' :: Nat' -> String
-showNat' Inf = "inf"
-showNat' (Nat n) = show n
diff --git a/src/Cryptol/TypeCheck/Solver/Numeric/Fin.hs b/src/Cryptol/TypeCheck/Solver/Numeric/Fin.hs
--- a/src/Cryptol/TypeCheck/Solver/Numeric/Fin.hs
+++ b/src/Cryptol/TypeCheck/Solver/Numeric/Fin.hs
@@ -35,8 +35,7 @@
TCon (TC tc) []
| TCNum _ <- tc -> SolvedIf []
- | TCInf <- tc ->
- Unsolvable $ TCErrorMessage "Expected a finite type, but found `inf`."
+ | TCInf <- tc -> Unsolvable
TCon (TF f) ts ->
case (f,ts) of
diff --git a/src/Cryptol/TypeCheck/Solver/SMT.hs b/src/Cryptol/TypeCheck/Solver/SMT.hs
--- a/src/Cryptol/TypeCheck/Solver/SMT.hs
+++ b/src/Cryptol/TypeCheck/Solver/SMT.hs
@@ -381,9 +381,6 @@
instance Mk Type where
mk tvs f x = SMT.fun f [toSMT tvs x]
-instance Mk TCErrorMessage where
- mk _ f _ = SMT.fun f []
-
instance Mk (Type,Type) where
mk tvs f (x,y) = SMT.fun f [ toSMT tvs x, toSMT tvs y]
diff --git a/src/Cryptol/TypeCheck/Solver/Selector.hs b/src/Cryptol/TypeCheck/Solver/Selector.hs
--- a/src/Cryptol/TypeCheck/Solver/Selector.hs
+++ b/src/Cryptol/TypeCheck/Solver/Selector.hs
@@ -50,7 +50,8 @@
where
cvt _ Nothing = return False
cvt f (Just a) = do ty <- f a
- newGoals CtExactType =<< unify ty outerT
+ ps <- unify (WithSource outerT (selSrc sel)) ty
+ newGoals CtExactType ps
newT <- applySubst outerT
return (newT /= outerT)
@@ -125,7 +126,7 @@
case mbInnerT of
Nothing -> return (imped, False)
Just innerT ->
- do newGoals CtExactType =<< unify innerT ft
+ do newGoals CtExactType =<< unify (WithSource innerT (selSrc sel)) ft
oT <- applySubst outerT
iT <- applySubst innerT
sln <- mkSelSln sel oT iT
@@ -158,7 +159,7 @@
| RecordSel {} <- s -> liftFun t1 t2
_ -> return HasGoalSln { hasDoSelect = \e -> ESel e s
- , hasDoSet = \e v -> ESet e s v }
+ , hasDoSet = \e v -> ESet outerT e s v }
where
-- Has s a t => Has s ([n]a) ([n]t)
@@ -185,7 +186,7 @@
_ -> panic "mkSelSln" [ "Unexpected inner seq type.", show innerT ]
- -- Has s b t => Has s (a -> b)
+ -- Has s b t => Has s (a -> b) (a -> t)
-- f.s ~~> \x -> (f x).s
-- { f | s = g } ~~> \x -> { f x | s = g x }
liftFun t1 t2 =
diff --git a/src/Cryptol/TypeCheck/Solver/Types.hs b/src/Cryptol/TypeCheck/Solver/Types.hs
--- a/src/Cryptol/TypeCheck/Solver/Types.hs
+++ b/src/Cryptol/TypeCheck/Solver/Types.hs
@@ -1,3 +1,4 @@
+{-# Language OverloadedStrings, DeriveGeneric, DeriveAnyClass #-}
module Cryptol.TypeCheck.Solver.Types where
import Data.Map(Map)
@@ -22,10 +23,11 @@
data Solved = SolvedIf [Prop] -- ^ Solved, assuming the sub-goals.
| Unsolved -- ^ We could not solve the goal.
- | Unsolvable TCErrorMessage -- ^ The goal can never be solved.
+ | Unsolvable -- ^ The goal can never be solved.
deriving (Show)
+
elseTry :: Solved -> Solved -> Solved
Unsolved `elseTry` x = x
x `elseTry` _ = x
@@ -48,4 +50,5 @@
case res of
SolvedIf ps -> text "solved" $$ nest 2 (vcat (map pp ps))
Unsolved -> text "unsolved"
- Unsolvable e -> text "unsolvable" <.> colon <+> text (tcErrorMessage e)
+ Unsolvable -> text "unsolvable"
+
diff --git a/src/Cryptol/TypeCheck/Subst.hs b/src/Cryptol/TypeCheck/Subst.hs
--- a/src/Cryptol/TypeCheck/Subst.hs
+++ b/src/Cryptol/TypeCheck/Subst.hs
@@ -6,6 +6,10 @@
-- Stability : provisional
-- Portability : portable
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE FlexibleInstances #-}
@@ -30,6 +34,7 @@
, substBinds
, applySubstToVar
, substToList
+ , fmap', (!$), (.$)
) where
import Data.Maybe
@@ -45,7 +50,7 @@
import qualified Cryptol.TypeCheck.SimpType as Simp
import qualified Cryptol.TypeCheck.SimpleSolver as Simp
import Cryptol.Utils.Panic(panic)
-import Cryptol.Utils.Misc(anyJust)
+import Cryptol.Utils.Misc (anyJust, anyJust2)
-- | A 'Subst' value represents a substitution that maps each 'TVar'
-- to a 'Type'.
@@ -196,8 +201,30 @@
+infixl 0 !$
+infixl 0 .$
+-- | Left-associative variant of the strict application operator '$!'.
+(!$) :: (a -> b) -> a -> b
+(!$) = ($!)
+-- | Left-associative variant of the application operator '$'.
+(.$) :: (a -> b) -> a -> b
+(.$) = ($)
+
+-- Only used internally to define fmap'.
+data Done a = Done a
+ deriving (Functor, Foldable, Traversable)
+
+instance Applicative Done where
+ pure x = Done x
+ Done f <*> Done x = Done (f x)
+
+-- | Strict variant of 'fmap'.
+fmap' :: Traversable t => (a -> b) -> t a -> t b
+fmap' f xs = case traverse f' xs of Done y -> y
+ where f' x = Done $! f x
+
-- | Apply a substitution. Returns `Nothing` if nothing changed.
apSubstMaybe :: Subst -> Type -> Maybe Type
apSubstMaybe su ty =
@@ -209,8 +236,10 @@
PC _ -> Just $! Simp.simplify mempty (TCon t ss)
_ -> Just (TCon t ss)
- TUser f ts t -> do t1 <- apSubstMaybe su t
- return (TUser f (map (apSubst su) ts) t1)
+ TUser f ts t ->
+ do (ts1, t1) <- anyJust2 (anyJust (apSubstMaybe su)) (apSubstMaybe su) (ts, t)
+ Just (TUser f ts1 t1)
+
TRec fs -> TRec `fmap` (anyJust (apSubstMaybe su) fs)
TVar x -> applySubstToVar su x
@@ -226,22 +255,30 @@
case lookupSubst x su of
-- For a defaulting substitution, we must recurse in order to
-- replace unmapped free vars with default types.
- Just t -> Just (if suDefaulting su then apSubst su t else t)
+ Just t
+ | suDefaulting su -> Just $! apSubst su t
+ | otherwise -> Just t
Nothing
| suDefaulting su -> Just $! defaultFreeVar x
| otherwise -> Nothing
class TVars t where
- apSubst :: Subst -> t -> t -- ^ replaces free vars
+ apSubst :: Subst -> t -> t
+ -- ^ Replaces free variables. To prevent space leaks when used with
+ -- large 'Subst' values, every instance of 'apSubst' should satisfy
+ -- a strictness property: Forcing evaluation of @'apSubst' s x@
+ -- should also force the evaluation of all recursive calls to
+ -- @'apSubst' s@. This ensures that unevaluated thunks will not
+ -- cause 'Subst' values to be retained on the heap.
instance TVars t => TVars (Maybe t) where
- apSubst s = fmap (apSubst s)
+ apSubst s = fmap' (apSubst s)
instance TVars t => TVars [t] where
- apSubst s = map (apSubst s)
+ apSubst s = fmap' (apSubst s)
instance (TVars s, TVars t) => TVars (s,t) where
- apSubst s (x,y) = (apSubst s x, apSubst s y)
+ apSubst s (x, y) = (,) !$ apSubst s x !$ apSubst s y
instance TVars Type where
apSubst su ty = fromMaybe ty (apSubstMaybe su ty)
@@ -258,11 +295,11 @@
, "Source: " ++ show d
, "Kind: " ++ show (pp k) ]
-instance (Functor m, TVars a) => TVars (List m a) where
- apSubst su = fmap (apSubst su)
+instance (Traversable m, TVars a) => TVars (List m a) where
+ apSubst su = fmap' (apSubst su)
instance TVars a => TVars (TypeMap a) where
- apSubst su = fmap (apSubst su)
+ apSubst su = fmap' (apSubst su)
-- | Apply the substitution to the keys of a type map.
@@ -303,19 +340,19 @@
that variable scopes will be properly preserved. -}
instance TVars Schema where
- apSubst su (Forall xs ps t) = Forall xs (concatMap pSplitAnd (apSubst su ps))
- (apSubst su t)
+ apSubst su (Forall xs ps t) =
+ Forall xs !$ (concatMap pSplitAnd (apSubst su ps)) !$ (apSubst su t)
instance TVars Expr where
apSubst su = go
where
go expr =
case expr of
- EApp e1 e2 -> EApp (go e1) (go e2)
- EAbs x t e1 -> EAbs x (apSubst su t) (go e1)
- ETAbs a e -> ETAbs a (go e)
- ETApp e t -> ETApp (go e) (apSubst su t)
- EProofAbs p e -> EProofAbs hmm (go e)
+ EApp e1 e2 -> EApp !$ (go e1) !$ (go e2)
+ EAbs x t e1 -> EAbs x !$ (apSubst su t) !$ (go e1)
+ ETAbs a e -> ETAbs a !$ (go e)
+ ETApp e t -> ETApp !$ (go e) !$ (apSubst su t)
+ EProofAbs p e -> EProofAbs !$ hmm !$ (go e)
where hmm = case pSplitAnd (apSubst su p) of
[p1] -> p1
res -> panic "apSubst@EProofAbs"
@@ -329,36 +366,39 @@
, show (pp su)
]
- EProofApp e -> EProofApp (go e)
+ EProofApp e -> EProofApp !$ (go e)
EVar {} -> expr
- ETuple es -> ETuple (map go es)
- ERec fs -> ERec (fmap go fs)
- ESet e x v -> ESet (go e) x (go v)
- EList es t -> EList (map go es) (apSubst su t)
- ESel e s -> ESel (go e) s
- EComp len t e mss -> EComp (apSubst su len) (apSubst su t) (go e) (apSubst su mss)
- EIf e1 e2 e3 -> EIf (go e1) (go e2) (go e3)
+ ETuple es -> ETuple !$ (fmap' go es)
+ ERec fs -> ERec !$ (fmap' go fs)
+ ESet ty e x v -> ESet !$ (apSubst su ty) !$ (go e) .$ x !$ (go v)
+ EList es t -> EList !$ (fmap' go es) !$ (apSubst su t)
+ ESel e s -> ESel !$ (go e) .$ s
+ EComp len t e mss -> EComp !$ (apSubst su len) !$ (apSubst su t) !$ (go e) !$ (apSubst su mss)
+ EIf e1 e2 e3 -> EIf !$ (go e1) !$ (go e2) !$ (go e3)
- EWhere e ds -> EWhere (go e) (apSubst su ds)
+ EWhere e ds -> EWhere !$ (go e) !$ (apSubst su ds)
instance TVars Match where
- apSubst su (From x len t e) = From x (apSubst su len) (apSubst su t) (apSubst su e)
- apSubst su (Let b) = Let (apSubst su b)
+ apSubst su (From x len t e) = From x !$ (apSubst su len) !$ (apSubst su t) !$ (apSubst su e)
+ apSubst su (Let b) = Let !$ (apSubst su b)
instance TVars DeclGroup where
- apSubst su (NonRecursive d) = NonRecursive (apSubst su d)
- apSubst su (Recursive ds) = Recursive (apSubst su ds)
+ apSubst su (NonRecursive d) = NonRecursive !$ (apSubst su d)
+ apSubst su (Recursive ds) = Recursive !$ (apSubst su ds)
instance TVars Decl where
- apSubst su d = d { dSignature = apSubst su (dSignature d)
- , dDefinition = apSubst su (dDefinition d)
- }
+ apSubst su d =
+ let !sig' = id $! apSubst su (dSignature d)
+ !def' = apSubst su (dDefinition d)
+ in d { dSignature = sig', dDefinition = def' }
instance TVars DeclDef where
- apSubst su (DExpr e) = DExpr (apSubst su e)
+ apSubst su (DExpr e) = DExpr !$ (apSubst su e)
apSubst _ DPrim = DPrim
instance TVars Module where
- apSubst su m = m { mDecls = apSubst su (mDecls m) }
+ apSubst su m =
+ let !decls' = apSubst su (mDecls m)
+ in m { mDecls = decls' }
diff --git a/src/Cryptol/TypeCheck/TCon.hs b/src/Cryptol/TypeCheck/TCon.hs
--- a/src/Cryptol/TypeCheck/TCon.hs
+++ b/src/Cryptol/TypeCheck/TCon.hs
@@ -1,4 +1,4 @@
-{-# Language DeriveGeneric, DeriveAnyClass #-}
+{-# Language OverloadedStrings, DeriveGeneric, DeriveAnyClass, Safe #-}
module Cryptol.TypeCheck.TCon where
import qualified Data.Map as Map
@@ -69,6 +69,7 @@
, "!=" ~> PC PNeq
, ">=" ~> PC PGeq
, "fin" ~> PC PFin
+ , "prime" ~> PC PPrime
, "Zero" ~> PC PZero
, "Logic" ~> PC PLogic
, "Ring" ~> PC PRing
@@ -122,7 +123,7 @@
kindOf (TC tc) = kindOf tc
kindOf (PC pc) = kindOf pc
kindOf (TF tf) = kindOf tf
- kindOf (TError k _) = k
+ kindOf (TError k) = k
instance HasKind UserTC where
kindOf (UserTC _ k) = k
@@ -151,6 +152,7 @@
PNeq -> KNum :-> KNum :-> KProp
PGeq -> KNum :-> KNum :-> KProp
PFin -> KNum :-> KProp
+ PPrime -> KNum :-> KProp
PHas _ -> KType :-> KType :-> KProp
PZero -> KType :-> KProp
PLogic -> KType :-> KProp
@@ -188,7 +190,7 @@
-- | Type constants.
-data TCon = TC TC | PC PC | TF TFun | TError Kind TCErrorMessage
+data TCon = TC TC | PC PC | TF TFun | TError Kind
deriving (Show, Eq, Ord, Generic, NFData)
@@ -198,6 +200,7 @@
| PNeq -- ^ @_ /= _@
| PGeq -- ^ @_ >= _@
| PFin -- ^ @fin _@
+ | PPrime -- ^ @prime _@
-- classes
| PHas Selector -- ^ @Has sel type field@ does not appear in schemas
@@ -250,10 +253,6 @@
-data TCErrorMessage = TCErrorMessage
- { tcErrorMessage :: !String
- -- XXX: Add location?
- } deriving (Show, Eq, Ord, Generic, NFData)
-- | Built-in type functions.
@@ -295,12 +294,9 @@
ppPrec _ (TC tc) = pp tc
ppPrec _ (PC tc) = pp tc
ppPrec _ (TF tc) = pp tc
- ppPrec _ (TError _ msg) = pp msg
+ ppPrec _ (TError _) = "Error"
-instance PP TCErrorMessage where
- ppPrec _ tc = parens (text "error:" <+> text (tcErrorMessage tc))
-
instance PP PC where
ppPrec _ x =
case x of
@@ -308,6 +304,7 @@
PNeq -> text "(/=)"
PGeq -> text "(>=)"
PFin -> text "fin"
+ PPrime -> text "prime"
PHas sel -> parens (ppSelector sel)
PZero -> text "Zero"
PLogic -> text "Logic"
diff --git a/src/Cryptol/TypeCheck/Type.hs b/src/Cryptol/TypeCheck/Type.hs
--- a/src/Cryptol/TypeCheck/Type.hs
+++ b/src/Cryptol/TypeCheck/Type.hs
@@ -15,6 +15,7 @@
import Data.Maybe (fromMaybe)
import Data.Set (Set)
import qualified Data.Set as Set
+import Data.Text (Text)
import Cryptol.Parser.Selector
import Cryptol.Parser.Position(Range,emptyRange)
@@ -111,8 +112,8 @@
-- | Type variables.
data TVar = TVFree !Int Kind (Set TParam) TVarInfo
- -- ^ Unique, kind, ids of bound type variables that are in scope
- -- The last field gives us some infor for nicer warnings/errors.
+ -- ^ Unique, kind, ids of bound type variables that are in scope.
+ -- The last field gives us some info for nicer warnings/errors.
| TVBound {-# UNPACK #-} !TParam
@@ -124,13 +125,18 @@
TVFree _ _ _ d -> d
TVBound tp -> tpInfo tp
-data TVarInfo = TVarInfo { tvarSource :: Range -- ^ Source code that gave rise
- , tvarDesc :: TVarSource -- ^ Description
+tvUnique :: TVar -> Int
+tvUnique (TVFree u _ _ _) = u
+tvUnique (TVBound TParam { tpUnique = u }) = u
+
+data TVarInfo = TVarInfo { tvarSource :: !Range -- ^ Source code that gave rise
+ , tvarDesc :: !TypeSource -- ^ Description
}
deriving (Show, Generic, NFData)
-data TVarSource = TVFromModParam Name -- ^ Name of module parameter
+-- | Explains how this type came to be, for better error messages.
+data TypeSource = TVFromModParam Name -- ^ Name of module parameter
| TVFromSignature Name -- ^ A variable in a signature
| TypeWildCard
| TypeOfRecordField Ident
@@ -141,13 +147,26 @@
| TypeParamInstPos {-Fun-}Name {-Pos (from 1)-}Int
| DefinitionOf Name
| LenOfCompGen
- | TypeOfArg (Maybe Int)
+ | TypeOfArg ArgDescr
| TypeOfRes
+ | FunApp
+ | TypeOfIfCondExpr
+ | TypeFromUserAnnotation
+ | GeneratorOfListComp
| TypeErrorPlaceHolder
deriving (Show, Generic, NFData)
+data ArgDescr = ArgDescr
+ { argDescrFun :: Maybe Name
+ , argDescrNumber :: Maybe Int
+ }
+ deriving (Show,Generic,NFData)
+
+noArgDescr :: ArgDescr
+noArgDescr = ArgDescr { argDescrFun = Nothing, argDescrNumber = Nothing }
+
-- | Get the names of something that is related to the tvar.
-tvSourceName :: TVarSource -> Maybe Name
+tvSourceName :: TypeSource -> Maybe Name
tvSourceName tvs =
case tvs of
TVFromModParam x -> Just x
@@ -155,8 +174,17 @@
TypeParamInstNamed x _ -> Just x
TypeParamInstPos x _ -> Just x
DefinitionOf x -> Just x
+ TypeOfArg x -> argDescrFun x
_ -> Nothing
+
+-- | A type annotated with information on how it came about.
+data TypeWithSource = WithSource
+ { twsType :: Type
+ , twsSource :: TypeSource
+ }
+
+
-- | The type is supposed to be of kind 'KProp'.
type Prop = Type
@@ -169,7 +197,7 @@
, tsParams :: [TParam] -- ^ Parameters
, tsConstraints :: [Prop] -- ^ Ensure body is OK
, tsDef :: Type -- ^ Definition
- , tsDoc :: !(Maybe String) -- ^ Documentation
+ , tsDoc :: !(Maybe Text) -- ^ Documentation
}
deriving (Show, Generic, NFData)
@@ -182,7 +210,7 @@
, ntParams :: [TParam]
, ntConstraints :: [Prop]
, ntFields :: [(Ident,Type)]
- , ntDoc :: Maybe String
+ , ntDoc :: Maybe Text
} deriving (Show, Generic, NFData)
@@ -192,7 +220,7 @@
, atKind :: Kind
, atCtrs :: ([TParam], [Prop])
, atFixitiy :: Maybe Fixity
- , atDoc :: Maybe String
+ , atDoc :: Maybe Text
} deriving (Show, Generic, NFData)
@@ -281,6 +309,10 @@
-- | Compute the set of all @Prop@s that are implied by the
-- given prop via superclass constraints.
superclassSet :: Prop -> Set Prop
+
+superclassSet (TCon (PC PPrime) [n]) =
+ Set.fromList [ pFin n, n >== tTwo ]
+
superclassSet (TCon (PC p0) [t]) = go p0
where
super p = Set.insert (TCon (PC p) [t]) (go p)
@@ -343,12 +375,20 @@
isBoundTV _ = False
-tIsError :: Type -> Maybe (TCErrorMessage,Type)
+tIsError :: Type -> Maybe Type
tIsError ty = case tNoUser ty of
- TCon (TError _ x) [t] -> Just (x,t)
- TCon (TError _ _) _ -> panic "tIsError" ["Malformed error"]
- _ -> Nothing
+ TCon (TError _) [t] -> Just t
+ TCon (TError _) _ -> panic "tIsError" ["Malformed error"]
+ _ -> Nothing
+tHasErrors :: Type -> Bool
+tHasErrors ty =
+ case tNoUser ty of
+ TCon (TError _) _ -> True
+ TCon _ ts -> any tHasErrors ts
+ TRec mp -> any tHasErrors mp
+ _ -> False
+
tIsNat' :: Type -> Maybe Nat'
tIsNat' ty =
case tNoUser ty of
@@ -433,6 +473,11 @@
TCon (PC PFin) [t1] -> Just t1
_ -> Nothing
+pIsPrime :: Prop -> Maybe Type
+pIsPrime ty = case tNoUser ty of
+ TCon (PC PPrime) [t1] -> Just t1
+ _ -> Nothing
+
pIsGeq :: Prop -> Maybe (Type,Type)
pIsGeq ty = case tNoUser ty of
TCon (PC PGeq) [t1,t2] -> Just (t1,t2)
@@ -595,10 +640,9 @@
-- | Make an error value of the given type to replace
-- the given malformed type (the argument to the error function)
-tError :: Type -> String -> Type
-tError t s = TCon (TError (k :-> k) msg) [t]
+tError :: Type -> Type
+tError t = TCon (TError (k :-> k)) [t]
where k = kindOf t
- msg = TCErrorMessage s
tf1 :: TFun -> Type -> Type
tf1 f x = TCon (TF f) [x]
@@ -717,14 +761,23 @@
pFin ty =
case tNoUser ty of
TCon (TC (TCNum _)) _ -> pTrue
- TCon (TC TCInf) _ -> tError (TCon (PC PFin) [ty]) "`inf` is not finite"
- -- XXX: should we be doing this here??
- _ -> TCon (PC PFin) [ty]
+ TCon (TC TCInf) _ -> tError prop -- XXX: should we be doing this here??
+ _ -> prop
+ where
+ prop = TCon (PC PFin) [ty]
pValidFloat :: Type -> Type -> Type
pValidFloat e p = TCon (PC PValidFloat) [e,p]
+pPrime :: Type -> Prop
+pPrime ty =
+ case tNoUser ty of
+ TCon (TC TCInf) _ -> tError prop
+ _ -> prop
+ where
+ prop = TCon (PC PPrime) [ty]
+
--------------------------------------------------------------------------------
noFreeVariables :: FVS t => t -> Bool
@@ -855,7 +908,9 @@
--
-- * 3: @app_type@
--
--- * 4: @atype@
+-- * 4: @dimensions atype@
+--
+-- * 5: @atype@
instance PP (WithNames Type) where
ppPrec prec ty0@(WithNames ty nmMap) =
case ty of
@@ -866,8 +921,16 @@
_ | Just tinf <- isTInfix ty0 -> optParens (prec > 2)
$ ppInfix 2 isTInfix tinf
- TUser c [] _ -> pp c
- TUser c ts _ -> optParens (prec > 3) $ pp c <+> fsep (map (go 4) ts)
+ TUser c ts t ->
+ withNameDisp $ \disp ->
+ case nameInfo c of
+ Declared m _
+ | NotInScope <- getNameFormat m (nameIdent c) disp ->
+ go prec t -- unfold type synonym if not in scope
+ _ ->
+ case ts of
+ [] -> pp c
+ _ -> optParens (prec > 3) $ pp c <+> fsep (map (go 5) ts)
TCon (TC tc) ts ->
case (tc,ts) of
@@ -877,42 +940,43 @@
(TCInteger, []) -> text "Integer"
(TCRational, []) -> text "Rational"
- (TCIntMod, [n]) -> optParens (prec > 3) $ text "Z" <+> go 4 n
+ (TCIntMod, [n]) -> optParens (prec > 3) $ text "Z" <+> go 5 n
(TCSeq, [t1,TCon (TC TCBit) []]) -> brackets (go 0 t1)
- (TCSeq, [t1,t2]) -> optParens (prec > 3)
- $ brackets (go 0 t1) <.> go 3 t2
+ (TCSeq, [t1,t2]) -> optParens (prec > 4)
+ $ brackets (go 0 t1) <.> go 4 t2
(TCFun, [t1,t2]) -> optParens (prec > 1)
$ go 2 t1 <+> text "->" <+> go 1 t2
(TCTuple _, fs) -> parens $ fsep $ punctuate comma $ map (go 0) fs
- (_, _) -> optParens (prec > 3) $ pp tc <+> fsep (map (go 4) ts)
+ (_, _) -> optParens (prec > 3) $ pp tc <+> fsep (map (go 5) 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]) -> optParens (prec > 3) $ text "fin" <+> (go 4 t1)
+ (PFin, [t1]) -> optParens (prec > 3) $ text "fin" <+> (go 5 t1)
+ (PPrime, [t1]) -> optParens (prec > 3) $ text "prime" <+> (go 5 t1)
(PHas x, [t1,t2]) -> ppSelector x <+> text "of"
<+> go 0 t1 <+> text "is" <+> go 0 t2
(PAnd, [t1,t2]) -> parens (commaSep (map (go 0) (t1 : pSplitAnd t2)))
- (PRing, [t1]) -> pp pc <+> go 4 t1
- (PField, [t1]) -> pp pc <+> go 4 t1
- (PIntegral, [t1]) -> pp pc <+> go 4 t1
- (PRound, [t1]) -> pp pc <+> go 4 t1
+ (PRing, [t1]) -> pp pc <+> go 5 t1
+ (PField, [t1]) -> pp pc <+> go 5 t1
+ (PIntegral, [t1]) -> pp pc <+> go 5 t1
+ (PRound, [t1]) -> pp pc <+> go 5 t1
- (PCmp, [t1]) -> pp pc <+> go 4 t1
- (PSignedCmp, [t1]) -> pp pc <+> go 4 t1
- (PLiteral, [t1,t2]) -> pp pc <+> go 4 t1 <+> go 4 t2
+ (PCmp, [t1]) -> pp pc <+> go 5 t1
+ (PSignedCmp, [t1]) -> pp pc <+> go 5 t1
+ (PLiteral, [t1,t2]) -> pp pc <+> go 5 t1 <+> go 5 t2
- (_, _) -> optParens (prec > 3) $ pp pc <+> fsep (map (go 4) ts)
+ (_, _) -> optParens (prec > 3) $ pp pc <+> fsep (map (go 5) ts)
TCon f ts -> optParens (prec > 3)
- $ pp f <+> fsep (map (go 4) ts)
+ $ pp f <+> fsep (map (go 5) ts)
where
go p t = ppWithNamesPrec nmMap p t
@@ -937,19 +1001,25 @@
instance PP (WithNames TVar) where
- ppPrec _ (WithNames (TVBound x) mp) =
- case IntMap.lookup (tpUnique x) mp of
- Just a -> text a
- Nothing ->
- case tpFlav x of
- TPModParam n -> ppPrefixName n
- TPOther (Just n) -> pp n <.> "`" <.> int (tpUnique x)
- _ -> pickTVarName (tpKind x) (tvarDesc (tpInfo x)) (tpUnique x)
+ ppPrec _ (WithNames tv mp) =
+ case tv of
+ TVBound {} -> nmTxt
+ TVFree {} -> "?" <.> nmTxt
+ where
+ nmTxt
+ | Just a <- IntMap.lookup (tvUnique tv) mp = text a
+ | otherwise =
+ case tv of
+ TVBound x ->
+ case tpFlav x of
+ TPModParam n -> ppPrefixName n
+ TPOther (Just n) -> pp n <.> "`" <.> int (tpUnique x)
+ _ -> pickTVarName (tpKind x) (tvarDesc (tpInfo x)) (tpUnique x)
- ppPrec _ (WithNames (TVFree x k _ d) _) =
- char '?' <.> pickTVarName k (tvarDesc d) x
+ TVFree x k _ d -> pickTVarName k (tvarDesc d) x
-pickTVarName :: Kind -> TVarSource -> Int -> Doc
+
+pickTVarName :: Kind -> TypeSource -> Int -> Doc
pickTVarName k src uni =
text $
case src of
@@ -969,10 +1039,14 @@
Declared m SystemName | m == exprModName -> mk "it"
_ -> using x
LenOfCompGen -> mk "n"
- TypeOfArg mb -> mk (case mb of
+ GeneratorOfListComp -> "seq"
+ TypeOfIfCondExpr -> "b"
+ TypeOfArg ad -> mk (case argDescrNumber ad of
Nothing -> "arg"
Just n -> "arg_" ++ show n)
TypeOfRes -> "res"
+ FunApp -> "fun"
+ TypeFromUserAnnotation -> "user"
TypeErrorPlaceHolder -> "err"
where
sh a = show (pp a)
@@ -991,7 +1065,17 @@
loc = if rng == emptyRange then empty else "at" <+> pp rng
rng = tvarSource tvinfo
-instance PP TVarSource where
+instance PP ArgDescr where
+ ppPrec _ ad = which <+> "argument" <+> ofFun
+ where
+ which = maybe "function" ordinal (argDescrNumber ad)
+ ofFun = case argDescrFun ad of
+ Nothing -> empty
+ Just f -> "of" <+> pp f
+
+
+
+instance PP TypeSource where
ppPrec _ tvsrc =
case tvsrc of
TVFromModParam m -> "module parameter" <+> pp m
@@ -1007,9 +1091,10 @@
quotes (pp f)
DefinitionOf x -> "the type of" <+> quotes (pp x)
LenOfCompGen -> "length of comprehension generator"
- TypeOfArg mb ->
- case mb of
- Nothing -> "type of function argument"
- Just n -> "type of" <+> ordinal n <+> "function argument"
+ TypeOfArg ad -> "type of" <+> pp ad
TypeOfRes -> "type of function result"
+ TypeOfIfCondExpr -> "type of `if` condition"
+ TypeFromUserAnnotation -> "user annotation"
+ GeneratorOfListComp -> "generator in a list comprehension"
+ FunApp -> "function call"
TypeErrorPlaceHolder -> "type error place-holder"
diff --git a/src/Cryptol/TypeCheck/TypeMap.hs b/src/Cryptol/TypeCheck/TypeMap.hs
--- a/src/Cryptol/TypeCheck/TypeMap.hs
+++ b/src/Cryptol/TypeCheck/TypeMap.hs
@@ -10,6 +10,8 @@
{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}
{-# LANGUAGE UndecidableInstances, FlexibleInstances #-}
{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveTraversable #-}
module Cryptol.TypeCheck.TypeMap
( TypeMap(..), TypesMap, TrieMap(..)
, insertTM, insertWithTM
@@ -64,7 +66,7 @@
data List m a = L { nil :: Maybe a
, cons :: m (List m a)
- } deriving (Functor)
+ } deriving (Functor, Foldable, Traversable)
instance TrieMap m a => TrieMap (List m) [a] where
emptyTM = L { nil = Nothing, cons = emptyTM }
@@ -116,7 +118,7 @@
data TypeMap a = TM { tvar :: Map TVar a
, tcon :: Map TCon (List TypeMap a)
, trec :: Map [Ident] (List TypeMap a)
- } deriving (Functor)
+ } deriving (Functor, Foldable, Traversable)
instance TrieMap TypeMap Type where
emptyTM = TM { tvar = emptyTM, tcon = emptyTM, trec = emptyTM }
diff --git a/src/Cryptol/TypeCheck/TypeOf.hs b/src/Cryptol/TypeCheck/TypeOf.hs
--- a/src/Cryptol/TypeCheck/TypeOf.hs
+++ b/src/Cryptol/TypeCheck/TypeOf.hs
@@ -34,7 +34,7 @@
ETuple es -> tTuple (map (fastTypeOf tyenv) es)
ERec fields -> tRec (fmap (fastTypeOf tyenv) fields)
ESel e sel -> typeSelect (fastTypeOf tyenv e) sel
- ESet e _ _ -> fastTypeOf tyenv e
+ ESet ty _ _ _ -> ty
EIf _ e _ -> fastTypeOf tyenv e
EComp len t _ _ -> tSeq len t
EAbs x t e -> tFun t (fastTypeOf (Map.insert x (Forall [] [] t) tyenv) e)
diff --git a/src/Cryptol/TypeCheck/TypePat.hs b/src/Cryptol/TypeCheck/TypePat.hs
--- a/src/Cryptol/TypeCheck/TypePat.hs
+++ b/src/Cryptol/TypeCheck/TypePat.hs
@@ -182,10 +182,10 @@
aLogic = tp PLogic ar1
--------------------------------------------------------------------------------
-anError :: Kind -> Pat Type TCErrorMessage
+anError :: Kind -> Pat Type ()
anError k = \a -> case tNoUser a of
- TCon (TError k1 err) _ | k == k1 -> return err
- _ -> mzero
+ TCon (TError (_ :-> k1) ) _ | k == k1 -> return ()
+ _ -> mzero
diff --git a/src/Cryptol/Utils/Ident.hs b/src/Cryptol/Utils/Ident.hs
--- a/src/Cryptol/Utils/Ident.hs
+++ b/src/Cryptol/Utils/Ident.hs
@@ -16,8 +16,11 @@
, modNameChunks
, packModName
, preludeName
+ , preludeReferenceName
, floatName
+ , suiteBName
, arrayName
+ , primeECName
, interactiveName
, noModuleName
, exprModName
@@ -38,12 +41,13 @@
, identText
, modParamIdent
- -- * Identifiers for primitived
+ -- * Identifiers for primitives
, PrimIdent(..)
, prelPrim
, floatPrim
, arrayPrim
-
+ , suiteBPrim
+ , primeECPrim
) where
import Control.DeepSeq (NFData)
@@ -108,12 +112,21 @@
preludeName :: ModName
preludeName = packModName ["Cryptol"]
+preludeReferenceName :: ModName
+preludeReferenceName = packModName ["Cryptol","Reference"]
+
floatName :: ModName
floatName = packModName ["Float"]
arrayName :: ModName
arrayName = packModName ["Array"]
+suiteBName :: ModName
+suiteBName = packModName ["SuiteB"]
+
+primeECName :: ModName
+primeECName = packModName ["PrimeEC"]
+
interactiveName :: ModName
interactiveName = packModName [""]
@@ -188,6 +201,12 @@
floatPrim :: T.Text -> PrimIdent
floatPrim = PrimIdent floatName
+
+suiteBPrim :: T.Text -> PrimIdent
+suiteBPrim = PrimIdent suiteBName
+
+primeECPrim :: T.Text -> PrimIdent
+primeECPrim = PrimIdent primeECName
arrayPrim :: T.Text -> PrimIdent
arrayPrim = PrimIdent arrayName
diff --git a/src/Cryptol/Utils/Misc.hs b/src/Cryptol/Utils/Misc.hs
--- a/src/Cryptol/Utils/Misc.hs
+++ b/src/Cryptol/Utils/Misc.hs
@@ -10,7 +10,6 @@
module Cryptol.Utils.Misc where
import MonadLib
-import Data.Maybe(fromMaybe)
import Prelude ()
import Prelude.Compat
@@ -18,7 +17,7 @@
-- | Apply a function to all elements of a container.
-- Returns `Nothing` if nothing changed, and @Just container@ otherwise.
anyJust :: Traversable t => (a -> Maybe a) -> t a -> Maybe (t a)
-anyJust f m = mk $ runId $ runStateT False $ traverse upd m
+anyJust f m = mk $ runLift $ runStateT False $ traverse upd m
where
mk (a,changes) = if changes then Just a else Nothing
@@ -32,4 +31,6 @@
anyJust2 f g (a,b) =
case (f a, g b) of
(Nothing, Nothing) -> Nothing
- (x,y) -> Just (fromMaybe a x, fromMaybe b y)
+ (Just x , Nothing) -> Just (x, b)
+ (Nothing, Just y ) -> Just (a, y)
+ (Just x , Just y ) -> Just (x, y)
diff --git a/src/GitRev.hs b/src/GitRev.hs
--- a/src/GitRev.hs
+++ b/src/GitRev.hs
@@ -24,3 +24,4 @@
dirty :: Bool
dirty = $(gitDirty)
+-- Last build Fri Sep 11 16:44:33 PDT 2020
diff --git a/utils/CryHtml.hs b/utils/CryHtml.hs
--- a/utils/CryHtml.hs
+++ b/utils/CryHtml.hs
@@ -54,6 +54,7 @@
Num {} -> "number"
Frac {} -> "number"
Ident {} -> "identifier"
+ Selector {} -> "selector"
KW {} -> "keyword"
Op {} -> "operator"
Sym {} -> "symbol"
@@ -72,6 +73,7 @@
[ "body { font-family: monospace }"
, ".number { color: #cc00cc }"
, ".identifier { }"
+ , ".selector { color: #33033 }"
, ".keyword { color: blue; }"
, ".operator { color: #cc00cc }"
, ".symbol { color: blue }"