diff --git a/CHANGES.md b/CHANGES.md
--- a/CHANGES.md
+++ b/CHANGES.md
@@ -1,3 +1,127 @@
+# 2.9.0
+
+## Language changes
+
+* Removed the `Arith` class. Replaced it instead with more specialized
+ numeric classes: `Ring`, `Integral`, `Field`, and `Round`. `Ring`
+ is the closest analogue to the old `Arith` class; it contains the
+ `fromInteger`, `(+)`, `(*)`, `(-)` and `negate` methods. `Ring`
+ contains all the base arithmetic types in Cryptol, and lifts
+ pointwise over tuples, sequences and functions, just as `Arith` did.
+
+ The new `Integral` class now contains the integer division and
+ modulus methods (`(/)` and `(%)`), and the sequence indexing,
+ sequence update and shifting operations are generalized over
+ `Integral`. The `toInteger` operation is also generalized over this
+ class. `Integral` contains the bitvector types and `Integer`.
+
+ The new `Field` class contains types representing mathematical
+ fields (or types that are approximately fields). It is currently
+ inhabited by the new `Rational` type, and the `Float`
+ family of types. It will eventually also contain the
+ `Real` type. It has the operation `recip` for reciprocal
+ and `(/.)` for field division (not to be confused for `(/)`,
+ which is Euclidean integral division).
+
+ There is also a new `Round` class for types that can sensibly be
+ rounded to integers. This class has the methods `floor`, `ceiling`,
+ `trunc`, `roundToEven` and `roundAway` for performing different
+ kinds of integer rounding. `Rational` and `Float` inhabit `Round`.
+
+ The type of `(^^)` is modified to be
+ `{a, e} (Ring a, Integral e) => a -> e -> a`. This makes it clear
+ that the semantics are iterated multiplication, which makes sense
+ in any ring.
+
+ Finally, the `lg2`, `(/$)` and `(%$)` methods of Arith have
+ had their types specialized so they operate only on bitvectors.
+
+* Added an `Eq` class, and moved the equality operations
+ from `Cmp` into `Eq`. The `Z` type becomes a member of `Eq`
+ but not `Cmp`.
+
+* Added a base `Rational` type. It is implemented as a pair of
+ integers, quotiented in the usual way. As such, it reduces to the
+ theory of integers and requires no new solver support (beyond
+ nonlinear integer arithmetic). `Rational` inhabits the new
+ `Field` and `Round` classes. Rational values can be
+ constructed using the `ratio` function, or via `fromInteger`.
+
+* The `generate` function (and thus `x @ i= e` definitions) has had
+ its type specialized so the index type is always `Integer`.
+
+* The new typeclasses are arranged into a class hierarchy, and the
+ typechecker will use that information to infer superclass instances
+ from subclasses.
+
+* Added a family of base types, `Float e p`, for working with
+ floating point numbers. The parameters control the precision of
+ the numbers, with `e` being the number of bits to use in the exponent
+ and `p-1` being the number of bits to use in the mantissa.
+ The `Float` family of types may be used through the usual overloaded
+ functionality in Cryptol, and there is a new built-in module called
+ `Float`, which contains functionality specific to floating point numbers.
+
+* Add a way to write fractional literals in base 2,8,10, and 16.
+ Fractional literals are overloaded, and may be used for different types
+ (currently `Rational` and the `Float` family). Fractional literal in base
+ 2,8,and 16 must be precise, and will be rejected statically if they cannot be
+ represented exactly. Fractional literals in base 10 are rounded to the
+ nearest even representable number.
+
+* Changes to the defaulting algorithm. The new algorithm only applies
+ to constraints arising from literals (i.e., `Literal` and `FLiteral`
+ constraints). The guiding principle is that we now default these
+ to one of the infinite precision types `Integer` or `Rational`.
+ `Literal` constraints are defaulted to `Integer`, unless the corresponding
+ type also has `Field` constraint, in which case we use `Rational`.
+ Fractional literal constraints are always defaulted to `Rational.
+
+
+## New features
+
+* Document the behavior of lifted selectors.
+
+* Added support for symbolic simulation via the `What4` library
+ in addition to the previous method based on `SBV`. The What4
+ symbolic simulator is used when selecting solvers with the `w4`
+ prefix, such as `w4-z3`, `w4-cvc4`, `w4-yices`, etc.
+ The `SBV` and `What4` libraries make different tradeoffs in how
+ they represent formulae. You may find one works better than another
+ for the same problem, even with the same solver.
+
+* More detailed information about the status of various symbols
+ in the output of the `:browse` command (issue #688).
+
+* The `:safe` command will attempt to prove that a given Cryptol
+ term is safe; in other words, that it will not encounter a run-time
+ error for all inputs. Run-time errors arise from things like
+ division-by-zero, index-out-of-bounds situations and
+ explicit calls to `error` or `assert`.
+
+* The `:prove` and `:sat` commands now incorporate safety predicates
+ by default. In a `:sat` call, models will only be found that do not
+ cause run-time errors. For `:prove` calls, the safety conditions are
+ added as additional proof goals. The prior behavior
+ (which ignored safety conditions) can be restored using
+ `:set ignore-safety = on`.
+
+* Improvements to the `any` prover. It will now shut down external
+ prover processes correctly when one finds a solution. It will also
+ wait for the first _successful_ result to be returned from a prover,
+ instead of failing as soon as one prover fails.
+
+* An experimental `parmap` primitive that applies a function to a
+ sequence of arguments and computes the results in parallel. This
+ operation should be considered experimental and may significantly
+ change or disappear in the future, and could possibly uncover
+ unknown race conditions in the interpreter.
+
+## Bug fixes
+
+* Closed issues #346, #444, #614, #617, #636, #660, #662, #663, #664, #667, #670,
+ #702, #711, #712, #716, #723, #725, #731
+
# 2.8.0 (September 4, 2019)
## New features
@@ -22,7 +146,7 @@
f : {a} (fin a, a >= 1) => [a] -> [a]
f : {a} (fin a) => (a >= 1) => [a] -> [a]
-
+
* Added a mechanism for user-defined type constraint operators, and use
this to define the new type constraint synonyms (<) and (>) (issues
#400, #618).
@@ -109,18 +233,3 @@
of functions that they expand to (issue #568).
* Closed issues #498, #547, #551, #562, and #563.
-
-## Solver versions
-
-Cryptol can interact with a variety of external SMT solvers to
-support the `:prove` and `:sat` commands, and requires Z3 for its
-type checker. Many versions of these solvers will work correctly, but
-for Yices and Z3 we recommend the following specific versions.
-
-* Z3 4.7.1
-* Yices 2.6.1
-
-For Yices, this is the latest version at the time of this writing.
-For Z3, it is not, and the latest versions (4.8.x) include changes
-that cause some examples that previously succeeded to time out when
-type checking.
diff --git a/LICENSE b/LICENSE
--- a/LICENSE
+++ b/LICENSE
@@ -1,4 +1,4 @@
-Copyright (c) 2013-2019 Galois Inc.
+Copyright (c) 2013-2020 Galois Inc.
All rights reserved.
Redistribution and use in source and binary forms, with or without
diff --git a/bench/Main.hs b/bench/Main.hs
--- a/bench/Main.hs
+++ b/bench/Main.hs
@@ -6,18 +6,21 @@
-- Stability : provisional
-- Portability : portable
+{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Main where
+import Control.DeepSeq ( force )
+import Control.Monad.IO.Class( liftIO )
import qualified Data.Text as T
import qualified Data.Text.IO as T
import System.FilePath (())
import qualified System.Directory as Dir
import qualified Cryptol.Eval as E
-import qualified Cryptol.Eval.Monad as E
import qualified Cryptol.Eval.Value as E
+import qualified Cryptol.Eval.Concrete as C
import qualified Cryptol.ModuleSystem.Base as M
import qualified Cryptol.ModuleSystem.Env as M
@@ -29,8 +32,7 @@
import qualified Cryptol.Parser.AST as P
import qualified Cryptol.Parser.NoInclude as P
-import qualified Cryptol.Symbolic as S
-import qualified Cryptol.Symbolic.Value as S
+import qualified Cryptol.Eval.SBV as S
import qualified Cryptol.TypeCheck as T
import qualified Cryptol.TypeCheck.AST as T
@@ -48,7 +50,6 @@
defaultMain [
bgroup "parser" [
parser "Prelude" "lib/Cryptol.cry"
- , parser "PreludeWithExtras" "bench/data/PreludeWithExtras.cry"
, parser "BigSequence" "bench/data/BigSequence.cry"
, parser "BigSequenceHex" "bench/data/BigSequenceHex.cry"
, parser "AES" "bench/data/AES.cry"
@@ -56,7 +57,6 @@
]
, bgroup "typechecker" [
tc cd "Prelude" "lib/Cryptol.cry"
- , tc cd "PreludeWithExtras" "bench/data/PreludeWithExtras.cry"
, tc cd "BigSequence" "bench/data/BigSequence.cry"
, tc cd "BigSequenceHex" "bench/data/BigSequenceHex.cry"
, tc cd "AES" "bench/data/AES.cry"
@@ -107,21 +107,25 @@
}
Right pm = P.parseModule cfg bytes
menv <- M.initialModuleEnv
- (Right ((prims, scm, tcEnv), menv'), _) <- M.runModuleM (evOpts,menv) $ withLib $ do
+ (eres, _) <- M.runModuleM (evOpts,menv) $ withLib $ do
-- code from `loadModule` and `checkModule` in
-- `Cryptol.ModuleSystem.Base`
let pm' = M.addPrelude pm
M.loadDeps pm'
- Right nim <- M.io (P.removeIncludesModule path pm')
+ enim <- M.io (P.removeIncludesModule path pm')
+ nim <- either (error "Failed to remove includes") return enim
npm <- M.noPat nim
(tcEnv,declsEnv,scm) <- M.renameModule npm
prims <- if P.thing (P.mName pm) == I.preludeName
then return (M.toPrimMap declsEnv)
else M.getPrimMap
return (prims, scm, tcEnv)
- return (prims, scm, tcEnv, menv')
+ case eres of
+ Right ((prims, scm, tcEnv), menv') ->
+ return (prims, scm, tcEnv, menv')
+ Left _ -> error $ "Failed to load " ++ name
in env setup $ \ ~(prims, scm, tcEnv, menv) ->
- bench name $ nfIO $ M.runModuleM (evOpts,menv) $ withLib $ do
+ bench name $ whnfIO $ M.runModuleM (evOpts,menv) $ withLib $ do
let act = M.TCAction { M.tcAction = T.tcModule
, M.tcLinter = M.moduleLinter (P.thing (P.mName scm))
, M.tcPrims = prims
@@ -133,17 +137,20 @@
let withLib = M.withPrependedSearchPath [cd "lib"] in
let setup = do
menv <- M.initialModuleEnv
- (Right (texpr, menv'), _) <- M.runModuleM (evOpts,menv) $ withLib $ do
+ (eres, _) <- M.runModuleM (evOpts,menv) $ withLib $ do
m <- M.loadModuleByPath path
M.setFocusedModule (T.mName m)
let Right pexpr = P.parseExpr expr
(_, texpr, _) <- M.checkExpr pexpr
return texpr
- return (texpr, menv')
+ case eres of
+ Right (texpr, menv') -> return (texpr, menv')
+ Left _ -> error $ "Failed to load " ++ name
in env setup $ \ ~(texpr, menv) ->
bench name $ nfIO $ E.runEval evOpts $ do
- env' <- E.evalDecls (S.allDeclGroups menv) mempty
- (e :: E.Value) <- E.evalExpr env' texpr
+ let ?evalPrim = C.evalPrim
+ env' <- E.evalDecls C.Concrete (M.allDeclGroups menv) mempty
+ (e :: C.Value) <- E.evalExpr C.Concrete env' texpr
E.forceValue e
@@ -152,16 +159,19 @@
let withLib = M.withPrependedSearchPath [cd "lib"] in
let setup = do
menv <- M.initialModuleEnv
- (Right (texpr, menv'), _) <- M.runModuleM (evOpts,menv) $ withLib $ do
+ (eres, _) <- M.runModuleM (evOpts,menv) $ withLib $ do
m <- M.loadModuleByPath path
M.setFocusedModule (T.mName m)
let Right pexpr = P.parseExpr expr
(_, texpr, _) <- M.checkExpr pexpr
return texpr
- return (texpr, menv')
+ case eres of
+ Right (texpr, menv') -> return (texpr, menv')
+ Left _ -> error $ "Failed to load " ++ name
in env setup $ \ ~(texpr, menv) ->
- bench name $ nfIO $ E.runEval evOpts $ do
- env' <- E.evalDecls (S.allDeclGroups menv) mempty
- (e :: S.Value) <- E.evalExpr env' texpr
- E.io $ SBV.generateSMTBenchmark False $
- return (S.fromVBit e)
+ bench name $ whnfIO $ fmap force E.runEval evOpts $ S.sbvEval $ do
+ let ?evalPrim = S.evalPrim
+ env' <- E.evalDecls S.SBV (M.allDeclGroups menv) mempty
+ (e :: S.Value) <- E.evalExpr S.SBV env' texpr
+ liftIO $ SBV.generateSMTBenchmark False $
+ return (E.fromVBit e)
diff --git a/bench/data/PreludeWithExtras.cry b/bench/data/PreludeWithExtras.cry
deleted file mode 100644
--- a/bench/data/PreludeWithExtras.cry
+++ /dev/null
@@ -1,501 +0,0 @@
-/*
- * Copyright (c) 2013-2016 Galois, Inc.
- * Distributed under the terms of the BSD3 license (see LICENSE file)
- */
-
-module Cryptol where
-
-/**
- * The value corresponding to a numeric type.
- */
-primitive number : {val, bits} (fin val, fin bits, bits >= width val) => [bits]
-
-infixr 10 ||
-infixr 20 &&
-infix 30 ==, ===, !=, !==
-infix 40 >, >=, <, <=
-infixl 50 ^
-infixr 60 #
-infixl 70 <<, <<<, >>, >>>
-infixl 80 +, -
-infixl 90 *, /, %
-infixr 95 ^^
-infixl 100 @, @@, !, !!
-
-/**
- * Add two values.
- * * For words, addition uses modulo arithmetic.
- * * Structured values are added element-wise.
- */
-primitive (+) : {a} (Arith a) => a -> a -> a
-
-/**
- * For words, subtraction uses modulo arithmetic.
- * Structured values are subtracted element-wise. Defined as:
- * a - b = a + negate b
- * See also: `negate'.
- */
-primitive (-) : {a} (Arith a) => a -> a -> a
-
-/**
- * For words, multiplies two words, modulus 2^^a.
- * Structured values are multiplied element-wise.
- */
-primitive (*) : {a} (Arith a) => a -> a -> a
-
-/**
- * For words, divides two words, modulus 2^^a.
- * Structured values are divided element-wise.
- */
-primitive (/) : {a} (Arith a) => a -> a -> a
-
-/**
- * For words, takes the modulus of two words, modulus 2^^a.
- * Over structured values, operates element-wise.
- * Be careful, as this will often give unexpected results due to interaction of
- * the two moduli.
- */
-primitive (%) : {a} (Arith a) => a -> a -> a
-
-/**
- * For words, takes the exponent of two words, modulus 2^^a.
- * Over structured values, operates element-wise.
- * Be careful, due to its fast-growing nature, exponentiation is prone to
- * interacting poorly with defaulting.
- */
-primitive (^^) : {a} (Arith a) => a -> a -> a
-
-/**
- * Log base two.
- *
- * For words, computes the ceiling of log, base 2, of a number.
- * Over structured values, operates element-wise.
- */
-primitive lg2 : {a} (Arith a) => a -> a
-
-
-type Bool = Bit
-
-/**
- * The constant True. Corresponds to the bit value 1.
- */
-primitive True : Bit
-
-/**
- * The constant False. Corresponds to the bit value 0.
- */
-primitive False : Bit
-
-/**
- * Returns the twos complement of its argument.
- * Over structured values, operates element-wise.
- * negate a = ~a + 1
- */
-primitive negate : {a} (Arith a) => a -> a
-
-/**
- * Binary complement.
- */
-primitive complement : {a} a -> a
-
-/**
- * Operator form of binary complement.
- */
-(~) : {a} a -> a
-(~) = complement
-
-/**
- * Less-than. Only works on comparable arguments.
- */
-primitive (<) : {a} (Cmp a) => a -> a -> Bit
-
-/**
- * Greater-than of two comparable arguments.
- */
-primitive (>) : {a} (Cmp a) => a -> a -> Bit
-
-/**
- * Less-than or equal of two comparable arguments.
- */
-primitive (<=) : {a} (Cmp a) => a -> a -> Bit
-
-/**
- * Greater-than or equal of two comparable arguments.
- */
-primitive (>=) : {a} (Cmp a) => a -> a -> Bit
-
-/**
- * Compares any two values of the same type for equality.
- */
-primitive (==) : {a} (Cmp a) => a -> a -> Bit
-
-/**
- * Compares any two values of the same type for inequality.
- */
-primitive (!=) : {a} (Cmp a) => a -> a -> Bit
-
-/**
- * Compare the outputs of two functions for equality
- */
-(===) : {a,b} (Cmp b) => (a -> b) -> (a -> b) -> (a -> Bit)
-f === g = \ x -> f x == g x
-
-/**
- * Compare the outputs of two functions for inequality
- */
-(!==) : {a,b} (Cmp b) => (a -> b) -> (a -> b) -> (a -> Bit)
-f !== g = \x -> f x != g x
-
-/**
- * Returns the smaller of two comparable arguments.
- */
-min : {a} (Cmp a) => a -> a -> a
-min x y = if x < y then x else y
-
-/**
- * Returns the greater of two comparable arguments.
- */
-max : {a} (Cmp a) => a -> a -> a
-max x y = if x > y then x else y
-
-/**
- * Logical `and' over bits. Extends element-wise over sequences, tuples.
- */
-primitive (&&) : {a} a -> a -> a
-
-/**
- * Logical `or' over bits. Extends element-wise over sequences, tuples.
- */
-primitive (||) : {a} a -> a -> a
-
-/**
- * Logical `exclusive or' over bits. Extends element-wise over sequences, tuples.
- */
-primitive (^) : {a} a -> a -> a
-
-/**
- * Gives an arbitrary shaped value whose bits are all False.
- * ~zero likewise gives an arbitrary shaped value whose bits are all True.
- */
-primitive zero : {a} a
-
-/**
- * Left shift. The first argument is the sequence to shift, the second is the
- * number of positions to shift by.
-*/
-primitive (<<) : {a, b, c} (fin b) => [a]c -> [b] -> [a]c
-
-/**
- * Right shift. The first argument is the sequence to shift, the second is the
- * number of positions to shift by.
- */
-primitive (>>) : {a, b, c} (fin b) => [a]c -> [b] -> [a]c
-
-/**
- * Left rotate. The first argument is the sequence to rotate, the second is the
- * number of positions to rotate by.
- */
-primitive (<<<) : {a, b, c} (fin a, fin b) => [a]c -> [b] -> [a]c
-
-/**
- * Right rotate. The first argument is the sequence to rotate, the second is
- * the number of positions to rotate by.
- */
-primitive (>>>) : {a, b, c} (fin a, fin b) => [a]c -> [b] -> [a]c
-
-primitive (#) : {front, back, a} (fin front) => [front]a -> [back]a
- -> [front + back] a
-
-
-/**
- * Split a sequence into a tuple of sequences.
- */
-primitive splitAt : {front, back, a} (fin front) => [front + back]a
- -> ([front]a, [back]a)
-/**
- * Joins sequences.
- */
-primitive join : {parts, each, a} (fin each) => [parts][each]a
- -> [parts * each]a
-
-/**
- * Splits a sequence into 'parts' groups with 'each' elements.
- */
-primitive split : {parts, each, a} (fin each) => [parts * each]a
- -> [parts][each]a
-
-/**
- * Reverses the elements in a sequence.
- */
-primitive reverse : {a, b} (fin a) => [a]b -> [a]b
-
-/**
- * Transposes an [a][b] matrix into a [b][a] matrix.
- */
-primitive transpose : {a, b, c} [a][b]c -> [b][a]c
-
-/**
- * Index operator. The first argument is a sequence. The second argument is
- * the zero-based index of the element to select from the sequence.
- */
-primitive (@) : {a, b, c} (fin c) => [a]b -> [c] -> b
-
-/**
- * Bulk index operator. The first argument is a sequence. The second argument
- * is a sequence of the zero-based indices of the elements to select.
- */
-primitive (@@) : {a, b, c, d} (fin d) => [a]b -> [c][d] -> [c]b
-
-/**
- * Reverse index operator. The first argument is a finite sequence. The second
- * argument is the zero-based index of the element to select, starting from the
- * end of the sequence.
- */
-primitive (!) : {a, b, c} (fin a, fin c) => [a]b -> [c] -> b
-
-/**
- * Bulk reverse index operator. The first argument is a finite sequence. The
- * second argument is a sequence of the zero-based indices of the elements to
- z select, starting from the end of the sequence.
- */
-primitive (!!) : {a, b, c, d} (fin a, fin d) => [a]b -> [c][d] -> [c]b
-
-primitive fromTo : {first, last, bits} (fin last, fin bits, last >= first,
- bits >= width last) => [1 + (last - first)][bits]
-
-primitive fromThenTo : {first, next, last, bits, len} (fin first, fin next,
- fin last, fin bits, bits >= width first,
- bits >= width next, bits >= width last,
- lengthFromThenTo first next last == len) => [len][bits]
-
-primitive infFrom : {bits} (fin bits) => [bits] -> [inf][bits]
-
-primitive infFromThen : {bits} (fin bits) => [bits] -> [bits] -> [inf][bits]
-
-primitive error : {at, len} (fin len) => [len][8] -> at
-
-
-/**
- * Performs multiplication of polynomials over GF(2).
- */
-primitive pmult : {a, b} (fin a, fin b) => [a] -> [b] -> [max 1 (a + b) - 1]
-
-/**
- * Performs division of polynomials over GF(2).
- */
-primitive pdiv : {a, b} (fin a, fin b) => [a] -> [b] -> [a]
-
-/**
- * Performs modulus of polynomials over GF(2).
- */
-primitive pmod : {a, b} (fin a, fin b) => [a] -> [1 + b] -> [b]
-
-/**
- * Generates random values from a seed. When called with a function, currently
- * generates a function that always returns zero.
- */
-primitive random : {a} [256] -> a
-
-type String n = [n][8]
-type Word n = [n]
-type Char = [8]
-
-take : {front,back,elem} (fin front) => [front + back] elem -> [front] elem
-take (x # _) = x
-
-drop : {front,back,elem} (fin front) => [front + back] elem -> [back] elem
-drop ((_ : [front] _) # y) = y
-
-tail : {a, b} [1 + a]b -> [a]b
-tail xs = drop`{1} xs
-
-width : {bits,len,elem} (fin len, fin bits, bits >= width len) => [len] elem -> [bits]
-width _ = `len
-
-undefined : {a} a
-undefined = error "undefined"
-
-groupBy : {each,parts,elem} (fin each) =>
- [parts * each] elem -> [parts][each]elem
-groupBy = split`{parts=parts}
-
-/**
- * Define the base 2 logarithm function in terms of width
- */
-type lg2 n = width (max n 1 - 1)
-
-/**
- * Debugging function for tracing. The first argument is a string,
- * which is prepended to the printed value of the second argument.
- * This combined string is then printed when the trace function is
- * evaluated. The return value is equal to the third argument.
- *
- * The exact timing and number of times the trace message is printed
- * depend on the internal details of the Cryptol evaluation order,
- * which are unspecified. Thus, the output produced by this
- * operation may be difficult to predict.
- */
-primitive trace : {n, a, b} [n][8] -> a -> b -> b
-
-/**
- * Debugging function for tracing values. The first argument is a string,
- * which is prepended to the printed value of the second argument.
- * This combined string is then printed when the trace function is
- * evaluated. The return value is equal to the second argument.
- *
- * The exact timing and number of times the trace message is printed
- * depend on the internal details of the Cryptol evaluation order,
- * which are unspecified. Thus, the output produced by this
- * operation may be difficult to predict.
- */
-traceVal : {n, a} [n][8] -> a -> a
-traceVal msg x = trace msg x x
-
-/*
- * Copyright (c) 2016 Galois, Inc.
- * Distributed under the terms of the BSD3 license (see LICENSE file)
- *
- * This module contains definitions that we wish to eventually promote
- * into the Prelude, but which currently cause typechecking of the
- * Prelude to take too long (see #299)
- */
-
-infixr 5 ==>
-
-/**
- * Logical implication
- */
-(==>) : Bit -> Bit -> Bit
-a ==> b = if a then b else True
-
-/**
- * Logical negation
- */
-not : {a} a -> a
-not a = ~ a
-
-/**
- * Conjunction
- */
-and : {n} (fin n) => [n]Bit -> Bit
-and xs = ~zero == xs
-
-/**
- * Disjunction
- */
-or : {n} (fin n) => [n]Bit -> Bit
-or xs = zero != xs
-
-/**
- * Conjunction after applying a predicate to all elements.
- */
-all : {a,n} (fin n) => (a -> Bit) -> [n]a -> Bit
-all f xs = and (map f xs)
-
-/**
- * Disjunction after applying a predicate to all elements.
- */
-any : {a,n} (fin n) => (a -> Bit) -> [n]a -> Bit
-any f xs = or (map f xs)
-
-/**
- * Map a function over an array.
- */
-map : {a, b, n} (a -> b) -> [n]a -> [n]b
-map f xs = [f x | x <- xs]
-
-/**
- * Functional left fold.
- *
- * foldl (+) 0 [1,2,3] = ((0 + 1) + 2) + 3
- */
-foldl : {a, b, n} (fin n) => (a -> b -> a) -> a -> [n]b -> a
-foldl f acc xs = ys ! 0
- where ys = [acc] # [f a x | a <- ys | x <- xs]
-
-/**
- * Functional right fold.
- *
- * foldr (-) 0 [1,2,3] = 0 - (1 - (2 - 3))
- */
-foldr : {a,b,n} (fin n) => (a -> b -> b) -> b -> [n]a -> b
-foldr f acc xs = ys ! 0
- where ys = [acc] # [f x a | a <- ys | x <- reverse xs]
-
-/**
- * Compute the sum of the words in the array.
- */
-sum : {a,n} (fin n, Arith a) => [n]a -> a
-sum xs = foldl (+) zero xs
-
-/**
- * Scan left is like a fold that emits the intermediate values.
- */
-scanl : {b, a, n} (b -> a -> b) -> b -> [n]a -> [n+1]b
-scanl f acc xs = ys
- where
- ys = [acc] # [f a x | a <- ys | x <- xs]
-
-/**
- * Scan right
- */
-scanr : {a,b,n} (fin n) => (a -> b -> b) -> b -> [n]a -> [n+1]b
-scanr f acc xs = reverse ys
- where
- ys = [acc] # [f x a | a <- ys | x <- reverse xs]
-
-/**
- * Zero extension
- */
-extend : {total,n} (fin total, fin n, total >= n) => [n]Bit -> [total]Bit
-extend n = zero # n
-
-/**
- * Signed extension. `extendSigned 0bwxyz : [8] == 0bwwwwwxyz`.
- */
-extendSigned : {total,n} (fin total, fin n, n >= 1, total >= n+1) => [n]Bit -> [total]Bit
-extendSigned xs = repeat (xs @ 0) # xs
-
-/**
- * Repeat a value.
- */
-repeat : {n, a} a -> [n]a
-repeat x = [ x | _ <- zero ]
-
-/**
- * `elem x xs` Returns true if x is equal to a value in xs.
- */
-elem : {n,a} (fin n, Cmp a) => a -> [n]a -> Bit
-elem a xs = any (\x -> x == a) xs
-
-/**
- * Create a list of tuples from two lists.
- */
-zip : {a,b,n} [n]a -> [n]b -> [n](a,b)
-zip xs ys = [(x,y) | x <- xs | y <- ys]
-
-/**
- * Create a list by applying the function to each pair of elements in the input.
- * lists
- */
-zipWith : {a,b,c,n} (a -> b -> c) -> [n]a -> [n]b -> [n]c
-zipWith f xs ys = [f x y | x <- xs | y <- ys]
-
-/**
- * Transform a function into uncurried form.
- */
-uncurry : {a,b,c} (a -> b -> c) -> (a,b) -> c
-uncurry f = \(a,b) -> f a b
-
-/**
- * Transform a function into curried form.
- */
-curry : {a,b,c} ((a, b) -> c) -> a -> b -> c
-curry f = \a b -> f (a,b)
-
-/**
- * Map a function iteratively over a seed value, producing an infinite
- * list of successive function applications.
- */
-iterate : { a } (a -> a) -> a -> [inf]a
-iterate f x = [x] # [ f v | v <- iterate f x ]
diff --git a/cryptol.cabal b/cryptol.cabal
--- a/cryptol.cabal
+++ b/cryptol.cabal
@@ -1,5 +1,5 @@
Name: cryptol
-Version: 2.8.0
+Version: 2.9.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
@@ -8,7 +8,7 @@
Maintainer: cryptol@galois.com
Homepage: http://www.cryptol.net/
Bug-reports: https://github.com/GaloisInc/cryptol/issues
-Copyright: 2013-2019 Galois Inc.
+Copyright: 2013-2020 Galois Inc.
Category: Language
Build-type: Simple
Cabal-version: 1.18
@@ -25,7 +25,7 @@
source-repository this
type: git
location: https://github.com/GaloisInc/cryptol.git
- tag: 2.8.0
+ tag: 2.9.0
flag static
default: False
@@ -44,42 +44,44 @@
Default-language:
Haskell2010
Build-depends: base >= 4.8 && < 5,
- base-compat >= 0.6 && < 0.11,
+ async >= 2.2 && < 2.3,
+ base-compat >= 0.6 && < 0.12,
+ bv-sized >= 1.0 && < 1.1,
bytestring >= 0.10,
array >= 0.4,
containers >= 0.5,
cryptohash-sha1 >= 0.11 && < 0.12,
deepseq >= 1.3,
directory >= 1.2.2.0,
+ exceptions,
filepath >= 1.3,
gitrev >= 1.0,
GraphSCC >= 1.0.4,
heredoc >= 0.2,
+ libBF >= 0.5.1,
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.1,
+ sbv >= 8.6,
simple-smt >= 0.7.1,
strict,
text >= 1.1,
tf-random >= 0.5,
transformers-base >= 0.4,
mtl >= 2.2.1,
- time >= 1.6.0.1,
- panic >= 0.3
-
+ time >= 1.6.0.1,
+ panic >= 0.3,
+ what4 >= 1.0 && < 1.1
Build-tools: alex, happy
hs-source-dirs: src
- Exposed-modules: Cryptol.Prims.Eval,
-
- Cryptol.Parser,
+ Exposed-modules: Cryptol.Parser,
Cryptol.Parser.Lexer,
Cryptol.Parser.AST,
- Cryptol.Parser.Fixity,
Cryptol.Parser.Position,
Cryptol.Parser.Names,
Cryptol.Parser.Name,
@@ -89,7 +91,9 @@
Cryptol.Parser.Utils,
Cryptol.Parser.Unlit,
+ Cryptol.Utils.Fixity,
Cryptol.Utils.Ident,
+ Cryptol.Utils.RecordMap,
Cryptol.Utils.PP,
Cryptol.Utils.Panic,
Cryptol.Utils.Debug,
@@ -155,18 +159,28 @@
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.Testing.Concrete,
Cryptol.Testing.Random,
Cryptol.Symbolic,
- Cryptol.Symbolic.Prims,
- Cryptol.Symbolic.Value,
+ Cryptol.Symbolic.SBV,
+ Cryptol.Symbolic.What4,
Cryptol.REPL.Command,
Cryptol.REPL.Monad,
@@ -178,10 +192,12 @@
Paths_cryptol,
GitRev
- GHC-options: -Wall -fsimpl-tick-factor=140
+ GHC-options: -Wall -fsimpl-tick-factor=140 -O2
if impl(ghc >= 8.0.1)
ghc-options: -Wno-redundant-constraints
+ ghc-prof-options: -O2 -fprof-auto-top
+
if flag(relocatable)
cpp-options: -DRELOCATABLE
@@ -201,14 +217,16 @@
, cryptol
, directory
, filepath
- , haskeline
+ , haskeline >= 0.7 && < 0.9
, monad-control
, text
, transformers
- GHC-options: -Wall -threaded -rtsopts "-with-rtsopts=-N1 -A64m"
+ GHC-options: -Wall -threaded -rtsopts "-with-rtsopts=-N1 -A64m" -O2
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
@@ -256,7 +274,7 @@
main-is: Main.hs
hs-source-dirs: bench
default-language: Haskell2010
- GHC-options: -Wall -threaded -rtsopts "-with-rtsopts=-N1 -A64m"
+ GHC-options: -Wall -threaded -rtsopts "-with-rtsopts=-N1 -A64m" -O2
if impl(ghc >= 8.0.1)
ghc-options: -Wno-redundant-constraints
if os(linux) && flag(static)
@@ -267,5 +285,5 @@
, deepseq
, directory
, filepath
- , sbv >= 8.1
+ , sbv
, text
diff --git a/cryptol/Main.hs b/cryptol/Main.hs
--- a/cryptol/Main.hs
+++ b/cryptol/Main.hs
@@ -55,6 +55,7 @@
, optCryptolrc :: Cryptolrc
, optCryptolPathOnly :: Bool
, optStopOnError :: Bool
+ , optNoUnicodeLogo :: Bool
} deriving (Show)
defaultOptions :: Options
@@ -68,6 +69,7 @@
, optCryptolrc = CryrcDefault
, optCryptolPathOnly = False
, optStopOnError = False
+ , optNoUnicodeLogo = False
}
options :: [OptDescr (OptParser Options)]
@@ -95,6 +97,9 @@
, Option "h" ["help"] (NoArg setHelp)
"display this message"
+ , Option "" ["no-unicode-logo"] (NoArg setNoUnicodeLogo)
+ "Don't use unicode characters in the REPL logo"
+
, Option "" ["ignore-cryptolrc"] (NoArg setCryrcDisabled)
"disable reading of .cryptolrc files"
@@ -130,6 +135,10 @@
setColorMode "always" = modify $ \ opts -> opts { optColorMode = AlwaysColor }
setColorMode x = OptFailure ["invalid color mode: " ++ x ++ "\n"]
+-- | Disable unicde characters in the REPL logo
+setNoUnicodeLogo :: OptParser Options
+setNoUnicodeLogo = modify $ \opts -> opts { optNoUnicodeLogo = True }
+
-- | Signal that version should be displayed.
setVersion :: OptParser Options
setVersion = modify $ \ opts -> opts { optVersion = True }
@@ -257,7 +266,9 @@
AlwaysColor -> return True
NoColor -> return False
AutoColor -> canDisplayColor
- displayLogo color
+
+ let useUnicode = not (optNoUnicodeLogo opts)
+ displayLogo color useUnicode
setUpdateREPLTitle (shouldSetREPLTitle >>= \b -> when b setREPLTitle)
updateREPLTitle
diff --git a/cryptol/REPL/Haskeline.hs b/cryptol/REPL/Haskeline.hs
--- a/cryptol/REPL/Haskeline.hs
+++ b/cryptol/REPL/Haskeline.hs
@@ -6,6 +6,7 @@
-- Stability : provisional
-- Portability : portable
+{-# LANGUAGE CPP #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE PatternGuards #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
@@ -22,20 +23,22 @@
import qualified Control.Exception as X
import Control.Monad (guard, join)
import qualified Control.Monad.Trans.Class as MTL
+#if !MIN_VERSION_haskeline(0,8,0)
import Control.Monad.Trans.Control
+#endif
import Data.Char (isAlphaNum, isSpace)
-import Data.Maybe(isJust)
import Data.Function (on)
import Data.List (isPrefixOf,nub,sortBy,sort)
+import Data.Maybe(isJust)
import qualified Data.Set as Set
import qualified Data.Text as T (unpack)
-import System.IO (stdout)
import System.Console.ANSI (setTitle, hSupportsANSI)
import System.Console.Haskeline
import System.Directory ( doesFileExist
, getHomeDirectory
, getCurrentDirectory)
import System.FilePath (())
+import System.IO (stdout)
import Prelude ()
import Prelude.Compat
@@ -128,7 +131,7 @@
setHistoryFile ss =
do dir <- getHomeDirectory
return ss { historyFile = Just (dir ".cryptol_history") }
- `X.catch` \(SomeException {}) -> return ss
+ `X.catch` \(X.SomeException {}) -> return ss
-- | Haskeline settings for the REPL.
replSettings :: Bool -> Settings REPL
@@ -159,9 +162,11 @@
-- Utilities -------------------------------------------------------------------
+#if !MIN_VERSION_haskeline(0,8,0)
instance MonadException REPL where
controlIO f = join $ liftBaseWith $ \f' ->
f $ RunIO $ \m -> restoreM <$> (f' m)
+#endif
-- Titles ----------------------------------------------------------------------
diff --git a/cryptol/REPL/Logo.hs b/cryptol/REPL/Logo.hs
--- a/cryptol/REPL/Logo.hs
+++ b/cryptol/REPL/Logo.hs
@@ -35,15 +35,17 @@
versionText = "version " ++ showVersion version ++ hashText
ver = sgr [SetColor Foreground Dull White]
++ replicate (lineLen - 20 - length versionText) ' '
- ++ versionText
+ ++ versionText ++ "\n"
+ ++ "https://cryptol.net :? for help"
ls = mk ver
slen = length ls `div` 3
(ws,rest) = splitAt slen ls
(vs,ds) = splitAt slen rest
lineLen = length (head ls)
-displayLogo :: Bool -> REPL ()
-displayLogo useColor = unlessBatch (io (mapM_ putStrLn (logo useColor logo2)))
+displayLogo :: Bool -> Bool -> REPL ()
+displayLogo useColor useUnicode =
+ unlessBatch (io (mapM_ putStrLn (logo useColor (if useUnicode then logo2 else logo1))))
logo1 :: String -> [String]
logo1 ver =
diff --git a/lib/Array.cry b/lib/Array.cry
new file mode 100644
--- /dev/null
+++ b/lib/Array.cry
@@ -0,0 +1,13 @@
+/*
+ * Copyright (c) 2020 Galois, Inc.
+ * Distributed under the terms of the BSD3 license (see LICENSE file)
+ */
+
+module Array where
+
+primitive type Array : * -> * -> *
+
+primitive arrayConstant : {a, b} b -> (Array a b)
+primitive arrayLookup : {a, b} (Array a b) -> a -> b
+primitive arrayUpdate : {a, b} (Array a b) -> a -> b -> (Array a b)
+
diff --git a/lib/Cryptol.cry b/lib/Cryptol.cry
--- a/lib/Cryptol.cry
+++ b/lib/Cryptol.cry
@@ -1,21 +1,10 @@
/*
- * Copyright (c) 2013-2016 Galois, Inc.
+ * Copyright (c) 2013-2020 Galois, Inc.
* Distributed under the terms of the BSD3 license (see LICENSE file)
*/
module Cryptol where
-/**
- * The value corresponding to a numeric type.
- */
-primitive number : {val, rep} Literal val rep => rep
-
-/**
- * An alternative name for 'number', present for backward compatibility.
- */
-demote : {val, rep} Literal val rep => rep
-demote = number`{val}
-
infixr 5 ==>
infixr 10 \/
infixr 15 /\
@@ -31,10 +20,8 @@
infixr 95 ^^
infixl 100 @, @@, !, !!
-// -----------------------------------------------------------------------------
-/** A numeric type representing infinity. */
-primitive type inf : #
+// Base types -----------------------------------------------------------------------
/** The type of boolean values. */
primitive type Bit : *
@@ -42,11 +29,45 @@
/** The type of unbounded integers. */
primitive type Integer : *
-/** 'Z n' is the type of integers, modulo 'n'. */
+/**
+ * 'Z n' is the type of integers, modulo 'n'.
+ *
+ * The values of 'Z n' may be thought of as equivalance
+ * classes of integers according to the equivalence
+ * 'x ~ y' iff 'n' divides 'x - y'. 'Z n' naturally
+ * forms a ring, but does not support integral division
+ * or indexing.
+ *
+ * However, you may use the 'fromZ' operation
+ * to project values in 'Z n' into the integers if such operations
+ * are required. This will compute the reduced representative
+ * 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.
+ */
primitive type {n : #} (fin n, n >= 1) => Z n : *
+/**
+ * 'Rational' is the type of rational numbers.
+ * Rational numbers form a Field (and thus a Ring).
+ *
+ * The 'ratio' operation may be used to directly create
+ * rational values from as a ratio of integers, or
+ * the 'fromInteger' method and the field operations
+ * can be used.
+ */
+primitive type Rational : *
+type Bool = Bit
+type Word n = [n]
+type Char = [8]
+type String n = [n]Char
+// Numeric operators and constraints ----------------------------------------------
+
+/** A numeric type representing infinity. */
+primitive type inf : #
+
/** Assert that two numeric types are equal. */
primitive type (==) : # -> # -> Prop
@@ -57,40 +78,20 @@
primitive type (>=) : # -> # -> Prop
/** Assert that a numeric type is a proper natural number (not 'inf'). */
-primitive type fin : * -> Prop
-
-/** Value types that have a notion of 'zero'. */
-primitive type Zero : * -> Prop
-
-/** Value types that support logical operations. */
-primitive type Logic : * -> Prop
-
-/** Value types that support arithmetic. */
-primitive type Arith : * -> Prop
-
-/** Value types that support unsigned comparisons. */
-primitive type Cmp : * -> Prop
-
-/** Value types that support signed comparisons. */
-primitive type SignedCmp : * -> Prop
-
-/** 'Literal n a' asserts that type 'a' contains the number 'n'. */
-primitive type Literal : # -> * -> Prop
-
-
+primitive type fin : # -> Prop
/** Add numeric types. */
primitive type (+) : # -> # -> #
+/** Multiply numeric types. */
+primitive type (*) : # -> # -> #
+
/** Subtract numeric types. */
primitive type
{m : #, n : # }
(fin n, m >= n) =>
m - n : #
-/** Multiply numeric types. */
-primitive type (*) : # -> # -> #
-
/** Divide numeric types, rounding down. */
primitive type
{ m : #, n : # }
@@ -109,6 +110,11 @@
/** The number of bits required to represent the value of a numeric type. */
primitive type width : # -> #
+/**
+ * Define the base 2 logarithm function in terms of width
+ */
+type lg2 n = width (max n 1 - 1)
+
/** The smaller of two numeric types. */
primitive type min : # -> # -> #
@@ -133,11 +139,6 @@
(fin start, fin next, fin last, start != next) =>
lengthFromThenTo start next last : #
-
-
-
-// -----------------------------------------------------------------------------
-
/**
* Assert that the first numeric type is less than or equal to the second.
*/
@@ -153,12 +154,132 @@
*/
type constraint i < j = j >= i + 1
+
+// The Literal class ----------------------------------------------------
+
+/** 'Literal n a' asserts that type 'a' contains the number 'n'. */
+primitive type Literal : # -> * -> Prop
+
/**
+ * The value corresponding to a numeric type.
+ */
+primitive number : {val, rep} Literal val rep => rep
+
+/**
+ * An alternative name for 'number', present for backward compatibility.
+ */
+demote : {val, rep} Literal val rep => rep
+demote = number`{val}
+
+/**
+ * Return the length of a sequence. Note that the result depends only
+ * on the type of the argument, not its value.
+ */
+length : {n, a, b} (fin n, Literal n b) => [n]a -> b
+length _ = `n
+
+/**
+ * A finite sequence counting up from 'first' to 'last'.
+ *
+ * '[a..b]' is syntactic sugar for 'fromTo`{first=a,last=b}'.
+ */
+primitive fromTo : {first, last, a} (fin last, last >= first,
+ Literal first a, Literal last a) =>
+ [1 + (last - first)]a
+
+/**
+ * A finite arithmetic sequence starting with 'first' and 'next',
+ * stopping when the values reach or would skip over 'last'.
+ *
+ * '[a,b..c]' is syntactic sugar for 'fromThenTo`{first=a,next=b,last=c}'.
+ */
+primitive fromThenTo : {first, next, last, a, len}
+ ( fin first, fin next, fin last
+ , Literal first a, Literal next a, Literal last a
+ , first != next
+ , lengthFromThenTo first next last == len) => [len]a
+
+// Fractional Literals ---------------------
+
+/** 'FLiteral m n r a' asserts that the type `a' contains the
+fraction `m/n`. The flag `r` indicates if we should round (`r >= 1`)
+or report an error if the number can't be represented exactly. */
+primitive type FLiteral : # -> # -> # -> * -> Prop
+
+/** A fractional literal corresponding to `m/n` */
+primitive
+ fraction : { m, n, r, a } FLiteral m n r a => a
+
+
+
+
+
+
+
+// The Zero class -------------------------------------------------------
+
+/** Value types that have a notion of 'zero'. */
+primitive type Zero : * -> Prop
+
+/**
+ * Gives an arbitrary shaped value whose bits are all False.
+ * ~zero likewise gives an arbitrary shaped value whose bits are all True.
+ */
+primitive zero : {a} (Zero a) => a
+
+
+// The Logic class ------------------------------------------------------
+
+/** Value types that support logical operations. */
+primitive type Logic : * -> Prop
+
+/**
+ * Logical 'and' over bits. Extends element-wise over sequences, tuples.
+ */
+primitive (&&) : {a} (Logic a) => a -> a -> a
+
+/**
+ * Logical 'or' over bits. Extends element-wise over sequences, tuples.
+ */
+primitive (||) : {a} (Logic a) => a -> a -> a
+
+/**
+ * Logical 'exclusive or' over bits. Extends element-wise over sequences, tuples.
+ */
+primitive (^) : {a} (Logic a) => a -> a -> a
+
+/**
+ * Bitwise complement. The prefix notation '~ x'
+ * is syntactic sugar for 'complement x'.
+ */
+primitive complement : {a} (Logic a) => a -> a
+
+
+// The Ring class -------------------------------------------------------
+
+/**
+ * Value types that support ring addition and multiplication.
+ *
+ * Floating-point values are only approximately a ring, but
+ * nonetheless inhabit this class.
+ */
+primitive type Ring : * -> Prop
+
+/**
+ * Converts an unbounded integer to a value in a Ring. When converting
+ * to the bitvector type [n], the value is reduced modulo 2^^n. Likewise,
+ * when converting to Z n, the value is reduced modulo n. When converting
+ * to a floating-point value, the value is rounded to the nearest
+ * representable value.
+ */
+primitive fromInteger : {a} (Ring a) => Integer -> a
+
+/**
* Add two values.
* * For type [n], addition is modulo 2^^n.
* * Structured values are added element-wise.
*/
-primitive (+) : {a} (Arith a) => a -> a -> a
+primitive (+) : {a} (Ring a) => a -> a -> a
/**
* Subtract two values.
@@ -167,128 +288,218 @@
* * Satisfies 'a - b = a + negate b'.
* See also: 'negate'.
*/
-primitive (-) : {a} (Arith a) => a -> a -> a
+primitive (-) : {a} (Ring a) => a -> a -> a
/**
* Multiply two values.
* * For type [n], multiplication is modulo 2^^n.
* * Structured values are multiplied element-wise.
*/
-primitive (*) : {a} (Arith a) => a -> a -> a
+primitive (*) : {a} (Ring a) => a -> a -> a
/**
- * Divide two values, rounding down.
+ * Returns the additive inverse of its argument.
+ * Over structured values, operates element-wise.
+ * The prefix notation '- x' is syntactic sugar
+ * for 'negate x'.
+ *
+ * Satisfies 'a + negate a = 0'.
+ * Satisfies 'negate a = ~a + 1' for bitvector values.
+ */
+primitive negate : {a} (Ring a) => a -> a
+
+
+// The Integral class -------------------------------------------------
+
+/**
+ * Value types that correspond to a segment of the
+ * integers. These types support integer division and
+ * modulus, indexing into sequences, and enumeration.
+ */
+primitive type Integral : * -> Prop
+
+/**
+ * Divide two values, rounding down (toward negative infinity).
* * For type [n], the arguments are treated as unsigned.
- * * Structured values are divided element-wise.
* * Division by zero is undefined.
*/
-primitive (/) : {a} (Arith a) => a -> a -> a
+primitive (/) : {a} (Integral a) => a -> a -> a
/**
* Compute the remainder from dividing two values.
* * For type [n], the arguments are treated as unsigned.
- * * Structured values are combined element-wise.
* * Remainder of division by zero is undefined.
* * Satisfies 'x % y == x - (x / y) * y'.
*/
-primitive (%) : {a} (Arith a) => a -> a -> a
+primitive (%) : {a} (Integral a) => a -> a -> a
/**
- * Compute the exponentiation of two values.
- * * For type [n], the exponent is treated as unsigned,
- * and the result is reduced modulo 2^^n.
- * * For type Integer, negative powers are undefined.
- * * Structured values are combined element-wise.
+ * Converts a value of an integral type to an integer.
*/
-primitive (^^) : {a} (Arith a) => a -> a -> a
+primitive toInteger : {a} (Integral a) => a -> Integer
/**
- * Log base two.
- *
- * For words, computes the ceiling of log, base 2, of a number.
- * Over structured values, operates element-wise.
+ * Compute the exponentiation of a value in a ring.
+ * * For type [n], the exponent is treated as unsigned.
+ * * It is an error to raise a value to a negative integer exponent.
+ * * Satisfies: 'x ^^ 0 == fromInteger 1'
+ * * Satisfies: 'x ^^ e == x * x ^^ (e-1)' when 'e > 0'.
*/
-primitive lg2 : {a} (Arith a) => a -> a
+primitive (^^) : {a, e} (Ring a, Integral e) => a -> e -> a
+/**
+ * An infinite sequence counting up from the given starting value.
+ * '[x...]' is syntactic sugar for 'infFrom x'.
+ */
+primitive infFrom : {a} (Integral a) => a -> [inf]a
-type Bool = Bit
+/**
+ * An infinite arithmetic sequence starting with the given two values.
+ * '[x,y...]' is syntactic sugar for 'infFromThen x y'.
+ */
+primitive infFromThen : {a} (Integral a) => a -> a -> [inf]a
+
+// The Field class -------------------------------------------------
+
/**
- * The constant True. Corresponds to the bit value 1.
+ * Value types that correspond to a field; that is,
+ * a ring also posessing multiplicative inverses for
+ * non-zero elements.
+ *
+ * Floating-point values are only approximately a field,
+ * but nonetheless inhabit this class.
*/
-primitive True : Bit
+primitive type Field : * -> Prop
/**
- * The constant False. Corresponds to the bit value 0.
+ * Reciprocal
+ *
+ * Compute the multiplicative inverse of an element of a field.
+ * The reciprocal of 0 is undefined.
*/
-primitive False : Bit
+primitive recip : {a} (Field a) => a -> a
/**
- * Returns the two's complement of its argument.
- * Over structured values, operates element-wise.
- * The prefix notation '- x' is syntactic sugar
- * for 'negate x'.
- * Satisfies 'negate a = ~a + 1'.
+ * Field division
+ *
+ * The division operation in a field.
+ * Satisfies 'x /. y == x * (recip y)'
+ *
+ * Field division by 0 is undefined.
*/
-primitive negate : {a} (Arith a) => a -> a
+primitive (/.) : {a} (Field a) => a -> a -> a
+
+// The Round class -------------------------------------------------
+
+/** Value types that can be rounded to integer values. */
+primitive type Round : * -> Prop
+
/**
- * Bitwise complement. The prefix notation '~ x'
- * is syntactic sugar for 'complement x'.
+ * Ceiling function.
+ *
+ * Given 'x', compute the smallest integer 'i'
+ * such that 'x <= i'.
*/
-primitive complement : {a} (Logic a) => a -> a
+primitive ceiling : {a} (Round a) => a -> Integer
/**
- * Less-than. Only works on comparable arguments.
+ * Floor function.
*
- * Bitvectors are compared using unsigned arithmetic.
+ * Given 'x', compute the largest integer 'i'
+ * such that 'i <= x'.
*/
-primitive (<) : {a} (Cmp a) => a -> a -> Bit
+primitive floor : {a} (Round a) => a -> Integer
/**
- * Greater-than of two comparable arguments.
+ * Truncate the value toward 0.
*
- * Bitvectors are compared using unsigned arithmetic.
+ * Given 'x' compute the nearest integer between
+ * 'x' and 0. For nonnegative 'x', this is floor,
+ * and for negative 'x' this is ceiling.
*/
-primitive (>) : {a} (Cmp a) => a -> a -> Bit
+primitive trunc : {a} (Round a) => a -> Integer
/**
- * Less-than or equal of two comparable arguments.
+ * Round to the nearest integer, ties away from 0.
*
- * Bitvectors are compared using unsigned arithmetic.
+ * Ties are broken away from 0. For nonnegative 'x'
+ * this is 'floor (x + 0.5)'. For negative 'x' this
+ * is 'ceiling (x - 0.5)'.
*/
-primitive (<=) : {a} (Cmp a) => a -> a -> Bit
+primitive roundAway : {a} (Round a) => a -> Integer
/**
- * Greater-than or equal of two comparable arguments.
+ * Round to the nearest integer, ties to even.
*
- * Bitvectors are compared using unsigned arithmetic.
+ * Ties are broken to the nearest even integer.
*/
-primitive (>=) : {a} (Cmp a) => a -> a -> Bit
+primitive roundToEven : {a} (Round a) => a -> Integer
+
+// The Eq class ----------------------------------------------------
+
+/** Value types that support equality comparisons. */
+primitive type Eq : * -> Prop
+
/**
* Compares any two values of the same type for equality.
*/
-primitive (==) : {a} (Cmp a) => a -> a -> Bit
+primitive (==) : {a} (Eq a) => a -> a -> Bit
/**
* Compares any two values of the same type for inequality.
*/
-primitive (!=) : {a} (Cmp a) => a -> a -> Bit
+primitive (!=) : {a} (Eq a) => a -> a -> Bit
/**
* Compare the outputs of two functions for equality.
*/
-(===) : {a, b} (Cmp b) => (a -> b) -> (a -> b) -> (a -> Bit)
+(===) : {a, b} (Eq b) => (a -> b) -> (a -> b) -> (a -> Bit)
f === g = \ x -> f x == g x
/**
* Compare the outputs of two functions for inequality.
*/
-(!==) : {a, b} (Cmp b) => (a -> b) -> (a -> b) -> (a -> Bit)
+(!==) : {a, b} (Eq b) => (a -> b) -> (a -> b) -> (a -> Bit)
f !== g = \x -> f x != g x
+
+// The Cmp class ---------------------------------------------------
+
+/** Value types that support equality and ordering comparisons. */
+primitive type Cmp : * -> Prop
+
/**
+ * Less-than. Only works on comparable arguments.
+ *
+ * Bitvectors are compared using unsigned arithmetic.
+ */
+primitive (<) : {a} (Cmp a) => a -> a -> Bit
+
+/**
+ * Greater-than of two comparable arguments.
+ *
+ * Bitvectors are compared using unsigned arithmetic.
+ */
+primitive (>) : {a} (Cmp a) => a -> a -> Bit
+
+/**
+ * Less-than or equal of two comparable arguments.
+ *
+ * Bitvectors are compared using unsigned arithmetic.
+ */
+primitive (<=) : {a} (Cmp a) => a -> a -> Bit
+
+/**
+ * Greater-than or equal of two comparable arguments.
+ *
+ * Bitvectors are compared using unsigned arithmetic.
+ */
+primitive (>=) : {a} (Cmp a) => a -> a -> Bit
+
+/**
* Returns the smaller of two comparable arguments.
* Bitvectors are compared using unsigned arithmetic.
*/
@@ -302,7 +513,20 @@
max : {a} (Cmp a) => a -> a -> a
max x y = if x > y then x else y
+/**
+ * Compute the absolute value of a value from an ordered ring.
+ * Bitvector values are considered unsigned, so this is
+ * the identity function on [n].
+ */
+abs : {a} (Cmp a, Ring a) => a -> a
+abs x = if x < fromInteger 0 then negate x else x
+
+// The SignedCmp class ----------------------------------------------
+
+/** Value types that support signed comparisons. */
+primitive type SignedCmp : * -> Prop
+
/**
* 2's complement signed less-than.
*/
@@ -326,47 +550,18 @@
(>=$) : {a} (SignedCmp a) => a -> a -> Bit
x >=$ y = ~(x <$ y)
-/**
- * 2's complement signed division. Division rounds toward 0.
- */
-primitive (/$) : {a} (Arith a) => a -> a -> a
-/**
- * 2's complement signed remainder. Division rounds toward 0.
- */
-primitive (%$) : {a} (Arith a) => a -> a -> a
-
-/**
- * Unsigned carry. Returns true if the unsigned addition of the given
- * bitvector arguments would result in an unsigned overflow.
- */
-primitive carry : {n} (fin n) => [n] -> [n] -> Bit
-
-/**
- * Signed carry. Returns true if the 2's complement signed addition of the
- * given bitvector arguments would result in a signed overflow.
- */
-primitive scarry : {n} (fin n, n >= 1) => [n] -> [n] -> Bit
-
-/**
- * Signed borrow. Returns true if the 2's complement signed subtraction of the
- * given bitvector arguments would result in a signed overflow.
- */
-sborrow : {n} (fin n, n >= 1) => [n] -> [n] -> Bit
-sborrow x y = ( x <$ (x-y) ) ^ y@0
+// Bit specific operations ----------------------------------------
/**
- * Zero extension of a bitvector.
+ * The constant True. Corresponds to the bit value 1.
*/
-zext : {m, n} (fin m, m >= n) => [n] -> [m]
-zext x = zero # x
+primitive True : Bit
/**
- * Sign extension of a bitvector.
+ * The constant False. Corresponds to the bit value 0.
*/
-sext : {m, n} (fin m, m >= n, n >= 1) => [n] -> [m]
-sext x = newbits # x
- where newbits = if x@0 then ~zero else zero
+primitive False : Bit
/**
* Short-cutting boolean conjunction function.
@@ -392,76 +587,103 @@
(==>) : Bit -> Bit -> Bit
a ==> b = if a then b else True
-/**
- * Logical 'and' over bits. Extends element-wise over sequences, tuples.
- */
-primitive (&&) : {a} (Logic a) => a -> a -> a
+// Bitvector specific operations ----------------------------------
+
/**
- * Logical 'or' over bits. Extends element-wise over sequences, tuples.
+ * 2's complement signed division. Division rounds toward 0.
+ * Division by 0 is undefined.
+ *
+ * * Satisfies 'x == x %$ y + (x /$ y) * y' for 'y != 0'.
*/
-primitive (||) : {a} (Logic a) => a -> a -> a
+primitive (/$) : {n} (fin n, n >= 1) => [n] -> [n] -> [n]
/**
- * Logical 'exclusive or' over bits. Extends element-wise over sequences, tuples.
+ * 2's complement signed remainder. Division rounds toward 0.
+ * Division by 0 is undefined. Satisfies the following for 'y != 0'
+ *
+ * * 'x %$ y == x - (x /$ y) * y'.
+ * * 'x >=$ 0 ==> x %$ y >=$ 0'
+ * * 'x <=$ 0 ==> x %$ y <=$ 0'
*/
-primitive (^) : {a} (Logic a) => a -> a -> a
+primitive (%$) : {n} (fin n, n >= 1) => [n] -> [n] -> [n]
/**
- * Gives an arbitrary shaped value whose bits are all False.
- * ~zero likewise gives an arbitrary shaped value whose bits are all True.
+ * Unsigned carry. Returns true if the unsigned addition of the given
+ * bitvector arguments would result in an unsigned overflow.
*/
-primitive zero : {a} (Zero a) => a
+carry : {n} (fin n) => [n] -> [n] -> Bit
+carry x y = (x + y) < x
/**
- * Converts a bitvector to a non-negative integer in the range 0 to 2^^n-1.
+ * Signed carry. Returns true if the 2's complement signed addition of the
+ * given bitvector arguments would result in a signed overflow.
*/
-primitive toInteger : {bits} (fin bits) => [bits] -> Integer
+scarry : {n} (fin n, n >= 1) => [n] -> [n] -> Bit
+scarry x y = (sx == sy) && (sx != sz)
+ where
+ z = x + y
+ sx = x@0
+ sy = y@0
+ sz = z@0
/**
- * Converts an unbounded integer to another arithmetic type. When converting
- * to the bitvector type [n], the value is reduced modulo 2^^n.
+ * Signed borrow. Returns true if the 2's complement signed subtraction of the
+ * given bitvector arguments would result in a signed overflow.
*/
-primitive fromInteger : {a} (Arith a) => Integer -> a
+sborrow : {n} (fin n, n >= 1) => [n] -> [n] -> Bit
+sborrow x y = ( x <$ (x-y) ) ^ y@0
/**
- * Converts an integer modulo n to an unbounded integer in the range 0 to n-1.
+ * Zero extension of a bitvector.
*/
-primitive fromZ : {n} (fin n, n >= 1) => Z n -> Integer
+zext : {m, n} (fin m, m >= n) => [n] -> [m]
+zext x = zero # x
/**
- * Left shift. The first argument is the sequence to shift, the second is the
- * number of positions to shift by.
-*/
-primitive (<<) : {n, ix, a} (fin ix, Zero a) => [n]a -> [ix] -> [n]a
+ * Sign extension of a bitvector.
+ */
+sext : {m, n} (fin m, m >= n, n >= 1) => [n] -> [m]
+sext x = newbits # x
+ where newbits = if x@0 then ~zero else zero
/**
- * Right shift. The first argument is the sequence to shift, the second is the
- * number of positions to shift by.
+ * 2's complement signed (arithmetic) right shift. The first argument
+ * is the sequence to shift (considered as a signed value),
+ * the second argument is the number of positions to shift
+ * by (considered as an unsigned value).
*/
-primitive (>>) : {n, ix, a} (fin ix, Zero a) => [n]a -> [ix] -> [n]a
+primitive (>>$) : {n, ix} (fin n, n >= 1, Integral ix) => [n] -> ix -> [n]
/**
- * Left rotate. The first argument is the sequence to rotate, the second is the
- * number of positions to rotate by.
+ * Log base two.
+ *
+ * For words, computes the ceiling of log, base 2, of a number.
+ * We set 'lg2 0 = 0'
*/
-primitive (<<<) : {n, ix, a} (fin n, fin ix) => [n]a -> [ix] -> [n]a
+primitive lg2 : {n} (fin n) => [n] -> [n]
+
+// Rational specific operations ----------------------------------------------
+
/**
- * Right rotate. The first argument is the sequence to rotate, the second is
- * the number of positions to rotate by.
+ * Compute the ratio of two integers as a rational.
+ * Ratio is undefined if the denominator is 0.
+ *
+ * 'ratio x y = (fromInteger x /. fromInteger y) : Rational'
*/
-primitive (>>>) : {n, ix, a} (fin n, fin ix) => [n]a -> [ix] -> [n]a
+primitive ratio : Integer -> Integer -> Rational
+
+// Zn specific operations ----------------------------------------------------
+
/**
- * 2's complement signed (arithmetic) right shift. The first argument
- * is the sequence to shift (considered as a signed value),
- * the second argument is the number of positions to shift
- * by (considered as an unsigned value).
+ * Converts an integer modulo n to an unbounded integer in the range 0 to n-1.
*/
-primitive (>>$) : {n, ix} (fin n, n >= 1, fin ix) => [n] -> [ix] -> [n]
+primitive fromZ : {n} (fin n, n >= 1) => Z n -> Integer
+// Sequence operations -------------------------------------------------------
/**
* Concatenates two sequences. On bitvectors, the most-significant bits
@@ -502,17 +724,80 @@
*/
primitive transpose : {rows, cols, a} [rows][cols]a -> [cols][rows]a
+
/**
+ * Select the first (left-most) 'front' elements of a sequence.
+ */
+take : {front, back, a} (fin front) => [front + back]a -> [front]a
+take (x # _) = x
+
+/**
+ * Select all the elements after (to the right of) the 'front' elements of a sequence.
+ */
+drop : {front, back, a} (fin front) => [front + back]a -> [back]a
+drop ((_ : [front] _) # y) = y
+
+/**
+ * Drop the first (left-most) element of a sequence.
+ */
+tail : {n, a} [1 + n]a -> [n]a
+tail xs = drop`{1} xs
+
+/**
+ * Return the first (left-most) element of a sequence.
+ */
+head : {n, a} [1 + n]a -> a
+head xs = xs @ 0
+
+/**
+ * Return the right-most element of a sequence.
+ */
+last : {n, a} (fin n) => [1 + n]a -> a
+last xs = xs ! 0
+
+/**
+ * Same as 'split', but with a different type argument order.
+ * Take a sequence of elements and break it into 'parts' sequences
+ * of 'each' elements.
+ */
+groupBy : {each, parts, a} (fin each) => [parts * each]a -> [parts][each]a
+groupBy = split`{parts=parts}
+
+/**
+ * Left shift. The first argument is the sequence to shift, the second is the
+ * number of positions to shift by.
+ */
+primitive (<<) : {n, ix, a} (Integral ix, Zero a) => [n]a -> ix -> [n]a
+
+/**
+ * Right shift. The first argument is the sequence to shift, the second is the
+ * number of positions to shift by.
+ */
+primitive (>>) : {n, ix, a} (Integral ix, Zero a) => [n]a -> ix -> [n]a
+
+/**
+ * Left rotate. The first argument is the sequence to rotate, the second is the
+ * number of positions to rotate by.
+ */
+primitive (<<<) : {n, ix, a} (fin n, Integral ix) => [n]a -> ix -> [n]a
+
+/**
+ * Right rotate. The first argument is the sequence to rotate, the second is
+ * the number of positions to rotate by.
+ */
+primitive (>>>) : {n, ix, a} (fin n, Integral ix) => [n]a -> ix -> [n]a
+
+/**
* Index operator. The first argument is a sequence. The second argument is
* the zero-based index of the element to select from the sequence.
*/
-primitive (@) : {n, a, ix} (fin ix) => [n]a -> [ix] -> a
+primitive (@) : {n, a, ix} (Integral ix) => [n]a -> ix -> a
/**
* Bulk index operator. The first argument is a sequence. The second argument
* is a sequence of the zero-based indices of the elements to select.
*/
-(@@) : {n, k, ix, a} (fin ix) => [n]a -> [k][ix] -> [k]a
+(@@) : {n, k, ix, a} (Integral ix) => [n]a -> [k]ix -> [k]a
xs @@ is = [ xs @ i | i <- is ]
/**
@@ -520,14 +805,14 @@
* argument is the zero-based index of the element to select, starting from the
* end of the sequence.
*/
-primitive (!) : {n, a, ix} (fin n, fin ix) => [n]a -> [ix] -> a
+primitive (!) : {n, a, ix} (fin n, Integral ix) => [n]a -> ix -> a
/**
* Bulk reverse index operator. The first argument is a finite sequence. The
* second argument is a sequence of the zero-based indices of the elements to
* select, starting from the end of the sequence.
*/
-(!!) : {n, k, ix, a} (fin n, fin ix) => [n]a -> [k][ix] -> [k]a
+(!!) : {n, k, ix, a} (fin n, Integral ix) => [n]a -> [k]ix -> [k]a
xs !! is = [ xs ! i | i <- is ]
/**
@@ -537,7 +822,7 @@
* The third argument is the new element. The return value is the
* initial sequence updated so that the indicated index has the given value.
*/
-primitive update : {n, a, ix} (fin ix) => [n]a -> [ix] -> a -> [n]a
+primitive update : {n, a, ix} (Integral ix) => [n]a -> ix -> a -> [n]a
/**
* Update the given sequence with new value at the given index position.
@@ -546,7 +831,7 @@
* The third argument is the new element. The return value is the
* initial sequence updated so that the indicated index has the given value.
*/
-primitive updateEnd : {n, a, ix} (fin n, fin ix) => [n]a -> [ix] -> a -> [n]a
+primitive updateEnd : {n, a, ix} (fin n, Integral ix) => [n]a -> ix -> a -> [n]a
/**
* Perform a series of updates to a sequence. The first argument is
@@ -555,7 +840,7 @@
* This function applies the 'update' function in sequence with the
* given update pairs.
*/
-updates : {n, k, ix, a} (fin ix, fin k) => [n]a -> [k][ix] -> [k]a -> [n]a
+updates : {n, k, ix, a} (Integral ix, fin k) => [n]a -> [k]ix -> [k]a -> [n]a
updates xs0 idxs vals = xss!0
where
xss = [ xs0 ] #
@@ -572,7 +857,7 @@
* This function applies the 'updateEnd' function in sequence with the
* given update pairs.
*/
-updatesEnd : {n, k, ix, a} (fin n, fin ix, fin k) => [n]a -> [k][ix] -> [k]a -> [n]a
+updatesEnd : {n, k, ix, a} (fin n, Integral ix, fin k) => [n]a -> [k]ix -> [k]a -> [n]a
updatesEnd xs0 idxs vals = xss!0
where
xss = [ xs0 ] #
@@ -583,50 +868,17 @@
]
/**
- * A finite sequence counting up from 'first' to 'last'.
- *
- * '[a..b]' is syntactic sugar for 'fromTo`{first=a,last=b}'.
- */
-primitive fromTo : {first, last, a} (fin last, last >= first, Literal last a) =>
- [1 + (last - first)]a
-
-/**
- * A finite arithmetic sequence starting with 'first' and 'next',
- * stopping when the values reach or would skip over 'last'.
- *
- * '[a,b..c]' is syntactic sugar for 'fromThenTo`{first=a,next=b,last=c}'.
- */
-primitive fromThenTo : {first, next, last, a, len}
- ( fin first, fin next, fin last
- , Literal first a, Literal next a, Literal last a
- , first != next
- , lengthFromThenTo first next last == len) => [len]a
-
-/**
- * An infinite sequence counting up from the given starting value.
- * '[x...]' is syntactic sugar for 'infFrom x'.
- */
-primitive infFrom : {a} (Arith a) => a -> [inf]a
-
-/**
- * An infinite arithmetic sequence starting with the given two values.
- * '[x,y...]' is syntactic sugar for 'infFromThen x y'.
- */
-primitive infFromThen : {a} (Arith a) => a -> a -> [inf]a
-
-/**
* Produce a sequence using a generating function.
* Satisfies 'generate f @ i == f i' for all 'i' between '0' and 'n-1'.
*
* Declarations of the form 'x @ i = e' are syntactic sugar for
* 'x = generate (\i -> e)'.
*/
-generate : {n, ix, a}
- (fin ix, n >= 1, ix >= width (n - 1)) => ([ix] -> a) -> [n]a
+generate : {n, a} (fin n, n >= 1) => (Integer -> a) -> [n]a
generate f = [ f i | i <- [0 .. n-1] ]
-primitive error : {a, len} (fin len) => [len][8] -> a
+// GF_2^n polynomial computations -------------------------------------------
/**
* Performs multiplication of polynomials over GF(2).
@@ -670,54 +922,46 @@
zs = [0] # [ z ^ (if xi then tail p else 0) | xi <- reverse x | p <- powers | z <- zs ]
-/**
- * Generates random values from a seed. When called with a function, currently
- * generates a function that always returns zero.
- */
-primitive random : {a} [256] -> a
-type String n = [n][8]
-type Word n = [n]
-type Char = [8]
-
-take : {front, back, a} (fin front) => [front + back]a -> [front]a
-take (x # _) = x
-
-drop : {front, back, a} (fin front) => [front + back]a -> [back]a
-drop ((_ : [front] _) # y) = y
-
-tail : {n, a} [1 + n]a -> [n]a
-tail xs = drop`{1} xs
+// Experimental primitives ------------------------------------------------------------
/**
- * Return the left-most element of a sequence.
+ * Parallel map. The given function is applied to each element in the
+ * given finite seqeuence, and the results are computed in parallel.
+ *
+ * This function is experimental.
*/
-head : {n, a} [1 + n]a -> a
-head xs = xs @ 0
+primitive parmap : {a, b, n} (fin n) => (a -> b) -> [n]a -> [n]b
+
+// Utility operations -----------------------------------------------------------------
+
/**
- * Return the right-most element of a sequence.
+ * Raise a run-time error with the given message.
+ * This function can be called at any type.
*/
-last : {n, a} (fin n) => [1 + n]a -> a
-last xs = xs ! 0
+primitive error : {a, n} (fin n) => String n -> a
/**
- * Return the length of a sequence. Note that the result depends only
- * on the type of the argument, not its value.
+ * Raise a run-time error with a generic message.
+ * This function can be called at any type.
*/
-length : {n, a, b} (fin n, Literal n b) => [n]a -> b
-length _ = `n
-
undefined : {a} a
undefined = error "undefined"
-groupBy : {each, parts, a} (fin each) => [parts * each]a -> [parts][each]a
-groupBy = split`{parts=parts}
+/**
+ * Assert that the given condition holds, and raise an error
+ * with the given message if it does not. If the condition
+ * holds, return the third argument unchanged.
+ */
+assert : {a, n} (fin n) => Bit -> String n -> a -> a
+assert pred msg x = if pred then x else error msg
/**
- * Define the base 2 logarithm function in terms of width
+ * Generates random values from a seed. When called with a function, currently
+ * generates a function that always returns zero.
*/
-type lg2 n = width (max n 1 - 1)
+primitive random : {a} [256] -> a
/**
* Debugging function for tracing. The first argument is a string,
@@ -730,7 +974,7 @@
* which are unspecified. Thus, the output produced by this
* operation may be difficult to predict.
*/
-primitive trace : {n, a, b} (fin n) => [n][8] -> a -> b -> b
+primitive trace : {n, a, b} (fin n) => String n -> a -> b -> b
/**
* Debugging function for tracing values. The first argument is a string,
@@ -743,9 +987,10 @@
* which are unspecified. Thus, the output produced by this
* operation may be difficult to predict.
*/
-traceVal : {n, a} (fin n) => [n][8] -> a -> a
+traceVal : {n, a} (fin n) => String n -> a -> a
traceVal msg x = trace msg x x
+
/* Functions previously in Cryptol::Extras */
/**
@@ -799,7 +1044,7 @@
/**
* Compute the sum of the values in the sequence.
*/
-sum : {n, a} (fin n, Arith a) => [n]a -> a
+sum : {n, a} (fin n, Ring a) => [n]a -> a
sum xs = foldl (+) (fromInteger 0) xs
/**
@@ -825,7 +1070,7 @@
/**
* 'elem x xs' returns true if x is equal to a value in xs.
*/
-elem : {n, a} (fin n, Cmp a) => a -> [n]a -> Bit
+elem : {n, a} (fin n, Eq a) => a -> [n]a -> Bit
elem a xs = any (\x -> x == a) xs
/**
@@ -857,4 +1102,5 @@
* list of successive function applications.
*/
iterate : {a} (a -> a) -> a -> [inf]a
-iterate f x = [x] # [ f v | v <- iterate f x ]
+iterate f x = xs
+ where xs = [x] # [ f v | v <- xs ]
diff --git a/lib/Float.cry b/lib/Float.cry
new file mode 100644
--- /dev/null
+++ b/lib/Float.cry
@@ -0,0 +1,184 @@
+module Float where
+
+primitive type ValidFloat : # -> # -> Prop
+
+/** IEEE-754 floating point numbers. */
+primitive type { exponent : #, precision : #}
+ ValidFloat exponent precision => Float exponent precision : *
+
+/** An abbreviation for common 16-bit floating point numbers. */
+type Float16 = Float 5 11
+
+/** An abbreviation for common 32-bit floating point numbers. */
+type Float32 = Float 8 24
+
+/** An abbreviation for common 64-bit floating point numbers. */
+type Float64 = Float 11 53
+
+/** An abbreviation for common 128-bit floating point numbers. */
+type Float128 = Float 15 113
+
+/** An abbreviation for common 256-bit floating point numbers. */
+type Float256 = Float 19 237
+
+
+
+/* ----------------------------------------------------------------------
+ * Rounding modes (this should be an enumeration type, when we add these)
+ *---------------------------------------------------------------------- */
+
+/**
+ * A 'RoundingMode' is used to specify the precise behavior of some
+ * floating point primitives.
+ *
+ * There are five valid 'RoundingMode' values:
+ * * roundNearestEven
+ * * roundNearestAway
+ * * roundPositive
+ * * roundNegative
+ * * roundZero
+ */
+type RoundingMode = [3]
+
+/** Round toward nearest, ties go to even. */
+roundNearestEven, rne : RoundingMode
+roundNearestEven = 0
+rne = roundNearestEven
+
+/** Round toward nearest, ties away from zero. */
+roundNearestAway, rna : RoundingMode
+roundNearestAway = 1
+rna = roundNearestAway
+
+/** Round toward positive infinity. */
+roundPositive, rtp : RoundingMode
+roundPositive = 2
+rtp = roundPositive
+
+/** Round toward negative infinity. */
+roundNegative, rtn : RoundingMode
+roundNegative = 3
+rtn = roundNegative
+
+/** Round toward zero. */
+roundZero, rtz : RoundingMode
+roundZero = 4
+rtz = roundZero
+
+
+
+/* ----------------------------------------------------------------------
+ * Constants
+ * ---------------------------------------------------------------------- */
+
+/** Not a number. */
+primitive
+ fpNaN : {e,p} ValidFloat e p => Float e p
+
+/** Positive infinity. */
+primitive
+ fpPosInf : {e,p} ValidFloat e p => Float e p
+
+fpNegInf : {e,p} ValidFloat e p => Float e p
+fpNegInf = - fpPosInf
+
+/** Positive zero. */
+fpPosZero : {e,p} ValidFloat e p => Float e p
+fpPosZero = zero
+
+/** Negative zero. */
+fpNegZero : {e,p} ValidFloat e p => Float e p
+fpNegZero = - fpPosZero
+
+
+// Binary representations
+
+/** A floating point number using the exact bit pattern,
+in IEEE interchange format with layout:
+
+ (sign : [1]) # (biased_exponent : [e]) # (significand : [p-1])
+*/
+primitive
+ fpFromBits : {e,p} ValidFloat e p => [e + p] -> Float e p
+
+/** Export a floating point number in IEEE interchange format with layout:
+
+ (sign : [1]) # (biased_exponent : [e]) # (significand : [p-1])
+
+NaN is represented as:
+ * positive: sign == 0
+ * quiet with no info: significand == 0b1 # 0
+*/
+primitive
+ fpToBits : {e,p} ValidFloat e p => Float e p -> [e + p]
+
+
+
+
+
+/* ----------------------------------------------------------------------
+ * Predicates
+ * ----------------------------------------------------------------------
+ */
+
+// Operations in `Cmp` use IEEE reasoning.
+
+/** Check if two floating point numbers are representationally the same.
+In particular, the following hold:
+ * NaN =.= NaN
+ * ~ (pfNegZero =.= fpPosZero)
+*/
+primitive
+ (=.=) : {e,p} ValidFloat e p => Float e p -> Float e p -> Bool
+
+infix 20 =.=
+
+
+/* Returns true for numbers that are not an infinity or NaN. */
+primitive
+ fpIsFinite : {e,p} ValidFloat e p => Float e p -> Bool
+
+
+
+/* ----------------------------------------------------------------------
+ * Arithmetic
+ * ---------------------------------------------------------------------- */
+
+
+/** Add floating point numbers using the given rounding mode. */
+primitive
+ fpAdd : {e,p} ValidFloat e p =>
+ RoundingMode -> Float e p -> Float e p -> Float e p
+
+/** Subtract floating point numbers using the given rounding mode. */
+primitive
+ fpSub : {e,p} ValidFloat e p =>
+ RoundingMode -> Float e p -> Float e p -> Float e p
+
+/** Multiply floating point numbers using the given rounding mode. */
+primitive
+ fpMul : {e,p} ValidFloat e p =>
+ RoundingMode -> Float e p -> Float e p -> Float e p
+
+/** Divide floating point numbers using the given rounding mode. */
+primitive
+ fpDiv : {e,p} ValidFloat e p =>
+ RoundingMode -> Float e p -> Float e p -> Float e p
+
+
+/* ------------------------------------------------------------ *
+ * Rationals *
+ * ------------------------------------------------------------ */
+
+/** Convert a floating point number to a rational.
+It is an error to use this with infinity or NaN **/
+primitive
+ fpToRational : {e,p} ValidFloat e p =>
+ Float e p -> Rational
+
+/** Convert a rational to a floating point number, using the
+given rounding mode, if the number cannot be represented exactly. */
+primitive
+ fpFromRational : {e,p} ValidFloat e p =>
+ RoundingMode -> Rational -> Float e p
+
diff --git a/src/Cryptol/Eval.hs b/src/Cryptol/Eval.hs
--- a/src/Cryptol/Eval.hs
+++ b/src/Cryptol/Eval.hs
@@ -6,13 +6,16 @@
-- Stability : provisional
-- Portability : portable
+{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DoAndIfThenElse #-}
+{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ParallelListComp #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE Safe #-}
{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE ViewPatterns #-}
module Cryptol.Eval (
moduleEnv
@@ -28,22 +31,27 @@
, evalSel
, evalSetSel
, EvalError(..)
+ , Unsupported(..)
, forceValue
) where
+import Cryptol.Eval.Backend
+import Cryptol.Eval.Concrete( Concrete(..) )
+import Cryptol.Eval.Generic ( iteValue )
import Cryptol.Eval.Env
import Cryptol.Eval.Monad
import Cryptol.Eval.Type
import Cryptol.Eval.Value
-import Cryptol.Parser.Selector(ppSelector)
import Cryptol.ModuleSystem.Name
+import Cryptol.Parser.Selector(ppSelector)
import Cryptol.TypeCheck.AST
import Cryptol.TypeCheck.Solver.InfNat(Nat'(..))
+import Cryptol.Utils.Ident
import Cryptol.Utils.Panic (panic)
import Cryptol.Utils.PP
+import Cryptol.Utils.RecordMap
import Control.Monad
-import qualified Data.Sequence as Seq
import Data.List
import Data.Maybe
import qualified Data.Map.Strict as Map
@@ -52,26 +60,52 @@
import Prelude ()
import Prelude.Compat
-type EvalEnv = GenEvalEnv Bool BV Integer
+type EvalEnv = GenEvalEnv Concrete
+type EvalPrims sym =
+ ( Backend sym, ?evalPrim :: PrimIdent -> Maybe (GenValue sym) )
+
+type ConcPrims =
+ ?evalPrim :: PrimIdent -> Maybe (GenValue Concrete)
+
-- Expression Evaluation -------------------------------------------------------
+{-# SPECIALIZE moduleEnv ::
+ ConcPrims =>
+ Concrete ->
+ Module ->
+ GenEvalEnv Concrete ->
+ SEval Concrete (GenEvalEnv Concrete)
+ #-}
+
-- | Extend the given evaluation environment with all the declarations
-- contained in the given module.
-moduleEnv :: EvalPrims b w i
- => Module -- ^ Module containing declarations to evaluate
- -> GenEvalEnv b w i -- ^ Environment to extend
- -> Eval (GenEvalEnv b w i)
-moduleEnv m env = evalDecls (mDecls m) =<< evalNewtypes (mNewtypes m) env
+moduleEnv ::
+ EvalPrims sym =>
+ sym ->
+ Module {- ^ Module containing declarations to evaluate -} ->
+ GenEvalEnv sym {- ^ Environment to extend -} ->
+ SEval sym (GenEvalEnv sym)
+moduleEnv sym m env = evalDecls sym (mDecls m) =<< evalNewtypes sym (mNewtypes m) env
+{-# SPECIALIZE evalExpr ::
+ ConcPrims =>
+ Concrete ->
+ GenEvalEnv Concrete ->
+ Expr ->
+ SEval Concrete (GenValue Concrete)
+ #-}
+
-- | Evaluate a Cryptol expression to a value. This evaluator is parameterized
-- by the `EvalPrims` class, which defines the behavior of bits and words, in
-- addition to providing implementations for all the primitives.
-evalExpr :: EvalPrims b w i
- => GenEvalEnv b w i -- ^ Evaluation environment
- -> Expr -- ^ Expression to evaluate
- -> Eval (GenValue b w i)
-evalExpr env expr = case expr of
+evalExpr ::
+ EvalPrims sym =>
+ sym ->
+ GenEvalEnv sym {- ^ Evaluation environment -} ->
+ Expr {- ^ Expression to evaluate -} ->
+ SEval sym (GenValue sym)
+evalExpr sym env expr = case expr of
-- Try to detect when the user has directly written a finite sequence of
-- literal bit values and pack these into a word.
@@ -80,51 +114,48 @@
-- when the element type is `Bit`.
| isTBit tyv -> {-# SCC "evalExpr->Elist/bit" #-}
return $ VWord len $
- case tryFromBits vs of
- Just w -> return $ WordVal w
- Nothing -> do xs <- mapM (delay Nothing) vs
- return $ BitsVal $ Seq.fromList $ map (fromVBit <$>) xs
+ case tryFromBits sym vs of
+ Just w -> WordVal <$> w
+ Nothing -> do xs <- mapM (sDelay sym Nothing) vs
+ return $ LargeBitsVal len $ finiteSeqMap sym xs
| otherwise -> {-# SCC "evalExpr->EList" #-} do
- xs <- mapM (delay Nothing) vs
- return $ VSeq len $ finiteSeqMap xs
+ xs <- mapM (sDelay sym Nothing) vs
+ return $ VSeq len $ finiteSeqMap sym xs
where
tyv = evalValType (envTypes env) ty
- vs = map (evalExpr env) es
+ vs = map eval es
len = genericLength es
ETuple es -> {-# SCC "evalExpr->ETuple" #-} do
- xs <- mapM (delay Nothing . eval) es
+ xs <- mapM (sDelay sym Nothing . eval) es
return $ VTuple xs
ERec fields -> {-# SCC "evalExpr->ERec" #-} do
- xs <- sequence [ do thk <- delay Nothing (eval e)
- return (f, thk)
- | (f, e) <- fields
- ]
+ xs <- traverse (sDelay sym Nothing . eval) fields
return $ VRecord xs
ESel e sel -> {-# SCC "evalExpr->ESel" #-} do
- x <- eval e
- evalSel x sel
+ e' <- eval e
+ evalSel sym e' sel
ESet e sel v -> {-# SCC "evalExpr->ESet" #-}
- do x <- eval e
- evalSetSel x sel (eval v)
+ do e' <- eval e
+ evalSetSel sym e' sel (eval v)
EIf c t f -> {-# SCC "evalExpr->EIf" #-} do
b <- fromVBit <$> eval c
- iteValue b (eval t) (eval f)
+ iteValue sym b (eval t) (eval f)
EComp n t h gs -> {-# SCC "evalExpr->EComp" #-} do
let len = evalNumType (envTypes env) n
let elty = evalValType (envTypes env) t
- evalComp env len elty h gs
+ evalComp sym env len elty h gs
EVar n -> {-# SCC "evalExpr->EVar" #-} do
case lookupVar n env of
Just val -> val
Nothing -> do
- envdoc <- ppEnv defaultPPOpts env
+ envdoc <- ppEnv sym defaultPPOpts env
panic "[Eval] evalExpr"
["var `" ++ show (pp n) ++ "` is not defined"
, show envdoc
@@ -132,8 +163,8 @@
ETAbs tv b -> {-# SCC "evalExpr->ETAbs" #-}
case tpKind tv of
- KType -> return $ VPoly $ \ty -> evalExpr (bindType (tpVar tv) (Right ty) env) b
- KNum -> return $ VNumPoly $ \n -> evalExpr (bindType (tpVar tv) (Left n) env) b
+ KType -> return $ VPoly $ \ty -> evalExpr sym (bindType (tpVar tv) (Right ty) env) b
+ KNum -> return $ VNumPoly $ \n -> evalExpr sym (bindType (tpVar tv) (Left n) env) b
k -> panic "[Eval] evalExpr" ["invalid kind on type abstraction", show k]
ETApp e ty -> {-# SCC "evalExpr->ETApp" #-} do
@@ -146,87 +177,128 @@
, show vdoc, show (pp e), show (pp ty)
]
- EApp f x -> {-# SCC "evalExpr->EApp" #-} do
+ EApp f v -> {-# SCC "evalExpr->EApp" #-} do
eval f >>= \case
- VFun f' -> f' (eval x)
+ VFun f' -> f' (eval v)
it -> do itdoc <- ppV it
panic "[Eval] evalExpr" ["not a function", show itdoc ]
EAbs n _ty b -> {-# SCC "evalExpr->EAbs" #-}
- return $ VFun (\v -> do env' <- bindVar n v env
- evalExpr env' b)
+ return $ VFun (\v -> do env' <- bindVar sym n v env
+ evalExpr sym env' b)
-- XXX these will likely change once there is an evidence value
- EProofAbs _ e -> evalExpr env e
- EProofApp e -> evalExpr env e
+ EProofAbs _ e -> eval e
+ EProofApp e -> eval e
EWhere e ds -> {-# SCC "evalExpr->EWhere" #-} do
- env' <- evalDecls ds env
- evalExpr env' e
+ env' <- evalDecls sym ds env
+ evalExpr sym env' e
where
{-# INLINE eval #-}
- eval = evalExpr env
- ppV = ppValue defaultPPOpts
+ eval = evalExpr sym env
+ ppV = ppValue sym defaultPPOpts
-- Newtypes --------------------------------------------------------------------
-evalNewtypes :: EvalPrims b w i
- => Map.Map Name Newtype
- -> GenEvalEnv b w i
- -> Eval (GenEvalEnv b w i)
-evalNewtypes nts env = foldM (flip evalNewtype) env $ Map.elems nts
+{-# SPECIALIZE evalNewtypes ::
+ ConcPrims =>
+ Concrete ->
+ Map.Map Name Newtype ->
+ GenEvalEnv Concrete ->
+ SEval Concrete (GenEvalEnv Concrete)
+ #-}
+evalNewtypes ::
+ EvalPrims sym =>
+ sym ->
+ Map.Map Name Newtype ->
+ GenEvalEnv sym ->
+ SEval sym (GenEvalEnv sym)
+evalNewtypes sym nts env = foldM (flip (evalNewtype sym)) env $ Map.elems nts
+
-- | Introduce the constructor function for a newtype.
-evalNewtype :: EvalPrims b w i
- => Newtype
- -> GenEvalEnv b w i
- -> Eval (GenEvalEnv b w i)
-evalNewtype nt = bindVar (ntName nt) (return (foldr tabs con (ntParams nt)))
+evalNewtype ::
+ EvalPrims sym =>
+ sym ->
+ Newtype ->
+ GenEvalEnv sym ->
+ SEval sym (GenEvalEnv sym)
+evalNewtype sym nt = bindVar sym (ntName nt) (return (foldr tabs con (ntParams nt)))
where
tabs _tp body = tlam (\ _ -> body)
con = VFun id
+{-# INLINE evalNewtype #-}
-- Declarations ----------------------------------------------------------------
+{-# SPECIALIZE evalDecls ::
+ ConcPrims =>
+ Concrete ->
+ [DeclGroup] ->
+ GenEvalEnv Concrete ->
+ SEval Concrete (GenEvalEnv Concrete)
+ #-}
+
-- | Extend the given evaluation environment with the result of evaluating the
-- given collection of declaration groups.
-evalDecls :: EvalPrims b w i
- => [DeclGroup] -- ^ Declaration groups to evaluate
- -> GenEvalEnv b w i -- ^ Environment to extend
- -> Eval (GenEvalEnv b w i)
-evalDecls dgs env = foldM evalDeclGroup env dgs
+evalDecls ::
+ EvalPrims sym =>
+ sym ->
+ [DeclGroup] {- ^ Declaration groups to evaluate -} ->
+ GenEvalEnv sym {- ^ Environment to extend -} ->
+ SEval sym (GenEvalEnv sym)
+evalDecls x dgs env = foldM (evalDeclGroup x) env dgs
-evalDeclGroup :: EvalPrims b w i
- => GenEvalEnv b w i
- -> DeclGroup
- -> Eval (GenEvalEnv b w i)
-evalDeclGroup env dg = do
+{-# SPECIALIZE evalDeclGroup ::
+ ConcPrims =>
+ Concrete ->
+ GenEvalEnv Concrete ->
+ DeclGroup ->
+ SEval Concrete (GenEvalEnv Concrete)
+ #-}
+
+evalDeclGroup ::
+ EvalPrims sym =>
+ sym ->
+ GenEvalEnv sym ->
+ DeclGroup ->
+ SEval sym (GenEvalEnv sym)
+evalDeclGroup sym env dg = do
case dg of
Recursive ds -> do
-- declare a "hole" for each declaration
-- and extend the evaluation environment
- holes <- mapM declHole ds
+ holes <- mapM (declHole sym) ds
let holeEnv = Map.fromList $ [ (nm,h) | (nm,_,h,_) <- holes ]
let env' = env `mappend` emptyEnv{ envVars = holeEnv }
-- evaluate the declaration bodies, building a new evaluation environment
- env'' <- foldM (evalDecl env') env ds
+ env'' <- foldM (evalDecl sym env') env ds
-- now backfill the holes we declared earlier using the definitions
-- calculated in the previous step
- mapM_ (fillHole env'') holes
+ mapM_ (fillHole sym env'') holes
-- return the map containing the holes
return env'
NonRecursive d -> do
- evalDecl env env d
+ evalDecl sym env env d
+
+{-# SPECIALIZE fillHole ::
+ Concrete ->
+ GenEvalEnv Concrete ->
+ (Name, Schema, SEval Concrete (GenValue Concrete), SEval Concrete (GenValue Concrete) -> SEval Concrete ()) ->
+ SEval Concrete ()
+ #-}
+
-- | This operation is used to complete the process of setting up recursive declaration
-- groups. It 'backfills' previously-allocated thunk values with the actual evaluation
-- procedure for the body of recursive definitions.
@@ -237,16 +309,19 @@
-- to this is to force an eta-expansion procedure on all recursive definitions.
-- However, for the so-called 'Value' types we can instead optimistically use the 'delayFill'
-- operation and only fall back on full eta expansion if the thunk is double-forced.
-fillHole :: BitWord b w i
- => GenEvalEnv b w i
- -> (Name, Schema, Eval (GenValue b w i), Eval (GenValue b w i) -> Eval ())
- -> Eval ()
-fillHole env (nm, sch, _, fill) = do
+
+fillHole ::
+ Backend sym =>
+ sym ->
+ GenEvalEnv sym ->
+ (Name, Schema, SEval sym (GenValue sym), SEval sym (GenValue sym) -> SEval sym ()) ->
+ SEval sym ()
+fillHole sym env (nm, sch, _, fill) = do
case lookupVar nm env of
Nothing -> evalPanic "fillHole" ["Recursive definition not completed", show (ppLocName nm)]
- Just x
- | isValueType env sch -> fill =<< delayFill x (etaDelay (show (ppLocName nm)) env sch x)
- | otherwise -> fill (etaDelay (show (ppLocName nm)) env sch x)
+ Just v
+ | isValueType env sch -> fill =<< sDelayFill sym v (etaDelay sym (show (ppLocName nm)) env sch v)
+ | otherwise -> fill (etaDelay sym (show (ppLocName nm)) env sch v)
-- | 'Value' types are non-polymorphic types recursive constructed from
@@ -254,29 +329,47 @@
-- be implemented rather more efficently than general types because we can
-- rely on the 'delayFill' operation to build a thunk that falls back on performing
-- eta-expansion rather than doing it eagerly.
-isValueType :: GenEvalEnv b w i -> Schema -> Bool
+isValueType :: GenEvalEnv sym -> Schema -> Bool
isValueType env Forall{ sVars = [], sProps = [], sType = t0 }
= go (evalValType (envTypes env) t0)
where
go TVBit = True
go (TVSeq _ x) = go x
go (TVTuple xs) = and (map go xs)
- go (TVRec xs) = and (map (go . snd) xs)
+ go (TVRec xs) = and (fmap go xs)
go _ = False
isValueType _ _ = False
+{-# SPECIALIZE etaWord ::
+ Concrete ->
+ Integer ->
+ SEval Concrete (GenValue Concrete) ->
+ SEval Concrete (WordValue Concrete)
+ #-}
+
-- | Eta-expand a word value. This forces an unpacked word representation.
-etaWord :: BitWord b w i
- => Integer
- -> Eval (GenValue b w i)
- -> Eval (WordValue b w i)
-etaWord n x = do
- w <- delay Nothing (fromWordVal "during eta-expansion" =<< x)
- return $ BitsVal $ Seq.fromFunction (fromInteger n) $ \i ->
- do w' <- w; indexWordValue w' (toInteger i)
+etaWord ::
+ Backend sym =>
+ sym ->
+ Integer ->
+ SEval sym (GenValue sym) ->
+ SEval sym (WordValue sym)
+etaWord sym n val = do
+ w <- sDelay sym Nothing (fromWordVal "during eta-expansion" =<< val)
+ xs <- memoMap $ IndexSeqMap $ \i ->
+ do w' <- w; VBit <$> indexWordValue sym w' i
+ pure $ LargeBitsVal n xs
+{-# SPECIALIZE etaDelay ::
+ Concrete ->
+ String ->
+ GenEvalEnv Concrete ->
+ Schema ->
+ SEval Concrete (GenValue Concrete) ->
+ SEval Concrete (GenValue Concrete)
+ #-}
-- | Given a simulator value and its type, fully eta-expand the value. This
-- is a type-directed pass that always produces a canonical value of the
@@ -284,28 +377,29 @@
-- the correct evaluation semantics of recursive definitions. Otherwise,
-- expressions that should be expected to produce well-defined values in the
-- denotational semantics will fail to terminate instead.
-etaDelay :: BitWord b w i
- => String
- -> GenEvalEnv b w i
- -> Schema
- -> Eval (GenValue b w i)
- -> Eval (GenValue b w i)
-etaDelay msg env0 Forall{ sVars = vs0, sType = tp0 } = goTpVars env0 vs0
+etaDelay ::
+ Backend sym =>
+ sym ->
+ String ->
+ GenEvalEnv sym ->
+ Schema ->
+ SEval sym (GenValue sym) ->
+ SEval sym (GenValue sym)
+etaDelay sym msg env0 Forall{ sVars = vs0, sType = tp0 } = goTpVars env0 vs0
where
- goTpVars env [] x = go (evalValType (envTypes env) tp0) x
- goTpVars env (v:vs) x =
+ goTpVars env [] val = go (evalValType (envTypes env) tp0) val
+ goTpVars env (v:vs) val =
case tpKind v of
KType -> return $ VPoly $ \t ->
- goTpVars (bindType (tpVar v) (Right t) env) vs ( ($t) . fromVPoly =<< x )
+ goTpVars (bindType (tpVar v) (Right t) env) vs ( ($t) . fromVPoly =<< val )
KNum -> return $ VNumPoly $ \n ->
- goTpVars (bindType (tpVar v) (Left n) env) vs ( ($n) . fromVNumPoly =<< x )
+ goTpVars (bindType (tpVar v) (Left n) env) vs ( ($n) . fromVNumPoly =<< val )
k -> panic "[Eval] etaDelay" ["invalid kind on type abstraction", show k]
- go tp (Ready x) =
- case x of
- VBit _ -> return x
- VInteger _ -> return x
- VWord _ _ -> return x
+ go tp x | isReady sym x = x >>= \case
+ VBit _ -> x
+ VInteger _ -> x
+ VWord _ _ -> x
VSeq n xs
| TVSeq _nt el <- tp
-> return $ VSeq n $ IndexSeqMap $ \i -> go el (lookupSeqMap xs i)
@@ -320,11 +414,11 @@
VRecord fs
| TVRec fts <- tp
- -> return $ VRecord $
- let err f = evalPanic "expected record value with field" [show f] in
- [ (f, go (fromMaybe (err f) (lookup f fts)) y)
- | (f, y) <- fs
- ]
+ -> do let res = zipRecords (\_ v t -> go t v) fs fts
+ case res of
+ Left (Left f) -> evalPanic "type mismatch during eta-expansion" ["missing field " ++ show f]
+ Left (Right f) -> evalPanic "type mismatch during eta-expansion" ["unexpected field " ++ show f]
+ Right fs' -> return (VRecord fs')
VFun f
| TVFun _t1 t2 <- tp
@@ -332,58 +426,67 @@
_ -> evalPanic "type mismatch during eta-expansion" []
- go tp x =
+ go tp v =
case tp of
- TVBit -> x
- TVInteger -> x
- TVIntMod _ -> x
+ TVBit -> v
+ TVInteger -> v
+ TVFloat {} -> v
+ TVIntMod _ -> v
+ TVRational -> v
+ TVArray{} -> v
TVSeq n TVBit ->
- do w <- delayFill (fromWordVal "during eta-expansion" =<< x) (etaWord n x)
+ do w <- sDelayFill sym (fromWordVal "during eta-expansion" =<< v) (etaWord sym n v)
return $ VWord n w
TVSeq n el ->
- do x' <- delay (Just msg) (fromSeq "during eta-expansion" =<< x)
+ do x' <- sDelay sym (Just msg) (fromSeq "during eta-expansion" =<< v)
return $ VSeq n $ IndexSeqMap $ \i -> do
go el (flip lookupSeqMap i =<< x')
TVStream el ->
- do x' <- delay (Just msg) (fromSeq "during eta-expansion" =<< x)
+ do x' <- sDelay sym (Just msg) (fromSeq "during eta-expansion" =<< v)
return $ VStream $ IndexSeqMap $ \i ->
go el (flip lookupSeqMap i =<< x')
TVFun _t1 t2 ->
- do x' <- delay (Just msg) (fromVFun <$> x)
- return $ VFun $ \a -> go t2 ( ($a) =<< x' )
+ do v' <- sDelay sym (Just msg) (fromVFun <$> v)
+ return $ VFun $ \a -> go t2 ( ($a) =<< v' )
TVTuple ts ->
do let n = length ts
- x' <- delay (Just msg) (fromVTuple <$> x)
+ v' <- sDelay sym (Just msg) (fromVTuple <$> v)
return $ VTuple $
- [ go t =<< (flip genericIndex i <$> x')
+ [ go t =<< (flip genericIndex i <$> v')
| i <- [0..(n-1)]
| t <- ts
]
TVRec fs ->
- do x' <- delay (Just msg) (fromVRecord <$> x)
+ do v' <- sDelay sym (Just msg) (fromVRecord <$> v)
let err f = evalPanic "expected record value with field" [show f]
- return $ VRecord $
- [ (f, go t =<< (fromMaybe (err f) . lookup f <$> x'))
- | (f,t) <- fs
- ]
+ let eta f t = go t =<< (fromMaybe (err f) . lookupField f <$> v')
+ return $ VRecord (mapWithFieldName eta fs)
- TVAbstract {} -> x
+ TVAbstract {} -> v
-declHole :: Decl
- -> Eval (Name, Schema, Eval (GenValue b w i), Eval (GenValue b w i) -> Eval ())
-declHole d =
+{-# SPECIALIZE declHole ::
+ Concrete ->
+ Decl ->
+ SEval Concrete
+ (Name, Schema, SEval Concrete (GenValue Concrete), SEval Concrete (GenValue Concrete) -> SEval Concrete ())
+ #-}
+
+declHole ::
+ Backend sym =>
+ sym -> Decl -> SEval sym (Name, Schema, SEval sym (GenValue sym), SEval sym (GenValue sym) -> SEval sym ())
+declHole sym d =
case dDefinition d of
DPrim -> evalPanic "Unexpected primitive declaration in recursive group"
[show (ppLocName nm)]
DExpr _ -> do
- (hole, fill) <- blackhole msg
+ (hole, fill) <- sDeclareHole sym msg
return (nm, sch, hole, fill)
where
nm = dName d
@@ -398,31 +501,43 @@
-- handle the subtle name-binding issues that arise from recursive
-- definitions. The 'read only' environment is used to bring recursive
-- names into scope while we are still defining them.
-evalDecl :: EvalPrims b w i
- => GenEvalEnv b w i -- ^ A 'read only' environment for use in declaration bodies
- -> GenEvalEnv b w i -- ^ An evaluation environment to extend with the given declaration
- -> Decl -- ^ The declaration to evaluate
- -> Eval (GenEvalEnv b w i)
-evalDecl renv env d =
+evalDecl ::
+ EvalPrims sym =>
+ sym ->
+ GenEvalEnv sym {- ^ A 'read only' environment for use in declaration bodies -} ->
+ GenEvalEnv sym {- ^ An evaluation environment to extend with the given declaration -} ->
+ Decl {- ^ The declaration to evaluate -} ->
+ SEval sym (GenEvalEnv sym)
+evalDecl sym renv env d =
case dDefinition d of
- DPrim -> case evalPrim d of
- Just v -> pure (bindVarDirect (dName d) v env)
- Nothing -> bindVar (dName d) (cryNoPrimError (dName d)) env
+ 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
- DExpr e -> bindVar (dName d) (evalExpr renv e) env
+ DExpr e -> bindVar sym (dName d) (evalExpr sym renv e) env
-- Selectors -------------------------------------------------------------------
+{-# SPECIALIZE evalSel ::
+ ConcPrims =>
+ Concrete ->
+ GenValue Concrete ->
+ Selector ->
+ SEval Concrete (GenValue Concrete)
+ #-}
+
-- | Apply the the given "selector" form to the given value. This function pushes
-- tuple and record selections pointwise down into other value constructs
-- (e.g., streams and functions).
-evalSel :: forall b w i
- . EvalPrims b w i
- => GenValue b w i
- -> Selector
- -> Eval (GenValue b w i)
-evalSel val sel = case sel of
+evalSel ::
+ EvalPrims sym =>
+ sym ->
+ GenValue sym ->
+ Selector ->
+ SEval sym (GenValue sym)
+evalSel sym val sel = case sel of
TupleSel n _ -> tupleSel n val
RecordSel n _ -> recordSel n val
@@ -432,7 +547,7 @@
tupleSel n v =
case v of
VTuple vs -> vs !! n
- _ -> do vdoc <- ppValue defaultPPOpts v
+ _ -> do vdoc <- ppValue sym defaultPPOpts v
evalPanic "Cryptol.Eval.evalSel"
[ "Unexpected value in tuple selection"
, show vdoc ]
@@ -440,7 +555,7 @@
recordSel n v =
case v of
VRecord {} -> lookupRecord n v
- _ -> do vdoc <- ppValue defaultPPOpts v
+ _ -> do vdoc <- ppValue sym defaultPPOpts v
evalPanic "Cryptol.Eval.evalSel"
[ "Unexpected value in record selection"
, show vdoc ]
@@ -449,26 +564,32 @@
case v of
VSeq _ vs -> lookupSeqMap vs (toInteger n)
VStream vs -> lookupSeqMap vs (toInteger n)
- VWord _ wv -> VBit <$> (flip indexWordValue (toInteger n) =<< wv)
- _ -> do vdoc <- ppValue defaultPPOpts val
+ VWord _ wv -> VBit <$> (flip (indexWordValue sym) (toInteger n) =<< wv)
+ _ -> do vdoc <- ppValue sym defaultPPOpts val
evalPanic "Cryptol.Eval.evalSel"
[ "Unexpected value in list selection"
, show vdoc ]
-
-evalSetSel :: forall b w i. EvalPrims b w i =>
- GenValue b w i -> Selector -> Eval (GenValue b w i) -> Eval (GenValue b w i)
-evalSetSel e x v =
- case x of
+{-# SPECIALIZE evalSetSel ::
+ ConcPrims =>
+ Concrete ->
+ GenValue Concrete -> Selector -> SEval Concrete (GenValue Concrete) -> SEval Concrete (GenValue Concrete)
+ #-}
+evalSetSel :: forall sym.
+ EvalPrims sym =>
+ sym ->
+ GenValue sym -> Selector -> SEval sym (GenValue sym) -> SEval sym (GenValue sym)
+evalSetSel sym e sel v =
+ case sel of
TupleSel n _ -> setTuple n
RecordSel n _ -> setRecord n
ListSel ix _ -> setList (toInteger ix)
where
bad msg =
- do ed <- ppValue defaultPPOpts e
+ do ed <- ppValue sym defaultPPOpts e
evalPanic "Cryptol.Eval.evalSetSel"
[ msg
- , "Selector: " ++ show (ppSelector x)
+ , "Selector: " ++ show (ppSelector sel)
, "Value: " ++ show ed
]
@@ -483,9 +604,9 @@
setRecord n =
case e of
VRecord xs ->
- case break ((n ==) . fst) xs of
- (as, (i,_) : bs) -> pure (VRecord (as ++ (i,v) : bs))
- _ -> bad "Missing field in record update."
+ case adjustField n (\_ -> v) xs of
+ Just xs' -> pure (VRecord xs')
+ Nothing -> bad "Missing field in record update."
_ -> bad "Record update on a non-record."
setList n =
@@ -493,7 +614,7 @@
VSeq i mp -> pure $ VSeq i $ updateSeqMap mp n v
VStream mp -> pure $ VStream $ updateSeqMap mp n v
VWord i m -> pure $ VWord i $ do m1 <- m
- updateWordValue m1 n asBit
+ updateWordValue sym m1 n asBit
_ -> bad "Sequence update on a non-sequence."
asBit = do res <- v
@@ -506,22 +627,22 @@
-- | Evaluation environments for list comprehensions: Each variable
-- name is bound to a list of values, one for each element in the list
-- comprehension.
-data ListEnv b w i = ListEnv
- { leVars :: !(Map.Map Name (Integer -> Eval (GenValue b w i)))
+data ListEnv sym = ListEnv
+ { leVars :: !(Map.Map Name (Integer -> SEval sym (GenValue sym)))
-- ^ Bindings whose values vary by position
- , leStatic :: !(Map.Map Name (Eval (GenValue b w i)))
+ , leStatic :: !(Map.Map Name (SEval sym (GenValue sym)))
-- ^ Bindings whose values are constant
, leTypes :: !TypeEnv
}
-instance Semigroup (ListEnv b w i) where
+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)
}
-instance Monoid (ListEnv b w i) where
+instance Monoid (ListEnv sym) where
mempty = ListEnv
{ leVars = Map.empty
, leStatic = Map.empty
@@ -530,59 +651,95 @@
mappend l r = l <> r
-toListEnv :: GenEvalEnv b w i -> ListEnv b w i
+toListEnv :: GenEvalEnv sym -> ListEnv sym
toListEnv e =
ListEnv
{ leVars = mempty
, leStatic = envVars e
, leTypes = envTypes e
}
+{-# INLINE toListEnv #-}
-- | Evaluate a list environment at a position.
-- This choses a particular value for the varying
-- locations.
-evalListEnv :: ListEnv b w i -> Integer -> GenEvalEnv b w i
+evalListEnv :: ListEnv sym -> Integer -> GenEvalEnv sym
evalListEnv (ListEnv vm st tm) i =
let v = fmap ($i) vm
in EvalEnv{ envVars = Map.union v st
, envTypes = tm
}
+{-# INLINE evalListEnv #-}
-bindVarList :: Name
- -> (Integer -> Eval (GenValue b w i))
- -> ListEnv b w i
- -> ListEnv b w i
+
+bindVarList ::
+ Name ->
+ (Integer -> SEval sym (GenValue sym)) ->
+ ListEnv sym ->
+ ListEnv sym
bindVarList n vs lenv = lenv { leVars = Map.insert n vs (leVars lenv) }
+{-# INLINE bindVarList #-}
-- List Comprehensions ---------------------------------------------------------
+{-# SPECIALIZE evalComp ::
+ ConcPrims =>
+ Concrete ->
+ GenEvalEnv Concrete ->
+ Nat' ->
+ TValue ->
+ Expr ->
+ [[Match]] ->
+ SEval Concrete (GenValue Concrete)
+ #-}
-- | Evaluate a comprehension.
-evalComp :: EvalPrims b w i
- => GenEvalEnv b w i -- ^ Starting evaluation environment
- -> Nat' -- ^ Length of the comprehension
- -> TValue -- ^ Type of the comprehension elements
- -> Expr -- ^ Head expression of the comprehension
- -> [[Match]] -- ^ List of parallel comprehension branches
- -> Eval (GenValue b w i)
-evalComp env len elty body ms =
- do lenv <- mconcat <$> mapM (branchEnvs (toListEnv env)) ms
+evalComp ::
+ EvalPrims sym =>
+ sym ->
+ GenEvalEnv sym {- ^ Starting evaluation environment -} ->
+ Nat' {- ^ Length of the comprehension -} ->
+ TValue {- ^ Type of the comprehension elements -} ->
+ Expr {- ^ Head expression of the comprehension -} ->
+ [[Match]] {- ^ List of parallel comprehension branches -} ->
+ SEval sym (GenValue sym)
+evalComp sym env len elty body ms =
+ do lenv <- mconcat <$> mapM (branchEnvs sym (toListEnv env)) ms
mkSeq len elty <$> memoMap (IndexSeqMap $ \i -> do
- evalExpr (evalListEnv lenv i) body)
+ evalExpr sym (evalListEnv lenv i) body)
+{-# SPECIALIZE branchEnvs ::
+ ConcPrims =>
+ Concrete ->
+ ListEnv Concrete ->
+ [Match] ->
+ SEval Concrete (ListEnv Concrete)
+ #-}
-- | Turn a list of matches into the final environments for each iteration of
-- the branch.
-branchEnvs :: EvalPrims b w i
- => ListEnv b w i
- -> [Match]
- -> Eval (ListEnv b w i)
-branchEnvs env matches = foldM evalMatch env matches
+branchEnvs ::
+ EvalPrims sym =>
+ sym ->
+ ListEnv sym ->
+ [Match] ->
+ SEval sym (ListEnv sym)
+branchEnvs sym env matches = foldM (evalMatch sym) env matches
+{-# SPECIALIZE evalMatch ::
+ ConcPrims =>
+ Concrete ->
+ ListEnv Concrete ->
+ Match ->
+ SEval Concrete (ListEnv Concrete)
+ #-}
+
-- | Turn a match into the list of environments it represents.
-evalMatch :: EvalPrims b w i
- => ListEnv b w i
- -> Match
- -> Eval (ListEnv b w i)
-evalMatch lenv m = case m of
+evalMatch ::
+ EvalPrims sym =>
+ sym ->
+ ListEnv sym ->
+ Match ->
+ SEval sym (ListEnv sym)
+evalMatch sym lenv m = case m of
-- many envs
From n l _ty expr ->
@@ -590,12 +747,12 @@
-- Select from a sequence of finite length. This causes us to 'stutter'
-- through our previous choices `nLen` times.
Nat nLen -> do
- vss <- memoMap $ IndexSeqMap $ \i -> evalExpr (evalListEnv lenv i) expr
+ vss <- memoMap $ IndexSeqMap $ \i -> evalExpr sym (evalListEnv lenv i) expr
let stutter xs = \i -> xs (i `div` nLen)
let lenv' = lenv { leVars = fmap stutter (leVars lenv) }
let vs i = do let (q, r) = i `divMod` nLen
lookupSeqMap vss q >>= \case
- VWord _ w -> VBit <$> (flip indexWordValue r =<< w)
+ VWord _ w -> VBit <$> (flip (indexWordValue sym) r =<< w)
VSeq _ xs' -> lookupSeqMap xs' r
VStream xs' -> lookupSeqMap xs' r
_ -> evalPanic "evalMatch" ["Not a list value"]
@@ -611,9 +768,9 @@
, leStatic = allvars
}
let env = EvalEnv allvars (leTypes lenv)
- xs <- evalExpr env expr
+ xs <- evalExpr sym env expr
let vs i = case xs of
- VWord _ w -> VBit <$> (flip indexWordValue i =<< w)
+ VWord _ w -> VBit <$> (flip (indexWordValue sym) i =<< w)
VSeq _ xs' -> lookupSeqMap xs' i
VStream xs' -> lookupSeqMap xs' i
_ -> evalPanic "evalMatch" ["Not a list value"]
@@ -630,4 +787,4 @@
f env =
case dDefinition d of
DPrim -> evalPanic "evalMatch" ["Unexpected local primitive"]
- DExpr e -> evalExpr env e
+ DExpr e -> evalExpr sym env e
diff --git a/src/Cryptol/Eval/Backend.hs b/src/Cryptol/Eval/Backend.hs
new file mode 100644
--- /dev/null
+++ b/src/Cryptol/Eval/Backend.hs
@@ -0,0 +1,705 @@
+{-# 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
new file mode 100644
--- /dev/null
+++ b/src/Cryptol/Eval/Concrete.hs
@@ -0,0 +1,529 @@
+-- |
+-- Module : Cryptol.Eval.Concrete
+-- Copyright : (c) 2013-2020 Galois, Inc.
+-- License : BSD3
+-- Maintainer : cryptol@galois.com
+-- Stability : provisional
+-- Portability : portable
+
+{-# LANGUAGE BangPatterns #-}
+{-# 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
+ , toExpr
+ ) where
+
+import Control.Monad (join,guard,zipWithM,mzero)
+import Data.Bits (Bits(..))
+import Data.Ratio(numerator,denominator)
+import MonadLib( ChoiceT, findOne, lift )
+import qualified LibBF as FP
+
+import qualified Data.Map.Strict as 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.Eval.Generic hiding (logicShift)
+import Cryptol.Eval.Monad
+import Cryptol.Eval.Type
+import Cryptol.Eval.Value
+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.PP
+import Cryptol.Utils.Logger(logPrint)
+import Cryptol.Utils.RecordMap
+
+
+-- Value to Expression conversion ----------------------------------------------
+
+-- | Given an expected type, returns an expression that evaluates to
+-- this value, if we can determine it.
+--
+-- XXX: View patterns would probably clean up this definition a lot.
+toExpr :: PrimMap -> AST.Type -> Value -> Eval (Maybe AST.Expr)
+toExpr prims t0 v0 = findOne (go t0 v0)
+ where
+
+ prim n = ePrim prims (prelPrim n)
+
+
+ go :: AST.Type -> Value -> ChoiceT Eval Expr
+ go ty val = case (tNoUser ty, val) of
+ (TRec tfs, VRecord vfs) -> do
+ -- NB, vfs first argument to keep their display order
+ res <- zipRecordsM (\_lbl v t -> go t =<< lift v) vfs tfs
+ case res of
+ Left _ -> mzero -- different fields
+ Right efs -> pure (ERec efs)
+ (TCon (TC (TCTuple tl)) ts, VTuple tvs) -> do
+ guard (tl == (length tvs))
+ ETuple `fmap` (zipWithM go ts =<< lift (sequence tvs))
+ (TCon (TC TCBit) [], VBit True ) -> return (prim "True")
+ (TCon (TC TCBit) [], VBit False) -> return (prim "False")
+ (TCon (TC TCInteger) [], VInteger i) ->
+ return $ ETApp (ETApp (prim "number") (tNum i)) ty
+ (TCon (TC TCIntMod) [_n], VInteger i) ->
+ return $ ETApp (ETApp (prim "number") (tNum i)) ty
+ (TCon (TC TCRational) [], VRational (SRational n d)) ->
+ do let n' = ETApp (ETApp (prim "number") (tNum n)) (TCon (TC TCInteger) [])
+ d' = ETApp (ETApp (prim "number") (tNum d)) (TCon (TC TCInteger) [])
+ return $ EApp (EApp (prim "ratio") n') d'
+ (TCon (TC TCFloat) [eT,pT], VFloat i) ->
+ pure (floatToExpr prims eT pT (bfValue i))
+
+ (TCon (TC TCSeq) [a,b], VSeq 0 _) -> do
+ guard (a == tZero)
+ return $ EList [] b
+ (TCon (TC TCSeq) [a,b], VSeq n svs) -> do
+ guard (a == tNum n)
+ ses <- mapM (go b) =<< lift (sequence (enumerateSeqMap n svs))
+ return $ EList ses b
+ (TCon (TC TCSeq) [a,(TCon (TC TCBit) [])], VWord _ wval) -> do
+ BV w v <- lift (asWordVal Concrete =<< wval)
+ guard (a == tNum w)
+ return $ ETApp (ETApp (prim "number") (tNum v)) ty
+ (_, VStream _) -> fail "cannot construct infinite expressions"
+ (_, VFun _) -> fail "cannot convert function values to expressions"
+ (_, VPoly _) -> fail "cannot convert polymorphic values to expressions"
+ _ -> do doc <- lift (ppValue Concrete defaultPPOpts val)
+ panic "Cryptol.Eval.Concrete.toExpr"
+ ["type mismatch:"
+ , pretty ty
+ , render doc
+ ]
+
+floatToExpr :: PrimMap -> AST.Type -> AST.Type -> FP.BigFloat -> AST.Expr
+floatToExpr prims eT pT 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 e) ->
+ let r = toRational m * (2 ^^ e)
+ in EProofApp $ ePrim prims (prelPrim "fraction")
+ `ETApp` tNum (numerator r)
+ `ETApp` tNum (denominator r)
+ `ETApp` tNum (0 :: Int)
+ `ETApp` tFloat eT pT
+ where
+ mkP n = EProofApp $ ePrim prims (floatPrim n) `ETApp` eT `ETApp` pT
+
+-- Primitives ------------------------------------------------------------------
+
+evalPrim :: PrimIdent -> Maybe Value
+evalPrim prim = Map.lookup prim primTable
+
+primTable :: Map.Map PrimIdent Value
+primTable = let sym = Concrete in
+ Map.union (floatPrims sym) $
+ Map.fromList $ map (\(n, v) -> (prelPrim n, v))
+
+ [ -- Literals
+ ("True" , VBit (bitLit sym True))
+ , ("False" , VBit (bitLit sym False))
+ , ("number" , {-# SCC "Prelude::number" #-}
+ ecNumberV sym)
+ , ("ratio" , {-# SCC "Prelude::ratio" #-}
+ ratioV sym)
+ , ("fraction" , ecFractionV sym)
+
+
+ -- Zero
+ , ("zero" , {-# SCC "Prelude::zero" #-}
+ VPoly (zeroV sym))
+
+ -- Logic
+ , ("&&" , {-# SCC "Prelude::(&&)" #-}
+ binary (andV sym))
+ , ("||" , {-# SCC "Prelude::(||)" #-}
+ binary (orV sym))
+ , ("^" , {-# SCC "Prelude::(^)" #-}
+ binary (xorV sym))
+ , ("complement" , {-# SCC "Prelude::complement" #-}
+ unary (complementV sym))
+
+ -- Ring
+ , ("fromInteger", {-# SCC "Prelude::fromInteger" #-}
+ fromIntegerV sym)
+ , ("+" , {-# SCC "Prelude::(+)" #-}
+ binary (addV sym))
+ , ("-" , {-# SCC "Prelude::(-)" #-}
+ binary (subV sym))
+ , ("*" , {-# SCC "Prelude::(*)" #-}
+ binary (mulV sym))
+ , ("negate" , {-# SCC "Prelude::negate" #-}
+ unary (negateV sym))
+
+ -- Integral
+ , ("toInteger" , {-# SCC "Prelude::toInteger" #-}
+ toIntegerV sym)
+ , ("/" , {-# SCC "Prelude::(/)" #-}
+ binary (divV sym))
+ , ("%" , {-# SCC "Prelude::(%)" #-}
+ binary (modV sym))
+ , ("^^" , {-# SCC "Prelude::(^^)" #-}
+ expV sym)
+ , ("infFrom" , {-# SCC "Prelude::infFrom" #-}
+ infFromV sym)
+ , ("infFromThen", {-# SCC "Prelude::infFromThen" #-}
+ infFromThenV sym)
+
+ -- Field
+ , ("recip" , {-# SCC "Prelude::recip" #-}
+ recipV sym)
+ , ("/." , {-# SCC "Prelude::(/.)" #-}
+ fieldDivideV sym)
+
+ -- Round
+ , ("floor" , {-# SCC "Prelude::floor" #-}
+ unary (floorV sym))
+ , ("ceiling" , {-# SCC "Prelude::ceiling" #-}
+ unary (ceilingV sym))
+ , ("trunc" , {-# SCC "Prelude::trunc" #-}
+ unary (truncV sym))
+ , ("roundAway" , {-# SCC "Prelude::roundAway" #-}
+ unary (roundAwayV sym))
+ , ("roundToEven", {-# SCC "Prelude::roundToEven" #-}
+ unary (roundToEvenV sym))
+
+ -- Bitvector specific operations
+ , ("/$" , {-# SCC "Prelude::(/$)" #-}
+ sdivV sym)
+ , ("%$" , {-# SCC "Prelude::(%$)" #-}
+ smodV sym)
+ , ("lg2" , {-# SCC "Prelude::lg2" #-}
+ lg2V sym)
+ , (">>$" , {-# SCC "Prelude::(>>$)" #-}
+ sshrV)
+
+ -- Cmp
+ , ("<" , {-# SCC "Prelude::(<)" #-}
+ binary (lessThanV sym))
+ , (">" , {-# SCC "Prelude::(>)" #-}
+ binary (greaterThanV sym))
+ , ("<=" , {-# SCC "Prelude::(<=)" #-}
+ binary (lessThanEqV sym))
+ , (">=" , {-# SCC "Prelude::(>=)" #-}
+ binary (greaterThanEqV sym))
+ , ("==" , {-# SCC "Prelude::(==)" #-}
+ binary (eqV sym))
+ , ("!=" , {-# SCC "Prelude::(!=)" #-}
+ binary (distinctV sym))
+
+ -- SignedCmp
+ , ("<$" , {-# SCC "Prelude::(<$)" #-}
+ binary (signedLessThanV sym))
+
+ -- Finite enumerations
+ , ("fromTo" , {-# SCC "Prelude::fromTo" #-}
+ fromToV sym)
+ , ("fromThenTo" , {-# SCC "Prelude::fromThenTo" #-}
+ fromThenToV sym)
+
+ -- Sequence manipulations
+ , ("#" , {-# SCC "Prelude::(#)" #-}
+ nlam $ \ front ->
+ nlam $ \ back ->
+ tlam $ \ elty ->
+ lam $ \ l -> return $
+ lam $ \ r -> join (ccatV sym front back elty <$> l <*> r))
+
+
+ , ("join" , {-# SCC "Prelude::join" #-}
+ nlam $ \ parts ->
+ nlam $ \ (finNat' -> each) ->
+ tlam $ \ a ->
+ lam $ \ x ->
+ joinV sym parts each a =<< x)
+
+ , ("split" , {-# SCC "Prelude::split" #-}
+ ecSplitV sym)
+
+ , ("splitAt" , {-# SCC "Prelude::splitAt" #-}
+ nlam $ \ front ->
+ nlam $ \ back ->
+ tlam $ \ a ->
+ lam $ \ x ->
+ splitAtV sym front back a =<< x)
+
+ , ("reverse" , {-# SCC "Prelude::reverse" #-}
+ nlam $ \_a ->
+ tlam $ \_b ->
+ lam $ \xs -> reverseV sym =<< xs)
+
+ , ("transpose" , {-# SCC "Prelude::transpose" #-}
+ nlam $ \a ->
+ nlam $ \b ->
+ tlam $ \c ->
+ lam $ \xs -> transposeV sym a b c =<< xs)
+
+ -- Shifts and rotates
+ , ("<<" , {-# SCC "Prelude::(<<)" #-}
+ logicShift shiftLW shiftLS)
+ , (">>" , {-# SCC "Prelude::(>>)" #-}
+ logicShift shiftRW shiftRS)
+ , ("<<<" , {-# SCC "Prelude::(<<<)" #-}
+ logicShift rotateLW rotateLS)
+ , (">>>" , {-# SCC "Prelude::(>>>)" #-}
+ logicShift rotateRW rotateRS)
+
+ -- Indexing and updates
+ , ("@" , {-# SCC "Prelude::(@)" #-}
+ indexPrim sym indexFront_int indexFront_bits indexFront)
+ , ("!" , {-# SCC "Prelude::(!)" #-}
+ indexPrim sym indexBack_int indexBack_bits indexBack)
+
+ , ("update" , {-# SCC "Prelude::update" #-}
+ updatePrim sym updateFront_word updateFront)
+
+ , ("updateEnd" , {-# SCC "Prelude::updateEnd" #-}
+ updatePrim sym updateBack_word updateBack)
+
+ -- Misc
+ , ("parmap" , {-# SCC "Prelude::parmap" #-}
+ parmapV sym)
+
+ , ("fromZ" , {-# SCC "Prelude::fromZ" #-}
+ fromZV sym)
+
+ , ("error" , {-# SCC "Prelude::error" #-}
+ tlam $ \a ->
+ nlam $ \_ ->
+ lam $ \s -> errorV sym a =<< (valueToString sym =<< s))
+
+ , ("random" , {-# SCC "Prelude::random" #-}
+ tlam $ \a ->
+ wlam sym $ \(bvVal -> x) -> randomV sym a x)
+
+ , ("trace" , {-# SCC "Prelude::trace" #-}
+ nlam $ \_n ->
+ tlam $ \_a ->
+ tlam $ \_b ->
+ lam $ \s -> return $
+ lam $ \x -> return $
+ lam $ \y -> do
+ msg <- valueToString sym =<< s
+ EvalOpts { evalPPOpts, evalLogger } <- getEvalOpts
+ doc <- ppValue sym evalPPOpts =<< x
+ yv <- y
+ io $ logPrint evalLogger
+ $ if null msg then doc else text msg <+> doc
+ return yv)
+ ]
+
+
+--------------------------------------------------------------------------------
+
+sshrV :: Value
+sshrV =
+ nlam $ \_n ->
+ tlam $ \ix ->
+ wlam Concrete $ \(BV w x) -> return $
+ lam $ \y ->
+ do idx <- y >>= asIndex Concrete ">>$" ix >>= \case
+ Left idx -> pure idx
+ Right wv -> bvVal <$> asWordVal Concrete wv
+ return $ VWord w $ pure $ WordVal $ mkBv w $ signedShiftRW w x idx
+
+logicShift :: (Integer -> Integer -> Integer -> Integer)
+ -- ^ The function may assume its arguments are masked.
+ -- It is responsible for masking its result if needed.
+ -> (Nat' -> TValue -> SeqMap Concrete -> Integer -> SeqMap Concrete)
+ -> Value
+logicShift opW opS
+ = nlam $ \ a ->
+ tlam $ \ _ix ->
+ tlam $ \ c ->
+ lam $ \ l -> return $
+ lam $ \ r -> do
+ i <- r >>= \case
+ VInteger i -> pure i
+ VWord _ wval -> bvVal <$> (asWordVal Concrete =<< wval)
+ _ -> evalPanic "logicShift" ["not an index"]
+ l >>= \case
+ VWord w wv -> return $ VWord w $ wv >>= \case
+ WordVal (BV _ x) -> return $ WordVal (BV w (opW w x i))
+ LargeBitsVal n xs -> return $ LargeBitsVal n $ opS (Nat n) c xs i
+
+ _ -> mkSeq a c <$> (opS a c <$> (fromSeq "logicShift" =<< l) <*> return i)
+
+-- Left shift for words.
+shiftLW :: Integer -> Integer -> Integer -> Integer
+shiftLW w ival by
+ | by < 0 = shiftRW w ival (negate by)
+ | by >= w = 0
+ | by > toInteger (maxBound :: Int) = panic "shiftLW" ["Shift amount too large", show by]
+ | otherwise = mask w (shiftL ival (fromInteger by))
+
+-- Right shift for words
+shiftRW :: Integer -> Integer -> Integer -> Integer
+shiftRW w ival by
+ | by < 0 = shiftLW w ival (negate by)
+ | by >= w = 0
+ | by > toInteger (maxBound :: Int) = panic "shiftRW" ["Shift amount too large", show by]
+ | otherwise = shiftR ival (fromInteger by)
+
+-- signed right shift for words
+signedShiftRW :: Integer -> Integer -> Integer -> Integer
+signedShiftRW w ival by
+ | by < 0 = shiftLW w ival (negate by)
+ | otherwise =
+ let by' = min w by in
+ if by' > toInteger (maxBound :: Int) then
+ panic "signedShiftRW" ["Shift amount too large", show by]
+ else
+ shiftR (signedValue w ival) (fromInteger by')
+
+shiftLS :: Nat' -> TValue -> SeqMap Concrete -> Integer -> SeqMap Concrete
+shiftLS w ety vs by
+ | by < 0 = shiftRS w ety vs (negate by)
+
+shiftLS w ety vs by = IndexSeqMap $ \i ->
+ case w of
+ Nat len
+ | i+by < len -> lookupSeqMap vs (i+by)
+ | i < len -> zeroV Concrete ety
+ | otherwise -> evalPanic "shiftLS" ["Index out of bounds"]
+ Inf -> lookupSeqMap vs (i+by)
+
+shiftRS :: Nat' -> TValue -> SeqMap Concrete -> Integer -> SeqMap Concrete
+shiftRS w ety vs by
+ | by < 0 = shiftLS w ety vs (negate by)
+
+shiftRS w ety vs by = IndexSeqMap $ \i ->
+ case w of
+ Nat len
+ | i >= by -> lookupSeqMap vs (i-by)
+ | i < len -> zeroV Concrete ety
+ | otherwise -> evalPanic "shiftLS" ["Index out of bounds"]
+ Inf
+ | i >= by -> lookupSeqMap vs (i-by)
+ | otherwise -> zeroV Concrete ety
+
+
+-- XXX integer doesn't implement rotateL, as there's no bit bound
+rotateLW :: Integer -> Integer -> Integer -> Integer
+rotateLW 0 i _ = i
+rotateLW w i by = mask w $ (i `shiftL` b) .|. (i `shiftR` (fromInteger w - b))
+ where b = fromInteger (by `mod` w)
+
+rotateLS :: Nat' -> TValue -> SeqMap Concrete -> Integer -> SeqMap Concrete
+rotateLS w _ vs by = IndexSeqMap $ \i ->
+ case w of
+ Nat len -> lookupSeqMap vs ((by + i) `mod` len)
+ _ -> panic "Cryptol.Eval.Prim.rotateLS" [ "unexpected infinite sequence" ]
+
+-- XXX integer doesn't implement rotateR, as there's no bit bound
+rotateRW :: Integer -> Integer -> Integer -> Integer
+rotateRW 0 i _ = i
+rotateRW w i by = mask w $ (i `shiftR` b) .|. (i `shiftL` (fromInteger w - b))
+ where b = fromInteger (by `mod` w)
+
+rotateRS :: Nat' -> TValue -> SeqMap Concrete -> Integer -> SeqMap Concrete
+rotateRS w _ vs by = IndexSeqMap $ \i ->
+ case w of
+ Nat len -> lookupSeqMap vs ((len - by + i) `mod` len)
+ _ -> panic "Cryptol.Eval.Prim.rotateRS" [ "unexpected infinite sequence" ]
+
+
+-- Sequence Primitives ---------------------------------------------------------
+
+indexFront :: Nat' -> TValue -> SeqMap Concrete -> TValue -> BV -> Eval Value
+indexFront _mblen _a vs _ix (bvVal -> ix) = lookupSeqMap vs ix
+
+indexFront_bits :: Nat' -> TValue -> SeqMap Concrete -> TValue -> [Bool] -> Eval Value
+indexFront_bits mblen a vs ix bs = indexFront mblen a vs ix =<< packWord Concrete bs
+
+indexFront_int :: Nat' -> TValue -> SeqMap Concrete -> TValue -> Integer -> Eval Value
+indexFront_int _mblen _a vs _ix idx = lookupSeqMap vs idx
+
+indexBack :: Nat' -> TValue -> SeqMap Concrete -> TValue -> BV -> Eval Value
+indexBack mblen a vs ix (bvVal -> idx) = indexBack_int mblen a vs ix idx
+
+indexBack_bits :: Nat' -> TValue -> SeqMap Concrete -> TValue -> [Bool] -> Eval Value
+indexBack_bits mblen a vs ix bs = indexBack mblen a vs ix =<< packWord Concrete bs
+
+indexBack_int :: Nat' -> TValue -> SeqMap Concrete -> TValue -> Integer -> Eval Value
+indexBack_int mblen _a vs _ix idx =
+ case mblen of
+ Nat len -> lookupSeqMap vs (len - idx - 1)
+ Inf -> evalPanic "indexBack" ["unexpected infinite sequence"]
+
+updateFront ::
+ Nat' {- ^ length of the sequence -} ->
+ TValue {- ^ type of values in the sequence -} ->
+ SeqMap Concrete {- ^ sequence to update -} ->
+ Either Integer (WordValue Concrete) {- ^ index -} ->
+ Eval Value {- ^ new value at index -} ->
+ Eval (SeqMap Concrete)
+updateFront _len _eltTy vs (Left idx) val = do
+ return $ updateSeqMap vs idx val
+
+updateFront _len _eltTy vs (Right w) val = do
+ idx <- bvVal <$> asWordVal Concrete w
+ return $ updateSeqMap vs idx val
+
+updateFront_word ::
+ Nat' {- ^ length of the sequence -} ->
+ TValue {- ^ type of values in the sequence -} ->
+ WordValue Concrete {- ^ bit sequence to update -} ->
+ Either Integer (WordValue Concrete) {- ^ index -} ->
+ Eval Value {- ^ new value at index -} ->
+ Eval (WordValue Concrete)
+updateFront_word _len _eltTy bs (Left idx) val = do
+ updateWordValue Concrete bs idx (fromVBit <$> val)
+
+updateFront_word _len _eltTy bs (Right w) val = do
+ idx <- bvVal <$> asWordVal Concrete w
+ updateWordValue Concrete bs idx (fromVBit <$> val)
+
+updateBack ::
+ Nat' {- ^ length of the sequence -} ->
+ TValue {- ^ type of values in the sequence -} ->
+ SeqMap Concrete {- ^ sequence to update -} ->
+ Either Integer (WordValue Concrete) {- ^ index -} ->
+ Eval Value {- ^ new value at index -} ->
+ Eval (SeqMap Concrete)
+updateBack Inf _eltTy _vs _w _val =
+ evalPanic "Unexpected infinite sequence in updateEnd" []
+updateBack (Nat n) _eltTy vs (Left idx) val = do
+ return $ updateSeqMap vs (n - idx - 1) val
+updateBack (Nat n) _eltTy vs (Right w) val = do
+ idx <- bvVal <$> asWordVal Concrete w
+ return $ updateSeqMap vs (n - idx - 1) val
+
+updateBack_word ::
+ Nat' {- ^ length of the sequence -} ->
+ TValue {- ^ type of values in the sequence -} ->
+ WordValue Concrete {- ^ bit sequence to update -} ->
+ Either Integer (WordValue Concrete) {- ^ index -} ->
+ Eval Value {- ^ new value at index -} ->
+ Eval (WordValue Concrete)
+updateBack_word Inf _eltTy _bs _w _val =
+ evalPanic "Unexpected infinite sequence in updateEnd" []
+updateBack_word (Nat n) _eltTy bs (Left idx) val = do
+ updateWordValue Concrete bs (n - idx - 1) (fromVBit <$> val)
+updateBack_word (Nat n) _eltTy bs (Right w) val = do
+ idx <- bvVal <$> asWordVal Concrete w
+ updateWordValue Concrete bs (n - idx - 1) (fromVBit <$> val)
diff --git a/src/Cryptol/Eval/Concrete/Float.hs b/src/Cryptol/Eval/Concrete/Float.hs
new file mode 100644
--- /dev/null
+++ b/src/Cryptol/Eval/Concrete/Float.hs
@@ -0,0 +1,69 @@
+{-# 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
new file mode 100644
--- /dev/null
+++ b/src/Cryptol/Eval/Concrete/FloatHelpers.hs
@@ -0,0 +1,252 @@
+{-# 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
new file mode 100644
--- /dev/null
+++ b/src/Cryptol/Eval/Concrete/Value.hs
@@ -0,0 +1,390 @@
+-- |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,7 +14,8 @@
{-# LANGUAGE DeriveGeneric #-}
module Cryptol.Eval.Env where
-import Cryptol.Eval.Monad( Eval, delay, ready, PPOpts )
+import Cryptol.Eval.Backend
+import Cryptol.Eval.Monad( PPOpts )
import Cryptol.Eval.Type
import Cryptol.Eval.Value
import Cryptol.ModuleSystem.Name
@@ -27,25 +28,24 @@
import Data.Semigroup
import GHC.Generics (Generic)
-import Control.DeepSeq
import Prelude ()
import Prelude.Compat
-- Evaluation Environment ------------------------------------------------------
-data GenEvalEnv b w i = EvalEnv
- { envVars :: !(Map.Map Name (Eval (GenValue b w i)))
+data GenEvalEnv sym = EvalEnv
+ { envVars :: !(Map.Map Name (SEval sym (GenValue sym)))
, envTypes :: !TypeEnv
- } deriving (Generic, NFData)
+ } deriving Generic
-instance Semigroup (GenEvalEnv b w i) where
+instance Semigroup (GenEvalEnv sym) where
l <> r = EvalEnv
{ envVars = Map.union (envVars l) (envVars r)
, envTypes = Map.union (envTypes l) (envTypes r)
}
-instance Monoid (GenEvalEnv b w i) where
+instance Monoid (GenEvalEnv sym) where
mempty = EvalEnv
{ envVars = Map.empty
, envTypes = Map.empty
@@ -53,47 +53,52 @@
mappend l r = l <> r
-ppEnv :: BitWord b w i => PPOpts -> GenEvalEnv b w i -> Eval Doc
-ppEnv opts env = brackets . fsep <$> mapM bind (Map.toList (envVars env))
+ppEnv :: Backend sym => sym -> PPOpts -> GenEvalEnv sym -> SEval sym Doc
+ppEnv sym opts env = brackets . fsep <$> mapM bind (Map.toList (envVars env))
where
- bind (k,v) = do vdoc <- ppValue opts =<< v
+ bind (k,v) = do vdoc <- ppValue sym opts =<< v
return (pp k <+> text "->" <+> vdoc)
-- | Evaluation environment with no bindings
-emptyEnv :: GenEvalEnv b w i
+emptyEnv :: GenEvalEnv sym
emptyEnv = mempty
-- | Bind a variable in the evaluation environment.
-bindVar :: Name
- -> Eval (GenValue b w i)
- -> GenEvalEnv b w i
- -> Eval (GenEvalEnv b w i)
-bindVar n val env = do
+bindVar ::
+ Backend sym =>
+ sym ->
+ Name ->
+ SEval sym (GenValue sym) ->
+ GenEvalEnv sym ->
+ SEval sym (GenEvalEnv sym)
+bindVar sym n val env = do
let nm = show $ ppLocName n
- val' <- delay (Just nm) val
+ val' <- sDelay sym (Just nm) val
return $ env{ envVars = Map.insert n val' (envVars env) }
-- | Bind a variable to a value in the evaluation environment, without
-- creating a thunk.
-bindVarDirect :: Name
- -> GenValue b w i
- -> GenEvalEnv b w i
- -> GenEvalEnv b w i
+bindVarDirect ::
+ Backend sym =>
+ Name ->
+ GenValue sym ->
+ GenEvalEnv sym ->
+ GenEvalEnv sym
bindVarDirect n val env = do
- env{ envVars = Map.insert n (ready val) (envVars env) }
+ env{ envVars = Map.insert n (pure val) (envVars env) }
-- | Lookup a variable in the environment.
{-# INLINE lookupVar #-}
-lookupVar :: Name -> GenEvalEnv b w i -> Maybe (Eval (GenValue b w i))
+lookupVar :: Name -> GenEvalEnv sym -> Maybe (SEval sym (GenValue sym))
lookupVar n env = Map.lookup n (envVars env)
-- | Bind a type variable of kind *.
{-# INLINE bindType #-}
-bindType :: TVar -> Either Nat' TValue -> GenEvalEnv b w i -> GenEvalEnv b w i
+bindType :: TVar -> Either Nat' TValue -> GenEvalEnv sym -> GenEvalEnv sym
bindType p ty env = env { envTypes = Map.insert p ty (envTypes env) }
-- | Lookup a type variable.
{-# INLINE lookupType #-}
-lookupType :: TVar -> GenEvalEnv b w i -> Maybe (Either Nat' TValue)
+lookupType :: TVar -> GenEvalEnv sym -> Maybe (Either Nat' TValue)
lookupType p env = Map.lookup p (envTypes env)
diff --git a/src/Cryptol/Eval/Generic.hs b/src/Cryptol/Eval/Generic.hs
new file mode 100644
--- /dev/null
+++ b/src/Cryptol/Eval/Generic.hs
@@ -0,0 +1,1965 @@
+-- |
+-- Module : Cryptol.Eval.Generic
+-- Copyright : (c) 2013-2020 Galois, Inc.
+-- License : BSD3
+-- Maintainer : cryptol@galois.com
+-- Stability : provisional
+-- Portability : portable
+
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE Safe #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE BangPatterns #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Cryptol.Eval.Generic where
+
+import qualified Control.Exception as X
+import Control.Monad.IO.Class (MonadIO(..))
+import Control.Monad (join, unless)
+
+import Data.Bits (testBit)
+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.Eval.Type
+import Cryptol.Eval.Value
+import Cryptol.Utils.Panic (panic)
+import Cryptol.Utils.RecordMap
+
+
+
+{-# SPECIALIZE mkLit :: Concrete -> TValue -> Integer -> Eval (GenValue Concrete)
+ #-}
+
+-- | Make a numeric literal value at the given type.
+mkLit :: Backend sym => sym -> TValue -> Integer -> SEval sym (GenValue sym)
+mkLit sym ty i =
+ case ty of
+ TVInteger -> VInteger <$> integerLit sym i
+ TVIntMod m
+ | m == 0 -> evalPanic "mkLit" ["0 modulus not allowed"]
+ | otherwise -> VInteger <$> integerLit sym (i `mod` m)
+ TVFloat e p -> VFloat <$> fpLit sym e p (fromInteger i)
+ TVSeq w TVBit -> pure $ word sym w i
+ TVRational -> VRational <$> (intToRational sym =<< integerLit sym i)
+ _ -> evalPanic "Cryptol.Eval.Prim.evalConst"
+ [ "Invalid type for number" ]
+
+{-# SPECIALIZE ecNumberV :: Concrete -> GenValue Concrete
+ #-}
+
+-- | Make a numeric constant.
+ecNumberV :: Backend sym => sym -> GenValue sym
+ecNumberV sym =
+ nlam $ \valT ->
+ VPoly $ \ty ->
+ case valT of
+ Nat v -> mkLit sym ty v
+ _ -> evalPanic "Cryptol.Eval.Prim.evalConst"
+ ["Unexpected Inf in constant."
+ , show valT
+ , show ty
+ ]
+
+
+
+{-# SPECIALIZE intV :: Concrete -> Integer -> TValue -> Eval (GenValue Concrete)
+ #-}
+intV :: Backend sym => sym -> SInteger sym -> TValue -> SEval sym (GenValue sym)
+intV sym i = ringNullary sym (\w -> wordFromInt sym w i) (pure i) (\m -> intToZn sym m i) (intToRational sym i)
+ (\e p -> fpRndMode sym >>= \r -> fpFromInteger sym e p r i)
+
+{-# SPECIALIZE ratioV :: Concrete -> GenValue Concrete #-}
+ratioV :: Backend sym => sym -> GenValue sym
+ratioV sym =
+ lam $ \x -> return $
+ lam $ \y ->
+ do x' <- fromVInteger <$> x
+ y' <- fromVInteger <$> y
+ VRational <$> ratio sym x' y'
+
+{-# SPECIALIZE ecFractionV :: Concrete -> GenValue Concrete
+ #-}
+ecFractionV :: Backend sym => sym -> GenValue sym
+ecFractionV sym =
+ ilam \n ->
+ ilam \d ->
+ ilam \_r ->
+ VPoly \ty ->
+ case ty of
+ TVFloat e p -> VFloat <$> fpLit sym e p (n % d)
+ TVRational ->
+ do x <- integerLit sym n
+ y <- integerLit sym d
+ VRational <$> ratio sym x y
+
+ _ -> evalPanic "ecFractionV"
+ [ "Unexpected `FLiteral` type: " ++ show ty ]
+
+
+
+{-# SPECIALIZE fromZV :: Concrete -> GenValue Concrete #-}
+fromZV :: Backend sym => sym -> GenValue sym
+fromZV sym =
+ nlam $ \(finNat' -> n) ->
+ lam $ \v -> VInteger <$> (znToInt sym n . fromVInteger =<< v)
+
+-- Operation Lifting -----------------------------------------------------------
+
+
+type Binary sym = TValue -> GenValue sym -> GenValue sym -> SEval sym (GenValue sym)
+
+{-# SPECIALIZE binary :: Binary Concrete -> GenValue Concrete
+ #-}
+binary :: Backend sym => Binary sym -> GenValue sym
+binary f = tlam $ \ ty ->
+ lam $ \ a -> return $
+ lam $ \ b -> do
+ --io $ putStrLn "Entering a binary function"
+ join (f ty <$> a <*> b)
+
+type Unary sym = TValue -> GenValue sym -> SEval sym (GenValue sym)
+
+{-# SPECIALIZE unary :: Unary Concrete -> GenValue Concrete
+ #-}
+unary :: Backend sym => Unary sym -> GenValue sym
+unary f = tlam $ \ ty ->
+ lam $ \ a -> f ty =<< a
+
+
+type BinWord sym = Integer -> SWord sym -> SWord sym -> SEval sym (SWord sym)
+
+{-# SPECIALIZE ringBinary :: Concrete -> BinWord Concrete ->
+ (SInteger Concrete -> SInteger Concrete -> SEval Concrete (SInteger Concrete)) ->
+ (Integer -> SInteger Concrete -> SInteger Concrete -> SEval Concrete (SInteger Concrete)) ->
+ (SRational Concrete -> SRational Concrete -> SEval Concrete (SRational Concrete)) ->
+ (SFloat Concrete -> SFloat Concrete -> SEval Concrete (SFloat Concrete)) ->
+ Binary Concrete
+ #-}
+
+ringBinary :: forall sym.
+ Backend sym =>
+ sym ->
+ BinWord sym ->
+ (SInteger sym -> SInteger sym -> SEval sym (SInteger sym)) ->
+ (Integer -> SInteger sym -> SInteger sym -> SEval sym (SInteger sym)) ->
+ (SRational sym -> SRational sym -> SEval sym (SRational sym)) ->
+ (SFloat sym -> SFloat sym -> SEval sym (SFloat sym)) ->
+ Binary sym
+ringBinary sym opw opi opz opq opfp = loop
+ where
+ loop' :: TValue
+ -> SEval sym (GenValue sym)
+ -> SEval sym (GenValue sym)
+ -> SEval sym (GenValue sym)
+ loop' ty l r = join (loop ty <$> l <*> r)
+
+ loop :: TValue
+ -> GenValue sym
+ -> GenValue sym
+ -> SEval sym (GenValue sym)
+ loop ty l r = case ty of
+ TVBit ->
+ evalPanic "ringBinary" ["Bit not in class Ring"]
+
+ TVInteger ->
+ VInteger <$> opi (fromVInteger l) (fromVInteger r)
+
+ TVIntMod n ->
+ VInteger <$> opz n (fromVInteger l) (fromVInteger r)
+
+ TVFloat {} ->
+ VFloat <$> opfp (fromVFloat l) (fromVFloat r)
+
+ TVRational ->
+ VRational <$> opq (fromVRational l) (fromVRational r)
+
+ TVArray{} ->
+ evalPanic "arithBinary" ["Array not in class Ring"]
+
+ TVSeq w a
+ -- words and finite sequences
+ | isTBit a -> do
+ lw <- fromVWord sym "ringLeft" l
+ rw <- fromVWord sym "ringRight" r
+ return $ VWord w (WordVal <$> opw w lw rw)
+ | otherwise -> VSeq w <$> (join (zipSeqMap (loop a) <$>
+ (fromSeq "ringBinary left" l) <*>
+ (fromSeq "ringBinary right" r)))
+
+ TVStream a ->
+ -- streams
+ VStream <$> (join (zipSeqMap (loop a) <$>
+ (fromSeq "ringBinary left" l) <*>
+ (fromSeq "ringBinary right" r)))
+
+ -- functions
+ TVFun _ ety ->
+ return $ lam $ \ x -> loop' ety (fromVFun l x) (fromVFun r x)
+
+ -- tuples
+ TVTuple tys ->
+ do ls <- mapM (sDelay sym Nothing) (fromVTuple l)
+ rs <- mapM (sDelay sym Nothing) (fromVTuple r)
+ return $ VTuple (zipWith3 loop' tys ls rs)
+
+ -- records
+ TVRec fs ->
+ do VRecord <$>
+ traverseRecordMap
+ (\f fty -> sDelay sym Nothing (loop' fty (lookupRecord f l) (lookupRecord f r)))
+ fs
+
+ TVAbstract {} ->
+ evalPanic "ringBinary" ["Abstract type not in `Ring`"]
+
+type UnaryWord sym = Integer -> SWord sym -> SEval sym (SWord sym)
+
+
+{-# SPECIALIZE ringUnary ::
+ Concrete ->
+ UnaryWord Concrete ->
+ (SInteger Concrete -> SEval Concrete (SInteger Concrete)) ->
+ (Integer -> SInteger Concrete -> SEval Concrete (SInteger Concrete)) ->
+ (SRational Concrete -> SEval Concrete (SRational Concrete)) ->
+ (SFloat Concrete -> SEval Concrete (SFloat Concrete)) ->
+ Unary Concrete
+ #-}
+ringUnary :: forall sym.
+ Backend sym =>
+ sym ->
+ UnaryWord sym ->
+ (SInteger sym -> SEval sym (SInteger sym)) ->
+ (Integer -> SInteger sym -> SEval sym (SInteger sym)) ->
+ (SRational sym -> SEval sym (SRational sym)) ->
+ (SFloat sym -> SEval sym (SFloat sym)) ->
+ Unary sym
+ringUnary sym opw opi opz opq opfp = loop
+ where
+ loop' :: TValue -> SEval sym (GenValue sym) -> SEval sym (GenValue sym)
+ loop' ty v = loop ty =<< v
+
+ loop :: TValue -> GenValue sym -> SEval sym (GenValue sym)
+ loop ty v = case ty of
+
+ TVBit ->
+ evalPanic "ringUnary" ["Bit not in class Ring"]
+
+ TVInteger ->
+ VInteger <$> opi (fromVInteger v)
+
+ TVIntMod n ->
+ VInteger <$> opz n (fromVInteger v)
+
+ TVFloat {} ->
+ VFloat <$> opfp (fromVFloat v)
+
+ TVRational ->
+ VRational <$> opq (fromVRational v)
+
+ TVArray{} ->
+ evalPanic "arithUnary" ["Array not in class Ring"]
+
+ TVSeq w a
+ -- words and finite sequences
+ | isTBit a -> do
+ wx <- fromVWord sym "ringUnary" v
+ return $ VWord w (WordVal <$> opw w wx)
+ | otherwise -> VSeq w <$> (mapSeqMap (loop a) =<< fromSeq "ringUnary" v)
+
+ TVStream a ->
+ VStream <$> (mapSeqMap (loop a) =<< fromSeq "ringUnary" v)
+
+ -- functions
+ TVFun _ ety ->
+ return $ lam $ \ y -> loop' ety (fromVFun v y)
+
+ -- tuples
+ TVTuple tys ->
+ do as <- mapM (sDelay sym Nothing) (fromVTuple v)
+ return $ VTuple (zipWith loop' tys as)
+
+ -- records
+ TVRec fs ->
+ VRecord <$>
+ traverseRecordMap
+ (\f fty -> sDelay sym Nothing (loop' fty (lookupRecord f v)))
+ fs
+
+ TVAbstract {} -> evalPanic "ringUnary" ["Abstract type not in `Ring`"]
+
+{-# SPECIALIZE ringNullary ::
+ Concrete ->
+ (Integer -> SEval Concrete (SWord Concrete)) ->
+ SEval Concrete (SInteger Concrete) ->
+ (Integer -> SEval Concrete (SInteger Concrete)) ->
+ SEval Concrete (SRational Concrete) ->
+ (Integer -> Integer -> SEval Concrete (SFloat Concrete)) ->
+ TValue ->
+ SEval Concrete (GenValue Concrete)
+ #-}
+
+ringNullary :: forall sym.
+ Backend sym =>
+ sym ->
+ (Integer -> SEval sym (SWord sym)) ->
+ SEval sym (SInteger sym) ->
+ (Integer -> SEval sym (SInteger sym)) ->
+ SEval sym (SRational sym) ->
+ (Integer -> Integer -> SEval sym (SFloat sym)) ->
+ TValue ->
+ SEval sym (GenValue sym)
+ringNullary sym opw opi opz opq opfp = loop
+ where
+ loop :: TValue -> SEval sym (GenValue sym)
+ loop ty =
+ case ty of
+ TVBit -> evalPanic "ringNullary" ["Bit not in class Ring"]
+
+ TVInteger -> VInteger <$> opi
+
+ TVIntMod n -> VInteger <$> opz n
+
+ TVFloat e p -> VFloat <$> opfp e p
+
+ TVRational -> VRational <$> opq
+
+ TVArray{} -> evalPanic "arithNullary" ["Array not in class Ring"]
+
+ TVSeq w a
+ -- words and finite sequences
+ | isTBit a -> pure $ VWord w $ (WordVal <$> opw w)
+ | otherwise ->
+ do v <- sDelay sym Nothing (loop a)
+ pure $ VSeq w $ IndexSeqMap $ const v
+
+ TVStream a ->
+ do v <- sDelay sym Nothing (loop a)
+ pure $ VStream $ IndexSeqMap $ const v
+
+ TVFun _ b ->
+ do v <- sDelay sym Nothing (loop b)
+ pure $ lam $ const $ v
+
+ TVTuple tys ->
+ do xs <- mapM (sDelay sym Nothing . loop) tys
+ pure $ VTuple xs
+
+ TVRec fs ->
+ do xs <- traverse (sDelay sym Nothing . loop) fs
+ pure $ VRecord xs
+
+ TVAbstract {} ->
+ evalPanic "ringNullary" ["Abstract type not in `Ring`"]
+
+{-# SPECIALIZE integralBinary :: Concrete -> BinWord Concrete ->
+ (SInteger Concrete -> SInteger Concrete -> SEval Concrete (SInteger Concrete)) ->
+ Binary Concrete
+ #-}
+
+integralBinary :: forall sym.
+ Backend sym =>
+ sym ->
+ BinWord sym ->
+ (SInteger sym -> SInteger sym -> SEval sym (SInteger sym)) ->
+ Binary sym
+integralBinary sym opw opi ty l r = case ty of
+ TVInteger ->
+ VInteger <$> opi (fromVInteger l) (fromVInteger r)
+
+ -- bitvectors
+ TVSeq w a
+ | isTBit a ->
+ do wl <- fromVWord sym "integralBinary left" l
+ wr <- fromVWord sym "integralBinary right" r
+ return $ VWord w (WordVal <$> opw w wl wr)
+
+ _ -> evalPanic "integralBinary" [show ty ++ " not int class `Integral`"]
+
+
+---------------------------------------------------------------------------
+-- Ring
+
+{-# SPECIALIZE fromIntegerV :: Concrete -> GenValue Concrete
+ #-}
+-- | Convert an unbounded integer to a value in Ring
+fromIntegerV :: Backend sym => sym -> GenValue sym
+fromIntegerV sym =
+ tlam $ \ a ->
+ lam $ \ v ->
+ do i <- fromVInteger <$> v
+ intV sym i a
+
+{-# INLINE addV #-}
+addV :: Backend sym => sym -> Binary sym
+addV sym = ringBinary sym opw opi opz opq opfp
+ where
+ opw _w x y = wordPlus sym x y
+ opi x y = intPlus sym x y
+ opz m x y = znPlus sym m x y
+ opq x y = rationalAdd sym x y
+ opfp x y = fpRndMode sym >>= \r -> fpPlus sym r x y
+
+{-# INLINE subV #-}
+subV :: Backend sym => sym -> Binary sym
+subV sym = ringBinary sym opw opi opz opq opfp
+ where
+ opw _w x y = wordMinus sym x y
+ opi x y = intMinus sym x y
+ opz m x y = znMinus sym m x y
+ opq x y = rationalSub sym x y
+ opfp x y = fpRndMode sym >>= \r -> fpMinus sym r x y
+
+{-# INLINE negateV #-}
+negateV :: Backend sym => sym -> Unary sym
+negateV sym = ringUnary sym opw opi opz opq opfp
+ where
+ opw _w x = wordNegate sym x
+ opi x = intNegate sym x
+ opz m x = znNegate sym m x
+ opq x = rationalNegate sym x
+ opfp x = fpNeg sym x
+
+{-# INLINE mulV #-}
+mulV :: Backend sym => sym -> Binary sym
+mulV sym = ringBinary sym opw opi opz opq opfp
+ where
+ opw _w x y = wordMult sym x y
+ opi x y = intMult sym x y
+ opz m x y = znMult sym m x y
+ opq x y = rationalMul sym x y
+ opfp x y = fpRndMode sym >>= \r -> fpMult sym r x y
+
+--------------------------------------------------
+-- Integral
+
+{-# INLINE divV #-}
+divV :: Backend sym => sym -> Binary sym
+divV sym = integralBinary sym opw opi
+ where
+ opw _w x y = wordDiv sym x y
+ opi x y = intDiv sym x y
+
+{-# SPECIALIZE expV :: Concrete -> GenValue Concrete #-}
+expV :: Backend sym => sym -> GenValue sym
+expV sym =
+ tlam $ \aty ->
+ tlam $ \ety ->
+ lam $ \am -> return $
+ lam $ \em ->
+ do a <- am
+ e <- em
+ case ety of
+ TVInteger ->
+ let ei = fromVInteger e in
+ case integerAsLit sym ei of
+ Just n
+ | n == 0 ->
+ do onei <- integerLit sym 1
+ intV sym onei aty
+
+ | n > 0 ->
+ do ebits <- enumerateIntBits' sym n ei
+ computeExponent sym aty a ebits
+
+ | otherwise -> raiseError sym NegativeExponent
+
+ Nothing -> liftIO (X.throw (UnsupportedSymbolicOp "integer exponentiation"))
+
+ TVSeq _w el | isTBit el ->
+ do ebits <- enumerateWordValue sym =<< fromWordVal "(^^)" e
+ computeExponent sym aty a ebits
+
+ _ -> evalPanic "expV" [show ety ++ " not int class `Integral`"]
+
+
+{-# SPECIALIZE computeExponent ::
+ Concrete -> TValue -> GenValue Concrete -> [SBit Concrete] -> SEval Concrete (GenValue Concrete)
+ #-}
+computeExponent :: Backend sym =>
+ sym -> TValue -> GenValue sym -> [SBit sym] -> SEval sym (GenValue sym)
+computeExponent sym aty a bs0 =
+ do onei <- integerLit sym 1
+ one <- intV sym onei aty
+ loop one (dropLeadingZeros bs0)
+
+ where
+ dropLeadingZeros [] = []
+ dropLeadingZeros (b:bs)
+ | Just False <- bitAsLit sym b = dropLeadingZeros bs
+ | otherwise = (b:bs)
+
+ loop acc [] = return acc
+ loop acc (b:bs) =
+ do sq <- mulV sym aty acc acc
+ acc' <- iteValue sym b
+ (mulV sym aty a sq)
+ (pure sq)
+ loop acc' bs
+
+{-# INLINE modV #-}
+modV :: Backend sym => sym -> Binary sym
+modV sym = integralBinary sym opw opi
+ where
+ opw _w x y = wordMod sym x y
+ opi x y = intMod sym x y
+
+{-# SPECIALIZE toIntegerV :: Concrete -> GenValue Concrete #-}
+-- | Convert a word to a non-negative integer.
+toIntegerV :: Backend sym => sym -> GenValue sym
+toIntegerV sym =
+ tlam $ \a ->
+ lam $ \v ->
+ case a of
+ TVSeq _w el | isTBit el ->
+ VInteger <$> (wordToInt sym =<< (fromVWord sym "toInteger" =<< v))
+ TVInteger -> v
+ _ -> evalPanic "toInteger" [show a ++ " not in class `Integral`"]
+
+-----------------------------------------------------------------------------
+-- Field
+
+{-# SPECIALIZE recipV :: Concrete -> GenValue Concrete #-}
+recipV :: Backend sym => sym -> GenValue sym
+recipV sym =
+ tlam $ \a ->
+ lam $ \x ->
+ case a of
+ TVRational -> VRational <$> (rationalRecip sym . fromVRational =<< x)
+ TVFloat e p ->
+ do one <- fpLit sym e p 1
+ r <- fpRndMode sym
+ xv <- fromVFloat <$> x
+ VFloat <$> fpDiv sym r one xv
+
+ _ -> evalPanic "recip" [show a ++ "is not a Field"]
+
+{-# SPECIALIZE fieldDivideV :: Concrete -> GenValue Concrete #-}
+fieldDivideV :: Backend sym => sym -> GenValue sym
+fieldDivideV sym =
+ tlam $ \a ->
+ lam $ \x -> return $
+ lam $ \y ->
+ case a of
+ TVRational ->
+ do x' <- fromVRational <$> x
+ y' <- fromVRational <$> y
+ VRational <$> rationalDivide sym x' y'
+ TVFloat _e _p ->
+ do xv <- fromVFloat <$> x
+ yv <- fromVFloat <$> y
+ r <- fpRndMode sym
+ VFloat <$> fpDiv sym r xv yv
+ _ -> evalPanic "recip" [show a ++ "is not a Field"]
+
+--------------------------------------------------------------
+-- Round
+
+{-# SPECIALIZE roundOp ::
+ Concrete ->
+ String ->
+ (SRational Concrete -> SEval Concrete (SInteger Concrete)) ->
+ (SFloat Concrete -> SEval Concrete (SInteger Concrete)) ->
+ Unary Concrete #-}
+
+roundOp ::
+ Backend sym =>
+ sym ->
+ String ->
+ (SRational sym -> SEval sym (SInteger sym)) ->
+ (SFloat sym -> SEval sym (SInteger sym)) ->
+ Unary sym
+roundOp _sym nm qop opfp ty v =
+ case ty of
+ TVRational -> VInteger <$> (qop (fromVRational v))
+ TVFloat _ _ -> VInteger <$> opfp (fromVFloat v)
+ _ -> evalPanic nm [show ty ++ " is not a Field"]
+
+{-# INLINE floorV #-}
+floorV :: Backend sym => sym -> Unary sym
+floorV sym = roundOp sym "floor" opq opfp
+ where
+ opq = rationalFloor sym
+ opfp = \x -> fpRndRTN sym >>= \r -> fpToInteger sym "floor" r x
+
+{-# INLINE ceilingV #-}
+ceilingV :: Backend sym => sym -> Unary sym
+ceilingV sym = roundOp sym "ceiling" opq opfp
+ where
+ opq = rationalCeiling sym
+ opfp = \x -> fpRndRTP sym >>= \r -> fpToInteger sym "ceiling" r x
+
+{-# INLINE truncV #-}
+truncV :: Backend sym => sym -> Unary sym
+truncV sym = roundOp sym "trunc" opq opfp
+ where
+ opq = rationalTrunc sym
+ opfp = \x -> fpRndRTZ sym >>= \r -> fpToInteger sym "trunc" r x
+
+{-# INLINE roundAwayV #-}
+roundAwayV :: Backend sym => sym -> Unary sym
+roundAwayV sym = roundOp sym "roundAway" opq opfp
+ where
+ opq = rationalRoundAway sym
+ opfp = \x -> fpRndRNA sym >>= \r -> fpToInteger sym "roundAway" r x
+
+{-# INLINE roundToEvenV #-}
+roundToEvenV :: Backend sym => sym -> Unary sym
+roundToEvenV sym = roundOp sym "roundToEven" opq opfp
+ where
+ opq = rationalRoundToEven sym
+ opfp = \x -> fpRndRNE sym >>= \r -> fpToInteger sym "roundToEven" r x
+
+--------------------------------------------------------------
+-- Logic
+
+{-# INLINE andV #-}
+andV :: Backend sym => sym -> Binary sym
+andV sym = logicBinary sym (bitAnd sym) (wordAnd sym)
+
+{-# INLINE orV #-}
+orV :: Backend sym => sym -> Binary sym
+orV sym = logicBinary sym (bitOr sym) (wordOr sym)
+
+{-# INLINE xorV #-}
+xorV :: Backend sym => sym -> Binary sym
+xorV sym = logicBinary sym (bitXor sym) (wordXor sym)
+
+{-# INLINE complementV #-}
+complementV :: Backend sym => sym -> Unary sym
+complementV sym = logicUnary sym (bitComplement sym) (wordComplement sym)
+
+-- Bitvector signed div and modulus
+
+{-# INLINE lg2V #-}
+lg2V :: Backend sym => sym -> GenValue sym
+lg2V sym =
+ nlam $ \(finNat' -> w) ->
+ wlam sym $ \x -> return $
+ VWord w (WordVal <$> wordLg2 sym x)
+
+{-# SPECIALIZE sdivV :: Concrete -> GenValue Concrete #-}
+sdivV :: Backend sym => sym -> GenValue sym
+sdivV sym =
+ nlam $ \(finNat' -> w) ->
+ wlam sym $ \x -> return $
+ wlam sym $ \y -> return $
+ VWord w (WordVal <$> wordSignedDiv sym x y)
+
+{-# SPECIALIZE smodV :: Concrete -> GenValue Concrete #-}
+smodV :: Backend sym => sym -> GenValue sym
+smodV sym =
+ nlam $ \(finNat' -> w) ->
+ wlam sym $ \x -> return $
+ wlam sym $ \y -> return $
+ VWord w (WordVal <$> wordSignedMod sym x y)
+
+-- Cmp -------------------------------------------------------------------------
+
+{-# SPECIALIZE cmpValue ::
+ Concrete ->
+ (SBit Concrete -> SBit Concrete -> SEval Concrete a -> SEval Concrete a) ->
+ (SWord Concrete -> SWord Concrete -> SEval Concrete a -> SEval Concrete a) ->
+ (SInteger Concrete -> SInteger Concrete -> SEval Concrete a -> SEval Concrete a) ->
+ (Integer -> SInteger Concrete -> SInteger Concrete -> SEval Concrete a -> SEval Concrete a) ->
+ (SRational Concrete -> SRational Concrete -> SEval Concrete a -> SEval Concrete a) ->
+ (SFloat Concrete -> SFloat Concrete -> SEval Concrete a -> SEval Concrete a) ->
+ (TValue -> GenValue Concrete -> GenValue Concrete -> SEval Concrete a -> SEval Concrete a)
+ #-}
+
+cmpValue ::
+ Backend sym =>
+ sym ->
+ (SBit sym -> SBit sym -> SEval sym a -> SEval sym a) ->
+ (SWord sym -> SWord sym -> SEval sym a -> SEval sym a) ->
+ (SInteger sym -> SInteger sym -> SEval sym a -> SEval sym a) ->
+ (Integer -> SInteger sym -> SInteger sym -> SEval sym a -> SEval sym a) ->
+ (SRational sym -> SRational sym -> SEval sym a -> SEval sym a) ->
+ (SFloat sym -> SFloat sym -> SEval sym a -> SEval sym a) ->
+ (TValue -> GenValue sym -> GenValue sym -> SEval sym a -> SEval sym a)
+cmpValue sym fb fw fi fz fq ff = cmp
+ where
+ cmp ty v1 v2 k =
+ case ty of
+ TVBit -> fb (fromVBit v1) (fromVBit v2) k
+ TVInteger -> fi (fromVInteger v1) (fromVInteger v2) k
+ TVFloat _ _ -> ff (fromVFloat v1) (fromVFloat v2) k
+ TVIntMod n -> fz n (fromVInteger v1) (fromVInteger v2) k
+ TVRational -> fq (fromVRational v1) (fromVRational v2) k
+ TVArray{} -> panic "Cryptol.Prims.Value.cmpValue"
+ [ "Arrays are not comparable" ]
+ TVSeq n t
+ | isTBit t -> do w1 <- fromVWord sym "cmpValue" v1
+ w2 <- fromVWord sym "cmpValue" v2
+ fw w1 w2 k
+ | otherwise -> cmpValues (repeat t)
+ (enumerateSeqMap n (fromVSeq v1))
+ (enumerateSeqMap n (fromVSeq v2))
+ k
+ TVStream _ -> panic "Cryptol.Prims.Value.cmpValue"
+ [ "Infinite streams are not comparable" ]
+ TVFun _ _ -> panic "Cryptol.Prims.Value.cmpValue"
+ [ "Functions are not comparable" ]
+ TVTuple tys -> cmpValues tys (fromVTuple v1) (fromVTuple v2) k
+ TVRec fields -> cmpValues
+ (recordElements fields)
+ (recordElements (fromVRecord v1))
+ (recordElements (fromVRecord v2))
+ k
+ TVAbstract {} -> evalPanic "cmpValue"
+ [ "Abstract type not in `Cmp`" ]
+
+ cmpValues (t : ts) (x1 : xs1) (x2 : xs2) k =
+ do x1' <- x1
+ x2' <- x2
+ cmp t x1' x2' (cmpValues ts xs1 xs2 k)
+ cmpValues _ _ _ k = k
+
+
+{-# INLINE bitLessThan #-}
+bitLessThan :: Backend sym => sym -> SBit sym -> SBit sym -> SEval sym (SBit sym)
+bitLessThan sym x y =
+ do xnot <- bitComplement sym x
+ bitAnd sym xnot y
+
+{-# INLINE bitGreaterThan #-}
+bitGreaterThan :: Backend sym => sym -> SBit sym -> SBit sym -> SEval sym (SBit sym)
+bitGreaterThan sym x y = bitLessThan sym y x
+
+{-# INLINE valEq #-}
+valEq :: Backend sym => sym -> TValue -> GenValue sym -> GenValue sym -> SEval sym (SBit sym)
+valEq sym ty v1 v2 = cmpValue sym fb fw fi fz fq ff ty v1 v2 (pure $ bitLit sym True)
+ where
+ fb x y k = eqCombine sym (bitEq sym x y) k
+ fw x y k = eqCombine sym (wordEq sym x y) k
+ fi x y k = eqCombine sym (intEq sym x y) k
+ fz m x y k = eqCombine sym (znEq sym m x y) k
+ fq x y k = eqCombine sym (rationalEq sym x y) k
+ ff x y k = eqCombine sym (fpEq sym x y) k
+
+{-# INLINE valLt #-}
+valLt :: Backend sym =>
+ sym -> TValue -> GenValue sym -> GenValue sym -> SBit sym -> SEval sym (SBit sym)
+valLt sym ty v1 v2 final = cmpValue sym fb fw fi fz fq ff ty v1 v2 (pure final)
+ where
+ fb x y k = lexCombine sym (bitLessThan sym x y) (bitEq sym x y) k
+ fw x y k = lexCombine sym (wordLessThan sym x y) (wordEq sym x y) k
+ fi x y k = lexCombine sym (intLessThan sym x y) (intEq sym x y) k
+ fz _ _ _ _ = panic "valLt" ["Z_n is not in `Cmp`"]
+ fq x y k = lexCombine sym (rationalLessThan sym x y) (rationalEq sym x y) k
+ ff x y k = lexCombine sym (fpLessThan sym x y) (fpEq sym x y) k
+
+{-# INLINE valGt #-}
+valGt :: Backend sym =>
+ sym -> TValue -> GenValue sym -> GenValue sym -> SBit sym -> SEval sym (SBit sym)
+valGt sym ty v1 v2 final = cmpValue sym fb fw fi fz fq ff ty v1 v2 (pure final)
+ where
+ fb x y k = lexCombine sym (bitGreaterThan sym x y) (bitEq sym x y) k
+ fw x y k = lexCombine sym (wordGreaterThan sym x y) (wordEq sym x y) k
+ fi x y k = lexCombine sym (intGreaterThan sym x y) (intEq sym x y) k
+ fz _ _ _ _ = panic "valGt" ["Z_n is not in `Cmp`"]
+ fq x y k = lexCombine sym (rationalGreaterThan sym x y) (rationalEq sym x y) k
+ ff x y k = lexCombine sym (fpGreaterThan sym x y) (fpEq sym x y) k
+
+{-# INLINE eqCombine #-}
+eqCombine :: Backend sym =>
+ sym ->
+ SEval sym (SBit sym) ->
+ SEval sym (SBit sym) ->
+ SEval sym (SBit sym)
+eqCombine sym eq k = join (bitAnd sym <$> eq <*> k)
+
+{-# INLINE lexCombine #-}
+lexCombine :: Backend sym =>
+ sym ->
+ SEval sym (SBit sym) ->
+ SEval sym (SBit sym) ->
+ SEval sym (SBit sym) ->
+ SEval sym (SBit sym)
+lexCombine sym cmp eq k =
+ do c <- cmp
+ e <- eq
+ bitOr sym c =<< bitAnd sym e =<< k
+
+{-# INLINE eqV #-}
+eqV :: Backend sym => sym -> Binary sym
+eqV sym ty v1 v2 = VBit <$> valEq sym ty v1 v2
+
+{-# INLINE distinctV #-}
+distinctV :: Backend sym => sym -> Binary sym
+distinctV sym ty v1 v2 = VBit <$> (bitComplement sym =<< valEq sym ty v1 v2)
+
+{-# INLINE lessThanV #-}
+lessThanV :: Backend sym => sym -> Binary sym
+lessThanV sym ty v1 v2 = VBit <$> valLt sym ty v1 v2 (bitLit sym False)
+
+{-# INLINE lessThanEqV #-}
+lessThanEqV :: Backend sym => sym -> Binary sym
+lessThanEqV sym ty v1 v2 = VBit <$> valLt sym ty v1 v2 (bitLit sym True)
+
+{-# INLINE greaterThanV #-}
+greaterThanV :: Backend sym => sym -> Binary sym
+greaterThanV sym ty v1 v2 = VBit <$> valGt sym ty v1 v2 (bitLit sym False)
+
+{-# INLINE greaterThanEqV #-}
+greaterThanEqV :: Backend sym => sym -> Binary sym
+greaterThanEqV sym ty v1 v2 = VBit <$> valGt sym ty v1 v2 (bitLit sym True)
+
+{-# INLINE signedLessThanV #-}
+signedLessThanV :: Backend sym => sym -> Binary sym
+signedLessThanV sym ty v1 v2 = VBit <$> cmpValue sym fb fw fi fz fq ff ty v1 v2 (pure $ bitLit sym False)
+ where
+ fb _ _ _ = panic "signedLessThan" ["Attempted to perform signed comparison on bit type"]
+ fw x y k = lexCombine sym (wordSignedLessThan sym x y) (wordEq sym x y) k
+ fi _ _ _ = panic "signedLessThan" ["Attempted to perform signed comparison on Integer type"]
+ fz m _ _ _ = panic "signedLessThan" ["Attempted to perform signed comparison on Z_" ++ show m ++ " type"]
+ fq _ _ _ = panic "signedLessThan" ["Attempted to perform signed comparison on Rational type"]
+ ff _ _ _ = panic "signedLessThan" ["Attempted to perform signed comparison on Float"]
+
+
+
+{-# SPECIALIZE zeroV ::
+ Concrete ->
+ TValue ->
+ SEval Concrete (GenValue Concrete)
+ #-}
+zeroV :: forall sym.
+ Backend sym =>
+ sym ->
+ TValue ->
+ SEval sym (GenValue sym)
+zeroV sym ty = case ty of
+
+ -- bits
+ TVBit ->
+ pure (VBit (bitLit sym False))
+
+ -- integers
+ TVInteger ->
+ VInteger <$> integerLit sym 0
+
+ -- integers mod n
+ TVIntMod _ ->
+ VInteger <$> integerLit sym 0
+
+ TVRational ->
+ VRational <$> (intToRational sym =<< integerLit sym 0)
+
+ TVArray{} -> evalPanic "zeroV" ["Array not in class Zero"]
+
+ -- floating point
+ TVFloat e p ->
+ VFloat <$> fpLit sym e p 0
+
+ -- sequences
+ TVSeq w ety
+ | isTBit ety -> pure $ word sym w 0
+ | otherwise ->
+ do z <- sDelay sym Nothing (zeroV sym ety)
+ pure $ VSeq w (IndexSeqMap $ const z)
+
+ TVStream ety ->
+ do z <- sDelay sym Nothing (zeroV sym ety)
+ pure $ VStream (IndexSeqMap $ const z)
+
+ -- functions
+ TVFun _ bty ->
+ do z <- sDelay sym Nothing (zeroV sym bty)
+ pure $ lam (const z)
+
+ -- tuples
+ TVTuple tys ->
+ do xs <- mapM (sDelay sym Nothing . zeroV sym) tys
+ pure $ VTuple xs
+
+ -- records
+ TVRec fields ->
+ do xs <- traverse (sDelay sym Nothing . zeroV sym) fields
+ pure $ VRecord xs
+
+ TVAbstract {} -> evalPanic "zeroV" [ "Abstract type not in `Zero`" ]
+
+-- | otherwise = evalPanic "zeroV" ["invalid type for zero"]
+
+{-# INLINE joinWordVal #-}
+joinWordVal :: Backend sym => sym -> WordValue sym -> WordValue sym -> SEval sym (WordValue sym)
+joinWordVal sym (WordVal w1) (WordVal w2)
+ | wordLen sym w1 + wordLen sym w2 < largeBitSize
+ = WordVal <$> joinWord sym w1 w2
+joinWordVal sym w1 w2
+ = pure $ LargeBitsVal (n1+n2) (concatSeqMap n1 (asBitsMap sym w1) (asBitsMap sym w2))
+ where n1 = wordValueSize sym w1
+ n2 = wordValueSize sym w2
+
+
+{-# SPECIALIZE joinWords ::
+ Concrete ->
+ Integer ->
+ Integer ->
+ SeqMap Concrete ->
+ SEval Concrete (GenValue Concrete)
+ #-}
+joinWords :: forall sym.
+ Backend sym =>
+ sym ->
+ Integer ->
+ Integer ->
+ SeqMap sym ->
+ SEval sym (GenValue sym)
+joinWords sym nParts nEach xs =
+ loop (WordVal <$> wordLit sym 0 0) (enumerateSeqMap nParts xs)
+
+ where
+ loop :: SEval sym (WordValue sym) -> [SEval sym (GenValue sym)] -> SEval sym (GenValue sym)
+ loop !wv [] =
+ VWord (nParts * nEach) <$> sDelay sym Nothing wv
+ loop !wv (w : ws) =
+ w >>= \case
+ VWord _ w' ->
+ loop (join (joinWordVal sym <$> wv <*> w')) ws
+ _ -> evalPanic "joinWords: expected word value" []
+
+{-# SPECIALIZE joinSeq ::
+ Concrete ->
+ Nat' ->
+ Integer ->
+ TValue ->
+ SeqMap Concrete ->
+ SEval Concrete (GenValue Concrete)
+ #-}
+joinSeq ::
+ Backend sym =>
+ sym ->
+ Nat' ->
+ Integer ->
+ TValue ->
+ SeqMap sym ->
+ SEval sym (GenValue sym)
+
+-- Special case for 0 length inner sequences.
+joinSeq sym _parts 0 a _xs
+ = zeroV sym (TVSeq 0 a)
+
+-- finite sequence of words
+joinSeq sym (Nat parts) each TVBit xs
+ | parts * each < largeBitSize
+ = joinWords sym parts each xs
+ | otherwise
+ = do let zs = IndexSeqMap $ \i ->
+ do let (q,r) = divMod i each
+ ys <- fromWordVal "join seq" =<< lookupSeqMap xs q
+ VBit <$> indexWordValue sym ys r
+ return $ VWord (parts * each) $ pure $ LargeBitsVal (parts * each) zs
+
+-- infinite sequence of words
+joinSeq sym Inf each TVBit xs
+ = return $ VStream $ IndexSeqMap $ \i ->
+ do let (q,r) = divMod i each
+ ys <- fromWordVal "join seq" =<< lookupSeqMap xs q
+ VBit <$> indexWordValue sym ys r
+
+-- finite or infinite sequence of non-words
+joinSeq _sym parts each _a xs
+ = return $ vSeq $ IndexSeqMap $ \i -> do
+ let (q,r) = divMod i each
+ ys <- fromSeq "join seq" =<< lookupSeqMap xs q
+ lookupSeqMap ys r
+ where
+ len = parts `nMul` (Nat each)
+ vSeq = case len of
+ Inf -> VStream
+ Nat n -> VSeq n
+
+
+{-# INLINE joinV #-}
+
+-- | Join a sequence of sequences into a single sequence.
+joinV ::
+ Backend sym =>
+ sym ->
+ Nat' ->
+ Integer ->
+ TValue ->
+ GenValue sym ->
+ SEval sym (GenValue sym)
+joinV sym parts each a val = joinSeq sym parts each a =<< fromSeq "joinV" val
+
+
+{-# INLINE splitWordVal #-}
+
+splitWordVal ::
+ Backend sym =>
+ sym ->
+ Integer ->
+ Integer ->
+ WordValue sym ->
+ SEval sym (WordValue sym, WordValue sym)
+splitWordVal sym leftWidth rightWidth (WordVal w) =
+ do (lw, rw) <- splitWord sym leftWidth rightWidth w
+ pure (WordVal lw, WordVal rw)
+splitWordVal _ leftWidth rightWidth (LargeBitsVal _n xs) =
+ let (lxs, rxs) = splitSeqMap leftWidth xs
+ in pure (LargeBitsVal leftWidth lxs, LargeBitsVal rightWidth rxs)
+
+{-# INLINE splitAtV #-}
+splitAtV ::
+ Backend sym =>
+ sym ->
+ Nat' ->
+ Nat' ->
+ TValue ->
+ GenValue sym ->
+ SEval sym (GenValue sym)
+splitAtV sym front back a val =
+ case back of
+
+ Nat rightWidth | aBit -> do
+ ws <- sDelay sym Nothing (splitWordVal sym leftWidth rightWidth =<< fromWordVal "splitAtV" val)
+ return $ VTuple
+ [ VWord leftWidth . pure . fst <$> ws
+ , VWord rightWidth . pure . snd <$> ws
+ ]
+
+ Inf | aBit -> do
+ vs <- sDelay sym Nothing (fromSeq "splitAtV" val)
+ ls <- sDelay sym Nothing (fst . splitSeqMap leftWidth <$> vs)
+ rs <- sDelay sym Nothing (snd . splitSeqMap leftWidth <$> vs)
+ return $ VTuple [ return $ VWord leftWidth (LargeBitsVal leftWidth <$> ls)
+ , VStream <$> rs
+ ]
+
+ _ -> do
+ vs <- sDelay sym Nothing (fromSeq "splitAtV" val)
+ ls <- sDelay sym Nothing (fst . splitSeqMap leftWidth <$> vs)
+ rs <- sDelay sym Nothing (snd . splitSeqMap leftWidth <$> vs)
+ return $ VTuple [ VSeq leftWidth <$> ls
+ , mkSeq back a <$> rs
+ ]
+
+ where
+ aBit = isTBit a
+
+ leftWidth = case front of
+ Nat n -> n
+ _ -> evalPanic "splitAtV" ["invalid `front` len"]
+
+
+{-# INLINE extractWordVal #-}
+
+-- | Extract a subsequence of bits from a @WordValue@.
+-- 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 `extractWordVal n i w` is equivalent to
+-- first shifting `w` right by `i` bits, and then truncating to
+-- `n` bits.
+extractWordVal ::
+ Backend sym =>
+ sym ->
+ Integer ->
+ Integer ->
+ WordValue sym ->
+ SEval sym (WordValue sym)
+extractWordVal sym len start (WordVal w) =
+ WordVal <$> extractWord sym len start w
+extractWordVal _ len start (LargeBitsVal n xs) =
+ let xs' = dropSeqMap (n - start - len) xs
+ in pure $ LargeBitsVal len xs'
+
+{-# INLINE ecSplitV #-}
+
+-- | Split implementation.
+ecSplitV :: Backend sym => sym -> GenValue sym
+ecSplitV sym =
+ nlam $ \ parts ->
+ nlam $ \ each ->
+ tlam $ \ a ->
+ lam $ \ val ->
+ case (parts, each) of
+ (Nat p, Nat e) | isTBit a -> do
+ ~(VWord _ val') <- val
+ return $ VSeq p $ IndexSeqMap $ \i ->
+ pure $ VWord e (extractWordVal sym e ((p-i-1)*e) =<< val')
+ (Inf, Nat e) | isTBit a -> do
+ val' <- sDelay sym Nothing (fromSeq "ecSplitV" =<< val)
+ return $ VStream $ IndexSeqMap $ \i ->
+ return $ VWord e $ return $ LargeBitsVal e $ IndexSeqMap $ \j ->
+ let idx = i*e + toInteger j
+ in idx `seq` do
+ xs <- val'
+ lookupSeqMap xs idx
+ (Nat p, Nat e) -> do
+ val' <- sDelay sym Nothing (fromSeq "ecSplitV" =<< val)
+ return $ VSeq p $ IndexSeqMap $ \i ->
+ return $ VSeq e $ IndexSeqMap $ \j -> do
+ xs <- val'
+ lookupSeqMap xs (e * i + j)
+ (Inf , Nat e) -> do
+ val' <- sDelay sym Nothing (fromSeq "ecSplitV" =<< val)
+ return $ VStream $ IndexSeqMap $ \i ->
+ return $ VSeq e $ IndexSeqMap $ \j -> do
+ xs <- val'
+ lookupSeqMap xs (e * i + j)
+ _ -> evalPanic "splitV" ["invalid type arguments to split"]
+
+{-# INLINE reverseV #-}
+
+reverseV :: forall sym.
+ Backend sym =>
+ sym ->
+ GenValue sym ->
+ SEval sym (GenValue sym)
+reverseV _ (VSeq n xs) =
+ return $ VSeq n $ reverseSeqMap n xs
+reverseV sym (VWord n x) = return (VWord n (revword <$> x))
+ where
+ revword wv =
+ let m = wordValueSize sym wv in
+ LargeBitsVal m $ reverseSeqMap m $ asBitsMap sym wv
+reverseV _ _ =
+ evalPanic "reverseV" ["Not a finite sequence"]
+
+{-# INLINE transposeV #-}
+
+transposeV ::
+ Backend sym =>
+ sym ->
+ Nat' ->
+ Nat' ->
+ TValue ->
+ GenValue sym ->
+ SEval sym (GenValue sym)
+transposeV sym a b c xs
+ | isTBit c, Nat na <- a = -- Fin a => [a][b]Bit -> [b][a]Bit
+ return $ bseq $ IndexSeqMap $ \bi ->
+ return $ VWord na $ return $ LargeBitsVal na $ IndexSeqMap $ \ai ->
+ do ys <- flip lookupSeqMap (toInteger ai) =<< fromSeq "transposeV" xs
+ case ys of
+ VStream ys' -> lookupSeqMap ys' bi
+ VWord _ wv -> VBit <$> (flip (indexWordValue sym) bi =<< wv)
+ _ -> evalPanic "transpose" ["expected sequence of bits"]
+
+ | isTBit c, Inf <- a = -- [inf][b]Bit -> [b][inf]Bit
+ return $ bseq $ IndexSeqMap $ \bi ->
+ return $ VStream $ IndexSeqMap $ \ai ->
+ do ys <- flip lookupSeqMap ai =<< fromSeq "transposeV" xs
+ case ys of
+ VStream ys' -> lookupSeqMap ys' bi
+ VWord _ wv -> VBit <$> (flip (indexWordValue sym) bi =<< wv)
+ _ -> evalPanic "transpose" ["expected sequence of bits"]
+
+ | otherwise = -- [a][b]c -> [b][a]c
+ return $ bseq $ IndexSeqMap $ \bi ->
+ return $ aseq $ IndexSeqMap $ \ai -> do
+ ys <- flip lookupSeqMap ai =<< fromSeq "transposeV 1" xs
+ z <- flip lookupSeqMap bi =<< fromSeq "transposeV 2" ys
+ return z
+
+ where
+ bseq =
+ case b of
+ Nat nb -> VSeq nb
+ Inf -> VStream
+ aseq =
+ case a of
+ Nat na -> VSeq na
+ Inf -> VStream
+
+
+{-# INLINE ccatV #-}
+
+ccatV ::
+ Backend sym =>
+ sym ->
+ Nat' ->
+ Nat' ->
+ TValue ->
+ (GenValue sym) ->
+ (GenValue sym) ->
+ SEval sym (GenValue sym)
+
+ccatV sym _front _back _elty (VWord m l) (VWord n r) =
+ return $ VWord (m+n) (join (joinWordVal sym <$> l <*> r))
+
+ccatV sym _front _back _elty (VWord m l) (VStream r) = do
+ l' <- sDelay sym Nothing l
+ return $ VStream $ IndexSeqMap $ \i ->
+ if i < m then
+ VBit <$> (flip (indexWordValue sym) i =<< l')
+ else
+ lookupSeqMap r (i-m)
+
+ccatV sym front back elty l r = do
+ l'' <- sDelay sym Nothing (fromSeq "ccatV left" l)
+ r'' <- sDelay sym Nothing (fromSeq "ccatV right" r)
+ let Nat n = front
+ mkSeq (evalTF TCAdd [front,back]) elty <$> return (IndexSeqMap $ \i ->
+ if i < n then do
+ ls <- l''
+ lookupSeqMap ls i
+ else do
+ rs <- r''
+ lookupSeqMap rs (i-n))
+
+{-# INLINE wordValLogicOp #-}
+
+wordValLogicOp ::
+ Backend sym =>
+ sym ->
+ (SBit sym -> SBit sym -> SEval sym (SBit sym)) ->
+ (SWord sym -> SWord sym -> SEval sym (SWord sym)) ->
+ WordValue sym ->
+ WordValue sym ->
+ SEval sym (WordValue sym)
+wordValLogicOp _sym _ wop (WordVal w1) (WordVal w2) = WordVal <$> wop w1 w2
+
+wordValLogicOp sym bop _ w1 w2 = LargeBitsVal (wordValueSize sym w1) <$> zs
+ where zs = memoMap $ IndexSeqMap $ \i -> join (op <$> (lookupSeqMap xs i) <*> (lookupSeqMap ys i))
+ xs = asBitsMap sym w1
+ ys = asBitsMap sym w2
+ op x y = VBit <$> (bop (fromVBit x) (fromVBit y))
+
+{-# SPECIALIZE logicBinary ::
+ Concrete ->
+ (SBit Concrete -> SBit Concrete -> SEval Concrete (SBit Concrete)) ->
+ (SWord Concrete -> SWord Concrete -> SEval Concrete (SWord Concrete)) ->
+ Binary Concrete
+ #-}
+
+-- | Merge two values given a binop. This is used for and, or and xor.
+logicBinary :: forall sym.
+ Backend sym =>
+ sym ->
+ (SBit sym -> SBit sym -> SEval sym (SBit sym)) ->
+ (SWord sym -> SWord sym -> SEval sym (SWord sym)) ->
+ Binary sym
+logicBinary sym opb opw = loop
+ where
+ loop' :: TValue
+ -> SEval sym (GenValue sym)
+ -> SEval sym (GenValue sym)
+ -> SEval sym (GenValue sym)
+ loop' ty l r = join (loop ty <$> l <*> r)
+
+ loop :: TValue
+ -> GenValue sym
+ -> GenValue sym
+ -> SEval sym (GenValue sym)
+
+ loop ty l r = case ty of
+ TVBit -> VBit <$> (opb (fromVBit l) (fromVBit r))
+ TVInteger -> evalPanic "logicBinary" ["Integer not in class Logic"]
+ TVIntMod _ -> evalPanic "logicBinary" ["Z not in class Logic"]
+ TVRational -> evalPanic "logicBinary" ["Rational not in class Logic"]
+ TVArray{} -> evalPanic "logicBinary" ["Array not in class Logic"]
+
+ TVFloat {} -> evalPanic "logicBinary" ["Float not in class Logic"]
+ TVSeq w aty
+ -- words
+ | isTBit aty
+ -> do v <- sDelay sym Nothing $ join
+ (wordValLogicOp sym opb opw <$>
+ fromWordVal "logicBinary l" l <*>
+ fromWordVal "logicBinary r" r)
+ return $ VWord w v
+
+ -- finite sequences
+ | otherwise -> VSeq w <$>
+ (join (zipSeqMap (loop aty) <$>
+ (fromSeq "logicBinary left" l)
+ <*> (fromSeq "logicBinary right" r)))
+
+ TVStream aty ->
+ VStream <$> (join (zipSeqMap (loop aty) <$>
+ (fromSeq "logicBinary left" l) <*>
+ (fromSeq "logicBinary right" r)))
+
+ TVTuple etys -> do
+ ls <- mapM (sDelay sym Nothing) (fromVTuple l)
+ rs <- mapM (sDelay sym Nothing) (fromVTuple r)
+ return $ VTuple $ zipWith3 loop' etys ls rs
+
+ TVFun _ bty ->
+ return $ lam $ \ a -> loop' bty (fromVFun l a) (fromVFun r a)
+
+ TVRec fields ->
+ VRecord <$>
+ traverseRecordMap
+ (\f fty -> sDelay sym Nothing (loop' fty (lookupRecord f l) (lookupRecord f r)))
+ fields
+
+ TVAbstract {} -> evalPanic "logicBinary"
+ [ "Abstract type not in `Logic`" ]
+
+{-# INLINE wordValUnaryOp #-}
+wordValUnaryOp ::
+ Backend sym =>
+ (SBit sym -> SEval sym (SBit sym)) ->
+ (SWord sym -> SEval sym (SWord sym)) ->
+ WordValue sym ->
+ SEval sym (WordValue sym)
+wordValUnaryOp _ wop (WordVal w) = WordVal <$> (wop w)
+wordValUnaryOp bop _ (LargeBitsVal n xs) = LargeBitsVal n <$> mapSeqMap f xs
+ where f x = VBit <$> (bop (fromVBit x))
+
+{-# SPECIALIZE logicUnary ::
+ Concrete ->
+ (SBit Concrete -> SEval Concrete (SBit Concrete)) ->
+ (SWord Concrete -> SEval Concrete (SWord Concrete)) ->
+ Unary Concrete
+ #-}
+
+logicUnary :: forall sym.
+ Backend sym =>
+ sym ->
+ (SBit sym -> SEval sym (SBit sym)) ->
+ (SWord sym -> SEval sym (SWord sym)) ->
+ Unary sym
+logicUnary sym opb opw = loop
+ where
+ loop' :: TValue -> SEval sym (GenValue sym) -> SEval sym (GenValue sym)
+ loop' ty val = loop ty =<< val
+
+ loop :: TValue -> GenValue sym -> SEval sym (GenValue sym)
+ loop ty val = case ty of
+ TVBit -> VBit <$> (opb (fromVBit val))
+
+ TVInteger -> evalPanic "logicUnary" ["Integer not in class Logic"]
+ TVIntMod _ -> evalPanic "logicUnary" ["Z not in class Logic"]
+ TVFloat {} -> evalPanic "logicUnary" ["Float not in class Logic"]
+ TVRational -> evalPanic "logicBinary" ["Rational not in class Logic"]
+ TVArray{} -> evalPanic "logicUnary" ["Array not in class Logic"]
+
+ TVSeq w ety
+ -- words
+ | isTBit ety
+ -> do v <- sDelay sym Nothing (wordValUnaryOp opb opw =<< fromWordVal "logicUnary" val)
+ return $ VWord w v
+
+ -- finite sequences
+ | otherwise
+ -> VSeq w <$> (mapSeqMap (loop ety) =<< fromSeq "logicUnary" val)
+
+ -- streams
+ TVStream ety ->
+ VStream <$> (mapSeqMap (loop ety) =<< fromSeq "logicUnary" val)
+
+ TVTuple etys ->
+ do as <- mapM (sDelay sym Nothing) (fromVTuple val)
+ return $ VTuple (zipWith loop' etys as)
+
+ TVFun _ bty ->
+ return $ lam $ \ a -> loop' bty (fromVFun val a)
+
+ TVRec fields ->
+ VRecord <$>
+ traverseRecordMap
+ (\f fty -> sDelay sym Nothing (loop' fty (lookupRecord f val)))
+ fields
+
+ TVAbstract {} -> evalPanic "logicUnary" [ "Abstract type not in `Logic`" ]
+
+
+{-# SPECIALIZE bitsValueLessThan ::
+ Concrete ->
+ Integer ->
+ [SBit Concrete] ->
+ Integer ->
+ SEval Concrete (SBit Concrete)
+ #-}
+bitsValueLessThan ::
+ Backend sym =>
+ sym ->
+ Integer {- ^ bit-width -} ->
+ [SBit sym] {- ^ big-endian list of index bits -} ->
+ Integer {- ^ Upper bound to test against -} ->
+ SEval sym (SBit sym)
+bitsValueLessThan sym _w [] _n = pure $ bitLit sym False
+bitsValueLessThan sym w (b:bs) n
+ | nbit =
+ do notb <- bitComplement sym b
+ bitOr sym notb =<< bitsValueLessThan sym (w-1) bs n
+ | otherwise =
+ do notb <- bitComplement sym b
+ bitAnd sym notb =<< bitsValueLessThan sym (w-1) bs n
+ where
+ nbit = testBit n (fromInteger (w-1))
+
+
+{-# INLINE assertIndexInBounds #-}
+assertIndexInBounds ::
+ Backend sym =>
+ sym ->
+ Nat' {- ^ Sequence size bounds -} ->
+ Either (SInteger sym) (WordValue sym) {- ^ Index value -} ->
+ SEval sym ()
+
+-- Can't index out of bounds for an infinite sequence
+assertIndexInBounds _sym Inf _ =
+ return ()
+
+-- Can't index out of bounds for a sequence that is
+-- longer than the expressible index values
+assertIndexInBounds sym (Nat n) (Right idx)
+ | n >= 2^(wordValueSize sym idx)
+ = return ()
+
+-- If the index is concrete, test it directly
+assertIndexInBounds sym (Nat n) (Left idx)
+ | Just i <- integerAsLit sym idx
+ = unless (i < n) (raiseError sym (InvalidIndex (Just i)))
+
+-- If the index is concrete, test it directly
+assertIndexInBounds sym (Nat n) (Right (WordVal idx))
+ | Just (_w,i) <- wordAsLit sym idx
+ = unless (i < n) (raiseError sym (InvalidIndex (Just i)))
+
+-- If the index is an integer, test that it
+-- is less than the concrete value of n.
+assertIndexInBounds sym (Nat n) (Left idx) =
+ do n' <- integerLit sym n
+ p <- intLessThan sym idx n'
+ assertSideCondition sym p (InvalidIndex Nothing)
+
+-- If the index is a packed word, test that it
+-- is less than the concrete value of n, which
+-- fits into w bits because of the above test.
+assertIndexInBounds sym (Nat n) (Right (WordVal idx)) =
+ do n' <- wordLit sym (wordLen sym idx) n
+ p <- wordLessThan sym idx n'
+ assertSideCondition sym p (InvalidIndex Nothing)
+
+-- If the index is an unpacked word, force all the bits
+-- and compute the unsigned less-than test directly.
+assertIndexInBounds sym (Nat n) (Right (LargeBitsVal w bits)) =
+ do bitsList <- traverse (fromVBit <$>) (enumerateSeqMap w bits)
+ p <- bitsValueLessThan sym w bitsList n
+ assertSideCondition sym p (InvalidIndex Nothing)
+
+
+-- | Indexing operations.
+
+{-# INLINE indexPrim #-}
+indexPrim ::
+ Backend sym =>
+ sym ->
+ (Nat' -> TValue -> SeqMap sym -> TValue -> SInteger sym -> SEval sym (GenValue sym)) ->
+ (Nat' -> TValue -> SeqMap sym -> TValue -> [SBit sym] -> SEval sym (GenValue sym)) ->
+ (Nat' -> TValue -> SeqMap sym -> TValue -> SWord sym -> SEval sym (GenValue sym)) ->
+ GenValue sym
+indexPrim sym int_op bits_op word_op =
+ nlam $ \ len ->
+ tlam $ \ eltTy ->
+ tlam $ \ ix ->
+ lam $ \ xs -> return $
+ lam $ \ idx -> do
+ vs <- xs >>= \case
+ VWord _ w -> w >>= \w' -> return $ IndexSeqMap (\i -> VBit <$> indexWordValue sym w' i)
+ VSeq _ vs -> return vs
+ VStream vs -> return vs
+ _ -> evalPanic "Expected sequence value" ["indexPrim"]
+ idx' <- asIndex sym "index" ix =<< idx
+ assertIndexInBounds sym len idx'
+ case idx' of
+ Left i -> int_op len eltTy vs ix i
+ Right (WordVal w') -> word_op len eltTy vs ix w'
+ Right (LargeBitsVal m bs) -> bits_op len eltTy vs ix =<< traverse (fromVBit <$>) (enumerateSeqMap m bs)
+
+{-# INLINE updatePrim #-}
+
+updatePrim ::
+ Backend sym =>
+ sym ->
+ (Nat' -> TValue -> WordValue sym -> Either (SInteger sym) (WordValue sym) -> SEval sym (GenValue sym) -> SEval sym (WordValue sym)) ->
+ (Nat' -> TValue -> SeqMap sym -> Either (SInteger sym) (WordValue sym) -> SEval sym (GenValue sym) -> SEval sym (SeqMap sym)) ->
+ GenValue sym
+updatePrim sym updateWord updateSeq =
+ nlam $ \len ->
+ tlam $ \eltTy ->
+ tlam $ \ix ->
+ lam $ \xs -> return $
+ lam $ \idx -> return $
+ lam $ \val -> do
+ idx' <- asIndex sym "update" ix =<< idx
+ assertIndexInBounds sym len idx'
+ xs >>= \case
+ VWord l w -> do w' <- sDelay sym Nothing w
+ return $ VWord l (w' >>= \w'' -> updateWord len eltTy w'' idx' val)
+ VSeq l vs -> VSeq l <$> updateSeq len eltTy vs idx' val
+ VStream vs -> VStream <$> updateSeq len eltTy vs idx' val
+ _ -> evalPanic "Expected sequence value" ["updatePrim"]
+
+{-# INLINE fromToV #-}
+
+-- @[ 0 .. 10 ]@
+fromToV :: Backend sym => sym -> GenValue sym
+fromToV sym =
+ nlam $ \ first ->
+ nlam $ \ lst ->
+ tlam $ \ ty ->
+ let !f = mkLit sym ty in
+ case (first, lst) of
+ (Nat first', Nat lst') ->
+ let len = 1 + (lst' - first')
+ in VSeq len $ IndexSeqMap $ \i -> f (first' + i)
+ _ -> evalPanic "fromToV" ["invalid arguments"]
+
+{-# INLINE fromThenToV #-}
+
+-- @[ 0, 1 .. 10 ]@
+fromThenToV :: Backend sym => sym -> GenValue sym
+fromThenToV sym =
+ nlam $ \ first ->
+ nlam $ \ next ->
+ nlam $ \ lst ->
+ tlam $ \ ty ->
+ nlam $ \ len ->
+ let !f = mkLit sym ty in
+ case (first, next, lst, len) of
+ (Nat first', Nat next', Nat _lst', Nat len') ->
+ let diff = next' - first'
+ in VSeq len' $ IndexSeqMap $ \i -> f (first' + i*diff)
+ _ -> evalPanic "fromThenToV" ["invalid arguments"]
+
+{-# INLINE infFromV #-}
+infFromV :: Backend sym => sym -> GenValue sym
+infFromV sym =
+ tlam $ \ ty ->
+ lam $ \ x ->
+ do mx <- sDelay sym Nothing x
+ return $ VStream $ IndexSeqMap $ \i ->
+ do x' <- mx
+ i' <- integerLit sym i
+ addV sym ty x' =<< intV sym i' ty
+
+{-# INLINE infFromThenV #-}
+infFromThenV :: Backend sym => sym -> GenValue sym
+infFromThenV sym =
+ tlam $ \ ty ->
+ lam $ \ first -> return $
+ lam $ \ next ->
+ do mxd <- sDelay sym Nothing
+ (do x <- first
+ y <- next
+ d <- subV sym ty y x
+ pure (x,d))
+ return $ VStream $ IndexSeqMap $ \i -> do
+ (x,d) <- mxd
+ i' <- integerLit sym i
+ addV sym ty x =<< mulV sym ty d =<< intV sym i' ty
+
+-- Shifting ---------------------------------------------------
+
+barrelShifter :: Backend sym =>
+ sym ->
+ (SeqMap sym -> Integer -> SEval sym (SeqMap sym))
+ {- ^ concrete shifting operation -} ->
+ SeqMap sym {- ^ initial value -} ->
+ [SBit sym] {- ^ bits of shift amount, in big-endian order -} ->
+ SEval sym (SeqMap sym)
+barrelShifter sym shift_op = go
+ where
+ go x [] = return x
+
+ go x (b:bs)
+ | Just True <- bitAsLit sym b
+ = do x_shft <- shift_op x (2 ^ length bs)
+ go x_shft bs
+
+ | Just False <- bitAsLit sym b
+ = do go x bs
+
+ | otherwise
+ = do x_shft <- shift_op x (2 ^ length bs)
+ x' <- memoMap (mergeSeqMap sym b x_shft x)
+ go x' bs
+
+{-# INLINE shiftLeftReindex #-}
+shiftLeftReindex :: Nat' -> Integer -> Integer -> Maybe Integer
+shiftLeftReindex sz i shft =
+ case sz of
+ Nat n | i+shft >= n -> Nothing
+ _ -> Just (i+shft)
+
+{-# INLINE shiftRightReindex #-}
+shiftRightReindex :: Nat' -> Integer -> Integer -> Maybe Integer
+shiftRightReindex _sz i shft =
+ if i-shft < 0 then Nothing else Just (i-shft)
+
+{-# INLINE rotateLeftReindex #-}
+rotateLeftReindex :: Nat' -> Integer -> Integer -> Maybe Integer
+rotateLeftReindex sz i shft =
+ case sz of
+ Inf -> evalPanic "cannot rotate infinite sequence" []
+ Nat n -> Just ((i+shft) `mod` n)
+
+{-# INLINE rotateRightReindex #-}
+rotateRightReindex :: Nat' -> Integer -> Integer -> Maybe Integer
+rotateRightReindex sz i shft =
+ case sz of
+ Inf -> evalPanic "cannot rotate infinite sequence" []
+ Nat n -> Just ((i+n-shft) `mod` n)
+
+-- | Compute the list of bits in an integer in big-endian order.
+-- Fails if neither the sequence length nor the type value
+-- provide an upper bound for the integer.
+enumerateIntBits :: Backend sym =>
+ sym ->
+ Nat' ->
+ TValue ->
+ SInteger sym ->
+ SEval sym [SBit sym]
+enumerateIntBits sym (Nat n) _ idx = enumerateIntBits' sym n idx
+enumerateIntBits _sym Inf _ _ = liftIO (X.throw (UnsupportedSymbolicOp "unbounded integer shifting"))
+
+-- | Compute the list of bits in an integer in big-endian order.
+-- The integer argument is a concrete upper bound for
+-- the symbolic integer.
+enumerateIntBits' :: Backend sym =>
+ sym ->
+ Integer ->
+ SInteger sym ->
+ SEval sym [SBit sym]
+enumerateIntBits' sym n idx =
+ do w <- wordFromInt sym (widthInteger n) idx
+ unpackWord sym w
+
+-- | Generic implementation of shifting.
+-- Uses the provided word-level operation to perform the shift, when
+-- possible. Otherwise falls back on a barrel shifter that uses
+-- the provided reindexing operation to implement the concrete
+-- shifting operations. The reindex operation is given the size
+-- of the sequence, the requested index value for the new output sequence,
+-- and the amount to shift. The return value is an index into the original
+-- sequence if in bounds, and Nothing otherwise.
+logicShift :: Backend sym =>
+ sym ->
+ String ->
+ (sym -> Nat' -> TValue -> SInteger sym -> SEval sym (SInteger sym))
+ {- ^ operation for range reduction on integers -} ->
+ (SWord sym -> SWord sym -> SEval sym (SWord sym))
+ {- ^ word shift operation for positive indices -} ->
+ (SWord sym -> SWord sym -> SEval sym (SWord sym))
+ {- ^ word shift operation for negative indices -} ->
+ (Nat' -> Integer -> Integer -> Maybe Integer)
+ {- ^ reindexing operation for positive indices (sequence size, starting index, shift amount -} ->
+ (Nat' -> Integer -> Integer -> Maybe Integer)
+ {- ^ reindexing operation for negative indices (sequence size, starting index, shift amount -} ->
+ GenValue sym
+logicShift sym nm shrinkRange wopPos wopNeg reindexPos reindexNeg =
+ nlam $ \m ->
+ tlam $ \ix ->
+ tlam $ \a ->
+ VFun $ \xs -> return $
+ VFun $ \y ->
+ do xs' <- xs
+ y' <- asIndex sym "shift" ix =<< y
+ case y' of
+ Left int_idx ->
+ do pneg <- intLessThan sym int_idx =<< integerLit sym 0
+ iteValue sym pneg
+ (intShifter sym nm wopNeg reindexNeg m ix a xs' =<< shrinkRange sym m ix =<< intNegate sym int_idx)
+ (intShifter sym nm wopPos reindexPos m ix a xs' =<< shrinkRange sym m ix int_idx)
+ Right idx ->
+ wordShifter sym nm wopPos reindexPos m a xs' idx
+
+intShifter :: Backend sym =>
+ sym ->
+ String ->
+ (SWord sym -> SWord sym -> SEval sym (SWord sym)) ->
+ (Nat' -> Integer -> Integer -> Maybe Integer) ->
+ Nat' ->
+ TValue ->
+ TValue ->
+ GenValue sym ->
+ SInteger sym ->
+ SEval sym (GenValue sym)
+intShifter sym nm wop reindex m ix a xs idx =
+ do let shiftOp vs shft =
+ memoMap $ IndexSeqMap $ \i ->
+ case reindex m i shft of
+ Nothing -> zeroV sym a
+ Just i' -> lookupSeqMap vs i'
+ case xs of
+ VWord w x ->
+ return $ VWord w $ do
+ x >>= \case
+ WordVal x' -> WordVal <$> (wop x' =<< wordFromInt sym w idx)
+ LargeBitsVal n bs0 ->
+ do idx_bits <- enumerateIntBits sym m ix idx
+ LargeBitsVal n <$> barrelShifter sym shiftOp bs0 idx_bits
+
+ VSeq w vs0 ->
+ do idx_bits <- enumerateIntBits sym m ix idx
+ VSeq w <$> barrelShifter sym shiftOp vs0 idx_bits
+
+ VStream vs0 ->
+ do idx_bits <- enumerateIntBits sym m ix idx
+ VStream <$> barrelShifter sym shiftOp vs0 idx_bits
+
+ _ -> evalPanic "expected sequence value in shift operation" [nm]
+
+
+wordShifter :: Backend sym =>
+ sym ->
+ String ->
+ (SWord sym -> SWord sym -> SEval sym (SWord sym)) ->
+ (Nat' -> Integer -> Integer -> Maybe Integer) ->
+ Nat' ->
+ TValue ->
+ GenValue sym ->
+ WordValue sym ->
+ SEval sym (GenValue sym)
+wordShifter sym nm wop reindex m a xs idx =
+ let shiftOp vs shft =
+ memoMap $ IndexSeqMap $ \i ->
+ case reindex m i shft of
+ Nothing -> zeroV sym a
+ Just i' -> lookupSeqMap vs i'
+ in case xs of
+ VWord w x ->
+ return $ VWord w $ do
+ x >>= \case
+ WordVal x' -> WordVal <$> (wop x' =<< asWordVal sym idx)
+ LargeBitsVal n bs0 ->
+ do idx_bits <- enumerateWordValue sym idx
+ LargeBitsVal n <$> barrelShifter sym shiftOp bs0 idx_bits
+
+ VSeq w vs0 ->
+ do idx_bits <- enumerateWordValue sym idx
+ VSeq w <$> barrelShifter sym shiftOp vs0 idx_bits
+
+ VStream vs0 ->
+ do idx_bits <- enumerateWordValue sym idx
+ VStream <$> barrelShifter sym shiftOp vs0 idx_bits
+
+ _ -> evalPanic "expected sequence value in shift operation" [nm]
+
+
+shiftShrink :: Backend sym => sym -> Nat' -> TValue -> SInteger sym -> SEval sym (SInteger sym)
+shiftShrink _sym Inf _ x = return x
+shiftShrink sym (Nat w) _ x =
+ do w' <- integerLit sym w
+ p <- intLessThan sym w' x
+ iteInteger sym p w' x
+
+rotateShrink :: Backend sym => sym -> Nat' -> TValue -> SInteger sym -> SEval sym (SInteger sym)
+rotateShrink _sym Inf _ _ = panic "rotateShrink" ["expected finite sequence in rotate"]
+rotateShrink sym (Nat 0) _ _ = integerLit sym 0
+rotateShrink sym (Nat w) _ x =
+ do w' <- integerLit sym w
+ intMod sym x w'
+
+-- Miscellaneous ---------------------------------------------------------------
+
+{-# SPECIALIZE errorV ::
+ Concrete ->
+ TValue ->
+ String ->
+ SEval Concrete (GenValue Concrete)
+ #-}
+errorV :: forall sym.
+ Backend sym =>
+ sym ->
+ TValue ->
+ String ->
+ SEval sym (GenValue sym)
+errorV sym ty msg = case ty of
+ -- bits
+ TVBit -> cryUserError sym msg
+ TVInteger -> cryUserError sym msg
+ TVIntMod _ -> cryUserError sym msg
+ TVRational -> cryUserError sym msg
+ TVArray{} -> cryUserError sym msg
+ TVFloat {} -> cryUserError sym msg
+
+ -- sequences
+ TVSeq w ety
+ | isTBit ety -> return $ VWord w $ return $ LargeBitsVal w $ IndexSeqMap $ \_ -> cryUserError sym msg
+ | otherwise -> return $ VSeq w (IndexSeqMap $ \_ -> errorV sym ety msg)
+
+ TVStream ety ->
+ return $ VStream (IndexSeqMap $ \_ -> errorV sym ety msg)
+
+ -- functions
+ TVFun _ bty ->
+ return $ lam (\ _ -> errorV sym bty msg)
+
+ -- tuples
+ TVTuple tys ->
+ return $ VTuple (map (\t -> errorV sym t msg) tys)
+
+ -- records
+ TVRec fields ->
+ return $ VRecord $ fmap (\t -> errorV sym t msg) $ fields
+
+ TVAbstract {} -> cryUserError sym msg
+
+
+{-# INLINE valueToChar #-}
+
+-- | Expect a word value. Mask it to an 8-bits ASCII value
+-- and return the associated character, if it is concrete.
+-- Otherwise, return a '?' character
+valueToChar :: Backend sym => sym -> GenValue sym -> SEval sym Char
+valueToChar sym (VWord 8 wval) =
+ do w <- asWordVal sym =<< wval
+ pure $! fromMaybe '?' (wordAsChar sym w)
+valueToChar _ _ = evalPanic "valueToChar" ["Not an 8-bit bitvector"]
+
+{-# INLINE valueToString #-}
+
+valueToString :: Backend sym => sym -> GenValue sym -> SEval sym String
+valueToString sym (VSeq n vals) = traverse (valueToChar sym =<<) (enumerateSeqMap n vals)
+valueToString _ _ = evalPanic "valueToString" ["Not a finite sequence"]
+
+-- Merge and if/then/else
+
+{-# INLINE iteValue #-}
+iteValue :: Backend sym =>
+ sym ->
+ SBit sym ->
+ SEval sym (GenValue sym) ->
+ SEval sym (GenValue sym) ->
+ SEval sym (GenValue sym)
+iteValue sym b x y
+ | Just True <- bitAsLit sym b = x
+ | Just False <- bitAsLit sym b = y
+ | otherwise = mergeValue' sym b x y
+
+{-# INLINE mergeWord #-}
+mergeWord :: Backend sym =>
+ sym ->
+ SBit sym ->
+ WordValue sym ->
+ WordValue sym ->
+ SEval sym (WordValue sym)
+mergeWord sym c (WordVal w1) (WordVal w2) =
+ WordVal <$> iteWord sym c w1 w2
+mergeWord sym c w1 w2 =
+ LargeBitsVal (wordValueSize sym w1) <$> memoMap (mergeSeqMap sym c (asBitsMap sym w1) (asBitsMap sym w2))
+
+{-# INLINE mergeWord' #-}
+mergeWord' :: Backend sym =>
+ sym ->
+ SBit sym ->
+ SEval sym (WordValue sym) ->
+ SEval sym (WordValue sym) ->
+ SEval sym (WordValue sym)
+mergeWord' sym = mergeEval sym (mergeWord sym)
+
+{-# INLINE mergeValue' #-}
+mergeValue' :: Backend sym =>
+ sym ->
+ SBit sym ->
+ SEval sym (GenValue sym) ->
+ SEval sym (GenValue sym) ->
+ SEval sym (GenValue sym)
+mergeValue' sym = mergeEval sym (mergeValue sym)
+
+mergeValue :: Backend sym =>
+ sym ->
+ SBit sym ->
+ GenValue sym ->
+ GenValue sym ->
+ SEval sym (GenValue sym)
+mergeValue sym c v1 v2 =
+ case (v1, v2) of
+ (VRecord fs1 , VRecord fs2 ) ->
+ do let res = zipRecords (\_lbl -> mergeValue' sym c) fs1 fs2
+ case res of
+ Left f -> panic "Cryptol.Eval.Generic" [ "mergeValue: incompatible record values", show f ]
+ Right r -> pure (VRecord r)
+ (VTuple vs1 , VTuple vs2 ) | length vs1 == length vs2 ->
+ pure $ VTuple $ zipWith (mergeValue' sym c) vs1 vs2
+ (VBit b1 , VBit b2 ) -> VBit <$> iteBit sym c b1 b2
+ (VInteger i1 , VInteger i2 ) -> VInteger <$> iteInteger sym c i1 i2
+ (VRational q1, VRational q2) -> VRational <$> iteRational sym c q1 q2
+ (VWord n1 w1 , VWord n2 w2 ) | n1 == n2 -> pure $ VWord n1 $ mergeWord' sym c w1 w2
+ (VSeq n1 vs1 , VSeq n2 vs2 ) | n1 == n2 -> VSeq n1 <$> memoMap (mergeSeqMap sym c vs1 vs2)
+ (VStream vs1 , VStream vs2 ) -> VStream <$> memoMap (mergeSeqMap sym c vs1 vs2)
+ (VFun f1 , VFun f2 ) -> pure $ VFun $ \x -> mergeValue' sym c (f1 x) (f2 x)
+ (VPoly f1 , VPoly f2 ) -> pure $ VPoly $ \x -> mergeValue' sym c (f1 x) (f2 x)
+ (_ , _ ) -> panic "Cryptol.Eval.Generic"
+ [ "mergeValue: incompatible values" ]
+
+{-# INLINE mergeSeqMap #-}
+mergeSeqMap :: Backend sym =>
+ sym ->
+ SBit sym ->
+ SeqMap sym ->
+ SeqMap sym ->
+ SeqMap sym
+mergeSeqMap sym c x y =
+ IndexSeqMap $ \i ->
+ iteValue sym c (lookupSeqMap x i) (lookupSeqMap y i)
+
+
+--------------------------------------------------------------------------------
+-- Experimental parallel primitives
+
+parmapV :: Backend sym => sym -> GenValue sym
+parmapV sym =
+ tlam $ \_a ->
+ tlam $ \_b ->
+ ilam $ \_n ->
+ lam $ \f -> pure $
+ lam $ \xs ->
+ do f' <- fromVFun <$> f
+ xs' <- xs
+ case xs' of
+ VWord n w ->
+ do m <- asBitsMap sym <$> w
+ m' <- sparkParMap sym f' n m
+ pure (VWord n (pure (LargeBitsVal n m')))
+ VSeq n m ->
+ VSeq n <$> sparkParMap sym f' n m
+
+ _ -> panic "parmapV" ["expected sequence!"]
+
+
+sparkParMap ::
+ Backend sym =>
+ sym ->
+ (SEval sym (GenValue sym) -> SEval sym (GenValue sym)) ->
+ Integer ->
+ SeqMap sym ->
+ SEval sym (SeqMap sym)
+sparkParMap sym f n m =
+ finiteSeqMap sym <$> mapM (sSpark sym . f) (enumerateSeqMap n m)
+
+--------------------------------------------------------------------------------
+-- Floating Point Operations
+
+-- | Make a Cryptol value for a binary arithmetic function.
+fpBinArithV :: Backend sym => sym -> FPArith2 sym -> GenValue sym
+fpBinArithV sym fun =
+ ilam \_ ->
+ ilam \_ ->
+ wlam sym \r ->
+ pure $ flam \x ->
+ pure $ flam \y ->
+ VFloat <$> fun sym r x y
+
+-- | Rounding mode used in FP operations that do not specify it explicitly.
+fpRndMode, fpRndRNE, fpRndRNA, fpRndRTP, fpRndRTN, fpRndRTZ ::
+ Backend sym => sym -> SEval sym (SWord sym)
+fpRndMode = fpRndRNE
+fpRndRNE sym = wordLit sym 3 0 {- to nearest, ties to even -}
+fpRndRNA sym = wordLit sym 3 1 {- to nearest, ties to away from 0 -}
+fpRndRTP sym = wordLit sym 3 2 {- to +inf -}
+fpRndRTN sym = wordLit sym 3 3 {- to -inf -}
+fpRndRTZ sym = wordLit sym 3 4 {- to 0 -}
diff --git a/src/Cryptol/Eval/Monad.hs b/src/Cryptol/Eval/Monad.hs
--- a/src/Cryptol/Eval/Monad.hs
+++ b/src/Cryptol/Eval/Monad.hs
@@ -9,6 +9,7 @@
{-# LANGUAGE Safe #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE OverloadedStrings #-}
module Cryptol.Eval.Monad
( -- * Evaluation monad
@@ -17,27 +18,26 @@
, EvalOpts(..)
, getEvalOpts
, PPOpts(..)
+, PPFloatFormat(..)
+, PPFloatExp(..)
+, defaultPPOpts
, io
-, delay
, delayFill
, ready
, blackhole
+, evalSpark
-- * Error reporting
+, Unsupported(..)
, EvalError(..)
, evalPanic
-, typeCannotBeDemoted
-, divideByZero
-, negativeExponent
-, logNegative
, wordTooWide
-, cryUserError
-, cryLoopError
-, cryNoPrimError
-, invalidIndex
+, 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
@@ -59,8 +59,26 @@
{ 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@)
@@ -83,21 +101,8 @@
-- | Access the evaluation options.
getEvalOpts :: Eval EvalOpts
-getEvalOpts = Thunk return
+getEvalOpts = Thunk pure
-{-# INLINE delay #-}
--- | Delay the given evaluation computation, returning a thunk
--- which will run the computation when forced. Raise a loop
--- error if the resulting thunk is forced during its own evaluation.
-delay :: Maybe String -- ^ Optional name to print if a loop is detected
- -> Eval a -- ^ Computation to delay
- -> Eval (Eval a)
-delay _ (Ready a) = Ready (Ready a)
-delay msg (Thunk x) = Thunk $ \opts -> do
- let msg' = maybe "" ("while evaluating "++) msg
- let retry = cryLoopError msg'
- r <- newIORef Unforced
- return $ unDelay retry r (x opts)
{-# INLINE delayFill #-}
@@ -105,20 +110,35 @@
-- 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 ::
+ 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 ::
+ 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)
@@ -166,11 +186,13 @@
instance Monad Eval where
return = Ready
- fail x = Thunk (\_ -> fail x)
(>>=) = evalBind
{-# INLINE return #-}
{-# INLINE (>>=) #-}
+instance Fail.MonadFail Eval where
+ fail x = Thunk (\_ -> fail x)
+
instance MonadIO Eval where
liftIO = io
@@ -196,7 +218,7 @@
-- | Data type describing errors that can occur during evaluation.
data EvalError
- = InvalidIndex Integer -- ^ Out-of-bounds index
+ = 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
@@ -205,11 +227,14 @@
| 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 i -> text "invalid sequence index:" <+> integer i
+ 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"
@@ -218,43 +243,30 @@
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
--- | For things like @`(inf)@ or @`(0-1)@.
-typeCannotBeDemoted :: Type -> a
-typeCannotBeDemoted t = X.throw (TypeCannotBeDemoted t)
--- | For division by 0.
-divideByZero :: Eval a
-divideByZero = io (X.throwIO DivideByZero)
+data Unsupported
+ = UnsupportedSymbolicOp String -- ^ Operation cannot be supported in the symbolic simulator
+ deriving (Typeable,Show)
--- | For exponentiation by a negative integer.
-negativeExponent :: Eval a
-negativeExponent = io (X.throwIO NegativeExponent)
+instance PP Unsupported where
+ ppPrec _ e = case e of
+ UnsupportedSymbolicOp nm -> text "operation can not be supported on symbolic values:" <+> text nm
--- | For logarithm of a negative integer.
-logNegative :: Eval a
-logNegative = io (X.throwIO LogNegative)
+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)
-
--- | For the Cryptol @error@ function.
-cryUserError :: String -> Eval a
-cryUserError msg = io (X.throwIO (UserError msg))
-
-cryNoPrimError :: Name -> Eval a
-cryNoPrimError x = io (X.throwIO (NoPrim x))
-
--- | For cases where we can detect tight loops.
-cryLoopError :: String -> Eval a
-cryLoopError msg = io (X.throwIO (LoopError msg))
-
--- | A sequencing operation has gotten an invalid index.
-invalidIndex :: Integer -> Eval a
-invalidIndex i = io (X.throwIO (InvalidIndex i))
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
@@ -8,34 +8,41 @@
> -- 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 Data.Semigroup (Semigroup(..))
> 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.Value (mkBv, ppBV)
-> import Cryptol.Prims.Eval (lg2)
-> import Cryptol.Utils.Ident (Ident, mkIdent)
+> 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)
@@ -62,15 +69,19 @@
The value types of Cryptol, along with their Haskell representations,
are as follows:
-| Cryptol type | Description | `TValue` representation |
-|:----------------- |:-------------- |:--------------------------- |
-| `Bit` | booleans | `TVBit` |
-| `Integer` | integers | `TVInteger` |
-| `[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` |
+| 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
@@ -78,9 +89,10 @@
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 type `Bit` may result in:
+Evaluating a Cryptol expression of base type (one of: `Bit`, `Integer`,
+`Z n`, or `Rational`) may result in:
-- a defined value `True` or `False`
+- a defined value (e.g., `True` or `False`)
- a run-time error, or
@@ -117,7 +129,9 @@
> -- | Value type for the reference evaluator.
> data Value
> = VBit (Either EvalError Bool) -- ^ @ Bit @ booleans
-> | VInteger (Either EvalError Integer) -- ^ @ Integer @ integers
+> | 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
@@ -126,8 +140,8 @@
> | VNumPoly (Nat' -> Value) -- ^ polymorphic values (kind #)
Invariant: Undefinedness and run-time exceptions are only allowed
-inside the argument of a `VBit` or `VInteger` constructor. All other
-`Value` and list constructors should evaluate without error. For
+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
@@ -171,10 +185,13 @@
> 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) <- fields ]
+> TVRec fields -> VRecord [ (f, go fty (lookupRecord f val)) | (f, fty) <- canonicalFields fields ]
> TVFun _ bty -> VFun (\v -> go bty (fromVFun val v))
> TVAbstract {} -> val
>
@@ -198,6 +215,24 @@
> 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
@@ -292,7 +327,7 @@
>
> 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) <- fields ]
+> 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)
>
@@ -397,6 +432,8 @@
> 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 ]
@@ -530,12 +567,21 @@
> | Just i <- asPrim n, Just v <- Map.lookup i primTable = v
> | otherwise = evalPanic "evalPrim" ["Unimplemented primitive", show n]
-Cryptol primitives fall into several groups:
+Cryptol primitives fall into several groups, mostly delenieated
+by corresponding typeclasses
-* Logic: `&&`, `||`, `^`, `complement`, `zero`, `True`, `False`
+* Literals: `True`, `False`, `number`, `ratio`
-* Arithmetic: `+`, `-`, `*`, `/`, `%`, `^^`, `lg2`, `negate`, `number`
+* Zero: zero
+* Logic: `&&`, `||`, `^`, `complement`
+
+* Ring: `+`, `-`, `*`, `negate`, `fromInteger`
+
+* Integral: `/`, `%`, `^^`, `toInteger`
+
+* Bitvector: `/$` `%$`, `lg2`, `<=$`
+
* Comparison: `<`, `>`, `<=`, `>=`, `==`, `!=`
* Sequences: `#`, `join`, `split`, `splitAt`, `reverse`, `transpose`
@@ -550,40 +596,93 @@
* Miscellaneous: `error`, `random`, `trace`
-> primTable :: Map Ident Value
-> primTable = Map.fromList $ map (\(n, v) -> (mkIdent (T.pack n), v))
+> primTable :: Map PrimIdent Value
+> primTable = Map.unions
+> [ cryptolPrimTable
+> , floatPrimTable
+> ]
+
+> cryptolPrimTable :: Map PrimIdent Value
+> cryptolPrimTable = Map.fromList $ map (\(n, v) -> (prelPrim (T.pack n), v))
>
-> -- Logic (bitwise):
-> [ ("&&" , binary (logicBinary (&&)))
+> -- 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))
-> , ("zero" , VPoly (logicNullary (Right False)))
-> , ("True" , VBit (Right True))
-> , ("False" , VBit (Right False))
>
-> -- Arithmetic:
-> , ("+" , binary (arithBinary (\x y -> Right (x + y))))
-> , ("-" , binary (arithBinary (\x y -> Right (x - y))))
-> , ("*" , binary (arithBinary (\x y -> Right (x * y))))
-> , ("/" , binary (arithBinary divWrap))
-> , ("%" , binary (arithBinary modWrap))
-> , ("/$" , binary (signedArithBinary divWrap))
-> , ("%$" , binary (signedArithBinary modWrap))
-> , ("^^" , binary (arithBinary expWrap))
-> , ("lg2" , unary (arithUnary lg2Wrap))
-> , ("negate" , unary (arithUnary (\x -> Right (- x))))
-> , ("number" , vFinPoly $ \val ->
-> VPoly $ \a ->
-> arithNullary (Right val) a)
-> , ("toInteger" , vFinPoly $ \_bits ->
-> VFun $ \x ->
-> VInteger (fromVWord x))
+> -- 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 ->
-> arithNullary (fromVInteger x) a)
+> ringNullary (fromVInteger x)
+> (fromInteger <$> fromVInteger x)
+> (\e p -> fpFromInteger e p <$> fromVInteger x)
+> a)
>
-> -- Comparison:
+> -- 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)))
@@ -592,7 +691,30 @@
> , ("!=" , binary (cmpOrder (\o -> o /= EQ)))
> , ("<$" , binary signedLessThan)
>
-> -- Sequences:
+> -- 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 ->
@@ -640,7 +762,6 @@
> , (">>" , shiftV shiftRV)
> , ("<<<" , rotateV rotateLV)
> , (">>>" , rotateV rotateRV)
-> , (">>$" , signedShiftRV)
>
> -- Indexing:
> , ("@" , indexPrimOne indexFront)
@@ -648,11 +769,11 @@
> , ("update" , updatePrim updateFront)
> , ("updateEnd" , updatePrim updateBack)
>
-> -- Enumerations:
+> -- Enumerations
> , ("fromTo" , vFinPoly $ \first ->
> vFinPoly $ \lst ->
> VPoly $ \ty ->
-> let f i = arithNullary (Right i) ty
+> let f i = literal i ty
> in VList (Nat (1 + lst - first)) (map f [first .. lst]))
>
> , ("fromThenTo" , vFinPoly $ \first ->
@@ -660,29 +781,46 @@
> vFinPoly $ \_lst ->
> VPoly $ \ty ->
> vFinPoly $ \len ->
-> let f i = arithNullary (Right i) ty
+> let f i = literal i ty
> in VList (Nat len) (map f (genericTake len [first, next ..])))
>
> , ("infFrom" , VPoly $ \ty ->
> VFun $ \first ->
-> let f i = arithUnary (\x -> Right (x + i)) ty first
-> in VList Inf (map f [0 ..]))
+> 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 ->
-> let f i = arithBinary (\x y -> Right (x + (y - x) * i)) ty first next
-> in VList Inf (map f [0 ..]))
+> 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 -> logicNullary (Left (UserError "error")) a)
+> VFun $ \_s -> cryError (UserError "error") a)
> -- TODO: obtain error string from argument s
>
> , ("random" , VPoly $ \a ->
-> VFun $ \_seed ->
-> logicNullary (Left (UserError "random: unimplemented")) a)
+> VFun $ \_seed -> cryError (UserError "random: unimplemented") a)
>
> , ("trace" , VNumPoly $ \_n ->
> VPoly $ \_a ->
@@ -692,12 +830,22 @@
> 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
---------------
@@ -735,6 +883,89 @@
> 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
-----
@@ -745,20 +976,6 @@
types, run-time exceptions on input bits only affect the output bits
at the same positions.
-> logicNullary :: Either EvalError Bool -> TValue -> Value
-> logicNullary b = go
-> where
-> go TVBit = VBit b
-> go TVInteger = VInteger (fmap (\c -> if c then -1 else 0) b)
-> go (TVIntMod _) = VInteger (fmap (const 0) b)
-> go (TVSeq n ety) = VList (Nat n) (genericReplicate n (go ety))
-> go (TVStream ety) = VList Inf (repeat (go ety))
-> go (TVTuple tys) = VTuple (map go tys)
-> go (TVRec fields) = VRecord [ (f, go fty) | (f, fty) <- fields ]
-> go (TVFun _ bty) = VFun (\_ -> go bty)
-> go (TVAbstract {}) =
-> evalPanic "logicUnary" ["Abstract type not in `Logic`"]
->
> logicUnary :: (Bool -> Bool) -> TValue -> Value -> Value
> logicUnary op = go
> where
@@ -766,16 +983,18 @@
> go ty val =
> case ty of
> TVBit -> VBit (fmap op (fromVBit val))
-> TVInteger -> evalPanic "logicUnary" ["Integer not in class Logic"]
-> TVIntMod _ -> evalPanic "logicUnary" ["Z not in class Logic"]
> 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) <- fields ]
+> TVRec fields -> VRecord [ (f, go fty (lookupRecord f val)) | (f, fty) <- canonicalFields fields ]
> TVFun _ bty -> VFun (\v -> go bty (fromVFun val v))
-> TVAbstract {} ->
-> evalPanic "logicUnary" ["Abstract type not in `Logic`"]
->
+> 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
@@ -783,42 +1002,52 @@
> go ty l r =
> case ty of
> TVBit -> VBit (liftA2 op (fromVBit l) (fromVBit r))
-> TVInteger -> evalPanic "logicBinary" ["Integer not in class Logic"]
-> TVIntMod _ -> evalPanic "logicBinary" ["Z not in class Logic"]
> 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) <- fields ]
+> | (f, fty) <- canonicalFields fields ]
> TVFun _ bty -> VFun (\v -> go bty (fromVFun l v) (fromVFun r v))
-> TVAbstract {} ->
-> evalPanic "logicBinary" ["Abstract type not in `Logic`"]
+> 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`"]
-Arithmetic
-----------
+Ring Arithmetic
+---------------
-Arithmetic primitives may be applied to any type that is made up of
-finite bitvectors. On type `[n]`, arithmetic operators are strict in
+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"]`.
-Signed arithmetic primitives may be applied to any type that is made
-up of non-empty finite bitvectors.
-
-> arithNullary :: Either EvalError Integer -> TValue -> Value
-> arithNullary i = go
+> 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 Arith"]
+> 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))
@@ -829,31 +1058,34 @@
> TVTuple tys ->
> VTuple (map go tys)
> TVRec fs ->
-> VRecord [ (f, go fty) | (f, fty) <- fs ]
+> VRecord [ (f, go fty) | (f, fty) <- canonicalFields fs ]
> TVAbstract {} ->
-> evalPanic "arithNullary" ["Absrat type not in `Arith`"]
->
-> arithUnary :: (Integer -> Either EvalError Integer)
-> -> TValue -> Value -> Value
-> arithUnary op = go
+> 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 Arith"]
+> evalPanic "arithUnary" ["Bit not in class Ring"]
> TVInteger ->
-> VInteger $
-> case fromVInteger val of
-> Left e -> Left e
-> Right i -> op i
+> VInteger $ appOp1 iop (fromVInteger val)
+> TVArray{} ->
+> evalPanic "arithUnary" ["Array not in class Ring"]
> TVIntMod n ->
-> VInteger $
-> case fromVInteger val of
-> Left e -> Left e
-> Right i -> flip mod n <$> op i
+> 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 (op =<< fromVWord val)
+> | 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))
@@ -862,52 +1094,34 @@
> TVTuple tys ->
> VTuple (zipWith go tys (fromVTuple val))
> TVRec fs ->
-> VRecord [ (f, go fty (lookupRecord f val)) | (f, fty) <- fs ]
+> VRecord [ (f, go fty (lookupRecord f val)) | (f, fty) <- canonicalFields fs ]
> TVAbstract {} ->
-> evalPanic "arithUnary" ["Absrat type not in `Arith`"]
->
-> arithBinary :: (Integer -> Integer -> Either EvalError Integer)
-> -> TValue -> Value -> Value -> Value
-> arithBinary = arithBinaryGeneric fromVWord
->
-> signedArithBinary :: (Integer -> Integer -> Either EvalError Integer)
-> -> TValue -> Value -> Value -> Value
-> signedArithBinary = arithBinaryGeneric fromSignedVWord
->
-> arithBinaryGeneric :: (Value -> Either EvalError Integer)
-> -> (Integer -> Integer -> Either EvalError Integer)
-> -> TValue -> Value -> Value -> Value
-> arithBinaryGeneric fromWord op = go
+> 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 Arith"]
+> evalPanic "arithBinary" ["Bit not in class Ring"]
> TVInteger ->
-> VInteger $
-> case fromVInteger l of
-> Left e -> Left e
-> Right i ->
-> case fromVInteger r of
-> Left e -> Left e
-> Right j -> op i j
+> VInteger $ appOp2 iop (fromVInteger l) (fromVInteger r)
> TVIntMod n ->
-> VInteger $
-> case fromVInteger l of
-> Left e -> Left e
-> Right i ->
-> case fromVInteger r of
-> Left e -> Left e
-> Right j -> flip mod n <$> op i j
+> 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 $
-> case fromWord l of
-> Left e -> Left e
-> Right i ->
-> case fromWord r of
-> Left e -> Left e
-> Right j -> op i j
+> | 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))
@@ -916,10 +1130,41 @@
> TVTuple tys ->
> VTuple (zipWith3 go tys (fromVTuple l) (fromVTuple r))
> TVRec fs ->
-> VRecord [ (f, go fty (lookupRecord f l) (lookupRecord f r)) | (f, fty) <- fs ]
+> VRecord [ (f, go fty (lookupRecord f l) (lookupRecord f r)) | (f, fty) <- canonicalFields fs ]
> TVAbstract {} ->
-> evalPanic "arithBinary" ["Abstract type not in class `Arith`"]
+> 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
@@ -933,13 +1178,73 @@
> modWrap _ 0 = Left DivideByZero
> modWrap x y = Right (x `rem` y)
>
-> expWrap :: Integer -> Integer -> Either EvalError Integer
-> expWrap x y = if y < 0 then Left NegativeExponent else Right (x ^ 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
----------
@@ -968,6 +1273,12 @@
> 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 _ ->
@@ -977,7 +1288,7 @@
> TVTuple etys ->
> lexList (zipWith3 lexCompare etys (fromVTuple l) (fromVTuple r))
> TVRec fields ->
-> let tys = map snd (sortBy (comparing fst) 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)
@@ -1011,14 +1322,14 @@
> 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 ->
-> case fromSignedVWord l of
-> Left e -> Left e
-> Right i ->
-> case fromSignedVWord r of
-> Left e -> Left e
-> Right j -> Right (compare i j)
+> | isTBit ety -> compare <$> fromSignedVWord l <*> fromSignedVWord r
> | otherwise ->
> lexList (zipWith (lexSignedCompare ety) (fromVList l) (fromVList r))
> TVStream _ ->
@@ -1028,7 +1339,7 @@
> TVTuple etys ->
> lexList (zipWith3 lexSignedCompare etys (fromVTuple l) (fromVTuple r))
> TVRec fields ->
-> let tys = map snd (sortBy (comparing fst) 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)
@@ -1077,14 +1388,14 @@
> shiftV :: (Nat' -> Value -> [Value] -> Integer -> [Value]) -> Value
> shiftV op =
> VNumPoly $ \n ->
-> VNumPoly $ \_ix ->
+> VPoly $ \ix ->
> VPoly $ \a ->
> VFun $ \v ->
> VFun $ \x ->
> copyByTValue (tvSeq n a) $
-> case fromVWord x of
-> Left e -> logicNullary (Left e) (tvSeq n a)
-> Right i -> VList n (op n (logicNullary (Right False) a) (fromVList v) i)
+> 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 =
@@ -1101,13 +1412,13 @@
> rotateV :: (Integer -> [Value] -> Integer -> [Value]) -> Value
> rotateV op =
> vFinPoly $ \n ->
-> VNumPoly $ \_ix ->
+> VPoly $ \ix ->
> VPoly $ \a ->
> VFun $ \v ->
> VFun $ \x ->
> copyByTValue (TVSeq n a) $
-> case fromVWord x of
-> Left e -> VList (Nat n) (genericReplicate n (logicNullary (Left e) 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]
@@ -1122,20 +1433,17 @@
>
> signedShiftRV :: Value
> signedShiftRV =
-> VNumPoly $ \n ->
-> VNumPoly $ \_ix ->
+> VNumPoly $ \(Nat n) ->
+> VPoly $ \ix ->
> VFun $ \v ->
> VFun $ \x ->
-> copyByTValue (tvSeq n TVBit) $
-> case fromVWord x of
-> Left e -> logicNullary (Left e) (tvSeq n TVBit)
-> Right i -> VList n $
+> 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
-> case n of
-> Nat m -> genericReplicate (min m i) z ++ genericTake (m - min m i) vs
-> Inf -> genericReplicate i z ++ vs
-
+> genericReplicate (min n i) z ++ genericTake (n - min n i) vs
Indexing
--------
@@ -1149,41 +1457,41 @@
> indexPrimOne op =
> VNumPoly $ \n ->
> VPoly $ \a ->
-> VNumPoly $ \_w ->
+> VPoly $ \ix ->
> VFun $ \l ->
> VFun $ \r ->
> copyByTValue a $
-> case fromVWord r of
-> Left e -> logicNullary (Left e) 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 -> logicNullary (Left (InvalidIndex ix)) a
+> 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 -> logicNullary (Left (InvalidIndex ix)) a
+> | 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 ->
-> VNumPoly $ \_idxLen ->
+> VPoly $ \ix ->
> VFun $ \xs ->
> VFun $ \idx ->
> VFun $ \val ->
> copyByTValue (tvSeq len eltTy) $
-> case fromVWord idx of
-> Left e -> logicNullary (Left e) (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 -> logicNullary (Left (InvalidIndex i)) (tvSeq len eltTy)
+> | otherwise -> cryError (InvalidIndex (Just i)) (tvSeq len eltTy)
>
> updateFront :: Nat' -> [Value] -> Integer -> Value -> [Value]
> updateFront _ vs i x = updateAt vs i x
@@ -1198,6 +1506,98 @@
> 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
--------------
@@ -1217,6 +1617,8 @@
> 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 "..."])
@@ -1243,7 +1645,7 @@
running the reference evaluator on an expression.
> evaluate :: Expr -> M.ModuleCmd Value
-> evaluate expr (_,modEnv) = return (Right (evalExpr env expr, modEnv), [])
+> evaluate expr (_, _, modEnv) = return (Right (evalExpr env expr, modEnv), [])
> where
> extDgs = concatMap mDecls (M.loadedModules modEnv)
> env = foldl evalDeclGroup mempty extDgs
diff --git a/src/Cryptol/Eval/SBV.hs b/src/Cryptol/Eval/SBV.hs
new file mode 100644
--- /dev/null
+++ b/src/Cryptol/Eval/SBV.hs
@@ -0,0 +1,850 @@
+-- |
+-- Module : Cryptol.Eval.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 PatternGuards #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE ViewPatterns #-}
+module Cryptol.Eval.SBV
+ ( SBV(..), Value
+ , SBVEval(..), SBVResult(..)
+ , evalPrim
+ , forallBV_, existsBV_
+ , forallSBool_, existsSBool_
+ , forallSInteger_, existsSInteger_
+ ) 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 qualified Data.Map as Map
+import qualified Data.Text as T
+
+import Data.SBV (symbolicEnv)
+import Data.SBV.Dynamic as 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
+ Map.fromList $ map (\(n, v) -> (prelPrim (T.pack n), v))
+
+ [ -- Literals
+ ("True" , VBit (bitLit sym True))
+ , ("False" , VBit (bitLit sym False))
+ , ("number" , ecNumberV sym) -- Converts a numeric type into its corresponding value.
+ -- { val, rep } (Literal val rep) => rep
+ , ("fraction" , ecFractionV sym)
+ , ("ratio" , ratioV sym)
+
+ -- Zero
+ , ("zero" , VPoly (zeroV sym))
+
+ -- Logic
+ , ("&&" , binary (andV sym))
+ , ("||" , binary (orV sym))
+ , ("^" , binary (xorV sym))
+ , ("complement" , unary (complementV sym))
+
+ -- Ring
+ , ("fromInteger" , fromIntegerV sym)
+ , ("+" , binary (addV sym))
+ , ("-" , binary (subV sym))
+ , ("negate" , unary (negateV sym))
+ , ("*" , binary (mulV sym))
+
+ -- Integral
+ , ("toInteger" , toIntegerV sym)
+ , ("/" , binary (divV sym))
+ , ("%" , binary (modV sym))
+ , ("^^" , expV sym)
+ , ("infFrom" , infFromV sym)
+ , ("infFromThen" , infFromThenV sym)
+
+ -- Field
+ , ("recip" , recipV sym)
+ , ("/." , fieldDivideV sym)
+
+ -- Round
+ , ("floor" , unary (floorV sym))
+ , ("ceiling" , unary (ceilingV sym))
+ , ("trunc" , unary (truncV sym))
+ , ("roundAway" , unary (roundAwayV sym))
+ , ("roundToEven" , unary (roundToEvenV sym))
+
+ -- Word operations
+ , ("/$" , sdivV sym)
+ , ("%$" , smodV sym)
+ , ("lg2" , lg2V sym)
+ , (">>$" , sshrV)
+
+ -- Cmp
+ , ("<" , binary (lessThanV sym))
+ , (">" , binary (greaterThanV sym))
+ , ("<=" , binary (lessThanEqV sym))
+ , (">=" , binary (greaterThanEqV sym))
+ , ("==" , binary (eqV sym))
+ , ("!=" , binary (distinctV sym))
+
+ -- SignedCmp
+ , ("<$" , binary (signedLessThanV sym))
+
+ -- Finite enumerations
+ , ("fromTo" , fromToV sym)
+ , ("fromThenTo" , fromThenToV sym)
+
+ -- Sequence manipulations
+ , ("#" , -- {a,b,d} (fin a) => [a] d -> [b] d -> [a + b] d
+ nlam $ \ front ->
+ nlam $ \ back ->
+ tlam $ \ elty ->
+ lam $ \ l -> return $
+ lam $ \ r -> join (ccatV sym front back elty <$> l <*> r))
+
+ , ("join" ,
+ nlam $ \ parts ->
+ nlam $ \ (finNat' -> each) ->
+ tlam $ \ a ->
+ lam $ \ x ->
+ joinV sym parts each a =<< x)
+
+ , ("split" , ecSplitV sym)
+
+ , ("splitAt" ,
+ nlam $ \ front ->
+ nlam $ \ back ->
+ tlam $ \ a ->
+ lam $ \ x ->
+ splitAtV sym front back a =<< x)
+
+ , ("reverse" , nlam $ \_a ->
+ tlam $ \_b ->
+ lam $ \xs -> reverseV sym =<< xs)
+
+ , ("transpose" , nlam $ \a ->
+ nlam $ \b ->
+ tlam $ \c ->
+ lam $ \xs -> transposeV sym a b c =<< xs)
+
+ -- Shifts and rotates
+ , ("<<" , logicShift sym "<<"
+ shiftShrink
+ (\x y -> pure (shl x y))
+ (\x y -> pure (lshr x y))
+ shiftLeftReindex shiftRightReindex)
+
+ , (">>" , logicShift sym ">>"
+ shiftShrink
+ (\x y -> pure (lshr x y))
+ (\x y -> pure (shl x y))
+ shiftRightReindex shiftLeftReindex)
+
+ , ("<<<" , logicShift sym "<<<"
+ rotateShrink
+ (\x y -> pure (SBV.svRotateLeft x y))
+ (\x y -> pure (SBV.svRotateRight x y))
+ rotateLeftReindex rotateRightReindex)
+
+ , (">>>" , logicShift sym ">>>"
+ rotateShrink
+ (\x y -> pure (SBV.svRotateRight x y))
+ (\x y -> pure (SBV.svRotateLeft x y))
+ rotateRightReindex rotateLeftReindex)
+
+ -- Indexing and updates
+ , ("@" , indexPrim sym indexFront indexFront_bits indexFront)
+ , ("!" , indexPrim sym indexBack indexBack_bits indexBack)
+
+ , ("update" , updatePrim sym updateFrontSym_word updateFrontSym)
+ , ("updateEnd" , updatePrim sym updateBackSym_word updateBackSym)
+
+ -- Misc
+
+ , ("fromZ" , fromZV sym)
+
+ , ("parmap" , parmapV sym)
+
+ -- {at,len} (fin len) => [len][8] -> at
+ , ("error" ,
+ tlam $ \a ->
+ nlam $ \_ ->
+ VFun $ \s -> errorV sym a =<< (valueToString sym =<< s))
+
+ , ("random" ,
+ tlam $ \a ->
+ wlam sym $ \x ->
+ case integerAsLit sym x of
+ Just i -> randomV sym a i
+ Nothing -> cryUserError sym "cannot evaluate 'random' with symbolic inputs")
+
+ -- The trace function simply forces its first two
+ -- values before returing the third in the symbolic
+ -- evaluator.
+ , ("trace",
+ nlam $ \_n ->
+ tlam $ \_a ->
+ tlam $ \_b ->
+ lam $ \s -> return $
+ lam $ \x -> return $
+ lam $ \y -> do
+ _ <- s
+ _ <- x
+ y)
+ ]
+
+
+indexFront ::
+ Nat' ->
+ TValue ->
+ SeqMap SBV ->
+ TValue ->
+ SVal ->
+ SEval SBV Value
+indexFront mblen a xs _ix idx
+ | Just i <- SBV.svAsInteger idx
+ = lookupSeqMap xs i
+
+ | Nat n <- mblen
+ , TVSeq wlen TVBit <- a
+ = do wvs <- traverse (fromWordVal "indexFront" =<<) (enumerateSeqMap n xs)
+ case asWordList wvs of
+ Just ws ->
+ do z <- wordLit SBV wlen 0
+ return $ VWord wlen $ pure $ WordVal $ SBV.svSelect ws z idx
+ Nothing -> folded
+
+ | otherwise
+ = folded
+
+ 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
+ folded =
+ case k of
+ KBounded _ w ->
+ case mblen of
+ Nat n | n < 2^w -> foldr f def [0 .. n-1]
+ _ -> foldr f def [0 .. 2^w - 1]
+ _ ->
+ case mblen of
+ Nat n -> foldr f def [0 .. n-1]
+ Inf -> liftIO (X.throw (UnsupportedSymbolicOp "unbounded integer indexing"))
+
+indexBack ::
+ 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"]
+
+indexFront_bits ::
+ Nat' ->
+ TValue ->
+ SeqMap SBV ->
+ TValue ->
+ [SBit SBV] ->
+ SEval SBV Value
+indexFront_bits 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))
+
+ | 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 SBV (InvalidIndex Nothing)
+
+ | otherwise
+ = iteValue SBV b
+ (go ((i `shiftL` 1) + 1) (k-1) bs)
+ (go (i `shiftL` 1) (k-1) bs)
+
+
+indexBack_bits ::
+ 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"]
+
+
+-- | 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
+ | otherwise =
+ case wv of
+ WordVal w -> return $ SBV.svEqual w (literalSWord (SBV.intSizeOf w) i)
+ _ -> bitsAre i <$> enumerateWordValueRev SBV wv -- little-endian
+ where
+ bitsAre :: Integer -> [SBit SBV] -> SBit SBV
+ bitsAre n [] = SBV.svBool (n == 0)
+ bitsAre n (b : bs) = SBV.svAnd (bitIs (odd n) b) (bitsAre (n `div` 2) bs)
+
+ bitIs :: Bool -> SBit SBV -> SBit SBV
+ bitIs b x = if b then x else SBV.svNot x
+
+
+updateFrontSym ::
+ Nat' ->
+ TValue ->
+ SeqMap SBV ->
+ Either (SInteger SBV) (WordValue SBV) ->
+ SEval SBV (GenValue SBV) ->
+ SEval SBV (SeqMap SBV)
+updateFrontSym _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)
+
+updateFrontSym _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)
+
+updateFrontSym_word ::
+ 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 (Nat _) eltTy (LargeBitsVal n bv) idx val =
+ LargeBitsVal n <$> updateFrontSym (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 (Nat n) eltTy bv (Right wv) val =
+ case wv of
+ WordVal idx
+ | Just j <- SBV.svAsInteger idx ->
+ updateWordValue SBV bv j (fromVBit <$> val)
+
+ | WordVal bw <- bv ->
+ WordVal <$>
+ do b <- fromVBit <$> val
+ let sz = SBV.intSizeOf bw
+ let z = literalSWord sz 0
+ let znot = SBV.svNot z
+ let q = SBV.svSymbolicMerge (SBV.kindOf bw) True b znot z
+ let msk = SBV.svShiftRight (literalSWord sz (bit (sz-1))) idx
+ 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
+
+
+updateBackSym ::
+ 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 (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)
+
+updateBackSym (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)
+
+updateBackSym_word ::
+ 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 (Nat _) eltTy (LargeBitsVal n bv) idx val =
+ LargeBitsVal n <$> updateBackSym (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 (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)
+
+ | WordVal bw <- bv ->
+ WordVal <$>
+ do b <- fromVBit <$> val
+ let sz = SBV.intSizeOf bw
+ let z = literalSWord sz 0
+ let znot = SBV.svNot z
+ let q = SBV.svSymbolicMerge (SBV.kindOf bw) True b znot z
+ let msk = SBV.svShiftLeft (literalSWord sz 1) idx
+ 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
+
+
+asWordList :: [WordValue SBV] -> Maybe [SWord SBV]
+asWordList = go id
+ where go :: ([SWord SBV] -> [SWord SBV]) -> [WordValue SBV] -> Maybe [SWord SBV]
+ go f [] = Just (f [])
+ 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 =
+ nlam $ \n ->
+ tlam $ \ix ->
+ wlam SBV $ \x -> return $
+ lam $ \y ->
+ y >>= asIndex SBV ">>$" 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
+ let z = svSymbolicMerge (kindOf x) True pneg zneg zpos
+ return . VWord w . pure . WordVal $ z
+
+ Right wv ->
+ do z <- ashr x <$> asWordVal SBV 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
@@ -17,6 +17,7 @@
import Cryptol.TypeCheck.Solver.InfNat
import Cryptol.Utils.Panic (panic)
import Cryptol.Utils.Ident (Ident)
+import Cryptol.Utils.RecordMap
import Data.Maybe(fromMaybe)
import qualified Data.Map.Strict as Map
@@ -29,11 +30,14 @@
data TValue
= TVBit -- ^ @ Bit @
| TVInteger -- ^ @ Integer @
+ | TVFloat Integer Integer -- ^ @ Float e p @
| TVIntMod Integer -- ^ @ Z n @
+ | TVRational -- ^ @Rational@
+ | TVArray TValue TValue -- ^ @ Array a b @
| TVSeq Integer TValue -- ^ @ [n]a @
| TVStream TValue -- ^ @ [inf]t @
| TVTuple [TValue] -- ^ @ (a, b, c )@
- | TVRec [(Ident, TValue)] -- ^ @ { x : a, y : b, z : c } @
+ | TVRec (RecordMap Ident TValue) -- ^ @ { x : a, y : b, z : c } @
| TVFun TValue TValue -- ^ @ a -> b @
| TVAbstract UserTC [Either Nat' TValue] -- ^ an abstract type
deriving (Generic, NFData)
@@ -44,11 +48,14 @@
case tv of
TVBit -> tBit
TVInteger -> tInteger
+ TVFloat e p -> tFloat (tNum e) (tNum p)
TVIntMod n -> tIntMod (tNum n)
+ TVRational -> tRational
+ TVArray a b -> tArray (tValTy a) (tValTy b)
TVSeq n t -> tSeq (tNum n) (tValTy t)
TVStream t -> tSeq tInf (tValTy t)
TVTuple ts -> tTuple (map tValTy ts)
- TVRec fs -> tRec [ (f, tValTy t) | (f, t) <- fs ]
+ TVRec fs -> tRec (fmap tValTy fs)
TVFun t1 t2 -> tFun (tValTy t1) (tValTy t2)
TVAbstract u vs -> tAbstract u (map arg vs)
where arg x = case x of
@@ -97,14 +104,17 @@
Nothing -> evalPanic "evalType" ["type variable not bound", show tv]
TUser _ _ ty' -> evalType env ty'
- TRec fields -> Right $ TVRec [ (f, val t) | (f, t) <- fields ]
+ TRec fields -> Right $ TVRec (fmap val fields)
TCon (TC c) ts ->
case (c, ts) of
(TCBit, []) -> Right $ TVBit
(TCInteger, []) -> Right $ TVInteger
+ (TCRational, []) -> Right $ TVRational
+ (TCFloat, [e,p])-> Right $ TVFloat (inum e) (inum p)
(TCIntMod, [n]) -> case num n of
Inf -> evalPanic "evalType" ["invalid type Z inf"]
Nat m -> Right $ TVIntMod m
+ (TCArray, [a, b]) -> Right $ TVArray (val a) (val b)
(TCSeq, [n, t]) -> Right $ tvSeq (num n) (val t)
(TCFun, [a, b]) -> Right $ TVFun (val a) (val b)
(TCTuple _, _) -> Right $ TVTuple (map val ts)
@@ -128,6 +138,10 @@
where
val = evalValType env
num = evalNumType env
+ inum x = case num x of
+ Nat i -> i
+ Inf -> evalPanic "evalType"
+ ["Expecting a finite size, but got `inf`"]
-- | Evaluation for value types (kind *).
evalValType :: HasCallStack => TypeEnv -> Type -> TValue
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
@@ -10,174 +10,220 @@
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DoAndIfThenElse #-}
-{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE Safe #-}
{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
-module Cryptol.Eval.Value where
+module Cryptol.Eval.Value
+ ( -- * GenericValue
+ GenValue(..)
+ , forceWordValue
+ , forceValue
+ , Backend(..)
+ , asciiMode
+ -- ** Value introduction operations
+ , word
+ , lam
+ , wlam
+ , flam
+ , tlam
+ , nlam
+ , ilam
+ , toStream
+ , toFinSeq
+ , toSeq
+ , mkSeq
+ -- ** Value eliminators
+ , fromVBit
+ , fromVInteger
+ , fromVRational
+ , fromVFloat
+ , fromVSeq
+ , fromSeq
+ , fromWordVal
+ , asIndex
+ , fromVWord
+ , vWordLen
+ , tryFromBits
+ , fromVFun
+ , fromVPoly
+ , fromVNumPoly
+ , fromVTuple
+ , fromVRecord
+ , lookupRecord
+ -- ** Pretty printing
+ , defaultPPOpts
+ , ppValue
+ -- * Sequence Maps
+ , SeqMap (..)
+ , lookupSeqMap
+ , finiteSeqMap
+ , infiniteSeqMap
+ , enumerateSeqMap
+ , streamSeqMap
+ , reverseSeqMap
+ , updateSeqMap
+ , dropSeqMap
+ , concatSeqMap
+ , splitSeqMap
+ , memoMap
+ , zipSeqMap
+ , mapSeqMap
+ , largeBitSize
+ -- * WordValue
+ , WordValue(..)
+ , asWordVal
+ , asBitsMap
+ , enumerateWordValue
+ , enumerateWordValueRev
+ , wordValueSize
+ , indexWordValue
+ , updateWordValue
+ ) where
+
+import Control.Monad.IO.Class
import Data.Bits
import Data.IORef
-import qualified Data.Sequence as Seq
-import qualified Data.Foldable as Fold
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import MonadLib
import qualified Cryptol.Eval.Arch as Arch
+import Cryptol.Eval.Backend
import Cryptol.Eval.Monad
import Cryptol.Eval.Type
-import Cryptol.TypeCheck.AST
import Cryptol.TypeCheck.Solver.InfNat(Nat'(..))
-import Cryptol.Utils.Ident (Ident,mkIdent)
-import Cryptol.Utils.PP
+import Cryptol.Utils.Ident (Ident)
import Cryptol.Utils.Panic(panic)
+import Cryptol.Utils.PP
+import Cryptol.Utils.RecordMap
-import Data.List(genericLength, genericIndex, genericDrop)
-import qualified Data.Text as T
-import Numeric (showIntAtBase)
+import Data.List(genericIndex)
import GHC.Generics (Generic)
-import Control.DeepSeq
-- Values ----------------------------------------------------------------------
--- | Concrete bitvector values: width, value
--- Invariant: The value must be within the range 0 .. 2^width-1
-data BV = BV !Integer !Integer deriving (Generic, NFData)
-
-instance Show BV where
- show = show . bvVal
-
--- | Apply an integer function to the values of bitvectors.
--- This function assumes both bitvectors are the same width.
-binBV :: (Integer -> Integer -> Integer) -> BV -> BV -> BV
-binBV f (BV w x) (BV _ y) = mkBv w (f x y)
-
--- | Apply an integer function to the values of a bitvector.
--- This function assumes the function will not require masking.
-unaryBV :: (Integer -> Integer) -> BV -> BV
-unaryBV f (BV w x) = mkBv w $ f x
-
-bvVal :: BV -> Integer
-bvVal (BV _w x) = x
-
--- | Smart constructor for 'BV's that checks for the width limit
-mkBv :: Integer -> Integer -> BV
-mkBv w i = BV w (mask w i)
-
-- | A sequence map represents a mapping from nonnegative integer indices
-- to values. These are used to represent both finite and infinite sequences.
-data SeqMap b w i
- = IndexSeqMap !(Integer -> Eval (GenValue b w i))
- | UpdateSeqMap !(Map Integer (Eval (GenValue b w i)))
- !(Integer -> Eval (GenValue b w i))
+data SeqMap sym
+ = IndexSeqMap !(Integer -> SEval sym (GenValue sym))
+ | UpdateSeqMap !(Map Integer (SEval sym (GenValue sym)))
+ !(Integer -> SEval sym (GenValue sym))
-lookupSeqMap :: SeqMap b w i -> Integer -> Eval (GenValue b w i)
+lookupSeqMap :: SeqMap sym -> Integer -> SEval sym (GenValue sym)
lookupSeqMap (IndexSeqMap f) i = f i
lookupSeqMap (UpdateSeqMap m f) i =
case Map.lookup i m of
Just x -> x
Nothing -> f i
-type SeqValMap = SeqMap Bool BV Integer
-
-instance NFData (SeqMap b w i) where
- rnf x = seq x ()
+-- | 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
-- | Generate a finite sequence map from a list of values
-finiteSeqMap :: [Eval (GenValue b w i)] -> SeqMap b w i
-finiteSeqMap xs =
+finiteSeqMap :: Backend sym => sym -> [SEval sym (GenValue sym)] -> SeqMap sym
+finiteSeqMap sym xs =
UpdateSeqMap
(Map.fromList (zip [0..] xs))
- invalidIndex
+ (invalidIndex sym)
-- | Generate an infinite sequence map from a stream of values
-infiniteSeqMap :: [Eval (GenValue b w i)] -> Eval (SeqMap b w i)
+infiniteSeqMap :: Backend sym => [SEval sym (GenValue sym)] -> SEval sym (SeqMap sym)
infiniteSeqMap xs =
-- TODO: use an int-trie?
memoMap (IndexSeqMap $ \i -> genericIndex xs i)
--- | Create a finite list of length `n` of the values from [0..n-1] in
+-- | Create a finite list of length @n@ of the values from @[0..n-1]@ in
-- the given the sequence emap.
-enumerateSeqMap :: (Integral n) => n -> SeqMap b w i -> [Eval (GenValue b w i)]
+enumerateSeqMap :: (Integral n) => n -> SeqMap sym -> [SEval sym (GenValue sym)]
enumerateSeqMap n m = [ lookupSeqMap m i | i <- [0 .. (toInteger n)-1] ]
-- | Create an infinite stream of all the values in a sequence map
-streamSeqMap :: SeqMap b w i -> [Eval (GenValue b w i)]
+streamSeqMap :: SeqMap sym -> [SEval sym (GenValue sym)]
streamSeqMap m = [ lookupSeqMap m i | i <- [0..] ]
-- | Reverse the order of a finite sequence map
reverseSeqMap :: Integer -- ^ Size of the sequence map
- -> SeqMap b w i
- -> SeqMap b w i
+ -> SeqMap sym
+ -> SeqMap sym
reverseSeqMap n vals = IndexSeqMap $ \i -> lookupSeqMap vals (n - 1 - i)
-updateSeqMap :: SeqMap b w i -> Integer -> Eval (GenValue b w i) -> SeqMap b w i
+updateSeqMap :: SeqMap sym -> Integer -> SEval sym (GenValue sym) -> SeqMap sym
updateSeqMap (UpdateSeqMap m sm) i x = UpdateSeqMap (Map.insert i x m) sm
updateSeqMap (IndexSeqMap f) i x = UpdateSeqMap (Map.singleton i x) f
--- | Concatenate the first `n` values of the first sequence map onto the
+-- | Concatenate the first @n@ values of the first sequence map onto the
-- beginning of the second sequence map.
-concatSeqMap :: Integer -> SeqMap b w i -> SeqMap b w i -> SeqMap b w i
+concatSeqMap :: Integer -> SeqMap sym -> SeqMap sym -> SeqMap sym
concatSeqMap n x y =
IndexSeqMap $ \i ->
if i < n
then lookupSeqMap x i
else lookupSeqMap y (i-n)
--- | Given a number `n` and a sequence map, return two new sequence maps:
--- the first containing the values from `[0..n-1]` and the next containing
--- the values from `n` onward.
-splitSeqMap :: Integer -> SeqMap b w i -> (SeqMap b w i, SeqMap b w i)
+-- | Given a number @n@ and a sequence map, return two new sequence maps:
+-- the first containing the values from @[0..n-1]@ and the next containing
+-- the values from @n@ onward.
+splitSeqMap :: Integer -> SeqMap sym -> (SeqMap sym, SeqMap sym)
splitSeqMap n xs = (hd,tl)
where
hd = xs
tl = IndexSeqMap $ \i -> lookupSeqMap xs (i+n)
--- | Drop the first @n@ elements of the given @SeqMap@.
-dropSeqMap :: Integer -> SeqMap b w i -> SeqMap b w i
+-- | Drop the first @n@ elements of the given 'SeqMap'.
+dropSeqMap :: Integer -> SeqMap sym -> SeqMap sym
dropSeqMap 0 xs = xs
dropSeqMap n xs = IndexSeqMap $ \i -> lookupSeqMap xs (i+n)
-- | Given a sequence map, return a new sequence map that is memoized using
-- a finite map memo table.
-memoMap :: SeqMap b w i -> Eval (SeqMap b w i)
+memoMap :: (MonadIO m, Backend sym) => SeqMap sym -> m (SeqMap sym)
memoMap x = do
- cache <- io $ newIORef $ Map.empty
+ cache <- liftIO $ newIORef $ Map.empty
return $ IndexSeqMap (memo cache)
where
memo cache i = do
- mz <- io (Map.lookup i <$> readIORef cache)
+ mz <- liftIO (Map.lookup i <$> readIORef cache)
case mz of
Just z -> return z
Nothing -> doEval cache i
doEval cache i = do
v <- lookupSeqMap x i
- io $ modifyIORef' cache (Map.insert i v)
+ liftIO $ modifyIORef' cache (Map.insert i v)
return v
-- | Apply the given evaluation function pointwise to the two given
-- sequence maps.
-zipSeqMap :: (GenValue b w i -> GenValue b w i -> Eval (GenValue b w i))
- -> SeqMap b w i
- -> SeqMap b w i
- -> Eval (SeqMap b w i)
+zipSeqMap ::
+ Backend sym =>
+ (GenValue sym -> GenValue sym -> SEval sym (GenValue sym)) ->
+ SeqMap sym ->
+ SeqMap sym ->
+ SEval sym (SeqMap sym)
zipSeqMap f x y =
memoMap (IndexSeqMap $ \i -> join (f <$> lookupSeqMap x i <*> lookupSeqMap y i))
-- | Apply the given function to each value in the given sequence map
-mapSeqMap :: (GenValue b w i -> Eval (GenValue b w i))
- -> SeqMap b w i -> Eval (SeqMap b w i)
+mapSeqMap ::
+ Backend sym =>
+ (GenValue sym -> SEval sym (GenValue sym)) ->
+ SeqMap sym -> SEval sym (SeqMap sym)
mapSeqMap f x =
memoMap (IndexSeqMap $ \i -> f =<< lookupSeqMap x i)
@@ -190,123 +236,99 @@
-- However, if we cannot be sure all the bits of the sequence
-- will eventually be forced, we must instead rely on an explicit sequence of bits
-- representation.
-data WordValue b w i
- = WordVal !w -- ^ Packed word representation for bit sequences.
- | BitsVal !(Seq.Seq (Eval b)) -- ^ Sequence of thunks representing bits.
- | LargeBitsVal !Integer !(SeqMap b w i ) -- ^ A large bitvector sequence, represented as a
- -- @SeqMap@ of bits.
- deriving (Generic, NFData)
-
--- | 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
+data WordValue sym
+ = WordVal !(SWord sym) -- ^ Packed word representation for bit sequences.
+ | LargeBitsVal !Integer !(SeqMap sym) -- ^ A large bitvector sequence, represented as a
+ -- 'SeqMap' of bits.
+ deriving (Generic)
-- | Force a word value into packed word form
-asWordVal :: BitWord b w i => WordValue b w i -> Eval w
-asWordVal (WordVal w) = return w
-asWordVal (BitsVal bs) = packWord <$> sequence (Fold.toList bs)
-asWordVal (LargeBitsVal n xs) = packWord <$> traverse (fromBit =<<) (enumerateSeqMap n xs)
+asWordVal :: Backend sym => sym -> WordValue sym -> SEval sym (SWord sym)
+asWordVal _ (WordVal w) = return w
+asWordVal sym (LargeBitsVal n xs) = packWord sym =<< traverse (fromVBit <$>) (enumerateSeqMap n xs)
-- | Force a word value into a sequence of bits
-asBitsMap :: BitWord b w i => WordValue b w i -> SeqMap b w i
-asBitsMap (WordVal w) = IndexSeqMap $ \i -> ready $ VBit $ wordBit w i
-asBitsMap (BitsVal bs) = IndexSeqMap $ \i -> VBit <$> join (checkedSeqIndex bs i)
-asBitsMap (LargeBitsVal _ xs) = xs
+asBitsMap :: Backend sym => sym -> WordValue sym -> SeqMap sym
+asBitsMap sym (WordVal w) = IndexSeqMap $ \i -> VBit <$> (wordBit sym w i)
+asBitsMap _ (LargeBitsVal _ xs) = xs
-- | Turn a word value into a sequence of bits, forcing each bit.
-- The sequence is returned in big-endian order.
-enumerateWordValue :: BitWord b w i => WordValue b w i -> Eval [b]
-enumerateWordValue (WordVal w) = return $ unpackWord w
-enumerateWordValue (BitsVal bs) = sequence (Fold.toList bs)
-enumerateWordValue (LargeBitsVal n xs) = traverse (fromBit =<<) (enumerateSeqMap n xs)
+enumerateWordValue :: Backend sym => sym -> WordValue sym -> SEval sym [SBit sym]
+enumerateWordValue sym (WordVal w) = unpackWord sym w
+enumerateWordValue _ (LargeBitsVal n xs) = traverse (fromVBit <$>) (enumerateSeqMap n xs)
-- | Turn a word value into a sequence of bits, forcing each bit.
-- The sequence is returned in reverse of the usual order, which is little-endian order.
-enumerateWordValueRev :: BitWord b w i => WordValue b w i -> Eval [b]
-enumerateWordValueRev (WordVal w) = return $ reverse $ unpackWord w
-enumerateWordValueRev (BitsVal bs) = sequence (Fold.toList $ Seq.reverse bs)
-enumerateWordValueRev (LargeBitsVal n xs) = traverse (fromBit =<<) (enumerateSeqMap n (reverseSeqMap n xs))
+enumerateWordValueRev :: Backend sym => sym -> WordValue sym -> SEval sym [SBit sym]
+enumerateWordValueRev sym (WordVal w) = reverse <$> unpackWord sym w
+enumerateWordValueRev _ (LargeBitsVal n xs) = traverse (fromVBit <$>) (enumerateSeqMap n (reverseSeqMap n xs))
-- | Compute the size of a word value
-wordValueSize :: BitWord b w i => WordValue b w i -> Integer
-wordValueSize (WordVal w) = wordLen w
-wordValueSize (BitsVal bs) = toInteger $ Seq.length bs
-wordValueSize (LargeBitsVal n _) = n
-
-checkedSeqIndex :: Seq.Seq a -> Integer -> Eval a
-checkedSeqIndex xs i =
- case Seq.viewl (Seq.drop (fromInteger i) xs) of
- x Seq.:< _ -> return x
- Seq.EmptyL -> invalidIndex i
-
-checkedIndex :: [a] -> Integer -> Eval a
-checkedIndex xs i =
- case genericDrop i xs of
- (x:_) -> return x
- _ -> invalidIndex i
+wordValueSize :: Backend sym => sym -> WordValue sym -> Integer
+wordValueSize sym (WordVal w) = wordLen sym w
+wordValueSize _ (LargeBitsVal n _) = n
-- | Select an individual bit from a word value
-indexWordValue :: BitWord b w i => WordValue b w i -> Integer -> Eval b
-indexWordValue (WordVal w) idx
- | idx < wordLen w = return $ wordBit w idx
- | otherwise = invalidIndex idx
-indexWordValue (BitsVal bs) idx = join (checkedSeqIndex bs idx)
-indexWordValue (LargeBitsVal n xs) idx
- | idx < n = fromBit =<< lookupSeqMap xs idx
- | otherwise = invalidIndex idx
+indexWordValue :: Backend sym => sym -> WordValue sym -> Integer -> SEval sym (SBit sym)
+indexWordValue sym (WordVal w) idx
+ | idx < wordLen sym w = wordBit sym w idx
+ | otherwise = invalidIndex sym idx
+indexWordValue sym (LargeBitsVal n xs) idx
+ | idx < n = fromVBit <$> lookupSeqMap xs idx
+ | otherwise = invalidIndex sym idx
--- | Produce a new @WordValue@ from the one given by updating the @i@th bit with the
+-- | Produce a new 'WordValue' from the one given by updating the @i@th bit with the
-- given bit value.
-updateWordValue :: BitWord b w i => WordValue b w i -> Integer -> Eval b -> Eval (WordValue b w i)
-updateWordValue (WordVal w) idx (Ready b)
- | idx < wordLen w = return $ WordVal $ wordUpdate w idx b
- | otherwise = invalidIndex idx
-updateWordValue (WordVal w) idx b
- | idx < wordLen w = return $ BitsVal $ Seq.update (fromInteger idx) b $ Seq.fromList $ map ready $ unpackWord w
- | otherwise = invalidIndex idx
-updateWordValue (BitsVal bs) idx b
- | idx < toInteger (Seq.length bs) = return $ BitsVal $ Seq.update (fromInteger idx) b bs
- | otherwise = invalidIndex idx
-updateWordValue (LargeBitsVal n xs) idx b
- | idx < n = return $ LargeBitsVal n $ updateSeqMap xs idx (VBit <$> b)
- | otherwise = invalidIndex idx
+updateWordValue :: Backend sym => sym -> WordValue sym -> Integer -> SEval sym (SBit sym) -> SEval sym (WordValue sym)
+updateWordValue sym (WordVal w) idx b
+ | idx >= wordLen sym w = invalidIndex sym idx
+ | isReady sym b = WordVal <$> (wordUpdate sym w idx =<< b)
+updateWordValue sym wv idx b
+ | idx < wordValueSize sym wv =
+ pure $ LargeBitsVal (wordValueSize sym wv) $ updateSeqMap (asBitsMap sym wv) idx (VBit <$> b)
+ | otherwise = invalidIndex sym idx
+
+
-- | Generic value type, parameterized by bit and word types.
--
-- NOTE: we maintain an important invariant regarding sequence types.
--- `VSeq` must never be used for finite sequences of bits.
--- Always use the `VWord` constructor instead! Infinite sequences of bits
--- are handled by the `VStream` constructor, just as for other types.
-data GenValue b w i
- = VRecord ![(Ident, Eval (GenValue b w i))] -- ^ @ { .. } @
- | VTuple ![Eval (GenValue b w i)] -- ^ @ ( .. ) @
- | VBit !b -- ^ @ Bit @
- | VInteger !i -- ^ @ Integer @ or @ Z n @
- | VSeq !Integer !(SeqMap b w i) -- ^ @ [n]a @
- -- Invariant: VSeq is never a sequence of bits
- | VWord !Integer !(Eval (WordValue b w i)) -- ^ @ [n]Bit @
- | VStream !(SeqMap b w i) -- ^ @ [inf]a @
- | VFun (Eval (GenValue b w i) -> Eval (GenValue b w i)) -- ^ functions
- | VPoly (TValue -> Eval (GenValue b w i)) -- ^ polymorphic values (kind *)
- | VNumPoly (Nat' -> Eval (GenValue b w i)) -- ^ polymorphic values (kind #)
- deriving (Generic, NFData)
+-- 'VSeq' must never be used for finite sequences of bits.
+-- Always use the 'VWord' constructor instead! Infinite sequences of bits
+-- are handled by the 'VStream' constructor, just as for other types.
+data GenValue sym
+ = VRecord !(RecordMap Ident (SEval sym (GenValue sym))) -- ^ @ { .. } @
+ | VTuple ![SEval sym (GenValue sym)] -- ^ @ ( .. ) @
+ | VBit !(SBit sym) -- ^ @ Bit @
+ | VInteger !(SInteger sym) -- ^ @ Integer @ or @ Z n @
+ | VRational !(SRational sym) -- ^ @ Rational @
+ | VFloat !(SFloat sym)
+ | VSeq !Integer !(SeqMap sym) -- ^ @ [n]a @
+ -- Invariant: VSeq is never a sequence of bits
+ | VWord !Integer !(SEval sym (WordValue sym)) -- ^ @ [n]Bit @
+ | VStream !(SeqMap sym) -- ^ @ [inf]a @
+ | VFun (SEval sym (GenValue sym) -> SEval sym (GenValue sym)) -- ^ functions
+ | VPoly (TValue -> SEval sym (GenValue sym)) -- ^ polymorphic values (kind *)
+ | VNumPoly (Nat' -> SEval sym (GenValue sym)) -- ^ polymorphic values (kind #)
+ deriving Generic
-- | Force the evaluation of a word value
-forceWordValue :: WordValue b w i -> Eval ()
-forceWordValue (WordVal _w) = return ()
-forceWordValue (BitsVal bs) = mapM_ (\b -> const () <$> b) bs
+forceWordValue :: Backend sym => WordValue sym -> SEval sym ()
+forceWordValue (WordVal w) = seq w (return ())
forceWordValue (LargeBitsVal n xs) = mapM_ (\x -> const () <$> x) (enumerateSeqMap n xs)
-- | Force the evaluation of a value
-forceValue :: GenValue b w i -> Eval ()
+forceValue :: Backend sym => GenValue sym -> SEval sym ()
forceValue v = case v of
- VRecord fs -> mapM_ (\x -> forceValue =<< snd x) fs
+ VRecord fs -> mapM_ (forceValue =<<) fs
VTuple xs -> mapM_ (forceValue =<<) xs
VSeq n xs -> mapM_ (forceValue =<<) (enumerateSeqMap n xs)
- VBit _b -> return ()
- VInteger _i -> return ()
+ VBit b -> seq b (return ())
+ VInteger i -> seq i (return ())
+ VRational q -> seq q (return ())
+ VFloat f -> seq f (return ())
VWord _ wv -> forceWordValue =<< wv
VStream _ -> return ()
VFun _ -> return ()
@@ -314,12 +336,14 @@
VNumPoly _ -> return ()
-instance (Show b, Show w, Show i) => Show (GenValue b w i) where
+instance Backend sym => Show (GenValue sym) where
show v = case v of
- VRecord fs -> "record:" ++ show (map fst fs)
+ VRecord fs -> "record:" ++ show (displayOrder fs)
VTuple xs -> "tuple:" ++ show (length xs)
- VBit b -> show b
- VInteger i -> show i
+ VBit _ -> "bit"
+ VInteger _ -> "integer"
+ VRational _ -> "rational"
+ VFloat _ -> "float"
VSeq n _ -> "seq:" ++ show n
VWord n _ -> "word:" ++ show n
VStream _ -> "stream"
@@ -327,37 +351,29 @@
VPoly _ -> "poly"
VNumPoly _ -> "numpoly"
-type Value = GenValue Bool BV Integer
-
-- Pretty Printing -------------------------------------------------------------
-defaultPPOpts :: PPOpts
-defaultPPOpts = PPOpts { useAscii = False, useBase = 10, useInfLength = 5 }
-
-atFst :: Functor f => (a -> f b) -> (a, c) -> f (b, c)
-atFst f (x,y) = fmap (,y) $ f x
-
-atSnd :: Functor f => (a -> f b) -> (c, a) -> f (c, b)
-atSnd f (x,y) = fmap (x,) $ f y
-
-ppValue :: forall b w i
- . BitWord b w i
- => PPOpts
- -> GenValue b w i
- -> Eval Doc
-ppValue opts = loop
+ppValue :: forall sym.
+ Backend sym =>
+ sym ->
+ PPOpts ->
+ GenValue sym ->
+ SEval sym Doc
+ppValue x opts = loop
where
- loop :: GenValue b w i -> Eval Doc
+ loop :: GenValue sym -> SEval sym Doc
loop val = case val of
- VRecord fs -> do fs' <- traverse (atSnd (>>=loop)) $ fs
- return $ braces (sep (punctuate comma (map ppField fs')))
+ VRecord fs -> do fs' <- traverse (>>= loop) fs
+ return $ braces (sep (punctuate comma (map ppField (displayFields fs'))))
where
ppField (f,r) = pp f <+> char '=' <+> r
VTuple vals -> do vals' <- traverse (>>=loop) vals
return $ parens (sep (punctuate comma vals'))
- VBit b -> return $ ppBit b
- VInteger i -> return $ ppInteger opts i
+ VBit b -> return $ ppBit x b
+ VInteger i -> return $ ppInteger x opts i
+ VRational q -> return $ ppRational x opts q
+ VFloat i -> return $ ppFloat x opts i
VSeq sz vals -> ppWordSeq sz vals
VWord _ wv -> ppWordVal =<< wv
VStream vals -> do vals' <- traverse (>>=loop) $ enumerateSeqMap (useInfLength opts) vals
@@ -369,317 +385,92 @@
VPoly _ -> return $ text ""
VNumPoly _ -> return $ text ""
- ppWordVal :: WordValue b w i -> Eval Doc
- ppWordVal w = ppWord opts <$> asWordVal w
+ ppWordVal :: WordValue sym -> SEval sym Doc
+ ppWordVal w = ppWord x opts <$> asWordVal x w
- ppWordSeq :: Integer -> SeqMap b w i -> Eval Doc
+ ppWordSeq :: Integer -> SeqMap sym -> SEval sym Doc
ppWordSeq sz vals = do
ws <- sequence (enumerateSeqMap sz vals)
case ws of
w : _
| Just l <- vWordLen w
, asciiMode opts l
- -> do vs <- traverse (fromVWord "ppWordSeq") ws
- case traverse wordAsChar vs of
+ -> do vs <- traverse (fromVWord x "ppWordSeq") ws
+ case traverse (wordAsChar x) vs of
Just str -> return $ text (show str)
- _ -> return $ brackets (fsep (punctuate comma $ map (ppWord opts) vs))
+ _ -> 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)
-integerToChar :: Integer -> Char
-integerToChar = toEnum . fromInteger
-
-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"
-
-
--- | This type class defines a collection of operations on bits and words that
--- are necessary to define generic evaluator primitives that operate on both concrete
--- and symbolic values uniformly.
-class BitWord b w i | b -> w, w -> i, i -> b where
- -- | Pretty-print an individual bit
- ppBit :: b -> Doc
-
- -- | Pretty-print a word value
- ppWord :: PPOpts -> w -> Doc
-
- -- | Pretty-print an integer value
- ppInteger :: PPOpts -> i -> Doc
-
- -- | Attempt to render a word value as an ASCII character. Return `Nothing`
- -- if the character value is unknown (e.g., for symbolic values).
- wordAsChar :: w -> Maybe Char
-
- -- | The number of bits in a word value.
- wordLen :: w -> Integer
-
- -- | Construct a literal bit value from a boolean.
- bitLit :: Bool -> b
-
- -- | Construct a literal word value given a bit width and a value.
- wordLit :: Integer -- ^ Width
- -> Integer -- ^ Value
- -> w
-
- -- | Construct a literal integer value from the given integer.
- integerLit :: Integer -- ^ Value
- -> i
-
- -- | 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 :: w -> Integer -> b
-
- -- | 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 :: w -> Integer -> b -> w
-
- -- | Construct a word value from a finite sequence of bits.
- -- NOTE: this assumes that the sequence of bits is big-endian and finite, so the
- -- first element of the list will be the most significant bit.
- packWord :: [b] -> w
-
- -- | Deconstruct a packed word value in to a finite sequence of bits.
- -- NOTE: this produces a list of bits that represent a big-endian word, so
- -- the most significant bit is the first element of the list.
- unpackWord :: w -> [b]
-
- -- | Concatenate the two given word values.
- -- NOTE: the first argument represents the more-significant bits
- joinWord :: w -> w -> w
-
- -- | Take the most-significant bits, and return
- -- those bits and the remainder. The first element
- -- of the pair is the most significant bits.
- -- The two integer sizes must sum to the length of the given word value.
- splitWord :: Integer -- ^ left width
- -> Integer -- ^ right width
- -> w
- -> (w, w)
-
- -- | Extract a subsequence of bits from a packed word value.
- -- The first integer argument is the number of bits in the
- -- resulting word. The second integer argument is the
- -- number of less-significant digits to discard. Stated another
- -- way, the operation `extractWord n i w` is equivalent to
- -- first shifting `w` right by `i` bits, and then truncating to
- -- `n` bits.
- extractWord :: Integer -- ^ Number of bits to take
- -> Integer -- ^ starting bit
- -> w
- -> w
-
- -- | 2's complement addition of packed words. The arguments must have
- -- equal bit width, and the result is of the same width. Overflow is silently
- -- discarded.
- wordPlus :: w -> w -> w
-
- -- | 2's complement subtraction of packed words. The arguments must have
- -- equal bit width, and the result is of the same width. Overflow is silently
- -- discarded.
- wordMinus :: w -> w -> w
-
- -- | 2's complement multiplication of packed words. The arguments must have
- -- equal bit width, and the result is of the same width. The high bits of the
- -- multiplication are silently discarded.
- wordMult :: w -> w -> w
-
- -- | Construct an integer value from the given packed word.
- wordToInt :: w -> i
-
- -- | Addition of unbounded integers.
- intPlus :: i -> i -> i
-
- -- | Subtraction of unbounded integers.
- intMinus :: i -> i -> i
-
- -- | Multiplication of unbounded integers.
- intMult :: i -> i -> i
-
- -- | Addition of integers modulo n, for a concrete positive integer n.
- intModPlus :: Integer -> i -> i -> i
-
- -- | Subtraction of integers modulo n, for a concrete positive integer n.
- intModMinus :: Integer -> i -> i -> i
-
- -- | Multiplication of integers modulo n, for a concrete positive integer n.
- intModMult :: Integer -> i -> i -> i
-
- -- | Construct a packed word of the specified width from an integer value.
- wordFromInt :: Integer -> i -> w
-
--- | This class defines additional operations necessary to define generic evaluation
--- functions.
-class BitWord b w i => EvalPrims b w i where
- -- | Eval prim binds primitive declarations to the primitive values that implement them. Returns 'Nothing' for abstract primitives (i.e., once that are
- -- not implemented by this backend).
- evalPrim :: Decl -> Maybe (GenValue b w i)
-
- -- | if/then/else operation. Choose either the 'then' value or the 'else' value depending
- -- on the value of the test bit.
- iteValue :: b -- ^ Test bit
- -> Eval (GenValue b w i) -- ^ 'then' value
- -> Eval (GenValue b w i) -- ^ 'else' value
- -> Eval (GenValue b w i)
-
-
--- Concrete Big-endian Words ------------------------------------------------------------
-
-mask :: Integer -- ^ Bit-width
- -> Integer -- ^ Value
- -> Integer -- ^ Masked result
-mask w i | w >= Arch.maxBigIntWidth = wordTooWide w
- | otherwise = i .&. ((1 `shiftL` fromInteger w) - 1)
-
-instance BitWord Bool BV Integer where
- wordLen (BV w _) = w
- wordAsChar (BV _ x) = Just $ integerToChar x
-
- wordBit (BV w x) idx = testBit x (fromInteger (w - 1 - idx))
-
- wordUpdate (BV w x) idx True = BV w (setBit x (fromInteger (w - 1 - idx)))
- wordUpdate (BV w x) idx False = BV w (clearBit x (fromInteger (w - 1 - idx)))
-
- ppBit b | b = text "True"
- | otherwise = text "False"
-
- ppWord = ppBV
-
- ppInteger _opts i = integer i
-
- bitLit b = b
- wordLit = mkBv
- integerLit i = i
-
- packWord bits = 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) = [ testBit a n | n <- [w' - 1, w' - 2 .. 0] ]
- where
- w' = fromInteger w
-
- joinWord (BV i x) (BV j y) =
- BV (i + j) (shiftL x (fromInteger j) + y)
-
- splitWord leftW rightW (BV _ x) =
- ( BV leftW (x `shiftR` (fromInteger rightW)), mkBv rightW x )
-
- extractWord n i (BV _ x) = mkBv n (x `shiftR` (fromInteger i))
-
- wordPlus (BV i x) (BV j y)
- | i == j = mkBv i (x+y)
- | otherwise = panic "Attempt to add words of different sizes: wordPlus" []
-
- wordMinus (BV i x) (BV j y)
- | i == j = mkBv i (x-y)
- | otherwise = panic "Attempt to subtract words of different sizes: wordMinus" []
-
- wordMult (BV i x) (BV j y)
- | i == j = mkBv i (x*y)
- | otherwise = panic "Attempt to multiply words of different sizes: wordMult" []
-
- intPlus x y = x + y
- intMinus x y = x - y
- intMult x y = x * y
-
- intModPlus m x y = (x + y) `mod` m
- intModMinus m x y = (x - y) `mod` m
- intModMult m x y = (x * y) `mod` m
-
- wordToInt (BV _ x) = x
- wordFromInt w x = mkBv w x
-
-- Value Constructors ----------------------------------------------------------
-- | Create a packed word of n bits.
-word :: BitWord b w i => Integer -> Integer -> GenValue b w i
-word n i
+word :: Backend sym => sym -> Integer -> Integer -> GenValue sym
+word sym n i
| n >= Arch.maxBigIntWidth = wordTooWide n
- | otherwise = VWord n $ ready $ WordVal $ wordLit n i
+ | otherwise = VWord n (WordVal <$> wordLit sym n i)
-lam :: (Eval (GenValue b w i) -> Eval (GenValue b w i)) -> GenValue b w i
+lam :: (SEval sym (GenValue sym) -> SEval sym (GenValue sym)) -> GenValue sym
lam = VFun
-- | Functions that assume word inputs
-wlam :: BitWord b w i => (w -> Eval (GenValue b w i)) -> GenValue b w i
-wlam f = VFun (\x -> x >>= fromVWord "wlam" >>= f)
+wlam :: Backend sym => sym -> (SWord sym -> SEval sym (GenValue sym)) -> GenValue sym
+wlam sym f = VFun (\arg -> arg >>= fromVWord sym "wlam" >>= f)
--- | A type lambda that expects a @Type@.
-tlam :: (TValue -> GenValue b w i) -> GenValue b w i
+-- | Functions that assume floating point inputs
+flam :: Backend sym =>
+ (SFloat sym -> SEval sym (GenValue sym)) -> GenValue sym
+flam f = VFun (\arg -> arg >>= f . fromVFloat)
+
+
+
+-- | A type lambda that expects a 'Type'.
+tlam :: Backend sym => (TValue -> GenValue sym) -> GenValue sym
tlam f = VPoly (return . f)
--- | A type lambda that expects a @Type@ of kind #.
-nlam :: (Nat' -> GenValue b w i) -> GenValue b w i
+-- | A type lambda that expects a 'Type' of kind #.
+nlam :: Backend sym => (Nat' -> GenValue sym) -> GenValue sym
nlam f = VNumPoly (return . f)
+-- | A type lambda that expects a finite numeric type.
+ilam :: Backend sym => (Integer -> GenValue sym) -> GenValue sym
+ilam f = nlam (\n -> case n of
+ Nat i -> f i
+ Inf -> panic "ilam" [ "Unexpected `inf`" ])
+
-- | Generate a stream.
-toStream :: [GenValue b w i] -> Eval (GenValue b w i)
+toStream :: Backend sym => [GenValue sym] -> SEval sym (GenValue sym)
toStream vs =
- VStream <$> infiniteSeqMap (map ready vs)
-
-toFinSeq :: BitWord b w i
- => Integer -> TValue -> [GenValue b w i] -> GenValue b w i
-toFinSeq len elty vs
- | isTBit elty = VWord len $ ready $ WordVal $ packWord $ map fromVBit vs
- | otherwise = VSeq len $ finiteSeqMap (map ready vs)
+ VStream <$> infiniteSeqMap (map pure vs)
--- | This is strict!
-boolToWord :: [Bool] -> Value
-boolToWord bs = VWord (genericLength bs) $ ready $ WordVal $ packWord bs
+toFinSeq ::
+ Backend sym =>
+ sym -> Integer -> TValue -> [GenValue sym] -> GenValue sym
+toFinSeq sym len elty vs
+ | isTBit elty = VWord len (WordVal <$> packWord sym (map fromVBit vs))
+ | otherwise = VSeq len $ finiteSeqMap sym (map pure vs)
-- | Construct either a finite sequence, or a stream. In the finite case,
-- record whether or not the elements were bits, to aid pretty-printing.
-toSeq :: BitWord b w i
- => Nat' -> TValue -> [GenValue b w i] -> Eval (GenValue b w i)
-toSeq len elty vals = case len of
- Nat n -> return $ toFinSeq n elty vals
+toSeq ::
+ Backend sym =>
+ sym -> Nat' -> TValue -> [GenValue sym] -> SEval sym (GenValue sym)
+toSeq sym len elty vals = case len of
+ Nat n -> return $ toFinSeq sym n elty vals
Inf -> toStream vals
-- | Construct either a finite sequence, or a stream. In the finite case,
-- record whether or not the elements were bits, to aid pretty-printing.
-mkSeq :: Nat' -> TValue -> SeqMap b w i -> GenValue b w i
+mkSeq :: Backend sym => Nat' -> TValue -> SeqMap sym -> GenValue sym
mkSeq len elty vals = case len of
Nat n
- | isTBit elty -> VWord n $ return $ BitsVal $ Seq.fromFunction (fromInteger n) $ \i ->
- fromVBit <$> lookupSeqMap vals (toInteger i)
+ | isTBit elty -> VWord n $ pure $ LargeBitsVal n vals
| otherwise -> VSeq n vals
Inf -> VStream vals
@@ -687,148 +478,105 @@
-- Value Destructors -----------------------------------------------------------
-- | Extract a bit value.
-fromVBit :: GenValue b w i -> b
+fromVBit :: GenValue sym -> SBit sym
fromVBit val = case val of
VBit b -> b
_ -> evalPanic "fromVBit" ["not a Bit"]
-- | Extract an integer value.
-fromVInteger :: GenValue b w i -> i
+fromVInteger :: GenValue sym -> SInteger sym
fromVInteger val = case val of
VInteger i -> i
_ -> evalPanic "fromVInteger" ["not an Integer"]
+-- | Extract a rational value.
+fromVRational :: GenValue sym -> SRational sym
+fromVRational val = case val of
+ VRational q -> q
+ _ -> evalPanic "fromVRational" ["not a Rational"]
+
-- | Extract a finite sequence value.
-fromVSeq :: GenValue b w i -> SeqMap b w i
+fromVSeq :: GenValue sym -> SeqMap sym
fromVSeq val = case val of
VSeq _ vs -> vs
_ -> evalPanic "fromVSeq" ["not a sequence"]
-- | Extract a sequence.
-fromSeq :: forall b w i. BitWord b w i => String -> GenValue b w i -> Eval (SeqMap b w i)
+fromSeq :: Backend sym => String -> GenValue sym -> SEval sym (SeqMap sym)
fromSeq msg val = case val of
VSeq _ vs -> return vs
VStream vs -> return vs
_ -> evalPanic "fromSeq" ["not a sequence", msg]
-fromStr :: Value -> Eval String
-fromStr (VSeq n vals) =
- traverse (\x -> toEnum . fromInteger <$> (fromWord "fromStr" =<< x)) (enumerateSeqMap n vals)
-fromStr _ = evalPanic "fromStr" ["Not a finite sequence"]
-
-fromBit :: GenValue b w i -> Eval b
-fromBit (VBit b) = return b
-fromBit _ = evalPanic "fromBit" ["Not a bit value"]
-
-fromWordVal :: String -> GenValue b w i -> Eval (WordValue b w i)
+fromWordVal :: Backend sym => String -> GenValue sym -> SEval sym (WordValue sym)
fromWordVal _msg (VWord _ wval) = wval
fromWordVal msg _ = evalPanic "fromWordVal" ["not a word value", msg]
+asIndex :: Backend sym =>
+ sym -> String -> TValue -> GenValue sym -> SEval sym (Either (SInteger sym) (WordValue sym))
+asIndex _sym _msg TVInteger (VInteger i) = pure (Left i)
+asIndex _sym _msg _ (VWord _ wval) = Right <$> wval
+asIndex _sym msg _ _ = evalPanic "asIndex" ["not an index value", msg]
+
-- | Extract a packed word.
-fromVWord :: BitWord b w i => String -> GenValue b w i -> Eval w
-fromVWord _msg (VWord _ wval) = wval >>= asWordVal
-fromVWord msg _ = evalPanic "fromVWord" ["not a word", msg]
+fromVWord :: Backend sym => sym -> String -> GenValue sym -> SEval sym (SWord sym)
+fromVWord sym _msg (VWord _ wval) = wval >>= asWordVal sym
+fromVWord _ msg _ = evalPanic "fromVWord" ["not a word", msg]
-vWordLen :: BitWord b w i => GenValue b w i -> Maybe Integer
+vWordLen :: Backend sym => GenValue sym -> Maybe Integer
vWordLen val = case val of
VWord n _wv -> Just n
_ -> Nothing
-- | If the given list of values are all fully-evaluated thunks
-- containing bits, return a packed word built from the same bits.
--- However, if any value is not a fully-evaluated bit, return `Nothing`.
-tryFromBits :: BitWord b w i => [Eval (GenValue b w i)] -> Maybe w
-tryFromBits = go id
+-- However, if any value is not a fully-evaluated bit, return 'Nothing'.
+tryFromBits :: Backend sym => sym -> [SEval sym (GenValue sym)] -> Maybe (SEval sym (SWord sym))
+tryFromBits sym = go id
where
- go f [] = Just (packWord (f []))
- go f (Ready (VBit b) : vs) = go (f . (b :)) vs
+ go f [] = Just (packWord sym =<< sequence (f []))
+ go f (v : vs) | isReady sym v = go (f . ((fromVBit <$> v):)) vs
go _ (_ : _) = Nothing
--- | Turn a value into an integer represented by w bits.
-fromWord :: String -> Value -> Eval Integer
-fromWord msg val = bvVal <$> fromVWord msg val
-
-- | Extract a function from a value.
-fromVFun :: GenValue b w i -> (Eval (GenValue b w i) -> Eval (GenValue b w i))
+fromVFun :: GenValue sym -> (SEval sym (GenValue sym) -> SEval sym (GenValue sym))
fromVFun val = case val of
VFun f -> f
_ -> evalPanic "fromVFun" ["not a function"]
-- | Extract a polymorphic function from a value.
-fromVPoly :: GenValue b w i -> (TValue -> Eval (GenValue b w i))
+fromVPoly :: GenValue sym -> (TValue -> SEval sym (GenValue sym))
fromVPoly val = case val of
VPoly f -> f
_ -> evalPanic "fromVPoly" ["not a polymorphic value"]
-- | Extract a polymorphic function from a value.
-fromVNumPoly :: GenValue b w i -> (Nat' -> Eval (GenValue b w i))
+fromVNumPoly :: GenValue sym -> (Nat' -> SEval sym (GenValue sym))
fromVNumPoly val = case val of
VNumPoly f -> f
_ -> evalPanic "fromVNumPoly" ["not a polymorphic value"]
-- | Extract a tuple from a value.
-fromVTuple :: GenValue b w i -> [Eval (GenValue b w i)]
+fromVTuple :: GenValue sym -> [SEval sym (GenValue sym)]
fromVTuple val = case val of
VTuple vs -> vs
_ -> evalPanic "fromVTuple" ["not a tuple"]
-- | Extract a record from a value.
-fromVRecord :: GenValue b w i -> [(Ident, Eval (GenValue b w i))]
+fromVRecord :: GenValue sym -> RecordMap Ident (SEval sym (GenValue sym))
fromVRecord val = case val of
VRecord fs -> fs
_ -> evalPanic "fromVRecord" ["not a record"]
--- | Lookup a field in a record.
-lookupRecord :: Ident -> GenValue b w i -> Eval (GenValue b w i)
-lookupRecord f rec = case lookup f (fromVRecord rec) of
- Just val -> val
- Nothing -> evalPanic "lookupRecord" ["malformed record"]
-
--- Value to Expression conversion ----------------------------------------------
-
--- | Given an expected type, returns an expression that evaluates to
--- this value, if we can determine it.
---
--- XXX: View patterns would probably clean up this definition a lot.
-toExpr :: PrimMap -> Type -> Value -> Eval (Maybe Expr)
-toExpr prims t0 v0 = findOne (go t0 v0)
- where
-
- prim n = ePrim prims (mkIdent (T.pack n))
+fromVFloat :: GenValue sym -> SFloat sym
+fromVFloat val =
+ case val of
+ VFloat x -> x
+ _ -> evalPanic "fromVFloat" ["not a Float"]
- go :: Type -> Value -> ChoiceT Eval Expr
- go ty val = case (tNoUser ty, val) of
- (TRec tfs, VRecord vfs) -> do
- let fns = map fst vfs
- guard (map fst tfs == fns)
- fes <- zipWithM go (map snd tfs) =<< lift (traverse snd vfs)
- return $ ERec (zip fns fes)
- (TCon (TC (TCTuple tl)) ts, VTuple tvs) -> do
- guard (tl == (length tvs))
- ETuple `fmap` (zipWithM go ts =<< lift (sequence tvs))
- (TCon (TC TCBit) [], VBit True ) -> return (prim "True")
- (TCon (TC TCBit) [], VBit False) -> return (prim "False")
- (TCon (TC TCInteger) [], VInteger i) ->
- return $ ETApp (ETApp (prim "number") (tNum i)) ty
- (TCon (TC TCIntMod) [_n], VInteger i) ->
- return $ ETApp (ETApp (prim "number") (tNum i)) ty
- (TCon (TC TCSeq) [a,b], VSeq 0 _) -> do
- guard (a == tZero)
- return $ EList [] b
- (TCon (TC TCSeq) [a,b], VSeq n svs) -> do
- guard (a == tNum n)
- ses <- mapM (go b) =<< lift (sequence (enumerateSeqMap n svs))
- return $ EList ses b
- (TCon (TC TCSeq) [a,(TCon (TC TCBit) [])], VWord _ wval) -> do
- BV w v <- lift (asWordVal =<< wval)
- guard (a == tNum w)
- return $ ETApp (ETApp (prim "number") (tNum v)) ty
- (_, VStream _) -> fail "cannot construct infinite expressions"
- (_, VFun _) -> fail "cannot convert function values to expressions"
- (_, VPoly _) -> fail "cannot convert polymorphic values to expressions"
- _ -> do doc <- lift (ppValue defaultPPOpts val)
- panic "Cryptol.Eval.Value.toExpr"
- ["type mismatch:"
- , pretty ty
- , render doc
- ]
+-- | Lookup a field in a record.
+lookupRecord :: Ident -> GenValue sym -> SEval sym (GenValue sym)
+lookupRecord f val =
+ case lookupField f (fromVRecord val) of
+ Just x -> x
+ Nothing -> evalPanic "lookupRecord" ["malformed record"]
diff --git a/src/Cryptol/Eval/What4.hs b/src/Cryptol/Eval/What4.hs
new file mode 100644
--- /dev/null
+++ b/src/Cryptol/Eval/What4.hs
@@ -0,0 +1,197 @@
+-- |
+-- Module : Cryptol.Eval.What4
+-- Copyright : (c) 2020 Galois, Inc.
+-- License : BSD3
+-- Maintainer : cryptol@galois.com
+
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Cryptol.Eval.What4
+ ( What4(..)
+ , W4Result(..)
+ , W4Defs(..)
+ , W4Eval
+ , w4Eval
+ , Value
+ , evalPrim
+ ) where
+
+
+import Control.Monad (join)
+import qualified Data.Map as Map
+
+import qualified What4.Interface as W4
+
+import Cryptol.Eval.Backend
+import Cryptol.Eval.Generic
+import Cryptol.Eval.Type (finNat')
+import Cryptol.Eval.Value
+import Cryptol.Eval.What4.Value
+import Cryptol.Eval.What4.Float(floatPrims)
+import Cryptol.Testing.Random( randomV )
+import Cryptol.Utils.Ident
+
+
+evalPrim :: W4.IsSymExprBuilder sym => sym -> PrimIdent -> Maybe (Value sym)
+evalPrim sym prim = Map.lookup prim (primTable sym)
+
+-- See also Cryptol.Prims.Eval.primTable
+primTable :: W4.IsSymExprBuilder sym => sym -> Map.Map PrimIdent (Value sym)
+primTable w4sym = let sym = What4 w4sym in
+ Map.union (floatPrims sym) $
+ Map.fromList $ map (\(n, v) -> (prelPrim n, v))
+
+ [ -- Literals
+ ("True" , VBit (bitLit sym True))
+ , ("False" , VBit (bitLit sym False))
+ , ("number" , ecNumberV sym) -- Converts a numeric type into its corresponding value.
+ -- { val, rep } (Literal val rep) => rep
+ , ("fraction" , ecFractionV sym)
+ , ("ratio" , ratioV sym)
+
+ -- Zero
+ , ("zero" , VPoly (zeroV sym))
+
+ -- Logic
+ , ("&&" , binary (andV sym))
+ , ("||" , binary (orV sym))
+ , ("^" , binary (xorV sym))
+ , ("complement" , unary (complementV sym))
+
+ -- Ring
+ , ("fromInteger" , fromIntegerV sym)
+ , ("+" , binary (addV sym))
+ , ("-" , binary (subV sym))
+ , ("negate" , unary (negateV sym))
+ , ("*" , binary (mulV sym))
+
+ -- Integral
+ , ("toInteger" , toIntegerV sym)
+ , ("/" , binary (divV sym))
+ , ("%" , binary (modV sym))
+ , ("^^" , expV sym)
+ , ("infFrom" , infFromV sym)
+ , ("infFromThen" , infFromThenV sym)
+
+ -- Field
+ , ("recip" , recipV sym)
+ , ("/." , fieldDivideV sym)
+
+ -- Round
+ , ("floor" , unary (floorV sym))
+ , ("ceiling" , unary (ceilingV sym))
+ , ("trunc" , unary (truncV sym))
+ , ("roundAway" , unary (roundAwayV sym))
+ , ("roundToEven" , unary (roundToEvenV sym))
+
+ -- Word operations
+ , ("/$" , sdivV sym)
+ , ("%$" , smodV sym)
+ , ("lg2" , lg2V sym)
+ , (">>$" , sshrV w4sym)
+
+ -- Cmp
+ , ("<" , binary (lessThanV sym))
+ , (">" , binary (greaterThanV sym))
+ , ("<=" , binary (lessThanEqV sym))
+ , (">=" , binary (greaterThanEqV sym))
+ , ("==" , binary (eqV sym))
+ , ("!=" , binary (distinctV sym))
+
+ -- SignedCmp
+ , ("<$" , binary (signedLessThanV sym))
+
+ -- Finite enumerations
+ , ("fromTo" , fromToV sym)
+ , ("fromThenTo" , fromThenToV sym)
+
+ -- Sequence manipulations
+ , ("#" , -- {a,b,d} (fin a) => [a] d -> [b] d -> [a + b] d
+ nlam $ \ front ->
+ nlam $ \ back ->
+ tlam $ \ elty ->
+ lam $ \ l -> return $
+ lam $ \ r -> join (ccatV sym front back elty <$> l <*> r))
+
+ , ("join" ,
+ nlam $ \ parts ->
+ nlam $ \ (finNat' -> each) ->
+ tlam $ \ a ->
+ lam $ \ x ->
+ joinV sym parts each a =<< x)
+
+ , ("split" , ecSplitV sym)
+
+ , ("splitAt" ,
+ nlam $ \ front ->
+ nlam $ \ back ->
+ tlam $ \ a ->
+ lam $ \ x ->
+ splitAtV sym front back a =<< x)
+
+ , ("reverse" , nlam $ \_a ->
+ tlam $ \_b ->
+ lam $ \xs -> reverseV sym =<< xs)
+
+ , ("transpose" , nlam $ \a ->
+ nlam $ \b ->
+ tlam $ \c ->
+ lam $ \xs -> transposeV sym a b c =<< xs)
+
+ -- Shifts and rotates
+ , ("<<" , logicShift sym "<<" shiftShrink
+ (w4bvShl w4sym) (w4bvLshr w4sym)
+ shiftLeftReindex shiftRightReindex)
+ , (">>" , logicShift sym ">>" shiftShrink
+ (w4bvLshr w4sym) (w4bvShl w4sym)
+ shiftRightReindex shiftLeftReindex)
+ , ("<<<" , logicShift sym "<<<" rotateShrink
+ (w4bvRol w4sym) (w4bvRor w4sym)
+ rotateLeftReindex rotateRightReindex)
+ , (">>>" , logicShift sym ">>>" rotateShrink
+ (w4bvRor w4sym) (w4bvRol w4sym)
+ 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))
+
+ , ("update" , updatePrim sym (updateFrontSym_word w4sym) (updateFrontSym w4sym))
+ , ("updateEnd" , updatePrim sym (updateBackSym_word w4sym) (updateBackSym w4sym))
+
+ -- Misc
+
+ , ("parmap" , parmapV sym)
+
+ , ("fromZ" , fromZV sym)
+
+ -- {at,len} (fin len) => [len][8] -> at
+ , ("error" ,
+ tlam $ \a ->
+ nlam $ \_ ->
+ VFun $ \s -> errorV sym a =<< (valueToString sym =<< s))
+
+ , ("random" ,
+ tlam $ \a ->
+ wlam sym $ \x ->
+ case wordAsLit sym x of
+ Just (_,i) -> randomV sym a i
+ Nothing -> cryUserError sym "cannot evaluate 'random' with symbolic inputs")
+
+ -- The trace function simply forces its first two
+ -- values before returing the third in the symbolic
+ -- evaluator.
+ , ("trace",
+ nlam $ \_n ->
+ tlam $ \_a ->
+ tlam $ \_b ->
+ lam $ \s -> return $
+ lam $ \x -> return $
+ lam $ \y -> do
+ _ <- s
+ _ <- x
+ y)
+ ]
+
+
+
diff --git a/src/Cryptol/Eval/What4/Float.hs b/src/Cryptol/Eval/What4/Float.hs
new file mode 100644
--- /dev/null
+++ b/src/Cryptol/Eval/What4/Float.hs
@@ -0,0 +1,68 @@
+{-# 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
new file mode 100644
--- /dev/null
+++ b/src/Cryptol/Eval/What4/SFloat.hs
@@ -0,0 +1,361 @@
+{-# 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
new file mode 100644
--- /dev/null
+++ b/src/Cryptol/Eval/What4/Value.hs
@@ -0,0 +1,975 @@
+-- |
+-- 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/IR/FreeVars.hs b/src/Cryptol/IR/FreeVars.hs
--- a/src/Cryptol/IR/FreeVars.hs
+++ b/src/Cryptol/IR/FreeVars.hs
@@ -9,9 +9,9 @@
import qualified Data.Set as Set
import Data.Map ( Map )
import qualified Data.Map as Map
-import Data.Semigroup (Semigroup(..))
import Cryptol.TypeCheck.AST
+import Cryptol.Utils.RecordMap
data Deps = Deps { valDeps :: Set Name
-- ^ Undefined value names
@@ -101,16 +101,12 @@
case expr of
EList es t -> freeVars es <> freeVars t
ETuple es -> freeVars es
- ERec fs -> freeVars (map snd fs)
+ ERec fs -> freeVars (recordElements fs)
ESel e _ -> freeVars e
ESet e _ v -> 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 fvsArm mss)
- where
- fvsArm = foldr mat mempty
- mat x rest = freeVars x <> rmVals (defs x) rest
-
+ <> mconcat (map foldFree mss)
EVar x -> mempty { valDeps = Set.singleton x }
ETAbs a e -> rmTParam a (freeVars e)
ETApp e t -> freeVars e <> freeVars t
@@ -118,8 +114,11 @@
EAbs x t e -> freeVars t <> rmVal x (freeVars e)
EProofAbs p e -> freeVars p <> freeVars e
EProofApp e -> freeVars e
- EWhere e ds -> freeVars ds <> rmVals (defs ds) (freeVars e)
-
+ EWhere e ds -> foldFree ds <> rmVals (defs ds) (freeVars e)
+ where
+ foldFree :: (FreeVars a, Defs a) => [a] -> Deps
+ foldFree = foldr updateFree mempty
+ updateFree x rest = freeVars x <> rmVals (defs x) rest
instance FreeVars Match where
freeVars m = case m of
@@ -139,7 +138,7 @@
TVar tv -> freeVars tv
TUser _ _ t -> freeVars t
- TRec fs -> freeVars (map snd fs)
+ TRec fs -> freeVars (recordElements fs)
instance FreeVars TVar where
@@ -178,6 +177,3 @@
defs m = case m of
From x _ _ _ -> Set.singleton x
Let d -> defs d
-
-
-
diff --git a/src/Cryptol/ModuleSystem.hs b/src/Cryptol/ModuleSystem.hs
--- a/src/Cryptol/ModuleSystem.hs
+++ b/src/Cryptol/ModuleSystem.hs
@@ -33,7 +33,7 @@
) where
import qualified Cryptol.Eval as E
-import qualified Cryptol.Eval.Value as E
+import qualified Cryptol.Eval.Concrete as Concrete
import Cryptol.ModuleSystem.Env
import Cryptol.ModuleSystem.Interface
import Cryptol.ModuleSystem.Monad
@@ -46,10 +46,11 @@
import qualified Cryptol.TypeCheck.AST as T
import qualified Cryptol.Utils.Ident as M
+import Data.ByteString (ByteString)
-- Public Interface ------------------------------------------------------------
-type ModuleCmd a = (E.EvalOpts,ModuleEnv) -> IO (ModuleRes a)
+type ModuleCmd a = (E.EvalOpts, FilePath -> IO ByteString, ModuleEnv) -> IO (ModuleRes a)
type ModuleRes a = (Either ModuleError (a,ModuleEnv), [ModuleWarning])
@@ -62,19 +63,21 @@
-- | Load the module contained in the given file.
loadModuleByPath :: FilePath -> ModuleCmd (ModulePath,T.Module)
-loadModuleByPath path (evo,env) = runModuleM (evo,resetModuleEnv env) $ do
- unloadModule ((InFile path ==) . lmFilePath)
- m <- Base.loadModuleByPath path
- setFocusedModule (T.mName m)
- return (InFile path,m)
+loadModuleByPath path (evo, byteReader, env) =
+ runModuleM (evo, byteReader, resetModuleEnv env) $ do
+ unloadModule ((InFile path ==) . lmFilePath)
+ m <- Base.loadModuleByPath path
+ setFocusedModule (T.mName m)
+ return (InFile path,m)
-- | Load the given parsed module.
loadModuleByName :: P.ModName -> ModuleCmd (ModulePath,T.Module)
-loadModuleByName n env = runModuleM env $ do
- unloadModule ((n ==) . lmName)
- (path,m') <- Base.loadModuleFrom (FromModule n)
- setFocusedModule (T.mName m')
- return (path,m')
+loadModuleByName n (evo, byteReader, env) =
+ runModuleM (evo, byteReader, resetModuleEnv env) $ do
+ unloadModule ((n ==) . lmName)
+ (path,m') <- Base.loadModuleFrom (FromModule n)
+ setFocusedModule (T.mName m')
+ return (path,m')
-- Extended Environments -------------------------------------------------------
@@ -88,7 +91,7 @@
checkExpr e env = runModuleM env (interactive (Base.checkExpr e))
-- | Evaluate an expression.
-evalExpr :: T.Expr -> ModuleCmd E.Value
+evalExpr :: T.Expr -> ModuleCmd Concrete.Value
evalExpr e env = runModuleM env (interactive (Base.evalExpr e))
-- | Typecheck top-level declarations.
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
@@ -9,12 +9,13 @@
-- This is the main driver---it provides entry points for the
-- various passes.
-{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ImplicitParams #-}
+{-# LANGUAGE RecordWildCards #-}
module Cryptol.ModuleSystem.Base where
-import Cryptol.ModuleSystem.Env (DynamicEnv(..), deIfaceDecls)
+import Cryptol.ModuleSystem.Env (DynamicEnv(..))
import Cryptol.ModuleSystem.Fingerprint
import Cryptol.ModuleSystem.Interface
import Cryptol.ModuleSystem.Monad
@@ -22,10 +23,12 @@
import Cryptol.ModuleSystem.Env (lookupModule
, LoadedModule(..)
, meCoreLint, CoreLint(..)
+ , ModContext(..)
, ModulePath(..), modulePathLabel)
import qualified Cryptol.Eval as E
-import qualified Cryptol.Eval.Value as E
-import Cryptol.Prims.Eval ()
+
+import qualified Cryptol.Eval.Concrete as Concrete
+import Cryptol.Eval.Concrete (Concrete(..))
import qualified Cryptol.ModuleSystem.NamingEnv as R
import qualified Cryptol.ModuleSystem.Renamer as R
import qualified Cryptol.Parser as P
@@ -39,20 +42,19 @@
import qualified Cryptol.TypeCheck.PP as T
import qualified Cryptol.TypeCheck.Sanity as TcSanity
import Cryptol.Transform.AddModParams (addModParams)
-import Cryptol.Utils.Ident (preludeName, interactiveName
+import Cryptol.Utils.Ident (preludeName, floatName, arrayName, interactiveName
, modNameChunks, notParamInstModName
, isParamInstModName )
import Cryptol.Utils.PP (pretty)
import Cryptol.Utils.Panic (panic)
import Cryptol.Utils.Logger(logPutStrLn, logPrint)
-import Cryptol.Prelude (preludeContents)
+import Cryptol.Prelude (preludeContents, floatContents, arrayContents)
import Cryptol.Transform.MonoValues (rewModule)
import qualified Control.Exception as X
import Control.Monad (unless,when)
-import qualified Data.ByteString as B
import Data.Maybe (fromMaybe)
import Data.Monoid ((<>))
import Data.Text.Encoding (decodeUtf8')
@@ -61,6 +63,7 @@
, isAbsolute
, joinPath
, ()
+ , normalise
, takeDirectory
, takeFileName
)
@@ -108,9 +111,10 @@
parseModule :: ModulePath -> ModuleM (Fingerprint, P.Module PName)
parseModule path = do
+ getBytes <- getByteReader
bytesRes <- case path of
- InFile p -> io (X.try (B.readFile p))
+ InFile p -> io (X.try (getBytes p))
InMem _ bs -> pure (Right bs)
bytes <- case bytesRes of
@@ -198,7 +202,8 @@
tcm <- optionalInstantiate =<< checkModule isrc path pm
-- extend the eval env, unless a functor.
- unless (T.isParametrizedModule tcm) $ modifyEvalEnv (E.moduleEnv tcm)
+ let ?evalPrim = Concrete.evalPrim
+ unless (T.isParametrizedModule tcm) $ modifyEvalEnv (E.moduleEnv Concrete tcm)
loadedModule path fp tcm
return tcm
@@ -254,6 +259,8 @@
handleNotFound =
case n of
m | m == preludeName -> pure (InMem "Cryptol" preludeContents)
+ | m == floatName -> pure (InMem "Float" floatContents)
+ | m == arrayName -> pure (InMem "Array" arrayContents)
_ -> moduleNotFound n =<< getSearchPath
-- generate all possible search paths
@@ -276,7 +283,7 @@
loop paths = case paths of
path':rest -> do
b <- io (doesFileExist path')
- if b then return path' else loop rest
+ if b then return (normalise path') else loop rest
[] -> cantFindFile path
possibleFiles paths = map ( path) paths
@@ -312,21 +319,15 @@
-- Type Checking ---------------------------------------------------------------
--- | Load the local environment, which consists of the environment for the
--- currently opened module, shadowed by the dynamic environment.
-getLocalEnv :: ModuleM (IfaceParams,IfaceDecls,R.NamingEnv)
-getLocalEnv =
- do (params,decls,fNames,_) <- getFocusedEnv
- denv <- getDynEnv
- let dynDecls = deIfaceDecls denv
- return (params,dynDecls `mappend` decls, deNames denv `R.shadowing` fNames)
-
-- | Typecheck a single expression, yielding a renamed parsed expression,
-- typechecked core expression, and a type schema.
checkExpr :: P.Expr PName -> ModuleM (P.Expr Name,T.Expr,T.Schema)
checkExpr e = do
- (params,decls,names) <- getLocalEnv
+ fe <- getFocusedEnv
+ let params = mctxParams fe
+ decls = mctxDecls fe
+ names = mctxNames fe
-- run NoPat
npe <- noPat e
@@ -347,7 +348,10 @@
-- INVARIANT: This assumes that NoPat has already been run on the declarations.
checkDecls :: [P.TopDecl PName] -> ModuleM (R.NamingEnv,[T.DeclGroup])
checkDecls ds = do
- (params,decls,names) <- getLocalEnv
+ fe <- getFocusedEnv
+ let params = mctxParams fe
+ decls = mctxDecls fe
+ names = mctxNames fe
-- introduce names for the declarations before renaming them
declsEnv <- liftSupply (R.namingEnv' (map (R.InModule interactiveName) ds))
@@ -366,8 +370,15 @@
getPrimMap :: ModuleM PrimMap
getPrimMap =
do env <- getModuleEnv
+ let mkPrims = ifacePrimMap . lmInterface
+ mp `alsoPrimFrom` m =
+ case lookupModule m env of
+ Nothing -> mp
+ Just lm -> mkPrims lm <> mp
+
case lookupModule preludeName env of
- Just lm -> return (ifacePrimMap (lmInterface lm))
+ Just prel -> return $ mkPrims prel
+ `alsoPrimFrom` floatName
Nothing -> panic "Cryptol.ModuleSystem.Base.getPrimMap"
[ "Unable to find the prelude" ]
@@ -401,7 +412,9 @@
-- this is a more-or-less obsolete feature, we are just not doing
-- ot for now.
e <- case path of
- InFile p -> io (removeIncludesModule p m)
+ InFile p -> do
+ r <- getByteReader
+ io (removeIncludesModule r p m)
InMem {} -> pure (Right m)
nim <- case e of
@@ -537,12 +550,13 @@
-- Evaluation ------------------------------------------------------------------
-evalExpr :: T.Expr -> ModuleM E.Value
+evalExpr :: T.Expr -> ModuleM Concrete.Value
evalExpr e = do
env <- getEvalEnv
denv <- getDynEnv
evopts <- getEvalOpts
- io $ E.runEval evopts $ (E.evalExpr (env <> deEnv denv) e)
+ let ?evalPrim = Concrete.evalPrim
+ io $ E.runEval evopts $ (E.evalExpr Concrete (env <> deEnv denv) e)
evalDecls :: [T.DeclGroup] -> ModuleM ()
evalDecls dgs = do
@@ -550,7 +564,8 @@
denv <- getDynEnv
evOpts <- getEvalOpts
let env' = env <> deEnv denv
- deEnv' <- io $ E.runEval evOpts $ E.evalDecls dgs env'
+ let ?evalPrim = Concrete.evalPrim
+ deEnv' <- io $ E.runEval evOpts $ E.evalDecls Concrete dgs env'
let denv' = denv { deDecls = deDecls denv ++ dgs
, deEnv = deEnv'
}
diff --git a/src/Cryptol/ModuleSystem/Env.hs b/src/Cryptol/ModuleSystem/Env.hs
--- a/src/Cryptol/ModuleSystem/Env.hs
+++ b/src/Cryptol/ModuleSystem/Env.hs
@@ -20,7 +20,7 @@
import Cryptol.Eval (EvalEnv)
import Cryptol.ModuleSystem.Fingerprint
import Cryptol.ModuleSystem.Interface
-import Cryptol.ModuleSystem.Name (Supply,emptySupply)
+import Cryptol.ModuleSystem.Name (Name,Supply,emptySupply)
import qualified Cryptol.ModuleSystem.NamingEnv as R
import Cryptol.Parser.AST
import qualified Cryptol.TypeCheck as T
@@ -31,8 +31,8 @@
import Control.Monad (guard,mplus)
import qualified Control.Exception as X
import Data.Function (on)
+import Data.Map (Map)
import qualified Data.Map as Map
-import Data.Maybe(fromMaybe)
import Data.Semigroup
import System.Directory (getAppUserDataDirectory, getCurrentDirectory)
import System.Environment(getExecutablePath)
@@ -45,6 +45,9 @@
import Prelude ()
import Prelude.Compat
+import Cryptol.Utils.Panic(panic)
+import Cryptol.Utils.PP(pp)
+
-- Module Environment ----------------------------------------------------------
-- | This is the current state of the interpreter.
@@ -88,7 +91,8 @@
} deriving Generic
-instance NFData ModuleEnv
+instance NFData ModuleEnv where
+ rnf x = meLoadedModules x `seq` meEvalEnv x `seq` meDynEnv x `seq` ()
-- | Should we run the linter?
data CoreLint = NoCoreLint -- ^ Don't run core lint
@@ -177,50 +181,99 @@
hasParamModules :: ModuleEnv -> Bool
hasParamModules = not . null . lmLoadedParamModules . meLoadedModules
+allDeclGroups :: ModuleEnv -> [T.DeclGroup]
+allDeclGroups = concatMap T.mDecls . loadedNonParamModules
--- | Produce an ifaceDecls that represents the focused environment of the module
--- system, as well as a 'NameDisp' for pretty-printing names according to the
--- imports.
---
--- XXX This could really do with some better error handling, just returning
--- mempty when one of the imports fails isn't really desirable.
---
--- XXX: This is not quite right. For example, it does not take into
--- account *how* things were imported in a module (e.g., qualified).
--- It would be simpler to simply store the naming environment that was
--- actually used when we renamed the module.
-focusedEnv :: ModuleEnv -> (IfaceParams,IfaceDecls,R.NamingEnv,NameDisp)
+-- | Contains enough information to browse what's in scope,
+-- or type check new expressions.
+data ModContext = ModContext
+ { mctxParams :: IfaceParams
+ , mctxDecls :: IfaceDecls
+ , mctxNames :: R.NamingEnv
+ , mctxNameDisp :: NameDisp
+ , mctxTypeProvenace :: Map Name DeclProvenance
+ , mctxValueProvenance :: Map Name DeclProvenance
+ }
+
+-- | Specifies how a declared name came to be in scope.
+data DeclProvenance =
+ NameIsImportedFrom ModName
+ | NameIsLocalPublic
+ | NameIsLocalPrivate
+ | NameIsParameter
+ | NameIsDynamicDecl
+ deriving (Eq,Ord)
+
+
+-- | Given the state of the environment, compute information about what's
+-- in scope on the REPL. This includes what's in the focused module, plus any
+-- additional definitions from the REPL (e.g., let bound names, and @it@).
+focusedEnv :: ModuleEnv -> ModContext
focusedEnv me =
- fromMaybe (noIfaceParams, mempty, mempty, mempty) $
- do fm <- meFocusedModule me
- lm <- lookupModule fm me
- deps <- mapM loadImport (T.mImports (lmModule lm))
- let (ifaces,names) = unzip deps
- Iface { .. } = lmInterface lm
- localDecls = ifPublic `mappend` ifPrivate
- localNames = R.unqualifiedEnv localDecls `mappend`
- R.modParamsNamingEnv ifParams
- namingEnv = localNames `R.shadowing` mconcat names
+ ModContext
+ { mctxParams = parameters
+ , mctxDecls = mconcat (dynDecls : localDecls : importedDecls)
+ , mctxNames = namingEnv
+ , mctxNameDisp = R.toNameDisp namingEnv
+ , mctxTypeProvenace = fst provenance
+ , mctxValueProvenance = snd provenance
+ }
- return ( ifParams
- , mconcat (localDecls:ifaces)
- , namingEnv
- , R.toNameDisp namingEnv)
where
+ (importedNames,importedDecls,importedProvs) = unzip3 (map loadImport imports)
+ localDecls = publicDecls `mappend` privateDecls
+ localNames = R.unqualifiedEnv localDecls `mappend`
+ R.modParamsNamingEnv parameters
+ dynDecls = deIfaceDecls (meDynEnv me)
+ dynNames = deNames (meDynEnv me)
+
+ namingEnv = dynNames `R.shadowing`
+ localNames `R.shadowing`
+ mconcat importedNames
+
+ provenance = shadowProvs
+ $ declsProv NameIsDynamicDecl dynDecls
+ : declsProv NameIsLocalPublic publicDecls
+ : declsProv NameIsLocalPrivate privateDecls
+ : paramProv parameters
+ : importedProvs
+
+ (imports, parameters, publicDecls, privateDecls) =
+ case meFocusedModule me of
+ Nothing -> (mempty, noIfaceParams, mempty, mempty)
+ Just fm ->
+ case lookupModule fm me of
+ Just lm ->
+ let Iface { .. } = lmInterface lm
+ in (T.mImports (lmModule lm), ifParams, ifPublic, ifPrivate)
+ Nothing -> panic "focusedEnv" ["Focused module is not loaded."]
+
loadImport imp =
- do lm <- lookupModule (iModule imp) me
- let decls = ifPublic (lmInterface lm)
- return (decls,R.interpImport imp decls)
+ case lookupModule (iModule imp) me of
+ Just lm ->
+ let decls = ifPublic (lmInterface lm)
+ in ( R.interpImport imp decls
+ , decls
+ , declsProv (NameIsImportedFrom (iModule imp)) decls
+ )
+ Nothing -> panic "focusedEnv"
+ [ "Missing imported module: " ++ show (pp (iModule imp)) ]
--- | The unqualified declarations and name environment for the dynamic
--- environment.
-dynamicEnv :: ModuleEnv -> (IfaceDecls,R.NamingEnv,NameDisp)
-dynamicEnv me = (decls,names,R.toNameDisp names)
- where
- decls = deIfaceDecls (meDynEnv me)
- names = R.unqualifiedEnv decls
+ -- earlier ones shadow
+ shadowProvs ps = let (tss,vss) = unzip ps
+ in (Map.unions tss, Map.unions vss)
+ paramProv IfaceParams { .. } = (doMap ifParamTypes, doMap ifParamFuns)
+ where doMap mp = const NameIsParameter <$> mp
+
+ declsProv prov IfaceDecls { .. } =
+ ( Map.unions [ doMap ifTySyns, doMap ifNewtypes, doMap ifAbstractTypes ]
+ , doMap ifDecls
+ )
+ where doMap mp = const prov <$> mp
+
+
-- Loaded Modules --------------------------------------------------------------
-- | The location of a module
@@ -281,14 +334,23 @@
data LoadedModule = LoadedModule
{ lmName :: ModName
+ -- ^ The name of this module. Should match what's in 'lmModule'
+
, lmFilePath :: ModulePath
-- ^ The file path used to load this module (may not be canonical)
+
, lmModuleId :: String
-- ^ An identifier used to identify the source of the bytes for the module.
-- For files we just use the cononical path, for in memory things we
-- use their label.
+
, lmInterface :: Iface
+ -- ^ The module's interface. This is for convenient. At the moment
+ -- we have the whole module in 'lmModule', so this could be computer.
+
, lmModule :: T.Module
+ -- ^ The actual type-checked module
+
, lmFingerprint :: Fingerprint
} deriving (Show, Generic, NFData)
@@ -328,6 +390,8 @@
}
-- | Remove a previously loaded module.
+-- Note that this removes exactly the modules specified by the predicate.
+-- One should be carfule to preserve the invariant on 'LoadedModules'.
removeLoadedModule :: (LoadedModule -> Bool) -> LoadedModules -> LoadedModules
removeLoadedModule rm lm =
LoadedModules
@@ -335,19 +399,17 @@
, lmLoadedParamModules = filter (not . rm) (lmLoadedParamModules lm)
}
-
-- Dynamic Environments --------------------------------------------------------
-- | Extra information we need to carry around to dynamically extend
-- an environment outside the context of a single module. Particularly
--- useful when dealing with interactive declarations as in @:let@ or
+-- useful when dealing with interactive declarations as in @let@ or
-- @it@.
-
data DynamicEnv = DEnv
{ deNames :: R.NamingEnv
, deDecls :: [T.DeclGroup]
, deEnv :: EvalEnv
- } deriving (Generic, NFData)
+ } deriving Generic
instance Semigroup DynamicEnv where
de1 <> de2 = DEnv
diff --git a/src/Cryptol/ModuleSystem/Exports.hs b/src/Cryptol/ModuleSystem/Exports.hs
--- a/src/Cryptol/ModuleSystem/Exports.hs
+++ b/src/Cryptol/ModuleSystem/Exports.hs
@@ -4,7 +4,6 @@
import Data.Set(Set)
import qualified Data.Set as Set
import Data.Foldable(fold)
-import Data.Semigroup (Semigroup(..))
import Control.DeepSeq(NFData)
import GHC.Generics (Generic)
diff --git a/src/Cryptol/ModuleSystem/Fingerprint.hs b/src/Cryptol/ModuleSystem/Fingerprint.hs
--- a/src/Cryptol/ModuleSystem/Fingerprint.hs
+++ b/src/Cryptol/ModuleSystem/Fingerprint.hs
@@ -15,7 +15,6 @@
import Control.DeepSeq (NFData (rnf))
import Crypto.Hash.SHA1 (hash)
import Data.ByteString (ByteString)
-import System.IO.Error (IOError)
import Control.Exception (try)
import qualified Data.ByteString as B
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
@@ -12,7 +12,6 @@
import Cryptol.Parser.Position(Located(..))
import Cryptol.ModuleSystem.Name
-import Cryptol.ModuleSystem.Exports(ExportSpec(..))
import Cryptol.TypeCheck.AST
import Cryptol.TypeCheck.Subst(listParamSubst, apSubst)
import Cryptol.Utils.Ident(ModName,modParamIdent)
@@ -185,7 +184,7 @@
EList xs t -> EList (inst env xs) (inst env t)
ETuple es -> ETuple (inst env es)
- ERec xs -> ERec [ (f,go e) | (f,e) <- xs ]
+ ERec xs -> ERec (fmap go xs)
ESel e s -> ESel (go e) s
ESet e x v -> ESet (go e) x (go v)
EIf e1 e2 e3 -> EIf (go e1) (go e2) (go e3)
@@ -241,7 +240,7 @@
_ -> ty
TUser x ts t -> TUser y (inst env ts) (inst env t)
where y = Map.findWithDefault x x (tyNameMap env)
- TRec fs -> TRec [ (f, inst env t) | (f,t) <- fs ]
+ TRec fs -> TRec (fmap (inst env) fs)
instance Inst TCon where
inst env tc =
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
@@ -27,6 +27,7 @@
import Cryptol.ModuleSystem.Name
import Cryptol.TypeCheck.AST
import Cryptol.Utils.Ident (ModName)
+import Cryptol.Utils.Panic(panic)
import Cryptol.Parser.Position(Located)
import qualified Data.Map as Map
@@ -177,6 +178,13 @@
, primTypes = Map.fromList (newtypes ++ types)
}
where
- exprs = [ (nameIdent n, n) | n <- Map.keys ifDecls ]
- newtypes = [ (nameIdent n, n) | n <- Map.keys ifNewtypes ]
- types = [ (nameIdent n, n) | n <- Map.keys ifTySyns ]
+ entry n = case asPrim n of
+ Just pid -> (pid,n)
+ Nothing ->
+ panic "ifaceDeclsPrimMap"
+ [ "Top level name not declared in a module?"
+ , show n ]
+
+ exprs = map entry (Map.keys ifDecls)
+ newtypes = map entry (Map.keys ifNewtypes)
+ types = map entry (Map.keys ifTySyns)
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
@@ -19,8 +19,7 @@
import Cryptol.ModuleSystem.Fingerprint
import Cryptol.ModuleSystem.Interface
import Cryptol.ModuleSystem.Name (FreshM(..),Supply)
-import Cryptol.ModuleSystem.Renamer
- (RenamerError(),RenamerWarning(),NamingEnv)
+import Cryptol.ModuleSystem.Renamer (RenamerError(),RenamerWarning())
import qualified Cryptol.Parser as Parser
import qualified Cryptol.Parser.AST as P
import Cryptol.Parser.Position (Located)
@@ -34,8 +33,10 @@
import Cryptol.Utils.PP
import Cryptol.Utils.Logger(Logger)
+import qualified Control.Monad.Fail as Fail
import Control.Monad.IO.Class
import Control.Exception (IOException)
+import Data.ByteString (ByteString)
import Data.Function (on)
import Data.Maybe (isJust)
import Data.Text.Encoding.Error (UnicodeException)
@@ -296,16 +297,21 @@
-- Module System Monad ---------------------------------------------------------
-data RO = RO { roLoading :: [ImportSource]
- , roEvalOpts :: EvalOpts
- }
+data RO m =
+ RO { roLoading :: [ImportSource]
+ , roEvalOpts :: EvalOpts
+ , roFileReader :: FilePath -> m ByteString
+ }
-emptyRO :: EvalOpts -> RO
-emptyRO ev = RO { roLoading = [], roEvalOpts = ev }
+emptyRO :: EvalOpts -> (FilePath -> m ByteString) -> RO m
+emptyRO ev fileReader =
+ RO { roLoading = [], roEvalOpts = ev, roFileReader = fileReader }
newtype ModuleT m a = ModuleT
- { unModuleT :: ReaderT RO (StateT ModuleEnv
- (ExceptionT ModuleError (WriterT [ModuleWarning] m))) a
+ { unModuleT :: ReaderT (RO m)
+ (StateT ModuleEnv
+ (ExceptionT ModuleError
+ (WriterT [ModuleWarning] m))) a
}
instance Monad m => Functor (ModuleT m) where
@@ -325,6 +331,8 @@
{-# INLINE (>>=) #-}
m >>= f = ModuleT (unModuleT m >>= unModuleT . f)
+
+instance Fail.MonadFail m => Fail.MonadFail (ModuleT m) where
{-# INLINE fail #-}
fail = ModuleT . raise . OtherFailure
@@ -343,27 +351,36 @@
liftIO m = lift $ liftIO m
runModuleT :: Monad m
- => (EvalOpts,ModuleEnv)
+ => (EvalOpts, FilePath -> m ByteString, ModuleEnv)
-> ModuleT m a
-> m (Either ModuleError (a, ModuleEnv), [ModuleWarning])
-runModuleT (ev,env) m =
+runModuleT (ev, byteReader, env) m =
runWriterT
$ runExceptionT
$ runStateT env
- $ runReaderT (emptyRO ev)
+ $ runReaderT (emptyRO ev byteReader)
$ unModuleT m
type ModuleM = ModuleT IO
-runModuleM :: (EvalOpts, ModuleEnv) -> ModuleM a
+runModuleM :: (EvalOpts, FilePath -> IO ByteString, ModuleEnv) -> ModuleM a
-> IO (Either ModuleError (a,ModuleEnv),[ModuleWarning])
runModuleM = runModuleT
-
io :: BaseM m IO => IO a -> ModuleT m a
io m = ModuleT (inBase m)
+getByteReader :: Monad m => ModuleT m (FilePath -> m ByteString)
+getByteReader = ModuleT $ do
+ RO { roFileReader = readFileBytes } <- ask
+ return readFileBytes
+
+readBytes :: Monad m => FilePath -> ModuleT m ByteString
+readBytes fn = do
+ fileReader <- getByteReader
+ ModuleT $ lift $ lift $ lift $ lift $ fileReader fn
+
getModuleEnv :: Monad m => ModuleT m ModuleEnv
getModuleEnv = ModuleT get
@@ -505,8 +522,7 @@
set $! env { meSearchPath = fps0 }
return x
--- XXX improve error handling here
-getFocusedEnv :: ModuleM (IfaceParams,IfaceDecls,NamingEnv,NameDisp)
+getFocusedEnv :: ModuleM ModContext
getFocusedEnv = ModuleT (focusedEnv `fmap` get)
getDynEnv :: ModuleM DynamicEnv
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
@@ -49,8 +49,8 @@
, lookupPrimType
) where
-import Cryptol.Parser.Fixity
import Cryptol.Parser.Position (Range,Located(..),emptyRange)
+import Cryptol.Utils.Fixity
import Cryptol.Utils.Ident
import Cryptol.Utils.Panic
import Cryptol.Utils.PP
@@ -179,9 +179,11 @@
Declared m _ -> withNameDisp $ \disp ->
case getNameFormat m nIdent disp of
- Qualified m' -> pp m' <.> text "::" <.> pp nIdent
- UnQualified -> pp nIdent
- NotInScope -> pp m <.> text "::" <.> pp nIdent
+ Qualified m' -> ppQual m' <.> pp nIdent
+ UnQualified -> pp nIdent
+ NotInScope -> ppQual m <.> pp nIdent -- XXX: only when not in scope?
+ where
+ ppQual mo = if mo == exprModName then empty else pp mo <.> text "::"
Parameter -> pp nIdent
@@ -189,7 +191,7 @@
ppPrec _ = ppPrefixName
instance PPName Name where
- ppNameFixity n = fmap (\(Fixity a i) -> (a,i)) $ nameFixity n
+ ppNameFixity n = nameFixity n
ppInfixName n @ Name { .. }
| isInfixIdent nIdent = ppName n
@@ -218,11 +220,11 @@
nameFixity = nFixity
-asPrim :: Name -> Maybe Ident
+asPrim :: Name -> Maybe PrimIdent
asPrim Name { .. } =
case nInfo of
- Declared p _ | p == preludeName -> Just nIdent
- _ -> Nothing
+ Declared p _ -> Just $ PrimIdent p $ identText nIdent
+ _ -> Nothing
toParamInstName :: Name -> Name
toParamInstName n =
@@ -347,11 +349,16 @@
-- Prim Maps -------------------------------------------------------------------
-- | A mapping from an identifier defined in some module to its real name.
-data PrimMap = PrimMap { primDecls :: Map.Map Ident Name
- , primTypes :: Map.Map Ident Name
+data PrimMap = PrimMap { primDecls :: Map.Map PrimIdent Name
+ , primTypes :: Map.Map PrimIdent Name
} deriving (Show, Generic, NFData)
-lookupPrimDecl, lookupPrimType :: Ident -> PrimMap -> Name
+instance Semigroup PrimMap where
+ x <> y = PrimMap { primDecls = Map.union (primDecls x) (primDecls y)
+ , primTypes = Map.union (primTypes x) (primTypes y)
+ }
+
+lookupPrimDecl, lookupPrimType :: PrimIdent -> PrimMap -> Name
-- | It's assumed that we're looking things up that we know already exist, so
-- this will panic if it doesn't find the name.
diff --git a/src/Cryptol/ModuleSystem/NamingEnv.hs b/src/Cryptol/ModuleSystem/NamingEnv.hs
--- a/src/Cryptol/ModuleSystem/NamingEnv.hs
+++ b/src/Cryptol/ModuleSystem/NamingEnv.hs
@@ -42,8 +42,8 @@
-- Naming Environment ----------------------------------------------------------
--- XXX The fixity environment should be removed, and Name should include fixity
--- information.
+-- | The 'NamingEnv' is used by the renamer to determine what
+-- identifiers refer to.
data NamingEnv = NamingEnv { neExprs :: !(Map.Map PName [Name])
-- ^ Expr renaming environment
, neTypes :: !(Map.Map PName [Name])
@@ -87,15 +87,20 @@
merge xs ys | xs == ys = xs
| otherwise = nub (xs ++ ys)
--- | Generate a mapping from 'Ident' to 'Name' for a given naming environment.
+-- | Generate a mapping from 'PrimIdent' to 'Name' for a
+-- given naming environment.
toPrimMap :: NamingEnv -> PrimMap
toPrimMap NamingEnv { .. } = PrimMap { .. }
where
- primDecls = Map.fromList [ (nameIdent n,n) | ns <- Map.elems neExprs
- , n <- ns ]
- primTypes = Map.fromList [ (nameIdent n,n) | ns <- Map.elems neTypes
- , n <- ns ]
+ entry n = case asPrim n of
+ Just p -> (p,n)
+ Nothing -> panic "toPrimMap" [ "Not a declared name?"
+ , show n
+ ]
+ primDecls = Map.fromList [ entry n | ns <- Map.elems neExprs, n <- ns ]
+ primTypes = Map.fromList [ entry n | ns <- Map.elems neTypes, n <- ns ]
+
-- | Generate a display format based on a naming environment.
toNameDisp :: NamingEnv -> NameDisp
toNameDisp NamingEnv { .. } = NameDisp display
@@ -105,19 +110,18 @@
-- only format declared names, as parameters don't need any special
-- formatting.
names = Map.fromList
- $ [ mkEntry pn mn (nameIdent n) | (pn,ns) <- Map.toList neExprs
- , n <- ns
- , Declared mn _ <- [nameInfo n] ]
+ $ [ mkEntry (mn, nameIdent n) pn | (pn,ns) <- Map.toList neExprs
+ , n <- ns
+ , Declared mn _ <- [nameInfo n] ]
- ++ [ mkEntry pn mn (nameIdent n) | (pn,ns) <- Map.toList neTypes
- , n <- ns
- , Declared mn _ <- [nameInfo n] ]
+ ++ [ mkEntry (mn, nameIdent n) pn | (pn,ns) <- Map.toList neTypes
+ , n <- ns
+ , Declared mn _ <- [nameInfo n] ]
- mkEntry pn mn i = ((mn,i),fmt)
- where
- fmt = case getModName pn of
- Just ns -> Qualified ns
- Nothing -> UnQualified
+ mkEntry key pn = (key,fmt)
+ where fmt = case getModName pn of
+ Just ns -> Qualified ns
+ Nothing -> UnQualified
-- | Produce sets of visible names for types and declarations.
@@ -137,7 +141,7 @@
qualify pfx NamingEnv { .. } =
NamingEnv { neExprs = Map.mapKeys toQual neExprs
, neTypes = Map.mapKeys toQual neTypes
- , .. }
+ }
where
-- XXX we don't currently qualify fresh names
@@ -149,7 +153,7 @@
filterNames p NamingEnv { .. } =
NamingEnv { neExprs = Map.filterWithKey check neExprs
, neTypes = Map.filterWithKey check neTypes
- , .. }
+ }
where
check :: PName -> a -> Bool
check n _ = p n
@@ -233,7 +237,9 @@
-- | Interpret an import in the context of an interface, to produce a name
-- environment for the renamer, and a 'NameDisp' for pretty-printing.
-interpImport :: Import -> IfaceDecls -> NamingEnv
+interpImport :: Import {- ^ The import declarations -} ->
+ IfaceDecls {- ^ Declarations of imported module -} ->
+ NamingEnv
interpImport imp publicDecls = qualified
where
diff --git a/src/Cryptol/ModuleSystem/Renamer.hs b/src/Cryptol/ModuleSystem/Renamer.hs
--- a/src/Cryptol/ModuleSystem/Renamer.hs
+++ b/src/Cryptol/ModuleSystem/Renamer.hs
@@ -36,14 +36,15 @@
import Cryptol.Parser.Selector(ppNestedSels,selName)
import Cryptol.Utils.Panic (panic)
import Cryptol.Utils.PP
+import Cryptol.Utils.RecordMap
import Data.List(find)
-import Data.Maybe (fromMaybe)
import qualified Data.Foldable as F
import Data.Map.Strict ( Map )
import qualified Data.Map.Strict as Map
import qualified Data.Sequence as Seq
import qualified Data.Semigroup as S
+import Data.Set (Set)
import qualified Data.Set as Set
import MonadLib hiding (mapM, mapM_)
@@ -179,6 +180,42 @@
hang (text "[warning] at" <+> pp (nameLoc x))
4 (text "Unused name:" <+> pp x)
+
+data RenamerWarnings = RenamerWarnings
+ { renWarnNameDisp :: !NameDisp
+ , renWarnShadow :: Map Name (Set Name)
+ , renWarnUnused :: Set Name
+ }
+
+noRenamerWarnings :: RenamerWarnings
+noRenamerWarnings = RenamerWarnings
+ { renWarnNameDisp = mempty
+ , renWarnShadow = Map.empty
+ , renWarnUnused = Set.empty
+ }
+
+addRenamerWarning :: RenamerWarning -> RenamerWarnings -> RenamerWarnings
+addRenamerWarning w ws =
+ case w of
+ SymbolShadowed x xs d ->
+ ws { renWarnNameDisp = renWarnNameDisp ws <> d
+ , renWarnShadow = Map.insertWith Set.union x (Set.fromList xs)
+ (renWarnShadow ws)
+ }
+ UnusedName x d ->
+ ws { renWarnNameDisp = renWarnNameDisp ws <> d
+ , renWarnUnused = Set.insert x (renWarnUnused ws)
+ }
+
+listRenamerWarnings :: RenamerWarnings -> [RenamerWarning]
+listRenamerWarnings ws =
+ [ mk (UnusedName x) | x <- Set.toList (renWarnUnused ws) ] ++
+ [ mk (SymbolShadowed x (Set.toList xs))
+ | (x,xs) <- Map.toList (renWarnShadow ws) ]
+ where
+ mk f = f (renWarnNameDisp ws)
+
+
-- Renaming Monad --------------------------------------------------------------
data RO = RO
@@ -189,7 +226,7 @@
}
data RW = RW
- { rwWarnings :: !(Seq.Seq RenamerWarning)
+ { rwWarnings :: !RenamerWarnings
, rwErrors :: !(Seq.Seq RenamerError)
, rwSupply :: !Supply
, rwNameUseCount :: !(Map Name Int)
@@ -197,6 +234,8 @@
-- Used to generate warnings for unused definitions.
}
+
+
newtype RenameM a = RenameM
{ unRenameM :: ReaderT RO (StateT RW Lift) a }
@@ -240,11 +279,14 @@
runRenamer :: Supply -> ModName -> NamingEnv -> RenameM a
-> (Either [RenamerError] (a,Supply),[RenamerWarning])
-runRenamer s ns env m = (res, warnUnused ns env ro rw ++ F.toList (rwWarnings rw))
+runRenamer s ns env m = (res, listRenamerWarnings warns)
where
+ warns = foldr addRenamerWarning (rwWarnings rw)
+ (warnUnused ns env ro rw)
+
(a,rw) = runM (unRenameM m) ro
RW { rwErrors = Seq.empty
- , rwWarnings = Seq.empty
+ , rwWarnings = noRenamerWarnings
, rwSupply = s
, rwNameUseCount = Map.empty
}
@@ -298,8 +340,7 @@
| CheckNone -- ^ Don't check the environment
deriving (Eq,Show)
--- | Shadow the current naming environment with some more names. The boolean
--- parameter indicates whether or not to check for shadowing.
+-- | Shadow the current naming environment with some more names.
shadowNames' :: BindsNames env => EnvCheck -> env -> RenameM a -> RenameM a
shadowNames' check names m = do
do env <- liftSupply (namingEnv' names)
@@ -337,7 +378,9 @@
if check == CheckAll
then case Map.lookup k (prj r) of
Nothing -> rwWarnings acc
- Just os -> rwWarnings acc Seq.|> SymbolShadowed (head ns) os disp
+ Just os -> addRenamerWarning
+ (SymbolShadowed (head ns) os disp)
+ (rwWarnings acc)
else rwWarnings acc
, rwErrors = rwErrors acc Seq.>< containsOverlap disp ns
@@ -565,95 +608,41 @@
rename (CType t) = CType <$> rename t
--- | Resolve fixity, then rename the resulting type.
instance Rename Type where
- rename ty0 = go =<< resolveTypeFixity ty0
- where
- go :: Type PName -> RenameM (Type Name)
- go (TFun a b) = TFun <$> go a <*> go b
- go (TSeq n a) = TSeq <$> go n <*> go a
- go TBit = return TBit
- go (TNum c) = return (TNum c)
- go (TChar c) = return (TChar c)
-
- go (TUser qn ps) = TUser <$> renameType qn <*> traverse go ps
- go (TRecord fs) = TRecord <$> traverse (rnNamed go) fs
- go (TTuple fs) = TTuple <$> traverse go fs
- go TWild = return TWild
- go (TLocated t' r) = withLoc r (TLocated <$> go t' <*> pure r)
-
- go (TParens t') = TParens <$> go t'
-
- -- at this point, the fixity is correct, and we just need to perform
- -- renaming.
- go (TInfix a o f b) = TInfix <$> rename a
- <*> rnLocated renameType o
- <*> pure f
- <*> rename b
-
-
-resolveTypeFixity :: Type PName -> RenameM (Type PName)
-resolveTypeFixity = go
- where
- go t = case t of
- TFun a b -> TFun <$> go a <*> go b
- TSeq n a -> TSeq <$> go n <*> go a
- TUser pn ps -> TUser pn <$> traverse go ps
- TRecord fs -> TRecord <$> traverse (traverse go) fs
- TTuple fs -> TTuple <$> traverse go fs
-
- TLocated t' r-> withLoc r (TLocated <$> go t' <*> pure r)
-
- TParens t' -> TParens <$> go t'
-
- TInfix a o _ b ->
- do op <- lookupFixity o
- a' <- go a
- b' <- go b
- mkTInfix a' op b'
-
- TBit -> return t
- TNum _ -> return t
- TChar _ -> return t
- TWild -> return t
-
-
-type TOp = Type PName -> Type PName -> Type PName
-
-mkTInfix :: Type PName -> (TOp,Fixity) -> Type PName -> RenameM (Type PName)
-
-mkTInfix t op@(o2,f2) z =
- case t of
- TLocated t1 _ -> mkTInfix t1 op z
- TInfix x ln f1 y ->
- doFixity (\a b -> TInfix a ln f1 b) f1 x y
-
- _ -> return (o2 t z)
-
- where
- doFixity mk f1 x y =
- case compareFixity f1 f2 of
- FCLeft -> return (o2 t z)
- FCRight -> do r <- mkTInfix y op z
- return (mk x r)
-
- -- As the fixity table is known, and this is a case where the fixity came
- -- from that table, it's a real error if the fixities didn't work out.
- FCError -> panic "Renamer" [ "fixity problem for type operators"
- , show (o2 t z) ]
+ rename ty0 =
+ case ty0 of
+ TFun a b -> TFun <$> rename a <*> rename b
+ TSeq n a -> TSeq <$> rename n <*> rename a
+ TBit -> return TBit
+ TNum c -> return (TNum c)
+ TChar c -> return (TChar c)
+ TUser qn ps -> TUser <$> renameType qn <*> traverse rename ps
+ TTyApp fs -> TTyApp <$> traverse (traverse rename) fs
+ TRecord fs -> TRecord <$> traverse (traverse rename) fs
+ TTuple fs -> TTuple <$> traverse rename fs
+ TWild -> return TWild
+ TLocated t' r -> withLoc r (TLocated <$> rename t' <*> pure r)
+ TParens t' -> TParens <$> rename t'
+ TInfix a o _ b -> do o' <- renameTypeOp o
+ a' <- rename a
+ b' <- rename b
+ mkTInfix a' o' b'
+mkTInfix :: Type Name -> (Located Name, Fixity) -> Type Name -> RenameM (Type Name)
+mkTInfix t@(TInfix x o1 f1 y) op@(o2,f2) z =
+ case compareFixity f1 f2 of
+ FCLeft -> return (TInfix t o2 f2 z)
+ FCRight -> do r <- mkTInfix y op z
+ return (TInfix x o1 f1 r)
+ FCError -> do record (FixityError o1 f1 o2 f2)
+ return (TInfix t o2 f2 z)
--- | When possible, rewrite the type operator to a known constructor, otherwise
--- return a 'TOp' that reconstructs the original term, and a default fixity.
-lookupFixity :: Located PName -> RenameM (TOp, Fixity)
-lookupFixity op =
- do n <- renameType sym
- let fi = fromMaybe defaultFixity (nameFixity n)
- return (\x y -> TInfix x op fi y, fi)
+mkTInfix (TLocated t' _) op z =
+ mkTInfix t' op z
- where
- sym = thing op
+mkTInfix t (o,f) z =
+ return (TInfix t o f z)
-- | Rename a binding.
@@ -683,7 +672,7 @@
PVar lv -> PVar <$> rnLocated renameVar lv
PWild -> pure PWild
PTuple ps -> PTuple <$> traverse rename ps
- PRecord nps -> PRecord <$> traverse (rnNamed rename) nps
+ PRecord nps -> PRecord <$> traverse (traverse rename) nps
PList elems -> PList <$> traverse rename elems
PTyped p' t -> PTyped <$> rename p' <*> rename t
PSplit l r -> PSplit <$> rename l <*> rename r
@@ -721,7 +710,7 @@
EGenerate e -> EGenerate
<$> rename e
ETuple es -> ETuple <$> traverse rename es
- ERecord fs -> ERecord <$> traverse (rnNamed rename) fs
+ ERecord fs -> ERecord <$> traverse (traverse rename) fs
ESel e' s -> ESel <$> rename e' <*> pure s
EUpd mb fs -> do checkLabels fs
EUpd <$> traverse rename mb <*> traverse rename fs
@@ -808,14 +797,26 @@
return (EInfix e o f z)
-renameOp :: Located PName -> RenameM (Located Name,Fixity)
-renameOp ln = withLoc ln $
- do n <- renameVar (thing ln)
- case nameFixity n of
- Just fixity -> return (ln { thing = n },fixity)
- Nothing -> return (ln { thing = n },defaultFixity)
+renameOp :: Located PName -> RenameM (Located Name, Fixity)
+renameOp ln =
+ withLoc ln $
+ do n <- renameVar (thing ln)
+ fixity <- lookupFixity n
+ return (ln { thing = n }, fixity)
+renameTypeOp :: Located PName -> RenameM (Located Name, Fixity)
+renameTypeOp ln =
+ withLoc ln $
+ do n <- renameType (thing ln)
+ fixity <- lookupFixity n
+ return (ln { thing = n }, fixity)
+lookupFixity :: Name -> RenameM Fixity
+lookupFixity n =
+ case nameFixity n of
+ Just fixity -> return fixity
+ Nothing -> return defaultFixity -- FIXME: should we raise an error instead?
+
instance Rename TypeInst where
rename ti = case ti of
NamedInst nty -> NamedInst <$> traverse rename nty
@@ -886,7 +887,7 @@
go PWild = return mempty
go (PTuple ps) = bindVars ps
- go (PRecord fs) = bindVars (map value fs)
+ go (PRecord fs) = bindVars (fmap snd (recordElements fs))
go (PList ps) = foldMap go ps
go (PTyped p ty) = go p `mappend` typeEnv ty
go (PSplit a b) = go a `mappend` go b
@@ -931,7 +932,8 @@
n <- liftSupply (mkParameter (getIdent pn) loc)
return (singletonT pn n)
- typeEnv (TRecord fs) = bindTypes (map value fs)
+ typeEnv (TRecord fs) = bindTypes (map snd (recordElements fs))
+ typeEnv (TTyApp fs) = bindTypes (map value fs)
typeEnv (TTuple ts) = bindTypes ts
typeEnv TWild = return mempty
typeEnv (TLocated ty loc) = withLoc loc (typeEnv ty)
diff --git a/src/Cryptol/Parser.y b/src/Cryptol/Parser.y
--- a/src/Cryptol/Parser.y
+++ b/src/Cryptol/Parser.y
@@ -52,6 +52,7 @@
%token
NUM { $$@(Located _ (Token (Num {}) _))}
+ FRAC { $$@(Located _ (Token (Frac {}) _))}
STRLIT { $$@(Located _ (Token (StrLit {}) _))}
CHARLIT { $$@(Located _ (Token (ChrLit {}) _))}
@@ -483,15 +484,18 @@
: qname { at $1 $ EVar (thing $1) }
| NUM { at $1 $ numLit (tokenType (thing $1)) }
+ | FRAC { at $1 $ fracLit (tokenType (thing $1)) }
| STRLIT { at $1 $ ELit $ ECString $ getStr $1 }
- | CHARLIT { at $1 $ ELit $ ECNum (getNum $1) CharLit }
+ | CHARLIT { at $1 $ ELit $ ECChar $ getChr $1 }
| '_' { at $1 $ EVar $ mkUnqual $ mkIdent "_" }
| '(' expr ')' { at ($1,$3) $ EParens $2 }
| '(' tuple_exprs ')' { at ($1,$3) $ ETuple (reverse $2) }
| '(' ')' { at ($1,$2) $ ETuple [] }
- | '{' '}' { at ($1,$2) $ ERecord [] }
- | '{' rec_expr '}' { at ($1,$3) $2 }
+ | '{' '}' {% mkRecord (rComb $1 $2) ERecord [] }
+ | '{' rec_expr '}' {% case $2 of {
+ Left upd -> pure $ at ($1,$3) upd;
+ Right fs -> mkRecord (rComb $1 $3) ERecord fs; }}
| '[' ']' { at ($1,$2) $ EList [] }
| '[' list_expr ']' { at ($1,$3) $2 }
| '`' tick_ty { at ($1,$2) $ ETypeVal $2 }
@@ -525,11 +529,10 @@
| tuple_exprs ',' expr { $3 : $1 }
-rec_expr :: { Expr PName }
- : aexpr '|' field_exprs { EUpd (Just $1) (reverse $3) }
- | '_' '|' field_exprs { EUpd Nothing (reverse $3) }
- | field_exprs {% do { xs <- mapM ufToNamed $1;
- pure (ERecord (reverse xs)) } }
+rec_expr :: { Either (Expr PName) [Named (Expr PName)] }
+ : aexpr '|' field_exprs { Left (EUpd (Just $1) (reverse $3)) }
+ | '_' '|' 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 }
@@ -598,8 +601,8 @@
| '[' ']' { at ($1,$2) $ PList [] }
| '[' pat ']' { at ($1,$3) $ PList [$2] }
| '[' tuple_pats ']' { at ($1,$3) $ PList (reverse $2) }
- | '{' '}' { at ($1,$2) $ PRecord [] }
- | '{' field_pats '}' { at ($1,$3) $ PRecord (reverse $2) }
+ | '{' '}' {% mkRecord (rComb $1 $2) PRecord [] }
+ | '{' field_pats '}' {% mkRecord (rComb $1 $3) PRecord $2 }
tuple_pats :: { [Pattern PName] }
: pat ',' pat { [$3, $1] }
@@ -672,14 +675,13 @@
: qname { at $1 $ TUser (thing $1) [] }
| '(' qop ')' { at $1 $ TUser (thing $2) [] }
| NUM { at $1 $ TNum (getNum $1) }
- | CHARLIT { at $1 $ TChar (toEnum $ fromInteger
- $ getNum $1) }
+ | CHARLIT { at $1 $ TChar (getChr $1) }
| '[' type ']' { at ($1,$3) $ TSeq $2 TBit }
| '(' type ')' { at ($1,$3) $ TParens $2 }
| '(' ')' { at ($1,$2) $ TTuple [] }
| '(' tuple_types ')' { at ($1,$3) $ TTuple (reverse $2) }
- | '{' '}' { at ($1,$2) $ TRecord [] }
- | '{' field_types '}' { at ($1,$3) $ TRecord (reverse $2) }
+ | '{' '}' {% mkRecord (rComb $1 $2) TRecord [] }
+ | '{' field_types '}' {% mkRecord (rComb $1 $3) TRecord $2 }
| '_' { at $1 TWild }
atypes :: { [ Type PName ] }
@@ -737,16 +739,15 @@
| '(' qop ')' { $2 }
{- The types that can come after a back-tick: either a type demotion,
-or an explicit type application. Explicit type applications are converted
-to records, which cannot be demoted. -}
+or an explicit type application. -}
tick_ty :: { Type PName }
: qname { at $1 $ TUser (thing $1) [] }
| NUM { at $1 $ TNum (getNum $1) }
| '(' type ')' {% validDemotedType (rComb $1 $3) $2 }
- | '{' '}' { at ($1,$2) (TRecord []) }
- | '{' field_ty_vals '}' { at ($1,$3) (TRecord (reverse $2)) }
- | '{' type '}' { anonRecord (getLoc ($1,$3)) [$2] }
- | '{' tuple_types '}' { anonRecord (getLoc ($1,$3)) (reverse $2) }
+ | '{' '}' { at ($1,$2) (TTyApp []) }
+ | '{' field_ty_vals '}' { at ($1,$3) (TTyApp (reverse $2)) }
+ | '{' type '}' { anonTyApp (getLoc ($1,$3)) [$2] }
+ | '{' tuple_types '}' { anonTyApp (getLoc ($1,$3)) (reverse $2) }
-- This for explicit type applications (e.g., f ` { front = 3 })
field_ty_val :: { Named (Type PName) }
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
@@ -61,7 +61,7 @@
-- * Expressions
, Expr(..)
- , Literal(..), NumInfo(..)
+ , Literal(..), NumInfo(..), FracInfo(..)
, Match(..)
, Pattern(..)
, Selector(..)
@@ -78,17 +78,19 @@
, cppKind, ppSelector
) where
-import Cryptol.Parser.Fixity
import Cryptol.Parser.Name
import Cryptol.Parser.Position
import Cryptol.Parser.Selector
+import Cryptol.Utils.Fixity
import Cryptol.Utils.Ident
+import Cryptol.Utils.RecordMap
import Cryptol.Utils.PP
import Data.List(intersperse)
import Data.Bits(shiftR)
import Data.Maybe (catMaybes)
-import Numeric(showIntAtBase)
+import Data.Ratio(numerator,denominator)
+import Numeric(showIntAtBase,showFloat,showHFloat)
import GHC.Generics (Generic)
import Control.DeepSeq
@@ -107,6 +109,8 @@
-- | A string with location information.
type LString = Located String
+-- | A record with located ident fields
+type Rec e = RecordMap Ident (Range, e)
newtype Program name = Program [TopDecl name]
deriving (Show)
@@ -277,12 +281,20 @@
| OctLit Int -- ^ n-digit octal literal
| DecLit -- ^ overloaded decimal literal
| HexLit Int -- ^ n-digit hex literal
- | CharLit -- ^ character literal
| PolyLit Int -- ^ polynomial literal
deriving (Eq, Show, Generic, NFData)
+-- | Information about fractional literals.
+data FracInfo = BinFrac
+ | OctFrac
+ | DecFrac
+ | HexFrac
+ deriving (Eq,Show,Generic,NFData)
+
-- | Literals.
data Literal = ECNum Integer NumInfo -- ^ @0x10@ (HexLit 2)
+ | ECChar Char -- ^ @'a'@
+ | ECFrac Rational FracInfo -- ^ @1.2e3@
| ECString String -- ^ @\"hello\"@
deriving (Eq, Show, Generic, NFData)
@@ -292,7 +304,7 @@
| EComplement (Expr n) -- ^ @ ~1 @
| EGenerate (Expr n) -- ^ @ generate f @
| ETuple [Expr n] -- ^ @ (1,2,3) @
- | ERecord [Named (Expr n)] -- ^ @ { x = 1, y = 2 } @
+ | ERecord (Rec (Expr n)) -- ^ @ { x = 1, y = 2 } @
| ESel (Expr n) Selector -- ^ @ e.l @
| EUpd (Maybe (Expr n)) [ UpdField n ] -- ^ @ { r | x = e } @
| EList [Expr n] -- ^ @ [1,2,3] @
@@ -332,7 +344,7 @@
data Pattern n = PVar (Located n) -- ^ @ x @
| PWild -- ^ @ _ @
| PTuple [Pattern n] -- ^ @ (x,y,z) @
- | PRecord [ Named (Pattern n) ] -- ^ @ { x = (a,b,c), y = z } @
+ | PRecord (Rec (Pattern n)) -- ^ @ { x = (a,b,c), y = z } @
| PList [ Pattern n ] -- ^ @ [ x, y, z ] @
| PTyped (Pattern n) (Type n) -- ^ @ x : [8] @
| PSplit (Pattern n) (Pattern n)-- ^ @ (x # y) @
@@ -360,7 +372,8 @@
| TNum Integer -- ^ @10@
| TChar Char -- ^ @'a'@
| TUser n [Type n] -- ^ A type variable or synonym
- | TRecord [Named (Type n)]-- ^ @{ x : [8], y : [32] }@
+ | TTyApp [Named (Type n)] -- ^ @`{ x = [8], y = Integer }@
+ | TRecord (Rec (Type n)) -- ^ @{ x : [8], y : [32] }@
| TTuple [Type n] -- ^ @([8], [32])@
| TWild -- ^ @_@, just some type.
| TLocated (Type n) Range -- ^ Location information
@@ -500,6 +513,8 @@
ppNamed :: PP a => String -> Named a -> Doc
ppNamed s x = ppL (name x) <+> text s <+> pp (value x)
+ppNamed' :: PP a => String -> (Ident, (Range, a)) -> Doc
+ppNamed' s (i,(_,v)) = pp i <+> text s <+> pp v
instance (Show name, PPName name) => PP (Module name) where
ppPrec _ m = text "module" <+> ppL (mName m) <+> text "where"
@@ -623,14 +638,29 @@
ppPrec _ lit =
case lit of
ECNum n i -> ppNumLit n i
+ ECChar c -> text (show c)
+ ECFrac n i -> ppFracLit n i
ECString s -> text (show s)
+ppFracLit :: Rational -> FracInfo -> Doc
+ppFracLit x i
+ | toRational dbl == x =
+ case i of
+ BinFrac -> frac
+ OctFrac -> frac
+ DecFrac -> text (showFloat dbl "")
+ HexFrac -> text (showHFloat dbl "")
+ | otherwise = frac
+ where
+ dbl = fromRational x :: Double
+ frac = "fraction`" <.> braces
+ (commaSep (map integer [ numerator x, denominator x ]))
+
ppNumLit :: Integer -> NumInfo -> Doc
ppNumLit n info =
case info of
DecLit -> integer n
- CharLit -> text (show (toEnum (fromInteger n) :: Char))
BinLit w -> pad 2 "0b" w
OctLit w -> pad 8 "0o" w
HexLit w -> pad 16 "0x" w
@@ -695,7 +725,7 @@
EGenerate x -> wrap n 3 (text "generate" <+> ppPrec 4 x)
ETuple es -> parens (commaSep (map pp es))
- ERecord fs -> braces (commaSep (map (ppNamed "=") fs))
+ ERecord fs -> braces (commaSep (map (ppNamed' "=") (displayFields fs)))
EList es -> brackets (commaSep (map pp es))
EFromTo e1 e2 e3 t1 -> brackets (pp e1 <.> step <+> text ".." <+> end)
where step = maybe empty (\e -> comma <+> pp e) e2
@@ -743,7 +773,7 @@
EInfix e1 op _ e2 -> wrap n 0 (pp e1 <+> ppInfixName (thing op) <+> pp e2)
where
isInfix (EApp (EApp (EVar ieOp) ieLeft) ieRight) = do
- (ieAssoc,iePrec) <- ppNameFixity ieOp
+ ieFixity <- ppNameFixity ieOp
return Infix { .. }
isInfix _ = Nothing
@@ -761,7 +791,7 @@
PVar x -> pp (thing x)
PWild -> char '_'
PTuple ps -> parens (commaSep (map pp ps))
- PRecord fs -> braces (commaSep (map (ppNamed "=") fs))
+ PRecord fs -> braces (commaSep (map (ppNamed' "=") (displayFields fs)))
PList ps -> brackets (commaSep (map pp ps))
PTyped p t -> wrap n 0 (ppPrec 1 p <+> text ":" <+> pp t)
PSplit p1 p2 -> wrap n 1 (ppPrec 1 p1 <+> text "#" <+> ppPrec 1 p2)
@@ -807,7 +837,8 @@
case ty of
TWild -> text "_"
TTuple ts -> parens $ commaSep $ map pp ts
- TRecord fs -> braces $ commaSep $ map (ppNamed ":") fs
+ TTyApp fs -> braces $ commaSep $ map (ppNamed " = ") fs
+ TRecord fs -> braces $ commaSep $ map (ppNamed' ":") (displayFields fs)
TBit -> text "Bit"
TNum x -> integer x
TChar x -> text (show x)
@@ -849,8 +880,13 @@
instance NoPos t => NoPos (Named t) where
noPos t = Named { name = noPos (name t), value = noPos (value t) }
+instance NoPos Range where
+ noPos _ = Range { from = Position 0 0, to = Position 0 0, source = "" }
+
instance NoPos t => NoPos [t] where noPos = fmap noPos
instance NoPos t => NoPos (Maybe t) where noPos = fmap noPos
+instance (NoPos a, NoPos b) => NoPos (a,b) where
+ noPos (a,b) = (noPos a, noPos b)
instance NoPos (Program name) where
noPos (Program x) = Program (noPos x)
@@ -936,7 +972,7 @@
EComplement x -> EComplement (noPos x)
EGenerate x -> EGenerate (noPos x)
ETuple x -> ETuple (noPos x)
- ERecord x -> ERecord (noPos x)
+ ERecord x -> ERecord (fmap noPos x)
ESel x y -> ESel (noPos x) y
EUpd x y -> EUpd (noPos x) (noPos y)
EList x -> EList (noPos x)
@@ -973,7 +1009,7 @@
PVar x -> PVar (noPos x)
PWild -> PWild
PTuple x -> PTuple (noPos x)
- PRecord x -> PRecord (noPos x)
+ PRecord x -> PRecord (fmap noPos x)
PList x -> PList (noPos x)
PTyped x y -> PTyped (noPos x) (noPos y)
PSplit x y -> PSplit (noPos x) (noPos y)
@@ -990,7 +1026,8 @@
case ty of
TWild -> TWild
TUser x y -> TUser x (noPos y)
- TRecord x -> TRecord (noPos x)
+ TTyApp x -> TTyApp (noPos x)
+ TRecord x -> TRecord (fmap noPos x)
TTuple x -> TTuple (noPos x)
TFun x y -> TFun (noPos x) (noPos y)
TSeq x y -> TSeq (noPos x) (noPos y)
diff --git a/src/Cryptol/Parser/Fixity.hs b/src/Cryptol/Parser/Fixity.hs
deleted file mode 100644
--- a/src/Cryptol/Parser/Fixity.hs
+++ /dev/null
@@ -1,50 +0,0 @@
--- |
--- Module : Cryptol.Parser.Fixity
--- Copyright : (c) 2013-2016 Galois, Inc.
--- License : BSD3
--- Maintainer : cryptol@galois.com
--- Stability : provisional
--- Portability : portable
-
-{-# LANGUAGE Safe #-}
-
-{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DeriveGeneric #-}
-module Cryptol.Parser.Fixity
- ( Fixity(..)
- , defaultFixity
- , FixityCmp(..)
- , compareFixity
- ) where
-
-import Cryptol.Utils.PP
-
-import GHC.Generics (Generic)
-import Control.DeepSeq
-
-data Fixity = Fixity { fAssoc :: !Assoc
- , fLevel :: !Int
- } deriving (Eq, Generic, NFData, Show)
-
-data FixityCmp = FCError
- | FCLeft
- | FCRight
- deriving (Show, Eq)
-
-compareFixity :: Fixity -> Fixity -> FixityCmp
-compareFixity (Fixity a1 p1) (Fixity a2 p2) =
- case compare p1 p2 of
- GT -> FCLeft
- LT -> FCRight
- EQ -> case (a1, a2) of
- (LeftAssoc, LeftAssoc) -> FCLeft
- (RightAssoc, RightAssoc) -> FCRight
- _ -> FCError
-
--- | The fixity used when none is provided.
-defaultFixity :: Fixity
-defaultFixity = Fixity LeftAssoc 100
-
-instance PP Fixity where
- ppPrec _ (Fixity assoc level) =
- text "precedence" <+> int level <.> comma <+> pp assoc
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,10 +45,17 @@
@qual_id = @qual @id
@qual_op = @qual @op
-@num2 = "0b" (_*[0-1])+
-@num8 = "0o" (_*[0-7])+
+@digits2 = (_*[0-1])+
+@digits8 = (_*[0-7])+
+@digits16 = (_*[0-9A-Fa-f])+
+@num2 = "0b" @digits2
+@num8 = "0o" @digits8
@num10 = [0-9](_*[0-9])*
-@num16 = "0x" (_*[0-9A-Fa-f])+
+@num16 = "0x" @digits16
+@fnum2 = @num2 "." @digits2 ([pP] [\+\-]? @num10)?
+@fnum8 = @num8 "." @digits8 ([pP] [\+\-]? @num10)?
+@fnum10 = @num10 "." @num10 ([eE] [\+\-]? @num10)?
+@fnum16 = @num16 "." @digits16 ([pP] [\+\-]? @num10)?
@strPart = [^\\\"]+
@chrPart = [^\\\']+
@@ -127,6 +134,12 @@
@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) }
+
+
"_" { emit $ Sym Underscore }
@id { mkIdent }
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
@@ -213,11 +213,11 @@
--------------------------------------------------------------------------------
-numToken :: Integer -> Text -> TokenT
-numToken rad ds = Num (toVal ds') (fromInteger rad) (T.length ds')
+numToken :: Int {- ^ base -} -> Text -> TokenT
+numToken rad ds = Num (toVal ds') rad (T.length ds')
where
ds' = T.filter (/= '_') ds
- toVal = T.foldl' (\x c -> rad * x + fromDigit c) 0
+ toVal = T.foldl' (\x c -> toInteger rad * x + fromDigit c) 0
fromDigit :: Char -> Integer
fromDigit x'
@@ -225,6 +225,40 @@
| otherwise = toInteger (fromEnum x - fromEnum '0')
where x = toLower x'
+
+-- 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
+ where
+ radI = fromIntegral rad :: Integer
+ radR = fromIntegral rad :: Rational
+
+ (whole,rest) = T.break (== '.') 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)
+
+
+ wholenNum = fromInteger
+ $ T.foldl' (\x c -> radI * x + fromDigit c) 0
+ $ digits whole
+
+ fracNum = T.foldl' (\x c -> (x + fromInteger (fromDigit c)) / radR) 0
+ $ T.reverse $ digits frac
+
+ expNum = case T.uncons mbExp of
+ Nothing -> 0 :: Integer
+ Just (_,es) ->
+ case T.uncons es of
+ Just ('+', more) -> read $ T.unpack more
+ _ -> read $ T.unpack es
+
+ eBase = if rad == 10 then 10 else 2 :: Rational
+
+
+
-------------------------------------------------------------------------------
data AlexInput = Inp { alexPos :: !Position
@@ -431,6 +465,7 @@
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
diff --git a/src/Cryptol/Parser/Name.hs b/src/Cryptol/Parser/Name.hs
--- a/src/Cryptol/Parser/Name.hs
+++ b/src/Cryptol/Parser/Name.hs
@@ -10,6 +10,7 @@
module Cryptol.Parser.Name where
+import Cryptol.Utils.Fixity
import Cryptol.Utils.Ident
import Cryptol.Utils.PP
import Cryptol.Utils.Panic (panic)
@@ -67,7 +68,7 @@
instance PPName PName where
ppNameFixity n
- | isInfixIdent i = Just (NonAssoc, 0) -- FIXME?
+ | isInfixIdent i = Just (Fixity NonAssoc 0) -- FIXME?
| otherwise = Nothing
where
i = getIdent n
diff --git a/src/Cryptol/Parser/Names.hs b/src/Cryptol/Parser/Names.hs
--- a/src/Cryptol/Parser/Names.hs
+++ b/src/Cryptol/Parser/Names.hs
@@ -12,6 +12,7 @@
module Cryptol.Parser.Names where
import Cryptol.Parser.AST
+import Cryptol.Utils.RecordMap
import Data.Set (Set)
import qualified Data.Set as Set
@@ -77,7 +78,7 @@
EComplement e -> namesE e
EGenerate e -> namesE e
ETuple es -> Set.unions (map namesE es)
- ERecord fs -> Set.unions (map (namesE . value) fs)
+ ERecord fs -> Set.unions (map (namesE . snd) (recordElements fs))
ESel e _ -> namesE e
EUpd mb fs -> let e = maybe Set.empty namesE mb
in Set.unions (e : map namesUF fs)
@@ -115,7 +116,7 @@
PVar x -> [x]
PWild -> []
PTuple ps -> namesPs ps
- PRecord fs -> namesPs (map value fs)
+ PRecord fs -> namesPs (map snd (recordElements fs))
PList ps -> namesPs ps
PTyped p _ -> namesP p
PSplit p1 p2 -> namesPs [p1,p2]
@@ -193,7 +194,7 @@
EComplement e -> tnamesE e
EGenerate e -> tnamesE e
ETuple es -> Set.unions (map tnamesE es)
- ERecord fs -> Set.unions (map (tnamesE . value) fs)
+ ERecord fs -> Set.unions (map (tnamesE . snd) (recordElements fs))
ESel e _ -> tnamesE e
EUpd mb fs -> let e = maybe Set.empty tnamesE mb
in Set.unions (e : map tnamesUF fs)
@@ -232,7 +233,7 @@
PVar _ -> Set.empty
PWild -> Set.empty
PTuple ps -> Set.unions (map tnamesP ps)
- PRecord fs -> Set.unions (map (tnamesP . value) fs)
+ PRecord fs -> Set.unions (map (tnamesP . snd) (recordElements fs))
PList ps -> Set.unions (map tnamesP ps)
PTyped p t -> Set.union (tnamesP p) (tnamesT t)
PSplit p1 p2 -> Set.union (tnamesP p1) (tnamesP p2)
@@ -266,7 +267,8 @@
TNum _ -> Set.empty
TChar __ -> Set.empty
TTuple ts -> Set.unions (map tnamesT ts)
- TRecord fs -> Set.unions (map (tnamesT . value) fs)
+ TRecord fs -> Set.unions (map (tnamesT . snd) (recordElements fs))
+ TTyApp fs -> Set.unions (map (tnamesT . value) fs)
TLocated t _ -> tnamesT t
TUser x ts -> Set.insert x (Set.unions (map tnamesT ts))
TParens t -> tnamesT t
diff --git a/src/Cryptol/Parser/NoInclude.hs b/src/Cryptol/Parser/NoInclude.hs
--- a/src/Cryptol/Parser/NoInclude.hs
+++ b/src/Cryptol/Parser/NoInclude.hs
@@ -17,9 +17,13 @@
import qualified Control.Applicative as A
import Control.DeepSeq
import qualified Control.Exception as X
+import qualified Control.Monad.Fail as Fail
+
+import Data.ByteString (ByteString)
import Data.Either (partitionEithers)
import Data.Text(Text)
-import qualified Data.Text.IO as T
+import qualified Data.Text.Encoding as T (decodeUtf8')
+import Data.Text.Encoding.Error (UnicodeException)
import GHC.Generics (Generic)
import MonadLib
import System.Directory (makeAbsolute)
@@ -32,11 +36,16 @@
import Cryptol.Parser.Unlit (guessPreProc)
import Cryptol.Utils.PP
-removeIncludesModule :: FilePath -> Module PName -> IO (Either [IncludeError] (Module PName))
-removeIncludesModule modPath m = runNoIncM modPath (noIncludeModule m)
+removeIncludesModule ::
+ (FilePath -> IO ByteString) ->
+ FilePath ->
+ Module PName ->
+ IO (Either [IncludeError] (Module PName))
+removeIncludesModule reader modPath m = runNoIncM reader modPath (noIncludeModule m)
data IncludeError
= IncludeFailed (Located FilePath)
+ | IncludeDecodeFailed (Located FilePath) UnicodeException
| IncludeParseError ParseError
| IncludeCycle [Located FilePath]
deriving (Show, Generic, NFData)
@@ -49,6 +58,13 @@
<+> pp (srcRange lp)
<+> text "was not found"
+ IncludeDecodeFailed lp err -> (char '`' <.> text (thing lp) <.> char '`')
+ <+> text "included at"
+ <+> pp (srcRange lp)
+ <+> text "contains invalid UTF-8."
+ <+> text "Details:"
+ $$ nest 2 (vcat (map text (lines (X.displayException err))))
+
IncludeParseError pe -> ppError pe
IncludeCycle is -> text "includes form a cycle:"
@@ -58,16 +74,18 @@
newtype NoIncM a = M
{ unM :: ReaderT Env (ExceptionT [IncludeError] IO) a }
-data Env = Env { envSeen :: [Located FilePath]
+data Env = Env { envSeen :: [Located FilePath]
-- ^ Files that have been loaded
- , envIncPath :: FilePath
+ , envIncPath :: FilePath
-- ^ The path that includes are relative to
+ , envFileReader :: FilePath -> IO ByteString
+ -- ^ How to load files
}
-runNoIncM :: FilePath -> NoIncM a -> IO (Either [IncludeError] a)
-runNoIncM sourcePath m =
+runNoIncM :: (FilePath -> IO ByteString) -> FilePath -> NoIncM a -> IO (Either [IncludeError] a)
+runNoIncM reader sourcePath m =
do incPath <- getIncPath sourcePath
- runM (unM m) Env { envSeen = [], envIncPath = incPath }
+ runM (unM m) Env { envSeen = [], envIncPath = incPath, envFileReader = reader }
tryNoIncM :: NoIncM a -> NoIncM (Either [IncludeError] a)
tryNoIncM m = M (try (unM m))
@@ -104,8 +122,10 @@
instance Monad NoIncM where
return x = M (return x)
m >>= f = M (unM m >>= unM . f)
- fail x = M (fail x)
+instance Fail.MonadFail NoIncM where
+ fail x = M (fail x)
+
-- | Raise an 'IncludeFailed' error.
includeFailed :: Located FilePath -> NoIncM a
includeFailed path = M (raise [IncludeFailed path])
@@ -178,9 +198,13 @@
-- | Read a file referenced by an include.
readInclude :: Located FilePath -> NoIncM Text
readInclude path = do
- file <- fromIncPath (thing path)
- source <- T.readFile file `failsWith` handler
- return source
+ readBytes <- envFileReader <$> M ask
+ file <- fromIncPath (thing path)
+ sourceBytes <- readBytes file `failsWith` handler
+ sourceText <- X.evaluate (T.decodeUtf8' sourceBytes) `failsWith` handler
+ case sourceText of
+ Left encodingErr -> M (raise [IncludeDecodeFailed path encodingErr])
+ Right txt -> return txt
where
handler :: X.IOException -> NoIncM a
handler _ = includeFailed path
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
@@ -24,6 +24,7 @@
import Cryptol.Parser.Names (namesP)
import Cryptol.Utils.PP
import Cryptol.Utils.Panic(panic)
+import Cryptol.Utils.RecordMap
import MonadLib hiding (mapM)
import Data.Maybe(maybeToList)
@@ -32,9 +33,6 @@
import GHC.Generics (Generic)
import Control.DeepSeq
-import Prelude ()
-import Prelude.Compat
-
class RemovePatterns t where
-- | Eliminate all patterns in a program.
removePatterns :: t -> (t, [Error])
@@ -101,12 +99,12 @@
return (pTy r x ty, zipWith getN as [0..] ++ concat dss)
PRecord fs ->
- do (as,dss) <- unzip `fmap` mapM (noPat . value) fs
+ do let (shape, els) = unzip (canonicalFields fs)
+ (as,dss) <- unzip `fmap` mapM (noPat . snd) els
x <- newName
r <- getRange
- let shape = map (thing . name) fs
- ty = TRecord (map (fmap (\_ -> TWild)) fs)
- getN a n = sel a x (RecordSel n (Just shape))
+ let ty = TRecord (fmap (\(rng,_) -> (rng,TWild)) fs)
+ getN a n = sel a x (RecordSel n (Just shape))
return (pTy r x ty, zipWith getN as shape ++ concat dss)
PTyped p t ->
@@ -150,7 +148,7 @@
EComplement e -> EComplement <$> noPatE e
EGenerate e -> EGenerate <$> noPatE e
ETuple es -> ETuple <$> mapM noPatE es
- ERecord es -> ERecord <$> mapM noPatF es
+ ERecord es -> ERecord <$> traverse (traverse noPatE) es
ESel e s -> ESel <$> noPatE e <*> return s
EUpd mb fs -> EUpd <$> traverse noPatE mb <*> traverse noPatUF fs
EList es -> EList <$> mapM noPatE es
@@ -171,8 +169,6 @@
EParens e -> EParens <$> noPatE e
EInfix x y f z-> EInfix <$> noPatE x <*> pure y <*> pure f <*> noPatE z
- where noPatF x = do e <- noPatE (value x)
- return x { value = e }
noPatUF :: UpdField PName -> NoPatM (UpdField PName)
noPatUF (UpdField h ls e) = UpdField h ls <$> noPatE e
@@ -542,9 +538,7 @@
instance Applicative NoPatM where pure = return; (<*>) = ap
instance Monad NoPatM where
return x = M (return x)
- fail x = M (fail x)
M x >>= k = M (x >>= unM . k)
-
-- | Pick a new name, to be used when desugaring patterns.
newName :: NoPatM PName
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
@@ -18,6 +18,7 @@
import Data.Maybe(fromMaybe)
import Data.Bits(testBit,setBit)
import Control.Monad(liftM,ap,unless,guard)
+import qualified Control.Monad.Fail as Fail
import Data.Text(Text)
import qualified Data.Text as T
import qualified Data.Map as Map
@@ -36,6 +37,7 @@
import Cryptol.Utils.Ident(packModName)
import Cryptol.Utils.PP
import Cryptol.Utils.Panic
+import Cryptol.Utils.RecordMap
parseString :: Config -> ParseM a -> String -> Either ParseError a
@@ -139,11 +141,13 @@
instance Monad ParseM where
return a = P (\_ _ s -> Right (a,s))
- fail s = panic "[Parser] fail" [s]
m >>= k = P (\cfg p s1 -> case unP m cfg p s1 of
Left e -> Left e
Right (a,s2) -> unP (k a) cfg p s2)
+instance Fail.MonadFail ParseM where
+ fail s = panic "[Parser] fail" [s]
+
happyError :: ParseM a
happyError = P $ \cfg _ s ->
case sPrevTok s of
@@ -187,6 +191,11 @@
Token (ChrLit x) _ -> toInteger (fromEnum x)
_ -> panic "[Parser] getNum" ["not a number:", show l]
+getChr :: Located Token -> Char
+getChr l = case thing l of
+ Token (ChrLit x) _ -> x
+ _ -> panic "[Parser] getChr" ["not a char:", show l]
+
getStr :: Located Token -> String
getStr l = case thing l of
Token (StrLit x) _ -> x
@@ -201,6 +210,17 @@
numLit x = panic "[Parser] numLit" ["invalid numeric literal", show x]
+fracLit :: TokenT -> Expr PName
+fracLit tok =
+ case 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
+ _ -> panic "[Parser] fracLit" [ "Invalid fraction", show tok ]
+
+
intVal :: Located Token -> ParseM Integer
intVal tok =
case tokenType (thing tok) of
@@ -233,6 +253,7 @@
case ty of
TLocated t r -> validDemotedType r t
TRecord {} -> bad "Record types"
+ TTyApp {} -> bad "Explicit type application"
TTuple {} -> bad "Tuple types"
TFun {} -> bad "Function types"
TSeq {} -> bad "Sequence types"
@@ -248,6 +269,18 @@
where bad x = errorMessage rng (x ++ " cannot be demoted.")
ok = return $ at rng ty
+-- | Input fields are reversed!
+mkRecord :: AddLoc b => Range -> (RecordMap Ident (Range, a) -> b) -> [Named a] -> ParseM b
+mkRecord rng f xs =
+ case res of
+ Left (nm,(nmRng,_)) -> errorMessage nmRng ("Record has repeated field: " ++ show (pp nm))
+ Right r -> pure $ at rng (f r)
+
+ where
+ res = recordFromFieldsErr ys
+ ys = map (\ (Named (Located r nm) x) -> (nm,(r,x))) (reverse xs)
+
+
-- | Input expression are reversed
mkEApp :: [Expr PName] -> Expr PName
mkEApp es@(eLast : _) = at (eFirst,eLast) $ foldl EApp f xs
@@ -255,7 +288,7 @@
eFirst : rest = reverse es
f : xs = cvtTypeParams eFirst rest
- {- Type applications are parsed as `ETypeVal (TRecord fs)` expressions.
+ {- Type applications are parsed as `ETypeVal (TTyApp fs)` expressions.
Here we associate them with their corresponding functions,
converting them into `EAppT` constructs. For example:
@@ -272,8 +305,8 @@
toTypeParam e =
case dropLoc e of
ETypeVal t -> case dropLoc t of
- TRecord fs -> Just (map mkTypeInst fs)
- _ -> Nothing
+ TTyApp fs -> Just (map mkTypeInst fs)
+ _ -> Nothing
_ -> Nothing
mkEApp es = panic "[Parser] mkEApp" ["Unexpected:", show es]
@@ -322,8 +355,8 @@
-- | WARNING: This is a bit of a hack.
-- It is used to represent anonymous type applications.
-anonRecord :: Maybe Range -> [Type PName] -> Type PName
-anonRecord ~(Just r) ts = TRecord (map toField ts)
+anonTyApp :: Maybe Range -> [Type PName] -> Type PName
+anonTyApp ~(Just r) ts = TTyApp (map toField ts)
where noName = Located { srcRange = r, thing = mkIdent (T.pack "") }
toField t = Named { name = noName, value = t }
@@ -408,14 +441,20 @@
| otherwise = errorMessage rng "Invalid polynomial coefficient"
mkPoly :: Range -> [ (Bool,Integer) ] -> ParseM (Expr PName)
-mkPoly rng terms = mk 0 (map fromInteger bits)
+mkPoly rng terms
+ | w <= toInteger (maxBound :: Int) = mk 0 (map fromInteger bits)
+ | otherwise = errorMessage rng ("Polynomial literal too large: " ++ show w)
+
where
w = case terms of
[] -> 0
- _ -> 1 + maximum (map (fromInteger . snd) terms)
+ _ -> 1 + maximum (map snd terms)
+
bits = [ n | (True,n) <- terms ]
- mk res [] = return $ ELit $ ECNum res (PolyLit w)
+ mk :: Integer -> [Int] -> ParseM (Expr PName)
+ mk res [] = return $ ELit $ ECNum res (PolyLit (fromInteger w :: Int))
+
mk res (n : ns)
| testBit res n = errorMessage rng
("Polynomial contains multiple terms with exponent "
@@ -503,7 +542,7 @@
Just (n,xs) ->
do vs <- mapM tpK as
unless (distinct (map fst vs)) $
- errorMessage schema_rng "Repeated parameterms."
+ errorMessage schema_rng "Repeated parameters."
let kindMap = Map.fromList vs
lkp v = case Map.lookup (thing v) kindMap of
Just (k,tp) -> pure (k,tp)
@@ -579,6 +618,9 @@
prefixDroppable x = x `elem` ("* \r\n\t" :: String)
+ whitespaceChar :: Char -> Bool
+ whitespaceChar x = x `elem` (" \r\n\t" :: String)
+
trimFront [] = []
trimFront (l:ls)
| T.all commentChar l = ls
@@ -596,7 +638,7 @@
commonPrefix c t =
case T.uncons t of
Just (c',_) -> c == c'
- Nothing -> False
+ Nothing -> whitespaceChar c -- end-of-line matches any whitespace
distrLoc :: Located [a] -> [Located a]
@@ -629,6 +671,7 @@
TChar{} -> err
TWild -> err
TRecord{} -> err
+ TTyApp{} -> err
where
err = errorMessage r "Invalid constraint"
@@ -684,8 +727,8 @@
EVar (UnQual l) ->
pure [ Located { thing = RecordSel l Nothing, srcRange = loc } ]
ELit (ECNum n _) ->
- pure [ Located { thing = TupleSel (fromInteger n) Nothing
- , srcRange = loc } ]
+ do ts <- mkTupleSel loc n
+ pure [ ts ]
_ -> errorMessage loc "Invalid label in record update."
diff --git a/src/Cryptol/Parser/Position.hs b/src/Cryptol/Parser/Position.hs
--- a/src/Cryptol/Parser/Position.hs
+++ b/src/Cryptol/Parser/Position.hs
@@ -22,7 +22,7 @@
import Cryptol.Utils.PP
data Located a = Located { srcRange :: !Range, thing :: !a }
- deriving (Eq, Show, Generic, NFData)
+ deriving (Eq, Ord, Show, Generic, NFData)
data Position = Position { line :: !Int, col :: !Int }
@@ -31,7 +31,7 @@
data Range = Range { from :: !Position
, to :: !Position
, source :: FilePath }
- deriving (Eq, Show, Generic, NFData)
+ deriving (Eq, Ord, Show, Generic, NFData)
-- | An empty range.
--
diff --git a/src/Cryptol/Parser/Unlit.hs b/src/Cryptol/Parser/Unlit.hs
--- a/src/Cryptol/Parser/Unlit.hs
+++ b/src/Cryptol/Parser/Unlit.hs
@@ -83,8 +83,8 @@
blanks current [] = mk Comment current
blanks current (l : ls)
- | isCodeLine l = mk Comment current ++ code [l] ls
| Just op <- isOpenFence l = mk Comment (l : current) ++ fenced op [] ls
+ | isCodeLine l = mk Comment current ++ code [l] ls
| isBlank l = blanks (l : current) ls
| otherwise = comment (l : current) ls
@@ -110,7 +110,7 @@
where
l' = Text.dropWhile isSpace l
- isCloseFence l = "```" `Text.isPrefixOf` l
+ isCloseFence l = "```" `Text.isPrefixOf` Text.dropWhile isSpace l
isBlank l = Text.all isSpace l
isCodeLine l = "\t" `Text.isPrefixOf` l || " " `Text.isPrefixOf` l
diff --git a/src/Cryptol/Parser/Utils.hs b/src/Cryptol/Parser/Utils.hs
--- a/src/Cryptol/Parser/Utils.hs
+++ b/src/Cryptol/Parser/Utils.hs
@@ -18,7 +18,6 @@
import Cryptol.Parser.AST
-
widthIdent :: Ident
widthIdent = mkIdent "width"
@@ -53,6 +52,7 @@
TUser f ts -> return (TUser f (ts ++ [t]))
_ -> Nothing
- cvtLit (ECNum n CharLit) = return (TChar $ toEnum $ fromInteger n)
cvtLit (ECNum n _) = return (TNum n)
+ cvtLit (ECChar c) = return (TChar c)
+ cvtLit (ECFrac {}) = Nothing
cvtLit (ECString _) = Nothing
diff --git a/src/Cryptol/Prelude.hs b/src/Cryptol/Prelude.hs
--- a/src/Cryptol/Prelude.hs
+++ b/src/Cryptol/Prelude.hs
@@ -13,17 +13,26 @@
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}
-module Cryptol.Prelude (preludeContents,cryptolTcContents) where
-
+module Cryptol.Prelude
+ ( preludeContents
+ , floatContents
+ , arrayContents
+ , cryptolTcContents
+ ) where
import Data.ByteString(ByteString)
import qualified Data.ByteString.Char8 as B
import Text.Heredoc (there)
+
preludeContents :: ByteString
preludeContents = B.pack [there|lib/Cryptol.cry|]
-cryptolTcContents :: String
-cryptolTcContents = [there|lib/CryptolTC.z3|]
+floatContents :: ByteString
+floatContents = B.pack [there|lib/Float.cry|]
+arrayContents :: ByteString
+arrayContents = B.pack [there|lib/Array.cry|]
+cryptolTcContents :: String
+cryptolTcContents = [there|lib/CryptolTC.z3|]
diff --git a/src/Cryptol/Prims/Eval.hs b/src/Cryptol/Prims/Eval.hs
deleted file mode 100644
--- a/src/Cryptol/Prims/Eval.hs
+++ /dev/null
@@ -1,1519 +0,0 @@
--- |
--- Module : Cryptol.Prims.Eval
--- Copyright : (c) 2013-2016 Galois, Inc.
--- License : BSD3
--- Maintainer : cryptol@galois.com
--- Stability : provisional
--- Portability : portable
-
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE Trustworthy #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE Rank2Types #-}
-{-# LANGUAGE PatternGuards #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE BangPatterns #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-module Cryptol.Prims.Eval where
-
-import Control.Monad (join, unless)
-
-import Cryptol.TypeCheck.AST
-import Cryptol.TypeCheck.Solver.InfNat (Nat'(..),fromNat,genLog, nMul)
-import Cryptol.Eval.Monad
-import Cryptol.Eval.Type
-import Cryptol.Eval.Value
-import Cryptol.Testing.Random (randomValue)
-import Cryptol.Utils.Panic (panic)
-import Cryptol.ModuleSystem.Name (asPrim)
-import Cryptol.Utils.Ident (Ident,mkIdent)
-import Cryptol.Utils.PP
-import Cryptol.Utils.Logger(logPrint)
-
-import qualified Data.Foldable as Fold
-import Data.List (sortBy)
-import qualified Data.Sequence as Seq
-import Data.Ord (comparing)
-import Data.Bits (Bits(..))
-
-import qualified Data.Map.Strict as Map
-import qualified Data.Text as T
-
-import System.Random.TF.Gen (seedTFGen)
-
--- Primitives ------------------------------------------------------------------
-
-instance EvalPrims Bool BV Integer where
- evalPrim Decl { dName = n, .. } =
- do prim <- asPrim n
- Map.lookup prim primTable
-
- iteValue b t f = if b then t else f
-
-
-primTable :: Map.Map Ident Value
-primTable = Map.fromList $ map (\(n, v) -> (mkIdent (T.pack n), v))
- [ ("+" , {-# SCC "Prelude::(+)" #-}
- binary (arithBinary (liftBinArith (+)) (liftBinInteger (+))
- (liftBinIntMod (+))))
- , ("-" , {-# SCC "Prelude::(-)" #-}
- binary (arithBinary (liftBinArith (-)) (liftBinInteger (-))
- (liftBinIntMod (-))))
- , ("*" , {-# SCC "Prelude::(*)" #-}
- binary (arithBinary (liftBinArith (*)) (liftBinInteger (*))
- (liftBinIntMod (*))))
- , ("/" , {-# SCC "Prelude::(/)" #-}
- binary (arithBinary (liftDivArith div) (liftDivInteger div)
- (const (liftDivInteger div))))
- , ("%" , {-# SCC "Prelude::(%)" #-}
- binary (arithBinary (liftDivArith mod) (liftDivInteger mod)
- (const (liftDivInteger mod))))
- , ("^^" , {-# SCC "Prelude::(^^)" #-}
- binary (arithBinary modExp integerExp intModExp))
- , ("lg2" , {-# SCC "Prelude::lg2" #-}
- unary (arithUnary (liftUnaryArith lg2) integerLg2 (const integerLg2)))
- , ("negate" , {-# SCC "Prelude::negate" #-}
- unary (arithUnary (liftUnaryArith negate) integerNeg intModNeg))
- , ("<" , {-# SCC "Prelude::(<)" #-}
- binary (cmpOrder "<" (\o -> o == LT )))
- , (">" , {-# SCC "Prelude::(>)" #-}
- binary (cmpOrder ">" (\o -> o == GT )))
- , ("<=" , {-# SCC "Prelude::(<=)" #-}
- binary (cmpOrder "<=" (\o -> o == LT || o == EQ)))
- , (">=" , {-# SCC "Prelude::(>=)" #-}
- binary (cmpOrder ">=" (\o -> o == GT || o == EQ)))
- , ("==" , {-# SCC "Prelude::(==)" #-}
- binary (cmpOrder "==" (\o -> o == EQ)))
- , ("!=" , {-# SCC "Prelude::(!=)" #-}
- binary (cmpOrder "!=" (\o -> o /= EQ)))
- , ("<$" , {-# SCC "Prelude::(<$)" #-}
- binary (signedCmpOrder "<$" (\o -> o == LT)))
- , ("/$" , {-# SCC "Prelude::(/$)" #-}
- binary (arithBinary (liftSigned bvSdiv) (liftDivInteger div)
- (const (liftDivInteger div))))
- , ("%$" , {-# SCC "Prelude::(%$)" #-}
- binary (arithBinary (liftSigned bvSrem) (liftDivInteger mod)
- (const (liftDivInteger mod))))
- , (">>$" , {-# SCC "Prelude::(>>$)" #-}
- sshrV)
- , ("&&" , {-# SCC "Prelude::(&&)" #-}
- binary (logicBinary (.&.) (binBV (.&.))))
- , ("||" , {-# SCC "Prelude::(||)" #-}
- binary (logicBinary (.|.) (binBV (.|.))))
- , ("^" , {-# SCC "Prelude::(^)" #-}
- binary (logicBinary xor (binBV xor)))
- , ("complement" , {-# SCC "Prelude::complement" #-}
- unary (logicUnary complement (unaryBV complement)))
- , ("toInteger" , ecToIntegerV)
- , ("fromInteger", ecFromIntegerV (flip mod))
- , ("fromZ" , {-# SCC "Prelude::fromZ" #-}
- nlam $ \ _modulus ->
- lam $ \ x -> x)
- , ("<<" , {-# SCC "Prelude::(<<)" #-}
- logicShift shiftLW shiftLB shiftLS)
- , (">>" , {-# SCC "Prelude::(>>)" #-}
- logicShift shiftRW shiftRB shiftRS)
- , ("<<<" , {-# SCC "Prelude::(<<<)" #-}
- logicShift rotateLW rotateLB rotateLS)
- , (">>>" , {-# SCC "Prelude::(>>>)" #-}
- logicShift rotateRW rotateRB rotateRS)
- , ("True" , VBit True)
- , ("False" , VBit False)
-
- , ("carry" , {-# SCC "Prelude::carry" #-}
- carryV)
- , ("scarry" , {-# SCC "Prelude::scarry" #-}
- scarryV)
- , ("number" , {-# SCC "Prelude::number" #-}
- ecNumberV)
-
- , ("#" , {-# SCC "Prelude::(#)" #-}
- nlam $ \ front ->
- nlam $ \ back ->
- tlam $ \ elty ->
- lam $ \ l -> return $
- lam $ \ r -> join (ccatV front back elty <$> l <*> r))
-
- , ("@" , {-# SCC "Prelude::(@)" #-}
- indexPrim indexFront_bits indexFront)
- , ("!" , {-# SCC "Prelude::(!)" #-}
- indexPrim indexBack_bits indexBack)
-
- , ("update" , {-# SCC "Prelude::update" #-}
- updatePrim updateFront_word updateFront)
-
- , ("updateEnd" , {-# SCC "Prelude::updateEnd" #-}
- updatePrim updateBack_word updateBack)
-
- , ("zero" , {-# SCC "Prelude::zero" #-}
- tlam zeroV)
-
- , ("join" , {-# SCC "Prelude::join" #-}
- nlam $ \ parts ->
- nlam $ \ (finNat' -> each) ->
- tlam $ \ a ->
- lam $ \ x ->
- joinV parts each a =<< x)
-
- , ("split" , {-# SCC "Prelude::split" #-}
- ecSplitV)
-
- , ("splitAt" , {-# SCC "Prelude::splitAt" #-}
- nlam $ \ front ->
- nlam $ \ back ->
- tlam $ \ a ->
- lam $ \ x ->
- splitAtV front back a =<< x)
-
- , ("fromTo" , {-# SCC "Prelude::fromTo" #-}
- fromToV)
- , ("fromThenTo" , {-# SCC "Prelude::fromThenTo" #-}
- fromThenToV)
- , ("infFrom" , {-# SCC "Prelude::infFrom" #-}
- infFromV)
- , ("infFromThen", {-# SCC "Prelude::infFromThen" #-}
- infFromThenV)
-
- , ("error" , {-# SCC "Prelude::error" #-}
- tlam $ \a ->
- nlam $ \_ ->
- lam $ \s -> errorV a =<< (fromStr =<< s))
-
- , ("reverse" , {-# SCC "Prelude::reverse" #-}
- nlam $ \_a ->
- tlam $ \_b ->
- lam $ \xs -> reverseV =<< xs)
-
- , ("transpose" , {-# SCC "Prelude::transpose" #-}
- nlam $ \a ->
- nlam $ \b ->
- tlam $ \c ->
- lam $ \xs -> transposeV a b c =<< xs)
-
- , ("random" , {-# SCC "Prelude::random" #-}
- tlam $ \a ->
- wlam $ \(bvVal -> x) -> return $ randomV a x)
- , ("trace" , {-# SCC "Prelude::trace" #-}
- nlam $ \_n ->
- tlam $ \_a ->
- tlam $ \_b ->
- lam $ \s -> return $
- lam $ \x -> return $
- lam $ \y -> do
- msg <- fromStr =<< s
- EvalOpts { evalPPOpts, evalLogger } <- getEvalOpts
- doc <- ppValue evalPPOpts =<< x
- yv <- y
- io $ logPrint evalLogger
- $ if null msg then doc else text msg <+> doc
- return yv)
- ]
-
--- | Make a numeric literal value at the given type.
-mkLit :: BitWord b w i => TValue -> Integer -> GenValue b w i
-mkLit ty =
- case ty of
- TVInteger -> VInteger . integerLit
- TVIntMod _ -> VInteger . integerLit
- TVSeq w TVBit -> word w
- _ -> evalPanic "Cryptol.Eval.Prim.evalConst"
- [ "Invalid type for number" ]
-
--- | Make a numeric constant.
-ecNumberV :: BitWord b w i => GenValue b w i
-ecNumberV = nlam $ \valT ->
- tlam $ \ty ->
- case valT of
- Nat v -> mkLit ty v
- _ -> evalPanic "Cryptol.Eval.Prim.evalConst"
- ["Unexpected Inf in constant."
- , show valT
- , show ty
- ]
-
--- | Convert a word to a non-negative integer.
-ecToIntegerV :: BitWord b w i => GenValue b w i
-ecToIntegerV =
- nlam $ \ _ ->
- wlam $ \ w -> return $ VInteger (wordToInt w)
-
--- | Convert an unbounded integer to a packed bitvector.
-ecFromIntegerV :: BitWord b w i => (Integer -> i -> i) -> GenValue b w i
-ecFromIntegerV opz =
- tlam $ \ a ->
- lam $ \ x ->
- do i <- fromVInteger <$> x
- return $ arithNullary (flip wordFromInt i) i (flip opz i) a
-
-
---------------------------------------------------------------------------------
-
--- | Create a packed word
-modExp :: Integer -- ^ bit size of the resulting word
- -> BV -- ^ base
- -> BV -- ^ exponent
- -> Eval BV
-modExp bits (BV _ base) (BV _ e)
- | bits == 0 = ready $ BV bits 0
- | base < 0 || bits < 0 = evalPanic "modExp"
- [ "bad args: "
- , " base = " ++ show base
- , " e = " ++ show e
- , " bits = " ++ show modulus
- ]
- | otherwise = ready $ mkBv bits $ doubleAndAdd base e modulus
- where
- modulus = 0 `setBit` fromInteger bits
-
-intModExp :: Integer -> Integer -> Integer -> Eval Integer
-intModExp modulus base e
- | modulus > 0 = ready $ doubleAndAdd base e modulus
- | modulus == 0 = integerExp base e
- | otherwise = evalPanic "intModExp" [ "negative modulus: " ++ show modulus ]
-
-integerExp :: Integer -> Integer -> Eval Integer
-integerExp x y
- | y < 0 = negativeExponent
- | otherwise = ready $ x ^ y
-
-integerLg2 :: Integer -> Eval Integer
-integerLg2 x
- | x < 0 = logNegative
- | otherwise = ready $ lg2 x
-
-integerNeg :: Integer -> Eval Integer
-integerNeg x = ready $ negate x
-
-intModNeg :: Integer -> Integer -> Eval Integer
-intModNeg modulus x = ready $ negate x `mod` modulus
-
-doubleAndAdd :: Integer -- ^ base
- -> Integer -- ^ exponent mask
- -> Integer -- ^ modulus
- -> Integer
-doubleAndAdd base0 expMask modulus = go 1 base0 expMask
- where
- go acc base k
- | k > 0 = acc' `seq` base' `seq` go acc' base' (k `shiftR` 1)
- | otherwise = acc
- where
- acc' | k `testBit` 0 = acc `modMul` base
- | otherwise = acc
-
- base' = base `modMul` base
-
- modMul x y = (x * y) `mod` modulus
-
-
-
--- Operation Lifting -----------------------------------------------------------
-
-type Binary b w i = TValue -> GenValue b w i -> GenValue b w i -> Eval (GenValue b w i)
-
-binary :: Binary b w i -> GenValue b w i
-binary f = tlam $ \ ty ->
- lam $ \ a -> return $
- lam $ \ b -> do
- --io $ putStrLn "Entering a binary function"
- join (f ty <$> a <*> b)
-
-type Unary b w i = TValue -> GenValue b w i -> Eval (GenValue b w i)
-
-unary :: Unary b w i -> GenValue b w i
-unary f = tlam $ \ ty ->
- lam $ \ a -> f ty =<< a
-
-
--- Arith -----------------------------------------------------------------------
-
--- | Turn a normal binop on Integers into one that can also deal with a bitsize.
--- However, if the bitvector size is 0, always return the 0
--- bitvector.
-liftBinArith :: (Integer -> Integer -> Integer) -> BinArith BV
-liftBinArith _ 0 _ _ = ready $ mkBv 0 0
-liftBinArith op w (BV _ x) (BV _ y) = ready $ mkBv w $ op x y
-
--- | Turn a normal binop on Integers into one that can also deal with a bitsize.
--- Generate a thunk that throws a divide by 0 error when forced if the second
--- argument is 0. However, if the bitvector size is 0, always return the 0
--- bitvector.
-liftDivArith :: (Integer -> Integer -> Integer) -> BinArith BV
-liftDivArith _ 0 _ _ = ready $ mkBv 0 0
-liftDivArith _ _ _ (BV _ 0) = divideByZero
-liftDivArith op w (BV _ x) (BV _ y) = ready $ mkBv w $ op x y
-
-type BinArith w = Integer -> w -> w -> Eval w
-
-liftBinInteger :: (Integer -> Integer -> Integer) -> Integer -> Integer -> Eval Integer
-liftBinInteger op x y = ready $ op x y
-
-liftBinIntMod ::
- (Integer -> Integer -> Integer) -> Integer -> Integer -> Integer -> Eval Integer
-liftBinIntMod op m x y
- | m == 0 = ready $ op x y
- | otherwise = ready $ (op x y) `mod` m
-
-liftDivInteger :: (Integer -> Integer -> Integer) -> Integer -> Integer -> Eval Integer
-liftDivInteger _ _ 0 = divideByZero
-liftDivInteger op x y = ready $ op x y
-
-modWrap :: Integral a => a -> a -> Eval a
-modWrap _ 0 = divideByZero
-modWrap x y = return (x `mod` y)
-
-arithBinary :: forall b w i
- . BitWord b w i
- => BinArith w
- -> (i -> i -> Eval i)
- -> (Integer -> i -> i -> Eval i)
- -> Binary b w i
-arithBinary opw opi opz = loop
- where
- loop' :: TValue
- -> Eval (GenValue b w i)
- -> Eval (GenValue b w i)
- -> Eval (GenValue b w i)
- loop' ty l r = join (loop ty <$> l <*> r)
-
- loop :: TValue
- -> GenValue b w i
- -> GenValue b w i
- -> Eval (GenValue b w i)
- loop ty l r = case ty of
- TVBit ->
- evalPanic "arithBinary" ["Bit not in class Arith"]
-
- TVInteger ->
- VInteger <$> opi (fromVInteger l) (fromVInteger r)
-
- TVIntMod n ->
- VInteger <$> opz n (fromVInteger l) (fromVInteger r)
-
- TVSeq w a
- -- words and finite sequences
- | isTBit a -> do
- lw <- fromVWord "arithLeft" l
- rw <- fromVWord "arithRight" r
- return $ VWord w (WordVal <$> opw w lw rw)
- | otherwise -> VSeq w <$> (join (zipSeqMap (loop a) <$>
- (fromSeq "arithBinary left" l) <*>
- (fromSeq "arithBinary right" r)))
-
- TVStream a ->
- -- streams
- VStream <$> (join (zipSeqMap (loop a) <$>
- (fromSeq "arithBinary left" l) <*>
- (fromSeq "arithBinary right" r)))
-
- -- functions
- TVFun _ ety ->
- return $ lam $ \ x -> loop' ety (fromVFun l x) (fromVFun r x)
-
- -- tuples
- TVTuple tys ->
- do ls <- mapM (delay Nothing) (fromVTuple l)
- rs <- mapM (delay Nothing) (fromVTuple r)
- return $ VTuple (zipWith3 loop' tys ls rs)
-
- -- records
- TVRec fs ->
- do fs' <- sequence
- [ (f,) <$> delay Nothing (loop' fty (lookupRecord f l) (lookupRecord f r))
- | (f,fty) <- fs
- ]
- return $ VRecord fs'
-
- TVAbstract {} ->
- evalPanic "arithBinary" ["Abstract type not in `Arith`"]
-
-type UnaryArith w = Integer -> w -> Eval w
-
-liftUnaryArith :: (Integer -> Integer) -> UnaryArith BV
-liftUnaryArith op w (BV _ x) = ready $ mkBv w $ op x
-
-arithUnary :: forall b w i
- . BitWord b w i
- => UnaryArith w
- -> (i -> Eval i)
- -> (Integer -> i -> Eval i)
- -> Unary b w i
-arithUnary opw opi opz = loop
- where
- loop' :: TValue -> Eval (GenValue b w i) -> Eval (GenValue b w i)
- loop' ty x = loop ty =<< x
-
- loop :: TValue -> GenValue b w i -> Eval (GenValue b w i)
- loop ty x = case ty of
-
- TVBit ->
- evalPanic "arithUnary" ["Bit not in class Arith"]
-
- TVInteger ->
- VInteger <$> opi (fromVInteger x)
-
- TVIntMod n ->
- VInteger <$> opz n (fromVInteger x)
-
- TVSeq w a
- -- words and finite sequences
- | isTBit a -> do
- wx <- fromVWord "arithUnary" x
- return $ VWord w (WordVal <$> opw w wx)
- | otherwise -> VSeq w <$> (mapSeqMap (loop a) =<< fromSeq "arithUnary" x)
-
- TVStream a ->
- VStream <$> (mapSeqMap (loop a) =<< fromSeq "arithUnary" x)
-
- -- functions
- TVFun _ ety ->
- return $ lam $ \ y -> loop' ety (fromVFun x y)
-
- -- tuples
- TVTuple tys ->
- do as <- mapM (delay Nothing) (fromVTuple x)
- return $ VTuple (zipWith loop' tys as)
-
- -- records
- TVRec fs ->
- do fs' <- sequence
- [ (f,) <$> delay Nothing (loop' fty (lookupRecord f x))
- | (f,fty) <- fs
- ]
- return $ VRecord fs'
-
- TVAbstract {} -> evalPanic "arithUnary" ["Abstract type not in `Arith`"]
-
-arithNullary ::
- forall b w i.
- BitWord b w i =>
- (Integer -> w) ->
- i ->
- (Integer -> i) ->
- TValue -> GenValue b w i
-arithNullary opw opi opz = loop
- where
- loop :: TValue -> GenValue b w i
- loop ty =
- case ty of
- TVBit -> evalPanic "arithNullary" ["Bit not in class Arith"]
-
- TVInteger -> VInteger opi
-
- TVIntMod n -> VInteger (opz n)
-
- TVSeq w a
- -- words and finite sequences
- | isTBit a -> VWord w $ ready $ WordVal $ opw w
- | otherwise -> VSeq w $ IndexSeqMap $ const $ ready $ loop a
-
- TVStream a -> VStream $ IndexSeqMap $ const $ ready $ loop a
-
- TVFun _ b -> lam $ const $ ready $ loop b
-
- TVTuple tys -> VTuple $ map (ready . loop) tys
-
- TVRec fs -> VRecord [ (f, ready (loop a)) | (f, a) <- fs ]
-
- TVAbstract {} ->
- evalPanic "arithNullary" ["Abstract type not in `Arith`"]
-
-lg2 :: Integer -> Integer
-lg2 i = case genLog i 2 of
- Just (i',isExact) | isExact -> i'
- | otherwise -> i' + 1
- Nothing -> 0
-
-addV :: BitWord b w i => Binary b w i
-addV = arithBinary opw opi opz
- where
- opw _w x y = ready $ wordPlus x y
- opi x y = ready $ intPlus x y
- opz m x y = ready $ intModPlus m x y
-
-subV :: BitWord b w i => Binary b w i
-subV = arithBinary opw opi opz
- where
- opw _w x y = ready $ wordMinus x y
- opi x y = ready $ intMinus x y
- opz m x y = ready $ intModMinus m x y
-
-mulV :: BitWord b w i => Binary b w i
-mulV = arithBinary opw opi opz
- where
- opw _w x y = ready $ wordMult x y
- opi x y = ready $ intMult x y
- opz m x y = ready $ intModMult m x y
-
-intV :: BitWord b w i => i -> TValue -> GenValue b w i
-intV i = arithNullary (flip wordFromInt i) i (const i)
-
--- Cmp -------------------------------------------------------------------------
-
-cmpValue :: BitWord b w i
- => (b -> b -> Eval a -> Eval a)
- -> (w -> w -> Eval a -> Eval a)
- -> (i -> i -> Eval a -> Eval a)
- -> (Integer -> i -> i -> Eval a -> Eval a)
- -> (TValue -> GenValue b w i -> GenValue b w i -> Eval a -> Eval a)
-cmpValue fb fw fi fz = cmp
- where
- cmp ty v1 v2 k =
- case ty of
- TVBit -> fb (fromVBit v1) (fromVBit v2) k
- TVInteger -> fi (fromVInteger v1) (fromVInteger v2) k
- TVIntMod n -> fz n (fromVInteger v1) (fromVInteger v2) k
- TVSeq n t
- | isTBit t -> do w1 <- fromVWord "cmpValue" v1
- w2 <- fromVWord "cmpValue" v2
- fw w1 w2 k
- | otherwise -> cmpValues (repeat t)
- (enumerateSeqMap n (fromVSeq v1))
- (enumerateSeqMap n (fromVSeq v2)) k
- TVStream _ -> panic "Cryptol.Prims.Value.cmpValue"
- [ "Infinite streams are not comparable" ]
- TVFun _ _ -> panic "Cryptol.Prims.Value.cmpValue"
- [ "Functions are not comparable" ]
- TVTuple tys -> cmpValues tys (fromVTuple v1) (fromVTuple v2) k
- TVRec fields -> do let vals = map snd . sortBy (comparing fst)
- let tys = vals fields
- cmpValues tys
- (vals (fromVRecord v1))
- (vals (fromVRecord v2)) k
- TVAbstract {} -> evalPanic "cmpValue"
- [ "Abstract type not in `Cmp`" ]
-
- cmpValues (t : ts) (x1 : xs1) (x2 : xs2) k =
- do x1' <- x1
- x2' <- x2
- cmp t x1' x2' (cmpValues ts xs1 xs2 k)
- cmpValues _ _ _ k = k
-
-
-lexCompare :: TValue -> Value -> Value -> Eval Ordering
-lexCompare ty a b = cmpValue op opw op (const op) ty a b (return EQ)
- where
- opw :: BV -> BV -> Eval Ordering -> Eval Ordering
- opw x y k = op (bvVal x) (bvVal y) k
-
- op :: Ord a => a -> a -> Eval Ordering -> Eval Ordering
- op x y k = case compare x y of
- EQ -> k
- cmp -> return cmp
-
-signedLexCompare :: TValue -> Value -> Value -> Eval Ordering
-signedLexCompare ty a b = cmpValue opb opw opi (const opi) ty a b (return EQ)
- where
- opb :: Bool -> Bool -> Eval Ordering -> Eval Ordering
- opb _x _y _k = panic "signedLexCompare"
- ["Attempted to perform signed comparisons on bare Bit type"]
-
- opw :: BV -> BV -> Eval Ordering -> Eval Ordering
- opw x y k = case compare (signedBV x) (signedBV y) of
- EQ -> k
- cmp -> return cmp
-
- opi :: Integer -> Integer -> Eval Ordering -> Eval Ordering
- opi _x _y _k = panic "signedLexCompare"
- ["Attempted to perform signed comparisons on Integer type"]
-
--- | Process two elements based on their lexicographic ordering.
-cmpOrder :: String -> (Ordering -> Bool) -> Binary Bool BV Integer
-cmpOrder _nm op ty l r = VBit . op <$> lexCompare ty l r
-
--- | Process two elements based on their lexicographic ordering, using signed comparisons
-signedCmpOrder :: String -> (Ordering -> Bool) -> Binary Bool BV Integer
-signedCmpOrder _nm op ty l r = VBit . op <$> signedLexCompare ty l r
-
-
--- Signed arithmetic -----------------------------------------------------------
-
--- | Lifted operation on finite bitsequences. Used
--- for signed comparisons and arithemtic.
-liftWord :: BitWord b w i
- => (w -> w -> Eval (GenValue b w i))
- -> GenValue b w i
-liftWord op =
- nlam $ \_n ->
- wlam $ \w1 -> return $
- wlam $ \w2 -> op w1 w2
-
-
-liftSigned :: (Integer -> Integer -> Integer -> Eval BV)
- -> BinArith BV
-liftSigned _ 0 = \_ _ -> return $ mkBv 0 0
-liftSigned op size = f
- where
- f (BV i x) (BV j y)
- | i == j && size == i = op size sx sy
- | otherwise = evalPanic "liftSigned" ["Attempt to compute with words of different sizes"]
- where sx = signedValue i x
- sy = signedValue j y
-
-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 - (1 `shiftL` (fromInteger i)) else x
-
-bvSlt :: Integer -> Integer -> Integer -> Eval Value
-bvSlt _sz x y = return . VBit $! (x < y)
-
-bvSdiv :: Integer -> Integer -> Integer -> Eval BV
-bvSdiv _ _ 0 = divideByZero
-bvSdiv sz x y = return $! mkBv sz (x `quot` y)
-
-bvSrem :: Integer -> Integer -> Integer -> Eval BV
-bvSrem _ _ 0 = divideByZero
-bvSrem sz x y = return $! mkBv sz (x `rem` y)
-
-sshrV :: Value
-sshrV =
- nlam $ \_n ->
- nlam $ \_k ->
- wlam $ \(BV i x) -> return $
- wlam $ \y ->
- let signx = testBit x (fromInteger (i-1))
- amt = fromInteger (bvVal y)
- negv = (((-1) `shiftL` amt) .|. x) `shiftR` amt
- posv = x `shiftR` amt
- in return . VWord i . ready . WordVal . mkBv i $! if signx then negv else posv
-
--- | Signed carry bit.
-scarryV :: Value
-scarryV =
- nlam $ \_n ->
- wlam $ \(BV i x) -> return $
- wlam $ \(BV j y) ->
- if i == j
- then let z = x + y
- xsign = testBit x (fromInteger i - 1)
- ysign = testBit y (fromInteger i - 1)
- zsign = testBit z (fromInteger i - 1)
- sc = (xsign == ysign) && (xsign /= zsign)
- in return $ VBit sc
- else evalPanic "scarryV" ["Attempted to compute with words of different sizes"]
-
--- | Unsigned carry bit.
-carryV :: Value
-carryV =
- nlam $ \_n ->
- wlam $ \(BV i x) -> return $
- wlam $ \(BV j y) ->
- if i == j
- then return . VBit $! testBit (x + y) (fromInteger i)
- else evalPanic "carryV" ["Attempted to compute with words of different sizes"]
-
--- Logic -----------------------------------------------------------------------
-
-zeroV :: forall b w i
- . BitWord b w i
- => TValue
- -> GenValue b w i
-zeroV ty = case ty of
-
- -- bits
- TVBit ->
- VBit (bitLit False)
-
- -- integers
- TVInteger ->
- VInteger (integerLit 0)
-
- -- integers mod n
- TVIntMod _ ->
- VInteger (integerLit 0)
-
- -- sequences
- TVSeq w ety
- | isTBit ety -> word w 0
- | otherwise -> VSeq w (IndexSeqMap $ \_ -> ready $ zeroV ety)
-
- TVStream ety ->
- VStream (IndexSeqMap $ \_ -> ready $ zeroV ety)
-
- -- functions
- TVFun _ bty ->
- lam (\ _ -> ready (zeroV bty))
-
- -- tuples
- TVTuple tys ->
- VTuple (map (ready . zeroV) tys)
-
- -- records
- TVRec fields ->
- VRecord [ (f,ready $ zeroV fty) | (f,fty) <- fields ]
-
- TVAbstract {} -> evalPanic "zeroV" [ "Abstract type not in `Zero`" ]
-
--- | otherwise = evalPanic "zeroV" ["invalid type for zero"]
-
-
-joinWordVal :: BitWord b w i =>
- WordValue b w i -> WordValue b w i -> WordValue b w i
-joinWordVal (WordVal w1) (WordVal w2)
- | wordLen w1 + wordLen w2 < largeBitSize
- = WordVal $ joinWord w1 w2
-joinWordVal (BitsVal xs) (WordVal w2)
- | toInteger (Seq.length xs) + wordLen w2 < largeBitSize
- = BitsVal (xs Seq.>< Seq.fromList (map ready $ unpackWord w2))
-joinWordVal (WordVal w1) (BitsVal ys)
- | wordLen w1 + toInteger (Seq.length ys) < largeBitSize
- = BitsVal (Seq.fromList (map ready $ unpackWord w1) Seq.>< ys)
-joinWordVal (BitsVal xs) (BitsVal ys)
- | toInteger (Seq.length xs) + toInteger (Seq.length ys) < largeBitSize
- = BitsVal (xs Seq.>< ys)
-joinWordVal w1 w2
- = LargeBitsVal (n1+n2) (concatSeqMap n1 (asBitsMap w1) (asBitsMap w2))
- where n1 = wordValueSize w1
- n2 = wordValueSize w2
-
-
-joinWords :: forall b w i
- . BitWord b w i
- => Integer
- -> Integer
- -> SeqMap b w i
- -> Eval (GenValue b w i)
-joinWords nParts nEach xs =
- loop (ready $ WordVal (wordLit 0 0)) (enumerateSeqMap nParts xs)
-
- where
- loop :: Eval (WordValue b w i) -> [Eval (GenValue b w i)] -> Eval (GenValue b w i)
- loop !wv [] = return $ VWord (nParts * nEach) wv
- loop !wv (w : ws) = do
- w >>= \case
- VWord _ w' -> loop (joinWordVal <$> wv <*> w') ws
- _ -> evalPanic "joinWords: expected word value" []
-
-
-joinSeq :: BitWord b w i
- => Nat'
- -> Integer
- -> TValue
- -> SeqMap b w i
- -> Eval (GenValue b w i)
-
--- Special case for 0 length inner sequences.
-joinSeq _parts 0 a _xs
- = return $ zeroV (TVSeq 0 a)
-
--- finite sequence of words
-joinSeq (Nat parts) each TVBit xs
- | parts * each < largeBitSize
- = joinWords parts each xs
- | otherwise
- = do let zs = IndexSeqMap $ \i ->
- do let (q,r) = divMod i each
- ys <- fromWordVal "join seq" =<< lookupSeqMap xs q
- VBit <$> indexWordValue ys (fromInteger r)
- return $ VWord (parts * each) $ ready $ LargeBitsVal (parts * each) zs
-
--- infinite sequence of words
-joinSeq Inf each TVBit xs
- = return $ VStream $ IndexSeqMap $ \i ->
- do let (q,r) = divMod i each
- ys <- fromWordVal "join seq" =<< lookupSeqMap xs q
- VBit <$> indexWordValue ys (fromInteger r)
-
--- finite or infinite sequence of non-words
-joinSeq parts each _a xs
- = return $ vSeq $ IndexSeqMap $ \i -> do
- let (q,r) = divMod i each
- ys <- fromSeq "join seq" =<< lookupSeqMap xs q
- lookupSeqMap ys r
- where
- len = parts `nMul` (Nat each)
- vSeq = case len of
- Inf -> VStream
- Nat n -> VSeq n
-
-
--- | Join a sequence of sequences into a single sequence.
-joinV :: BitWord b w i
- => Nat'
- -> Integer
- -> TValue
- -> GenValue b w i
- -> Eval (GenValue b w i)
-joinV parts each a val = joinSeq parts each a =<< fromSeq "joinV" val
-
-
-splitWordVal :: BitWord b w i
- => Integer
- -> Integer
- -> WordValue b w i
- -> (WordValue b w i, WordValue b w i)
-splitWordVal leftWidth rightWidth (WordVal w) =
- let (lw, rw) = splitWord leftWidth rightWidth w
- in (WordVal lw, WordVal rw)
-splitWordVal leftWidth _rightWidth (BitsVal bs) =
- let (lbs, rbs) = Seq.splitAt (fromInteger leftWidth) bs
- in (BitsVal lbs, BitsVal rbs)
-splitWordVal leftWidth rightWidth (LargeBitsVal _n xs) =
- let (lxs, rxs) = splitSeqMap leftWidth xs
- in (LargeBitsVal leftWidth lxs, LargeBitsVal rightWidth rxs)
-
-splitAtV :: BitWord b w i
- => Nat'
- -> Nat'
- -> TValue
- -> GenValue b w i
- -> Eval (GenValue b w i)
-splitAtV front back a val =
- case back of
-
- Nat rightWidth | aBit -> do
- ws <- delay Nothing (splitWordVal leftWidth rightWidth <$> fromWordVal "splitAtV" val)
- return $ VTuple
- [ VWord leftWidth . ready . fst <$> ws
- , VWord rightWidth . ready . snd <$> ws
- ]
-
- Inf | aBit -> do
- vs <- delay Nothing (fromSeq "splitAtV" val)
- ls <- delay Nothing (do m <- fst . splitSeqMap leftWidth <$> vs
- let ms = map (fromVBit <$>) (enumerateSeqMap leftWidth m)
- return $ Seq.fromList $ ms)
- rs <- delay Nothing (snd . splitSeqMap leftWidth <$> vs)
- return $ VTuple [ return $ VWord leftWidth (BitsVal <$> ls)
- , VStream <$> rs
- ]
-
- _ -> do
- vs <- delay Nothing (fromSeq "splitAtV" val)
- ls <- delay Nothing (fst . splitSeqMap leftWidth <$> vs)
- rs <- delay Nothing (snd . splitSeqMap leftWidth <$> vs)
- return $ VTuple [ VSeq leftWidth <$> ls
- , mkSeq back a <$> rs
- ]
-
- where
- aBit = isTBit a
-
- leftWidth = case front of
- Nat n -> n
- _ -> evalPanic "splitAtV" ["invalid `front` len"]
-
-
- -- | Extract a subsequence of bits from a @WordValue@.
- -- 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 `extractWordVal n i w` is equivalent to
- -- first shifting `w` right by `i` bits, and then truncating to
- -- `n` bits.
-extractWordVal :: BitWord b w i
- => Integer
- -> Integer
- -> WordValue b w i
- -> WordValue b w i
-extractWordVal len start (WordVal w) =
- WordVal $ extractWord len start w
-extractWordVal len start (BitsVal bs) =
- BitsVal $ Seq.take (fromInteger len) $
- Seq.drop (Seq.length bs - fromInteger start - fromInteger len) bs
-extractWordVal len start (LargeBitsVal n xs) =
- let xs' = dropSeqMap (n - start - len) xs
- in LargeBitsVal len xs'
-
-
--- | Split implementation.
-ecSplitV :: BitWord b w i
- => GenValue b w i
-ecSplitV =
- nlam $ \ parts ->
- nlam $ \ each ->
- tlam $ \ a ->
- lam $ \ val ->
- case (parts, each) of
- (Nat p, Nat e) | isTBit a -> do
- ~(VWord _ val') <- val
- return $ VSeq p $ IndexSeqMap $ \i -> do
- return $ VWord e (extractWordVal e ((p-i-1)*e) <$> val')
- (Inf, Nat e) | isTBit a -> do
- val' <- delay Nothing (fromSeq "ecSplitV" =<< val)
- return $ VStream $ IndexSeqMap $ \i ->
- return $ VWord e $ return $ BitsVal $ Seq.fromFunction (fromInteger e) $ \j ->
- let idx = i*e + toInteger j
- in idx `seq` do
- xs <- val'
- fromVBit <$> lookupSeqMap xs idx
- (Nat p, Nat e) -> do
- val' <- delay Nothing (fromSeq "ecSplitV" =<< val)
- return $ VSeq p $ IndexSeqMap $ \i ->
- return $ VSeq e $ IndexSeqMap $ \j -> do
- xs <- val'
- lookupSeqMap xs (e * i + j)
- (Inf , Nat e) -> do
- val' <- delay Nothing (fromSeq "ecSplitV" =<< val)
- return $ VStream $ IndexSeqMap $ \i ->
- return $ VSeq e $ IndexSeqMap $ \j -> do
- xs <- val'
- lookupSeqMap xs (e * i + j)
- _ -> evalPanic "splitV" ["invalid type arguments to split"]
-
-
-reverseV :: forall b w i
- . BitWord b w i
- => GenValue b w i
- -> Eval (GenValue b w i)
-reverseV (VSeq n xs) =
- return $ VSeq n $ reverseSeqMap n xs
-reverseV (VWord n wv) = return (VWord n (revword <$> wv))
- where
- revword (WordVal w) = BitsVal $ Seq.reverse $ Seq.fromList $ map ready $ unpackWord w
- revword (BitsVal bs) = BitsVal $ Seq.reverse bs
- revword (LargeBitsVal m xs) = LargeBitsVal m $ reverseSeqMap m xs
-reverseV _ =
- evalPanic "reverseV" ["Not a finite sequence"]
-
-
-transposeV :: BitWord b w i
- => Nat'
- -> Nat'
- -> TValue
- -> GenValue b w i
- -> Eval (GenValue b w i)
-transposeV a b c xs
- | isTBit c, Nat na <- a = -- Fin a => [a][b]Bit -> [b][a]Bit
- return $ bseq $ IndexSeqMap $ \bi ->
- return $ VWord na $ return $ BitsVal $
- Seq.fromFunction (fromInteger na) $ \ai -> do
- ys <- flip lookupSeqMap (toInteger ai) =<< fromSeq "transposeV" xs
- case ys of
- VStream ys' -> fromVBit <$> lookupSeqMap ys' bi
- VWord _ wv -> flip indexWordValue bi =<< wv
- _ -> evalPanic "transpose" ["expected sequence of bits"]
-
- | isTBit c, Inf <- a = -- [inf][b]Bit -> [b][inf]Bit
- return $ bseq $ IndexSeqMap $ \bi ->
- return $ VStream $ IndexSeqMap $ \ai ->
- do ys <- flip lookupSeqMap ai =<< fromSeq "transposeV" xs
- case ys of
- VStream ys' -> VBit . fromVBit <$> lookupSeqMap ys' bi
- VWord _ wv -> VBit <$> (flip indexWordValue bi =<< wv)
- _ -> evalPanic "transpose" ["expected sequence of bits"]
-
- | otherwise = -- [a][b]c -> [b][a]c
- return $ bseq $ IndexSeqMap $ \bi ->
- return $ aseq $ IndexSeqMap $ \ai -> do
- ys <- flip lookupSeqMap ai =<< fromSeq "transposeV 1" xs
- z <- flip lookupSeqMap bi =<< fromSeq "transposeV 2" ys
- return z
-
- where
- bseq =
- case b of
- Nat nb -> VSeq nb
- Inf -> VStream
- aseq =
- case a of
- Nat na -> VSeq na
- Inf -> VStream
-
-
-
-
-ccatV :: (Show b, Show w, BitWord b w i)
- => Nat'
- -> Nat'
- -> TValue
- -> (GenValue b w i)
- -> (GenValue b w i)
- -> Eval (GenValue b w i)
-
-ccatV _front _back _elty (VWord m l) (VWord n r) =
- return $ VWord (m+n) (joinWordVal <$> l <*> r)
-
-ccatV _front _back _elty (VWord m l) (VStream r) = do
- l' <- delay Nothing l
- return $ VStream $ IndexSeqMap $ \i ->
- if i < m then
- VBit <$> (flip indexWordValue i =<< l')
- else
- lookupSeqMap r (i-m)
-
-ccatV front back elty l r = do
- l'' <- delay Nothing (fromSeq "ccatV left" l)
- r'' <- delay Nothing (fromSeq "ccatV right" r)
- let Nat n = front
- mkSeq (evalTF TCAdd [front,back]) elty <$> return (IndexSeqMap $ \i ->
- if i < n then do
- ls <- l''
- lookupSeqMap ls i
- else do
- rs <- r''
- lookupSeqMap rs (i-n))
-
-wordValLogicOp :: BitWord b w i
- => (b -> b -> b)
- -> (w -> w -> w)
- -> WordValue b w i
- -> WordValue b w i
- -> Eval (WordValue b w i)
-wordValLogicOp _ wop (WordVal w1) (WordVal w2) = return $ WordVal (wop w1 w2)
-wordValLogicOp bop _ (BitsVal xs) (BitsVal ys) =
- BitsVal <$> sequence (Seq.zipWith (\x y -> delay Nothing (bop <$> x <*> y)) xs ys)
-wordValLogicOp bop _ (WordVal w1) (BitsVal ys) =
- ready $ BitsVal $ Seq.zipWith (\x y -> bop <$> x <*> y) (Seq.fromList $ map ready $ unpackWord w1) ys
-wordValLogicOp bop _ (BitsVal xs) (WordVal w2) =
- ready $ BitsVal $ Seq.zipWith (\x y -> bop <$> x <*> y) xs (Seq.fromList $ map ready $ unpackWord w2)
-wordValLogicOp bop _ w1 w2 = LargeBitsVal (wordValueSize w1) <$> zs
- where zs = memoMap $ IndexSeqMap $ \i -> op <$> (lookupSeqMap xs i) <*> (lookupSeqMap ys i)
- xs = asBitsMap w1
- ys = asBitsMap w2
- op x y = VBit (bop (fromVBit x) (fromVBit y))
-
--- | Merge two values given a binop. This is used for and, or and xor.
-logicBinary :: forall b w i
- . BitWord b w i
- => (b -> b -> b)
- -> (w -> w -> w)
- -> Binary b w i
-logicBinary opb opw = loop
- where
- loop' :: TValue
- -> Eval (GenValue b w i)
- -> Eval (GenValue b w i)
- -> Eval (GenValue b w i)
- loop' ty l r = join (loop ty <$> l <*> r)
-
- loop :: TValue
- -> GenValue b w i
- -> GenValue b w i
- -> Eval (GenValue b w i)
-
- loop ty l r = case ty of
- TVBit -> return $ VBit (opb (fromVBit l) (fromVBit r))
- TVInteger -> evalPanic "logicBinary" ["Integer not in class Logic"]
- TVIntMod _ -> evalPanic "logicBinary" ["Z not in class Logic"]
- TVSeq w aty
- -- words
- | isTBit aty
- -> do v <- delay Nothing $ join
- (wordValLogicOp opb opw <$>
- fromWordVal "logicBinary l" l <*>
- fromWordVal "logicBinary r" r)
- return $ VWord w v
-
- -- finite sequences
- | otherwise -> VSeq w <$>
- (join (zipSeqMap (loop aty) <$>
- (fromSeq "logicBinary left" l)
- <*> (fromSeq "logicBinary right" r)))
-
- TVStream aty ->
- VStream <$> (join (zipSeqMap (loop aty) <$>
- (fromSeq "logicBinary left" l) <*>
- (fromSeq "logicBinary right" r)))
-
- TVTuple etys -> do
- ls <- mapM (delay Nothing) (fromVTuple l)
- rs <- mapM (delay Nothing) (fromVTuple r)
- return $ VTuple $ zipWith3 loop' etys ls rs
-
- TVFun _ bty ->
- return $ lam $ \ a -> loop' bty (fromVFun l a) (fromVFun r a)
-
- TVRec fields ->
- do fs <- sequence
- [ (f,) <$> delay Nothing (loop' fty a b)
- | (f,fty) <- fields
- , let a = lookupRecord f l
- b = lookupRecord f r
- ]
- return $ VRecord fs
-
- TVAbstract {} -> evalPanic "logicBinary"
- [ "Abstract type not in `Logic`" ]
-
-
-wordValUnaryOp :: BitWord b w i
- => (b -> b)
- -> (w -> w)
- -> WordValue b w i
- -> Eval (WordValue b w i)
-wordValUnaryOp _ wop (WordVal w) = return $ WordVal (wop w)
-wordValUnaryOp bop _ (BitsVal bs) = return $ BitsVal (fmap (bop <$>) bs)
-wordValUnaryOp bop _ (LargeBitsVal n xs) = LargeBitsVal n <$> mapSeqMap f xs
- where f x = VBit . bop <$> fromBit x
-
-logicUnary :: forall b w i
- . BitWord b w i
- => (b -> b)
- -> (w -> w)
- -> Unary b w i
-logicUnary opb opw = loop
- where
- loop' :: TValue -> Eval (GenValue b w i) -> Eval (GenValue b w i)
- loop' ty val = loop ty =<< val
-
- loop :: TValue -> GenValue b w i -> Eval (GenValue b w i)
- loop ty val = case ty of
- TVBit -> return . VBit . opb $ fromVBit val
-
- TVInteger -> evalPanic "logicUnary" ["Integer not in class Logic"]
- TVIntMod _ -> evalPanic "logicUnary" ["Z not in class Logic"]
-
- TVSeq w ety
- -- words
- | isTBit ety
- -> do v <- delay Nothing (wordValUnaryOp opb opw =<< fromWordVal "logicUnary" val)
- return $ VWord w v
-
- -- finite sequences
- | otherwise
- -> VSeq w <$> (mapSeqMap (loop ety) =<< fromSeq "logicUnary" val)
-
- -- streams
- TVStream ety ->
- VStream <$> (mapSeqMap (loop ety) =<< fromSeq "logicUnary" val)
-
- TVTuple etys ->
- do as <- mapM (delay Nothing) (fromVTuple val)
- return $ VTuple (zipWith loop' etys as)
-
- TVFun _ bty ->
- return $ lam $ \ a -> loop' bty (fromVFun val a)
-
- TVRec fields ->
- do fs <- sequence
- [ (f,) <$> delay Nothing (loop' fty a)
- | (f,fty) <- fields, let a = lookupRecord f val
- ]
- return $ VRecord fs
-
- TVAbstract {} -> evalPanic "logicUnary" [ "Abstract type not in `Logic`" ]
-
-
-logicShift :: (Integer -> Integer -> Integer -> Integer)
- -- ^ The function may assume its arguments are masked.
- -- It is responsible for masking its result if needed.
- -> (Integer -> Seq.Seq (Eval Bool) -> Integer -> Seq.Seq (Eval Bool))
- -> (Nat' -> TValue -> SeqValMap -> Integer -> SeqValMap)
- -> Value
-logicShift opW obB opS
- = nlam $ \ a ->
- nlam $ \ _ ->
- tlam $ \ c ->
- lam $ \ l -> return $
- lam $ \ r -> do
- BV _ i <- fromVWord "logicShift amount" =<< r
- l >>= \case
- VWord w wv -> return $ VWord w $ wv >>= \case
- WordVal (BV _ x) -> return $ WordVal (BV w (opW w x i))
- BitsVal bs -> return $ BitsVal (obB w bs i)
- LargeBitsVal n xs -> return $ LargeBitsVal n $ opS (Nat n) c xs i
-
- _ -> mkSeq a c <$> (opS a c <$> (fromSeq "logicShift" =<< l) <*> return i)
-
--- Left shift for words.
-shiftLW :: Integer -> Integer -> Integer -> Integer
-shiftLW w ival by
- | by >= w = 0
- | otherwise = mask w (shiftL ival (fromInteger by))
-
-shiftLB :: Integer -> Seq.Seq (Eval Bool) -> Integer -> Seq.Seq (Eval Bool)
-shiftLB w bs by =
- Seq.drop (fromInteger (min w by)) bs
- Seq.><
- Seq.replicate (fromInteger (min w by)) (ready False)
-
-shiftLS :: Nat' -> TValue -> SeqValMap -> Integer -> SeqValMap
-shiftLS w ety vs by = IndexSeqMap $ \i ->
- case w of
- Nat len
- | i+by < len -> lookupSeqMap vs (i+by)
- | i < len -> return $ zeroV ety
- | otherwise -> evalPanic "shiftLS" ["Index out of bounds"]
- Inf -> lookupSeqMap vs (i+by)
-
-shiftRW :: Integer -> Integer -> Integer -> Integer
-shiftRW w i by
- | by >= w = 0
- | otherwise = shiftR i (fromInteger by)
-
-shiftRB :: Integer -> Seq.Seq (Eval Bool) -> Integer -> Seq.Seq (Eval Bool)
-shiftRB w bs by =
- Seq.replicate (fromInteger (min w by)) (ready False)
- Seq.><
- Seq.take (fromInteger (w - min w by)) bs
-
-shiftRS :: Nat' -> TValue -> SeqValMap -> Integer -> SeqValMap
-shiftRS w ety vs by = IndexSeqMap $ \i ->
- case w of
- Nat len
- | i >= by -> lookupSeqMap vs (i-by)
- | i < len -> return $ zeroV ety
- | otherwise -> evalPanic "shiftLS" ["Index out of bounds"]
- Inf
- | i >= by -> lookupSeqMap vs (i-by)
- | otherwise -> return $ zeroV ety
-
-
--- XXX integer doesn't implement rotateL, as there's no bit bound
-rotateLW :: Integer -> Integer -> Integer -> Integer
-rotateLW 0 i _ = i
-rotateLW w i by = mask w $ (i `shiftL` b) .|. (i `shiftR` (fromInteger w - b))
- where b = fromInteger (by `mod` w)
-
-rotateLB :: Integer -> Seq.Seq (Eval Bool) -> Integer -> Seq.Seq (Eval Bool)
-rotateLB w bs by =
- let (hd,tl) = Seq.splitAt (fromInteger (by `mod` w)) bs
- in tl Seq.>< hd
-
-rotateLS :: Nat' -> TValue -> SeqValMap -> Integer -> SeqValMap
-rotateLS w _ vs by = IndexSeqMap $ \i ->
- case w of
- Nat len -> lookupSeqMap vs ((by + i) `mod` len)
- _ -> panic "Cryptol.Eval.Prim.rotateLS" [ "unexpected infinite sequence" ]
-
--- XXX integer doesn't implement rotateR, as there's no bit bound
-rotateRW :: Integer -> Integer -> Integer -> Integer
-rotateRW 0 i _ = i
-rotateRW w i by = mask w $ (i `shiftR` b) .|. (i `shiftL` (fromInteger w - b))
- where b = fromInteger (by `mod` w)
-
-rotateRB :: Integer -> Seq.Seq (Eval Bool) -> Integer -> Seq.Seq (Eval Bool)
-rotateRB w bs by =
- let (hd,tl) = Seq.splitAt (fromInteger (w - (by `mod` w))) bs
- in tl Seq.>< hd
-
-rotateRS :: Nat' -> TValue -> SeqValMap -> Integer -> SeqValMap
-rotateRS w _ vs by = IndexSeqMap $ \i ->
- case w of
- Nat len -> lookupSeqMap vs ((len - by + i) `mod` len)
- _ -> panic "Cryptol.Eval.Prim.rotateRS" [ "unexpected infinite sequence" ]
-
-
--- Sequence Primitives ---------------------------------------------------------
-
--- | Indexing operations.
-indexPrim :: BitWord b w i
- => (Maybe Integer -> TValue -> SeqMap b w i -> Seq.Seq b -> Eval (GenValue b w i))
- -> (Maybe Integer -> TValue -> SeqMap b w i -> w -> Eval (GenValue b w i))
- -> GenValue b w i
-indexPrim bits_op word_op =
- nlam $ \ n ->
- tlam $ \ a ->
- nlam $ \ _i ->
- lam $ \ l -> return $
- lam $ \ r -> do
- vs <- l >>= \case
- VWord _ w -> w >>= \w' -> return $ IndexSeqMap (\i -> VBit <$> indexWordValue w' i)
- VSeq _ vs -> return vs
- VStream vs -> return vs
- _ -> evalPanic "Expected sequence value" ["indexPrim"]
- r >>= \case
- VWord _ w -> w >>= \case
- WordVal w' -> word_op (fromNat n) a vs w'
- BitsVal bs -> bits_op (fromNat n) a vs =<< sequence bs
- LargeBitsVal m xs -> bits_op (fromNat n) a vs . Seq.fromList =<< traverse (fromBit =<<) (enumerateSeqMap m xs)
- _ -> evalPanic "Expected word value" ["indexPrim"]
-
-indexFront :: Maybe Integer -> TValue -> SeqValMap -> BV -> Eval Value
-indexFront mblen _a vs (bvVal -> ix) =
- case mblen of
- Just len | len <= ix -> invalidIndex ix
- _ -> lookupSeqMap vs ix
-
-indexFront_bits :: Maybe Integer -> TValue -> SeqValMap -> Seq.Seq Bool -> Eval Value
-indexFront_bits mblen a vs = indexFront mblen a vs . packWord . Fold.toList
-
-indexBack :: Maybe Integer -> TValue -> SeqValMap -> BV -> Eval Value
-indexBack mblen _a vs (bvVal -> ix) =
- case mblen of
- Just len | len > ix -> lookupSeqMap vs (len - ix - 1)
- | otherwise -> invalidIndex ix
- Nothing -> evalPanic "indexBack"
- ["unexpected infinite sequence"]
-
-indexBack_bits :: Maybe Integer -> TValue -> SeqValMap -> Seq.Seq Bool -> Eval Value
-indexBack_bits mblen a vs = indexBack mblen a vs . packWord . Fold.toList
-
-
-updateFront
- :: Nat'
- -> TValue
- -> SeqMap Bool BV Integer
- -> WordValue Bool BV Integer
- -> Eval (GenValue Bool BV Integer)
- -> Eval (SeqMap Bool BV Integer)
-updateFront len _eltTy vs w val = do
- idx <- bvVal <$> asWordVal w
- case len of
- Inf -> return ()
- Nat n -> unless (idx < n) (invalidIndex idx)
- return $ updateSeqMap vs idx val
-
-updateFront_word
- :: Nat'
- -> TValue
- -> WordValue Bool BV Integer
- -> WordValue Bool BV Integer
- -> Eval (GenValue Bool BV Integer)
- -> Eval (WordValue Bool BV Integer)
-updateFront_word _len _eltTy bs w val = do
- idx <- bvVal <$> asWordVal w
- updateWordValue bs idx (fromBit =<< val)
-
-updateBack
- :: Nat'
- -> TValue
- -> SeqMap Bool BV Integer
- -> WordValue Bool BV Integer
- -> Eval (GenValue Bool BV Integer)
- -> Eval (SeqMap Bool BV Integer)
-updateBack Inf _eltTy _vs _w _val =
- evalPanic "Unexpected infinite sequence in updateEnd" []
-updateBack (Nat n) _eltTy vs w val = do
- idx <- bvVal <$> asWordVal w
- unless (idx < n) (invalidIndex idx)
- return $ updateSeqMap vs (n - idx - 1) val
-
-updateBack_word
- :: Nat'
- -> TValue
- -> WordValue Bool BV Integer
- -> WordValue Bool BV Integer
- -> Eval (GenValue Bool BV Integer)
- -> Eval (WordValue Bool BV Integer)
-updateBack_word Inf _eltTy _bs _w _val =
- evalPanic "Unexpected infinite sequence in updateEnd" []
-updateBack_word (Nat n) _eltTy bs w val = do
- idx <- bvVal <$> asWordVal w
- updateWordValue bs (n - idx - 1) (fromBit =<< val)
-
-{-
- idx <- bvVal <$> asWordVal w
- unless (idx < n) (invalidIndex idx)
- let idx' = n - idx - 1
- return $! Seq.update (fromInteger idx') (fromVBit <$> val) bs
--}
-
-
-updatePrim
- :: BitWord b w i
- => (Nat' -> TValue -> WordValue b w i -> WordValue b w i -> Eval (GenValue b w i) -> Eval (WordValue b w i))
- -> (Nat' -> TValue -> SeqMap b w i -> WordValue b w i -> Eval (GenValue b w i) -> Eval (SeqMap b w i))
- -> GenValue b w i
-updatePrim updateWord updateSeq =
- nlam $ \len ->
- tlam $ \eltTy ->
- nlam $ \_idxLen ->
- lam $ \xs -> return $
- lam $ \idx -> return $
- lam $ \val -> do
- idx' <- fromWordVal "update" =<< idx
- xs >>= \case
- VWord l w -> do w' <- delay Nothing w
- return $ VWord l (w' >>= \w'' -> updateWord len eltTy w'' idx' val)
- VSeq l vs -> VSeq l <$> updateSeq len eltTy vs idx' val
- VStream vs -> VStream <$> updateSeq len eltTy vs idx' val
- _ -> evalPanic "Expected sequence value" ["updatePrim"]
-
--- @[ 0 .. 10 ]@
-fromToV :: BitWord b w i
- => GenValue b w i
-fromToV =
- nlam $ \ first ->
- nlam $ \ lst ->
- tlam $ \ ty ->
- let !f = mkLit ty in
- case (first, lst) of
- (Nat first', Nat lst') ->
- let len = 1 + (lst' - first')
- in VSeq len $ IndexSeqMap $ \i -> ready $ f (first' + i)
- _ -> evalPanic "fromToV" ["invalid arguments"]
-
--- @[ 0, 1 .. 10 ]@
-fromThenToV :: BitWord b w i
- => GenValue b w i
-fromThenToV =
- nlam $ \ first ->
- nlam $ \ next ->
- nlam $ \ lst ->
- tlam $ \ ty ->
- nlam $ \ len ->
- let !f = mkLit ty in
- case (first, next, lst, len) of
- (Nat first', Nat next', Nat _lst', Nat len') ->
- let diff = next' - first'
- in VSeq len' $ IndexSeqMap $ \i -> ready $ f (first' + i*diff)
- _ -> evalPanic "fromThenToV" ["invalid arguments"]
-
-
-infFromV :: BitWord b w i => GenValue b w i
-infFromV =
- tlam $ \ ty ->
- lam $ \ x' ->
- return $ VStream $ IndexSeqMap $ \i ->
- do x <- x'
- addV ty x (intV (integerLit i) ty)
-
-infFromThenV :: BitWord b w i => GenValue b w i
-infFromThenV =
- tlam $ \ ty ->
- lam $ \ first -> return $
- lam $ \ next ->
- do x <- first
- y <- next
- d <- subV ty y x
- return $ VStream $ IndexSeqMap $ \i ->
- addV ty x =<< mulV ty d (intV (integerLit i) ty)
-
--- Random Values ---------------------------------------------------------------
-
--- | 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 :: BitWord b w i => TValue -> Integer -> GenValue b w i
-randomV ty seed =
- case randomValue (tValTy ty) of
- Nothing -> zeroV 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)
-
--- Miscellaneous ---------------------------------------------------------------
-
-errorV :: forall b w i
- . BitWord b w i
- => TValue
- -> String
- -> Eval (GenValue b w i)
-errorV ty msg = case ty of
- -- bits
- TVBit -> cryUserError msg
- TVInteger -> cryUserError msg
- TVIntMod _ -> cryUserError msg
-
- -- sequences
- TVSeq w ety
- | isTBit ety -> return $ VWord w $ return $ BitsVal $
- Seq.replicate (fromInteger w) (cryUserError msg)
- | otherwise -> return $ VSeq w (IndexSeqMap $ \_ -> errorV ety msg)
-
- TVStream ety ->
- return $ VStream (IndexSeqMap $ \_ -> errorV ety msg)
-
- -- functions
- TVFun _ bty ->
- return $ lam (\ _ -> errorV bty msg)
-
- -- tuples
- TVTuple tys ->
- return $ VTuple (map (flip errorV msg) tys)
-
- -- records
- TVRec fields ->
- return $ VRecord [ (f,errorV fty msg) | (f,fty) <- fields ]
-
- TVAbstract {} -> cryUserError msg
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
@@ -7,6 +7,8 @@
-- Portability : portable
{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RecordWildCards #-}
@@ -58,10 +60,12 @@
import qualified Cryptol.Utils.Ident as M
import qualified Cryptol.ModuleSystem.Env as M
+import Cryptol.Eval.Concrete( Concrete(..) )
+import qualified Cryptol.Eval.Concrete as Concrete
import qualified Cryptol.Eval.Monad as E
import qualified Cryptol.Eval.Value as E
import qualified Cryptol.Eval.Reference as R
-import Cryptol.Testing.Concrete
+import Cryptol.Testing.Random
import qualified Cryptol.Testing.Random as TestR
import Cryptol.Parser
(parseExprWith,parseReplWith,ParseError(),Config(..),defaultConfig
@@ -72,13 +76,18 @@
import qualified Cryptol.TypeCheck.Subst as T
import Cryptol.TypeCheck.Solve(defaultReplExpr)
import qualified Cryptol.TypeCheck.Solver.SMT as SMT
-import Cryptol.TypeCheck.PP (dump,ppWithNames,emptyNameMap,backticks)
-import Cryptol.Utils.PP
-import Cryptol.Utils.Panic(panic)
+import Cryptol.TypeCheck.PP (dump,ppWithNames,emptyNameMap)
+import Cryptol.Utils.PP
+import Cryptol.Utils.Panic(panic)
+import Cryptol.Utils.RecordMap
import qualified Cryptol.Parser.AST as P
import qualified Cryptol.Transform.Specialize as S
-import Cryptol.Symbolic (ProverCommand(..), QueryType(..), SatNum(..),ProverStats)
-import qualified Cryptol.Symbolic as Symbolic
+import Cryptol.Symbolic
+ ( ProverCommand(..), QueryType(..)
+ , ProverStats,ProverResult(..),CounterExampleType(..)
+ )
+import qualified Cryptol.Symbolic.SBV as SBV
+import qualified Cryptol.Symbolic.What4 as W4
import qualified Control.Exception as X
import Control.Monad hiding (mapM, mapM)
@@ -86,10 +95,11 @@
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS8
-import Data.Bits ((.&.))
+import Data.Bits (shiftL, (.&.), (.|.))
import Data.Char (isSpace,isPunctuation,isSymbol,isAlphaNum,isAscii)
import Data.Function (on)
-import Data.List (intercalate, nub, sortBy, partition, isPrefixOf,intersperse)
+import Data.List (intercalate, nub, sortBy, groupBy,
+ partition, isPrefixOf,intersperse)
import Data.Maybe (fromMaybe,mapMaybe,isNothing)
import System.Environment (lookupEnv)
import System.Exit (ExitCode(ExitSuccess))
@@ -99,9 +109,12 @@
import System.Directory(getHomeDirectory,setCurrentDirectory,doesDirectoryExist
,getTemporaryDirectory,setPermissions,removeFile
,emptyPermissions,setOwnerReadable)
+import Data.Map (Map)
import qualified Data.Map as Map
import qualified Data.Set as Set
-import System.IO(hFlush,stdout,openTempFile,hClose)
+import System.IO
+ (Handle,hFlush,stdout,openTempFile,hClose,openFile
+ ,IOMode(..),hGetContents,hSeek,SeekMode(..))
import System.Random.TF(newTFGen)
import Numeric (showFFloat)
import qualified Data.Text as T
@@ -112,7 +125,6 @@
import Prelude ()
import Prelude.Compat
-import qualified Data.SBV as SBV (Solver)
import qualified Data.SBV.Internals as SBV (showTDiff)
-- Commands --------------------------------------------------------------------
@@ -126,10 +138,11 @@
-- | Command builder.
data CommandDescr = CommandDescr
- { cNames :: [String]
- , cArgs :: [String]
- , cBody :: CommandBody
- , cHelp :: String
+ { cNames :: [String]
+ , cArgs :: [String]
+ , cBody :: CommandBody
+ , cHelp :: String
+ , cLongHelp :: String
}
instance Show CommandDescr where
@@ -177,28 +190,50 @@
nbCommandList =
[ CommandDescr [ ":t", ":type" ] ["EXPR"] (ExprArg typeOfCmd)
"Check the type of an expression."
+ ""
, CommandDescr [ ":b", ":browse" ] ["[ MODULE ]"] (ModNameArg browseCmd)
"Display environment for all loaded modules, or for a specific module."
+ ""
, CommandDescr [ ":?", ":help" ] ["[ TOPIC ]"] (HelpArg helpCmd)
- "Display a brief description of a function, type, or command."
+ "Display a brief description of a function, type, or command. (e.g. :help :help)"
+ (unlines
+ [ "TOPIC can be any of:"
+ , " * Specific REPL colon-commands (e.g. :help :prove)"
+ , " * Functions (e.g. :help join)"
+ , " * Infix operators (e.g. :help +)"
+ , " * Type constructors (e.g. :help Z)"
+ , " * Type constraints (e.g. :help fin)"
+ , " * :set-able options (e.g. :help :set base)" ])
, CommandDescr [ ":s", ":set" ] ["[ OPTION [ = VALUE ] ]"] (OptionArg setOptionCmd)
"Set an environmental option (:set on its own displays current values)."
+ ""
, CommandDescr [ ":check" ] ["[ EXPR ]"] (ExprArg (void . qcCmd QCRandom))
"Use random testing to check that the argument always returns true.\n(If no argument, check all properties.)"
+ ""
, CommandDescr [ ":exhaust" ] ["[ EXPR ]"] (ExprArg (void . qcCmd QCExhaust))
"Use exhaustive testing to prove that the argument always returns\ntrue. (If no argument, check all properties.)"
+ ""
, CommandDescr [ ":prove" ] ["[ EXPR ]"] (ExprArg proveCmd)
"Use an external solver to prove that the argument always returns\ntrue. (If no argument, check all properties.)"
+ ""
, CommandDescr [ ":sat" ] ["[ EXPR ]"] (ExprArg satCmd)
"Use a solver to find a satisfying assignment for which the argument\nreturns true. (If no argument, find an assignment for all properties.)"
+ ""
+ , CommandDescr [ ":safe" ] ["[ EXPR ]"] (ExprArg safeCmd)
+ "Use an external solver to prove that an expression is safe\n(does not encounter run-time errors) for all inputs."
+ ""
, CommandDescr [ ":debug_specialize" ] ["EXPR"](ExprArg specializeCmd)
"Do type specialization on a closed expression."
+ ""
, CommandDescr [ ":eval" ] ["EXPR"] (ExprArg refEvalCmd)
"Evaluate an expression with the reference evaluator."
+ ""
, CommandDescr [ ":ast" ] ["EXPR"] (ExprArg astOfCmd)
"Print out the pre-typechecked AST of a given term."
+ ""
, CommandDescr [ ":extract-coq" ] [] (NoArg allTerms)
"Print out the post-typechecked AST of all currently defined terms,\nin a Coq-parseable format."
+ ""
]
commandList :: [CommandDescr]
@@ -206,28 +241,38 @@
nbCommandList ++
[ CommandDescr [ ":q", ":quit" ] [] (NoArg quitCmd)
"Exit the REPL."
+ ""
, CommandDescr [ ":l", ":load" ] ["FILE"] (FilenameArg loadCmd)
"Load a module by filename."
+ ""
, CommandDescr [ ":r", ":reload" ] [] (NoArg reloadCmd)
"Reload the currently loaded module."
+ ""
, CommandDescr [ ":e", ":edit" ] ["[ FILE ]"] (FilenameArg editCmd)
"Edit FILE or the currently loaded module."
+ ""
, CommandDescr [ ":!" ] ["COMMAND"] (ShellArg runShellCmd)
"Execute a command in the shell."
+ ""
, CommandDescr [ ":cd" ] ["DIR"] (FilenameArg cdCmd)
"Set the current working directory."
+ ""
, CommandDescr [ ":m", ":module" ] ["[ MODULE ]"] (FilenameArg moduleCmd)
"Load a module by its name."
+ ""
, CommandDescr [ ":w", ":writeByteArray" ] ["FILE", "EXPR"] (FileExprArg writeFileCmd)
"Write data of type 'fin n => [n][8]' to a file."
+ ""
, CommandDescr [ ":readByteArray" ] ["FILE"] (FilenameArg readFileCmd)
"Read data from a file as type 'fin n => [n][8]', binding\nthe value to variable 'it'."
+ ""
, CommandDescr [ ":dumptests" ] ["FILE", "EXPR"] (FileExprArg dumpTestsCmd)
(unlines [ "Dump a tab-separated collection of tests for the given"
, "expression into a file. The first column in each line is"
, "the expected output, and the remainder are the inputs. The"
, "number of tests is determined by the \"tests\" option."
])
+ ""
]
genHelp :: [CommandDescr] -> [String]
@@ -265,9 +310,19 @@
do base <- getKnownUser "base"
ascii <- getKnownUser "ascii"
infLength <- getKnownUser "infLength"
+
+ fpBase <- getKnownUser "fp-base"
+ fpFmtTxt <- getKnownUser "fp-format"
+ let fpFmt = case parsePPFloatFormat fpFmtTxt of
+ Just f -> f
+ Nothing -> panic "getPPValOpts"
+ [ "Failed to parse fp-format" ]
+
return E.PPOpts { E.useBase = base
, E.useAscii = ascii
, E.useInfLength = infLength
+ , E.useFPBase = fpBase
+ , E.useFPFormat = fpFmt
}
getEvalOpts :: REPL E.EvalOpts
@@ -286,7 +341,7 @@
P.ExprInput expr -> do
(val,_ty) <- replEvalExpr expr
ppOpts <- getPPValOpts
- valDoc <- rEvalRethrow (E.ppValue ppOpts val)
+ valDoc <- rEvalRethrow (E.ppValue Concrete ppOpts val)
-- This is the point where the value gets forced. We deepseq the
-- pretty-printed representation of it, rather than the value
@@ -301,14 +356,24 @@
-- be generalized if mono-binds is enabled
replEvalDecl decl
-printCounterexample :: Bool -> P.Expr P.PName -> [E.Value] -> REPL ()
-printCounterexample isSat pexpr vs =
+printCounterexample :: CounterExampleType -> P.Expr P.PName -> [Concrete.Value] -> REPL ()
+printCounterexample cexTy pexpr vs =
do ppOpts <- getPPValOpts
- docs <- mapM (rEval . E.ppValue ppOpts) vs
+ docs <- mapM (rEval . E.ppValue Concrete ppOpts) vs
let doc = ppPrec 3 pexpr -- function application has precedence 3
rPrint $ hang doc 2 (sep docs) <+>
- text (if isSat then "= True" else "= False")
+ case cexTy of
+ SafetyViolation -> text "~> ERROR"
+ PredicateFalsified -> text "= False"
+printSatisfyingModel :: P.Expr P.PName -> [Concrete.Value] -> REPL ()
+printSatisfyingModel pexpr vs =
+ do ppOpts <- getPPValOpts
+ docs <- mapM (rEval . E.ppValue Concrete ppOpts) vs
+ let doc = ppPrec 3 pexpr -- function application has precedence 3
+ rPrint $ hang doc 2 (sep docs) <+> text ("= True")
+
+
dumpTestsCmd :: FilePath -> String -> REPL ()
dumpTestsCmd outFile str =
do expr <- replParseExpr str
@@ -324,8 +389,8 @@
tests <- io $ TestR.returnTests g evo gens val testNum
out <- forM tests $
\(args, x) ->
- do argOut <- mapM (rEval . E.ppValue ppopts) args
- resOut <- rEval (E.ppValue ppopts x)
+ do argOut <- mapM (rEval . E.ppValue Concrete ppopts) args
+ resOut <- rEval (E.ppValue Concrete ppopts x)
return (renderOneLine resOut ++ "\t" ++ intercalate "\t" (map renderOneLine argOut) ++ "\n")
io $ writeFile outFile (concat out) `X.catch` handler
where
@@ -361,7 +426,7 @@
["Exhaustive testing ran out of test cases"]
f _ (vs : vss1) = do
evo <- getEvalOpts
- result <- io $ runOneTest evo val vs
+ result <- io $ evalTest evo val vs
return (result, vss1)
testSpec = TestSpec {
testFn = f
@@ -381,7 +446,7 @@
return [report]
Just (sz,tys,_) | qcMode == QCRandom ->
- case TestR.testableType ty of
+ case TestR.testableTypeGenerators ty of
Nothing -> raise (TypeNotTestable ty)
Just gens -> do
rPutStrLn "Using random testing."
@@ -452,13 +517,12 @@
opts <- getPPValOpts
case failure of
FailFalse vs -> do
- let isSat = False
- printCounterexample isSat pexpr vs
+ printCounterexample PredicateFalsified pexpr vs
case (tys,vs) of
([t],[v]) -> bindItVariableVal t v
_ -> let fs = [ M.packIdent ("arg" ++ show (i::Int)) | i <- [ 1 .. ] ]
- t = T.TRec (zip fs tys)
- v = E.VRecord (zip fs (map return vs))
+ t = T.TRec (recordFromFields (zip fs tys))
+ v = E.VRecord (recordFromFields (zip fs (map return vs)))
in bindItVariableVal t v
FailError err [] -> do
@@ -466,7 +530,7 @@
rPrint (pp err)
FailError err vs -> do
prtLn "ERROR for the following inputs:"
- mapM_ (\v -> rPrint =<< (rEval $ E.ppValue opts v)) vs
+ mapM_ (\v -> rPrint =<< (rEval $ E.ppValue Concrete opts v)) vs
rPrint (pp err)
Pass -> panic "Cryptol.REPL.Command" ["unexpected Test.Pass"]
@@ -482,7 +546,7 @@
-- may be generated multiple times. If the test vectors were chosen
-- randomly without replacement, the proportion would instead be @k/n@.
--
--- We compute raising to the @k@ power in the log domain to improve
+-- We compute raising to the @k@ power in the log domain to improve
-- numerical precision. The equivalant comptutation is:
-- @-expm1( k * log1p (-1/n) )@
--
@@ -517,7 +581,7 @@
satCmd = cmdProveSat True
proveCmd = cmdProveSat False
-showProverStats :: Maybe SBV.Solver -> ProverStats -> REPL ()
+showProverStats :: Maybe String -> ProverStats -> REPL ()
showProverStats mprover stat = rPutStrLn msg
where
@@ -525,11 +589,54 @@
maybe "" (\p -> ", using " ++ show p) mprover ++ ")"
rethrowErrorCall :: REPL a -> REPL a
-rethrowErrorCall m = REPL (\r -> unREPL m r `X.catch` handler)
+rethrowErrorCall m = REPL (\r -> unREPL m r `X.catches` hs)
where
- handler (X.ErrorCallWithLocation s _) = X.throwIO (SBVError s)
+ hs =
+ [ X.Handler $ \ (X.ErrorCallWithLocation s _) -> X.throwIO (SBVError s)
+ , X.Handler $ \ e -> X.throwIO (SBVException e)
+ , X.Handler $ \ e -> X.throwIO (SBVPortfolioException e)
+ , X.Handler $ \ e -> X.throwIO (W4Exception e)
+ ]
+-- | Attempts to prove the given term is safe for all inputs
+safeCmd :: String -> REPL ()
+safeCmd str = do
+ proverName <- getKnownUser "prover"
+ fileName <- getKnownUser "smtfile"
+ let mfile = if fileName == "-" then Nothing else Just fileName
+ if proverName `elem` ["offline","sbv-offline","w4-offline"] then
+ offlineProveSat proverName SafetyQuery str mfile
+ else
+ do (firstProver,result,stats) <- rethrowErrorCall (onlineProveSat proverName SafetyQuery str mfile)
+ case result of
+ EmptyResult ->
+ panic "REPL.Command" [ "got EmptyResult for online prover query" ]
+
+ ProverError msg -> rPutStrLn msg
+
+ ThmResult _ts -> rPutStrLn "Safe"
+
+ CounterExample cexType tevs -> do
+ rPutStrLn "Counterexample"
+ let tes = map ( \(t,e,_) -> (t,e)) tevs
+ vs = map ( \(_,_,v) -> v) tevs
+
+ (t,e) <- mkSolverResult "counterexample" False (Right tes)
+ pexpr <- replParseExpr str
+
+ ~(EnvBool yes) <- getUser "show-examples"
+ when yes $ printCounterexample cexType pexpr vs
+
+ bindItVariable t e
+
+ AllSatResult _ -> do
+ panic "REPL.Command" ["Unexpected AllSAtResult for ':safe' call"]
+
+ seeStats <- getUserShowProverStats
+ when seeStats (showProverStats firstProver stats)
+
+
-- | Console-specific version of 'proveSat'. Prints output to the
-- console, and binds the @it@ variable to a record whose form depends
-- on the expression given. See ticket #66 for a discussion of this
@@ -549,72 +656,75 @@
cmdProveSat isSat str = do
let cexStr | isSat = "satisfying assignment"
| otherwise = "counterexample"
+ qtype <- if isSat then SatQuery <$> getUserSatNum else pure ProveQuery
proverName <- getKnownUser "prover"
fileName <- getKnownUser "smtfile"
let mfile = if fileName == "-" then Nothing else Just fileName
- case proverName :: String of
- "offline" -> do
- result <- offlineProveSat isSat str mfile
- case result of
- Left msg -> rPutStrLn msg
- Right smtlib -> do
- let filename = fromMaybe "standard output" mfile
- let satWord | isSat = "satisfiability"
- | otherwise = "validity"
- rPutStrLn $
- "Writing to SMT-Lib file " ++ filename ++ "..."
- rPutStrLn $
- "To determine the " ++ satWord ++
- " of the expression, use an external SMT solver."
- case mfile of
- Just path -> io $ writeFile path smtlib
- Nothing -> rPutStr smtlib
- _ -> do
- (firstProver,result,stats) <- rethrowErrorCall (onlineProveSat isSat str mfile)
- case result of
- Symbolic.EmptyResult ->
- panic "REPL.Command" [ "got EmptyResult for online prover query" ]
- Symbolic.ProverError msg -> rPutStrLn msg
- Symbolic.ThmResult ts -> do
- rPutStrLn (if isSat then "Unsatisfiable" else "Q.E.D.")
- (t, e) <- mkSolverResult cexStr (not isSat) (Left ts)
- bindItVariable t e
- Symbolic.AllSatResult tevss -> do
- let tess = map (map $ \(t,e,_) -> (t,e)) tevss
- vss = map (map $ \(_,_,v) -> v) tevss
- resultRecs <- mapM (mkSolverResult cexStr isSat . Right) tess
- let collectTes tes = (t, es)
- where
- (ts, es) = unzip tes
- t = case nub ts of
- [t'] -> t'
- _ -> panic "REPL.Command.onlineProveSat"
- [ "satisfying assignments with different types" ]
- (ty, exprs) =
- case resultRecs of
- [] -> panic "REPL.Command.onlineProveSat"
- [ "no satisfying assignments after mkSolverResult" ]
- [(t, e)] -> (t, [e])
- _ -> collectTes resultRecs
- pexpr <- replParseExpr str
- ~(EnvBool yes) <- getUser "show-examples"
- when yes $ forM_ vss (printCounterexample isSat pexpr)
+ if proverName `elem` ["offline","sbv-offline","w4-offline"] then
+ offlineProveSat proverName qtype str mfile
+ else
+ do (firstProver,result,stats) <- rethrowErrorCall (onlineProveSat proverName qtype str mfile)
+ case result of
+ EmptyResult ->
+ panic "REPL.Command" [ "got EmptyResult for online prover query" ]
- case (ty, exprs) of
- (t, [e]) -> bindItVariable t e
- (t, es ) -> bindItVariables t es
+ ProverError msg -> rPutStrLn msg
- seeStats <- getUserShowProverStats
- when seeStats (showProverStats firstProver stats)
+ ThmResult ts -> do
+ rPutStrLn (if isSat then "Unsatisfiable" else "Q.E.D.")
+ (t, e) <- mkSolverResult cexStr (not isSat) (Left ts)
+ bindItVariable t e
-onlineProveSat :: Bool
+ CounterExample cexType tevs -> do
+ rPutStrLn "Counterexample"
+ let tes = map ( \(t,e,_) -> (t,e)) tevs
+ vs = map ( \(_,_,v) -> v) tevs
+
+ (t,e) <- mkSolverResult cexStr isSat (Right tes)
+ pexpr <- replParseExpr str
+
+ ~(EnvBool yes) <- getUser "show-examples"
+ when yes $ printCounterexample cexType pexpr vs
+
+ bindItVariable t e
+
+ AllSatResult tevss -> do
+ rPutStrLn "Satisfiable"
+ let tess = map (map $ \(t,e,_) -> (t,e)) tevss
+ vss = map (map $ \(_,_,v) -> v) tevss
+ resultRecs <- mapM (mkSolverResult cexStr isSat . Right) tess
+ let collectTes tes = (t, es)
+ where
+ (ts, es) = unzip tes
+ t = case nub ts of
+ [t'] -> t'
+ _ -> panic "REPL.Command.onlineProveSat"
+ [ "satisfying assignments with different types" ]
+ (ty, exprs) =
+ case resultRecs of
+ [] -> panic "REPL.Command.onlineProveSat"
+ [ "no satisfying assignments after mkSolverResult" ]
+ [(t, e)] -> (t, [e])
+ _ -> collectTes resultRecs
+ pexpr <- replParseExpr str
+
+ ~(EnvBool yes) <- getUser "show-examples"
+ when yes $ forM_ vss (printSatisfyingModel pexpr)
+
+ case (ty, exprs) of
+ (t, [e]) -> bindItVariable t e
+ (t, es ) -> bindItVariables t es
+
+ seeStats <- getUserShowProverStats
+ when seeStats (showProverStats firstProver stats)
+
+onlineProveSat :: String
+ -> QueryType
-> String -> Maybe FilePath
- -> REPL (Maybe SBV.Solver,Symbolic.ProverResult,ProverStats)
-onlineProveSat isSat str mfile = do
- proverName <- getKnownUser "prover"
+ -> REPL (Maybe String,ProverResult,ProverStats)
+onlineProveSat proverName qtype str mfile = do
verbose <- getKnownUser "debug"
- satNum <- getUserSatNum
modelValidate <- getUserProverValidate
parseExpr <- replParseExpr str
(_, expr, schema) <- replCheckExpr parseExpr
@@ -622,8 +732,9 @@
validEvalContext schema
decls <- fmap M.deDecls getDynEnv
timing <- io (newIORef 0)
- let cmd = Symbolic.ProverCommand {
- pcQueryType = if isSat then SatQuery satNum else ProveQuery
+ ~(EnvBool ignoreSafety) <- getUser "ignore-safety"
+ let cmd = ProverCommand {
+ pcQueryType = qtype
, pcProverName = proverName
, pcVerbose = verbose
, pcValidate = modelValidate
@@ -632,22 +743,29 @@
, pcSmtFile = mfile
, pcExpr = expr
, pcSchema = schema
+ , pcIgnoreSafety = ignoreSafety
}
- (firstProver, res) <- liftModuleCmd $ Symbolic.satProve cmd
+ (firstProver, res) <- getProverConfig >>= \case
+ Left sbvCfg -> liftModuleCmd $ SBV.satProve sbvCfg cmd
+ Right w4Cfg ->
+ do ~(EnvBool hashConsing) <- getUser "hash-consing"
+ liftModuleCmd $ W4.satProve w4Cfg hashConsing cmd
+
stas <- io (readIORef timing)
return (firstProver,res,stas)
-offlineProveSat :: Bool -> String -> Maybe FilePath -> REPL (Either String String)
-offlineProveSat isSat str mfile = do
+offlineProveSat :: String -> QueryType -> String -> Maybe FilePath -> REPL ()
+offlineProveSat proverName qtype str mfile = do
verbose <- getKnownUser "debug"
modelValidate <- getUserProverValidate
parseExpr <- replParseExpr str
(_, expr, schema) <- replCheckExpr parseExpr
decls <- fmap M.deDecls getDynEnv
timing <- io (newIORef 0)
- let cmd = Symbolic.ProverCommand {
- pcQueryType = if isSat then SatQuery (SomeSat 0) else ProveQuery
- , pcProverName = "offline"
+ ~(EnvBool ignoreSafety) <- getUser "ignore-safety"
+ let cmd = ProverCommand {
+ pcQueryType = qtype
+ , pcProverName = proverName
, pcVerbose = verbose
, pcValidate = modelValidate
, pcProverStats = timing
@@ -655,9 +773,52 @@
, pcSmtFile = mfile
, pcExpr = expr
, pcSchema = schema
+ , pcIgnoreSafety = ignoreSafety
}
- liftModuleCmd $ Symbolic.satProveOffline cmd
+ put <- getPutStr
+ let putLn x = put (x ++ "\n")
+ let displayMsg =
+ do let filename = fromMaybe "standard output" mfile
+ let satWord = case qtype of
+ SatQuery _ -> "satisfiability"
+ ProveQuery -> "validity"
+ SafetyQuery -> "safety"
+ putLn $
+ "Writing to SMT-Lib file " ++ filename ++ "..."
+ putLn $
+ "To determine the " ++ satWord ++
+ " of the expression, use an external SMT solver."
+
+ getProverConfig >>= \case
+ Left sbvCfg ->
+ do result <- liftModuleCmd $ SBV.satProveOffline sbvCfg cmd
+ case result of
+ Left msg -> rPutStrLn msg
+ Right smtlib -> do
+ io $ displayMsg
+ case mfile of
+ Just path -> io $ writeFile path smtlib
+ Nothing -> rPutStr smtlib
+
+ Right w4Cfg ->
+ do ~(EnvBool hashConsing) <- getUser "hash-consing"
+ result <- liftModuleCmd $ W4.satProveOffline w4Cfg hashConsing cmd $ \f ->
+ do displayMsg
+ case mfile of
+ Just path ->
+ X.bracket (openFile path WriteMode) hClose f
+ Nothing ->
+ withRWTempFile "smtOutput.tmp" $ \h ->
+ do f h
+ hSeek h AbsoluteSeek 0
+ hGetContents h >>= put
+
+ case result of
+ Just msg -> rPutStrLn msg
+ Nothing -> return ()
+
+
rIdent :: M.Ident
rIdent = M.packIdent "result"
@@ -675,12 +836,12 @@
Left ts -> mkArgs (map addError ts)
Right tes -> mkArgs tes
- eTrue = T.ePrim prims (M.packIdent "True")
- eFalse = T.ePrim prims (M.packIdent "False")
+ eTrue = T.ePrim prims (M.prelPrim "True")
+ eFalse = T.ePrim prims (M.prelPrim "False")
resultE = if result then eTrue else eFalse
- rty = T.TRec $ [(rIdent, T.tBit )] ++ map fst argF
- re = T.ERec $ [(rIdent, resultE)] ++ map snd argF
+ rty = T.TRec (recordFromFields $ [(rIdent, T.tBit )] ++ map fst argF)
+ re = T.ERec (recordFromFields $ [(rIdent, resultE)] ++ map snd argF)
return (rty, re)
where
@@ -731,21 +892,46 @@
-- XXX need more warnings from the module system
whenDebug (rPutStrLn (dump def))
- (_,_,_,names) <- getFocusedEnv
+ fDisp <- M.mctxNameDisp <$> getFocusedEnv
-- type annotation ':' has precedence 2
- rPrint $ runDoc names $ ppPrec 2 expr <+> text ":" <+> pp sig
+ rPrint $ runDoc fDisp $ ppPrec 2 expr <+> text ":" <+> pp sig
readFileCmd :: FilePath -> REPL ()
readFileCmd fp = do
bytes <- replReadFile fp (\err -> rPutStrLn (show err) >> return Nothing)
case bytes of
- Nothing -> return ()
- Just bs ->
- do pm <- getPrimMap
- let expr = T.eString pm (map (toEnum . fromIntegral) (BS.unpack bs))
- ty = T.tString (BS.length bs)
- bindItVariable ty expr
+ Nothing -> return ()
+ Just bs ->
+ do pm <- getPrimMap
+ let val = byteStringToInteger bs
+ let len = BS.length bs
+ let split = T.ePrim pm (M.prelPrim "split")
+ let number = T.ePrim pm (M.prelPrim "number")
+ let f = T.EProofApp (foldl T.ETApp split [T.tNum len, T.tNum (8::Integer), T.tBit])
+ 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
+-- | Convert a 'ByteString' (big-endian) of length @n@ to an 'Integer'
+-- with @8*n@ bits. This function uses a balanced binary fold to
+-- achieve /O(n log n)/ total memory allocation and run-time, in
+-- contrast to the /O(n^2)/ that would be required by a naive
+-- left-fold.
+byteStringToInteger :: BS.ByteString -> Integer
+-- byteStringToInteger = BS.foldl' (\a b -> a `shiftL` 8 .|. toInteger b) 0
+byteStringToInteger bs
+ | l == 0 = 0
+ | l == 1 = toInteger (BS.head bs)
+ | otherwise = x1 `shiftL` (l2 * 8) .|. x2
+ where
+ l = BS.length bs
+ l1 = l `div` 2
+ l2 = l - l1
+ (bs1, bs2) = BS.splitAt l1 bs
+ x1 = byteStringToInteger bs1
+ x2 = byteStringToInteger bs2
+
writeFileCmd :: FilePath -> String -> REPL ()
writeFileCmd file str = do
expr <- replParseExpr str
@@ -764,12 +950,12 @@
(T.tIsSeq x)
serializeValue (E.VSeq n vs) = do
ws <- rEval
- (mapM (>>=E.fromVWord "serializeValue") $ E.enumerateSeqMap n vs)
+ (mapM (>>= E.fromVWord Concrete "serializeValue") $ E.enumerateSeqMap n vs)
return $ BS.pack $ map serializeByte ws
serializeValue _ =
panic "Cryptol.REPL.Command.writeFileCmd"
["Impossible: Non-VSeq value of type [n][8]."]
- serializeByte (E.BV _ v) = fromIntegral (v .&. 0xFF)
+ serializeByte (Concrete.BV _ v) = fromIntegral (v .&. 0xFF)
rEval :: E.Eval a -> REPL a
@@ -814,6 +1000,15 @@
_ <- replEdit p
reloadCmd
+withRWTempFile :: String -> (Handle -> IO a) -> IO a
+withRWTempFile name k =
+ X.bracket
+ (do tmp <- getTemporaryDirectory
+ let esc c = if isAscii c && isAlphaNum c then c else '_'
+ openTempFile tmp (map esc name))
+ (\(nm,h) -> hClose h >> removeFile nm)
+ (k . snd)
+
withROTempFile :: String -> ByteString -> (FilePath -> REPL a) -> REPL a
withROTempFile name cnt k =
do (path,h) <- mkTmp
@@ -879,10 +1074,6 @@
browseCmd :: String -> REPL ()
browseCmd input = do
- (params, iface, fNames, disp) <- getFocusedEnv
- denv <- getDynEnv
- let names = M.deNames denv `M.shadowing` fNames
-
let mnames = map (M.textToModName . T.pack) (words input)
validModNames <- (:) M.interactiveName <$> getModNames
let checkModName m =
@@ -890,6 +1081,16 @@
rPutStrLn ("error: " ++ show m ++ " is not a loaded module.")
mapM_ checkModName mnames
+ fe <- getFocusedEnv
+
+ let params = M.mctxParams fe
+ iface = M.mctxDecls fe
+ names = M.mctxNames fe
+ disp = M.mctxNameDisp fe
+ provV = M.mctxValueProvenance fe
+ provT = M.mctxTypeProvenace fe
+
+
let f &&& g = \x -> f x && g x
isUser x = case M.nameInfo x of
M.Declared _ M.SystemName -> False
@@ -903,16 +1104,15 @@
visibleType = isUser &&& restricted &&& inSet visibleTypes
visibleDecl = isUser &&& restricted &&& inSet visibleDecls
-
browseMParams visibleType visibleDecl params disp
- browseTSyns visibleType iface disp
- browsePrimTys visibleType iface disp
- browseNewtypes visibleType iface disp
- browseVars visibleDecl iface disp
+ browseTSyns visibleType provT iface disp
+ browsePrimTys visibleType provT iface disp
+ browseNewtypes visibleType provT iface disp
+ browseVars visibleDecl provV iface disp
browseMParams :: (M.Name -> Bool) -> (M.Name -> Bool) ->
- M.IfaceParams-> NameDisp -> REPL ()
+ M.IfaceParams -> NameDisp -> REPL ()
browseMParams visT visD M.IfaceParams { .. } names =
do ppBlock names ppParamTy "Type Parameters"
(sorted visT T.mtpName ifParamTypes)
@@ -927,55 +1127,152 @@
sorted vis nm mp = sortBy (M.cmpNameDisplay names `on` nm)
$ filter (vis . nm) $ Map.elems mp
+type Prov = Map M.Name M.DeclProvenance
-browsePrimTys :: (M.Name -> Bool) -> M.IfaceDecls -> NameDisp -> REPL ()
-browsePrimTys isVisible M.IfaceDecls { .. } names =
- do let pts = sortBy (M.cmpNameDisplay names `on` T.atName)
- [ ts | ts <- Map.elems ifAbstractTypes, isVisible (T.atName ts) ]
- ppBlock names ppA "Primitive Types" pts
+browsePrimTys :: (M.Name -> Bool) -> Prov -> M.IfaceDecls -> NameDisp -> REPL ()
+browsePrimTys isVisible prov M.IfaceDecls { .. } names =
+ ppSection (Map.elems ifAbstractTypes)
+ Section { secName = "Primitive Types"
+ , secEntryName = T.atName
+ , secProvenance = prov
+ , secDisp = names
+ , secPP = ppA
+ , secVisible = isVisible
+ }
where
ppA a = pp (T.atName a) <+> ":" <+> pp (T.atKind a)
-browseTSyns :: (M.Name -> Bool) -> M.IfaceDecls -> NameDisp -> REPL ()
-browseTSyns isVisible M.IfaceDecls { .. } names = do
- let tsyns = sortBy (M.cmpNameDisplay names `on` T.tsName)
- [ ts | ts <- Map.elems ifTySyns, isVisible (T.tsName ts) ]
- (cts,tss) = partition isCtrait tsyns
+browseTSyns :: (M.Name -> Bool) -> Prov -> M.IfaceDecls -> NameDisp -> REPL ()
+browseTSyns isVisible prov M.IfaceDecls { .. } names =
+ do ppSection tss
+ Section { secName = "Type Synonyms"
+ , secEntryName = T.tsName
+ , secProvenance = prov
+ , secDisp = names
+ , secVisible = isVisible
+ , secPP = pp
+ }
+ ppSection cts
+ Section { secName = "Constraint Synonyms"
+ , secEntryName = T.tsName
+ , secProvenance = prov
+ , secDisp = names
+ , secVisible = isVisible
+ , secPP = pp
+ }
+ where
+ (cts,tss) = partition isCtrait (Map.elems ifTySyns)
+ isCtrait t = T.kindResult (T.kindOf (T.tsDef t)) == T.KProp
- ppBlock names pp "Type Synonyms" tss
- ppBlock names pp "Constraint Synonyms" cts
+browseNewtypes ::
+ (M.Name -> Bool) -> Prov -> M.IfaceDecls -> NameDisp -> REPL ()
+browseNewtypes isVisible prov M.IfaceDecls { .. } names =
+ ppSection (Map.elems ifNewtypes)
+ Section { secName = "Newtypes"
+ , secEntryName = T.ntName
+ , secVisible = isVisible
+ , secProvenance = prov
+ , secDisp = names
+ , secPP = T.ppNewtypeShort
+ }
+browseVars :: (M.Name -> Bool) -> Prov -> M.IfaceDecls -> NameDisp -> REPL ()
+browseVars isVisible prov M.IfaceDecls { .. } names =
+ do ppSection props Section { secName = "Properties"
+ , secEntryName = M.ifDeclName
+ , secVisible = isVisible
+ , secProvenance = prov
+ , secDisp = names
+ , secPP = ppVar
+ }
+ ppSection syms Section { secName = "Symbols"
+ , secEntryName = M.ifDeclName
+ , secVisible = isVisible
+ , secProvenance = prov
+ , secDisp = names
+ , secPP = ppVar
+ }
+
where
- isCtrait t = T.kindResult (T.kindOf (T.tsDef t)) == T.KProp
+ isProp p = T.PragmaProperty `elem` (M.ifDeclPragmas p)
+ (props,syms) = partition isProp (Map.elems ifDecls)
-browseNewtypes :: (M.Name -> Bool) -> M.IfaceDecls -> NameDisp -> REPL ()
-browseNewtypes isVisible M.IfaceDecls { .. } names = do
- let nts = sortBy (M.cmpNameDisplay names `on` T.ntName)
- [ nt | nt <- Map.elems ifNewtypes, isVisible (T.ntName nt) ]
- unless (null nts) $ do
- rPutStrLn "Newtypes"
- rPutStrLn "========"
- rPrint (runDoc names (nest 4 (vcat (map T.ppNewtypeShort nts))))
- rPutStrLn ""
+ ppVar M.IfaceDecl { .. } = hang (pp ifDeclName <+> char ':') 2 (pp ifDeclSig)
-browseVars :: (M.Name -> Bool) -> M.IfaceDecls -> NameDisp -> REPL ()
-browseVars isVisible M.IfaceDecls { .. } names = do
- let vars = sortBy (M.cmpNameDisplay names `on` M.ifDeclName)
- [ d | d <- Map.elems ifDecls, isVisible (M.ifDeclName d) ]
- let isProp p = T.PragmaProperty `elem` (M.ifDeclPragmas p)
- (props,syms) = partition isProp vars
+data Section a = Section
+ { secName :: String
+ , secEntryName :: a -> M.Name
+ , secVisible :: M.Name -> Bool
+ , secProvenance :: Map M.Name M.DeclProvenance
+ , secDisp :: NameDisp
+ , secPP :: a -> Doc
+ }
+ppSection :: [a] -> Section a -> REPL ()
+ppSection things s
+ | null grouped = pure ()
+ | otherwise =
+ do let heading = secName s
+ rPutStrLn heading
+ rPutStrLn (map (const '=') heading)
+ rPutStrLn ""
+ mapM_ ppSub grouped
- let ppVar M.IfaceDecl { .. } = hang (pp ifDeclName <+> char ':')
- 2 (pp ifDeclSig)
+ where
+ ppSub (p,ts) =
+ do let heading = provHeading p
+ rPutStrLn (" " ++ heading)
+ rPutStrLn (" " ++ map (const '-') heading)
+ rPutStrLn ""
+ rPutStrLn $ show $ runDoc (secDisp s) $ nest 4 $ vcat $ map (secPP s) ts
+ rPutStrLn ""
- ppBlock names ppVar "Properties" props
- ppBlock names ppVar "Symbols" syms
+ grouped = map rearrange $
+ groupBy sameProv $
+ sortBy cmpThings
+ [ (n,p,t) | t <- things,
+ let n = secEntryName s t,
+ secVisible s n,
+ let p = case Map.lookup n (secProvenance s) of
+ Just i -> i
+ Nothing -> panic "ppSection"
+ [ "Name with no provenance"
+ , show n ]
+ ]
+ rearrange xs = (p, [ a | (_,_,a) <- xs ])
+ where (_,p,_) : _ = xs
+ cmpThings (n1, p1, _) (n2, p2, _) =
+ case cmpProv p1 p2 of
+ EQ -> M.cmpNameDisplay (secDisp s) n1 n2
+ r -> r
+
+ sameProv (_,p1,_) (_,p2,_) = provOrd p1 == provOrd p2
+
+ provOrd p =
+ case p of
+ M.NameIsParameter -> Left 1 :: Either Int P.ModName
+ M.NameIsDynamicDecl -> Left 2
+ M.NameIsLocalPublic -> Left 3
+ M.NameIsLocalPrivate -> Left 4
+ M.NameIsImportedFrom x -> Right x
+
+ cmpProv p1 p2 = compare (provOrd p1) (provOrd p2)
+
+ provHeading p =
+ case p of
+ M.NameIsParameter -> "Parameters"
+ M.NameIsDynamicDecl -> "REPL"
+ M.NameIsLocalPublic -> "Public"
+ M.NameIsLocalPrivate -> "Private"
+ M.NameIsImportedFrom m -> "From " ++ show (pp m)
+
+
+
ppBlock :: NameDisp -> (a -> Doc) -> String -> [a] -> REPL ()
ppBlock names ppFun name xs = unless (null xs) $
do rPutStrLn name
@@ -984,7 +1281,6 @@
rPutStrLn ""
-
setOptionCmd :: String -> REPL ()
setOptionCmd str
| Just value <- mbValue = setUser key value
@@ -1027,14 +1323,19 @@
| otherwise =
case parseHelpName cmd of
Just qname ->
- do (params,env,rnEnv,nameEnv) <- getFocusedEnv
- let vNames = M.lookupValNames qname rnEnv
+ do fe <- getFocusedEnv
+ let params = M.mctxParams fe
+ env = M.mctxDecls fe
+ rnEnv = M.mctxNames fe
+ disp = M.mctxNameDisp fe
+
+ vNames = M.lookupValNames qname rnEnv
tNames = M.lookupTypeNames qname rnEnv
- let helps = map (showTypeHelp params env nameEnv) tNames ++
- map (showValHelp params env nameEnv qname) vNames
+ let helps = map (showTypeHelp params env disp) tNames ++
+ map (showValHelp params env disp qname) vNames
- separ = rPutStrLn " ~~~ * ~~~"
+ separ = rPutStrLn " ---------"
sequence_ (intersperse separ helps)
when (null (vNames ++ tNames)) $
@@ -1175,6 +1476,9 @@
rPutStrLn ""
rPutStrLn (cHelp c)
rPutStrLn ""
+ when (not (null (cLongHelp c))) $ do
+ rPutStrLn (cLongHelp c)
+ rPutStrLn ""
showOptionHelp arg =
case lookupTrieExact arg userOptions of
@@ -1244,7 +1548,7 @@
liftModuleCmd cmd =
do evo <- getEvalOpts
env <- getModuleEnv
- moduleCmdResult =<< io (cmd (evo,env))
+ moduleCmdResult =<< io (cmd (evo, BS.readFile, env))
moduleCmdResult :: M.ModuleRes a -> REPL a
moduleCmdResult (res,ws0) = do
@@ -1272,7 +1576,7 @@
filterShadowing w = Just w
let ws = mapMaybe filterDefaults . mapMaybe filterShadowing $ ws0
- (_,_,_,names) <- getFocusedEnv
+ names <- M.mctxNameDisp <$> getFocusedEnv
mapM_ (rPrint . runDoc names . pp) ws
case res of
Right (a,me') -> setModuleEnv me' >> return a
@@ -1312,7 +1616,7 @@
replSpecExpr :: T.Expr -> REPL T.Expr
replSpecExpr e = liftModuleCmd $ S.specialize e
-replEvalExpr :: P.Expr P.PName -> REPL (E.Value, T.Type)
+replEvalExpr :: P.Expr P.PName -> REPL (Concrete.Value, T.Type)
replEvalExpr expr =
do (_,def,sig) <- replCheckExpr expr
validEvalContext def
@@ -1338,11 +1642,8 @@
warnDefaults ts =
case ts of
[] -> return ()
- _ ->
- do warnDefaulting <- getKnownUser "warnDefaulting"
- when warnDefaulting $
- do rPutStrLn "Showing a specific instance of polymorphic result:"
- mapM_ warnDefault ts
+ _ -> do rPutStrLn "Showing a specific instance of polymorphic result:"
+ mapM_ warnDefault ts
warnDefault (x,t) =
rPrint (" *" <+> nest 2 ("Using" <+> quotes (pp t) <+> "for" <+>
@@ -1388,10 +1689,10 @@
-- | Extend the dynamic environment with a fresh binding for "it",
-- as defined by the given value. If we cannot determine the definition
-- of the value, then we don't bind `it`.
-bindItVariableVal :: T.Type -> E.Value -> REPL ()
+bindItVariableVal :: T.Type -> Concrete.Value -> REPL ()
bindItVariableVal ty val =
do prims <- getPrimMap
- mb <- rEval (E.toExpr prims ty val)
+ mb <- rEval (Concrete.toExpr prims ty val)
case mb of
Nothing -> return ()
Just expr -> bindItVariable ty expr
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
@@ -36,7 +36,6 @@
, getModuleEnv, setModuleEnv
, getDynEnv, setDynEnv
, uniqify, freshName
- , getTSyns, getNewtypes, getVars
, whenDebug
, getExprNames
, getTypeNames
@@ -64,6 +63,8 @@
, getUserSatNum
, getUserShowProverStats
, getUserProverValidate
+ , parsePPFloatFormat
+ , getProverConfig
-- ** Configurable Output
, getPutStr
@@ -78,7 +79,7 @@
import Cryptol.REPL.Trie
-import Cryptol.Eval (EvalError)
+import Cryptol.Eval (EvalError, Unsupported)
import qualified Cryptol.ModuleSystem as M
import qualified Cryptol.ModuleSystem.Env as M
import qualified Cryptol.ModuleSystem.Name as M
@@ -95,13 +96,19 @@
import Cryptol.Utils.Panic (panic)
import Cryptol.Utils.Logger(Logger, logPutStr, funLogger)
import qualified Cryptol.Parser.AST as P
-import Cryptol.Symbolic (proverNames, lookupProver, SatNum(..))
+import Cryptol.Symbolic (SatNum(..))
+import Cryptol.Symbolic.SBV (SBVPortfolioException)
+import Cryptol.Symbolic.What4 (W4Exception)
+import Cryptol.Eval.Monad(PPFloatFormat(..),PPFloatExp(..))
+import qualified Cryptol.Symbolic.SBV as SBV (proverNames, setupProver, defaultProver, SBVProverConfig)
+import qualified Cryptol.Symbolic.What4 as W4 (proverNames, setupProver, W4ProverConfig)
import Control.Monad (ap,unless,when)
import Control.Monad.Base
+import qualified Control.Monad.Catch as Ex
import Control.Monad.IO.Class
import Control.Monad.Trans.Control
-import Data.Char (isSpace)
+import Data.Char (isSpace, toLower)
import Data.IORef
(IORef,newIORef,readIORef,modifyIORef,atomicModifyIORef)
import Data.List (intercalate, isPrefixOf, unfoldr, sortBy)
@@ -114,7 +121,7 @@
import qualified Data.Set as Set
import Text.Read (readMaybe)
-import Data.SBV.Dynamic (sbvCheckSolverInstallation)
+import Data.SBV (SBVException)
import Prelude ()
import Prelude.Compat
@@ -157,6 +164,8 @@
, eUpdateTitle :: REPL ()
-- ^ Execute this every time we load a module.
-- This is used to change the title of terminal when loading a module.
+
+ , eProverConfig :: Either SBV.SBVProverConfig W4.W4ProverConfig
}
-- | Initial, empty environment.
@@ -173,6 +182,7 @@
, eLogger = l
, eLetEnabled = True
, eUpdateTitle = return ()
+ , eProverConfig = Left SBV.defaultProver
}
-- | Build up the prompt for the REPL.
@@ -258,6 +268,25 @@
let (a,s') = f (M.meSupply eModuleEnv)
in (RW { eModuleEnv = eModuleEnv { M.meSupply = s' }, .. },a)
+instance Ex.MonadThrow REPL where
+ throwM e = liftIO $ X.throwIO e
+
+instance Ex.MonadCatch REPL where
+ catch op handler = control $ \runInBase -> Ex.catch (runInBase op) (runInBase . handler)
+
+instance Ex.MonadMask REPL where
+ mask op = REPL $ \ref -> Ex.mask $ \u -> unREPL (op (q u)) ref
+ where q u (REPL b) = REPL (\ref -> u (b ref))
+
+ uninterruptibleMask op = REPL $ \ref ->
+ Ex.uninterruptibleMask $ \u -> unREPL (op (q u)) ref
+ where q u (REPL b) = REPL (\ref -> u (b ref))
+
+ generalBracket acq rls op = control $ \runInBase ->
+ Ex.generalBracket (runInBase acq)
+ (\saved -> \e -> runInBase (restoreM saved >>= \a -> rls a e))
+ (\saved -> runInBase (restoreM saved >>= op))
+
-- Exceptions ------------------------------------------------------------------
-- | REPL exceptions.
@@ -268,11 +297,15 @@
| NoPatError [Error]
| NoIncludeError [IncludeError]
| EvalError EvalError
+ | Unsupported Unsupported
| ModuleSystemError NameDisp M.ModuleError
| EvalPolyError T.Schema
| TypeNotTestable T.Type
| EvalInParamModule [M.Name]
| SBVError String
+ | SBVException SBVException
+ | SBVPortfolioException SBVPortfolioException
+ | W4Exception W4Exception
deriving (Show,Typeable)
instance X.Exception REPLException
@@ -292,6 +325,7 @@
NoIncludeError es -> vcat (map ppIncludeError es)
ModuleSystemError ns me -> fixNameDisp ns (pp me)
EvalError e -> pp e
+ Unsupported e -> pp e
EvalPolyError s -> text "Cannot evaluate polymorphic value."
$$ text "Type:" <+> pp s
TypeNotTestable t -> text "The expression is not of a testable type."
@@ -300,6 +334,9 @@
text "Expression depends on definitions from a parameterized module:"
$$ nest 2 (vcat (map pp xs))
SBVError s -> text "SBV error:" $$ text s
+ SBVException e -> text "SBV exception:" $$ text (show e)
+ SBVPortfolioException e -> text "SBV exception:" $$ text (show e)
+ W4Exception e -> text "What4 exception:" $$ text (show e)
-- | Raise an exception.
raise :: REPLException -> REPL a
@@ -314,7 +351,7 @@
rethrowEvalError :: IO a -> IO a
-rethrowEvalError m = run `X.catch` rethrow
+rethrowEvalError m = run `X.catch` rethrow `X.catch` rethrowUnsupported
where
run = do
a <- m
@@ -323,7 +360,8 @@
rethrow :: EvalError -> IO a
rethrow exn = X.throwIO (EvalError exn)
-
+ rethrowUnsupported :: Unsupported -> IO a
+ rethrowUnsupported exn = X.throwIO (Unsupported exn)
-- Primitives ------------------------------------------------------------------
@@ -382,6 +420,9 @@
me <- getModuleEnv
setModuleEnv $ me { M.meSearchPath = path ++ M.meSearchPath me }
+getProverConfig :: REPL (Either SBV.SBVProverConfig W4.W4ProverConfig)
+getProverConfig = eProverConfig <$> getRW
+
shouldContinue :: REPL Bool
shouldContinue = eContinue `fmap` getRW
@@ -471,75 +512,33 @@
rPrint :: Show a => a -> REPL ()
rPrint x = rPutStrLn (show x)
-getFocusedEnv :: REPL (M.IfaceParams,M.IfaceDecls,M.NamingEnv,NameDisp)
-getFocusedEnv = do
- me <- getModuleEnv
- -- dyNames is a NameEnv that removes the #Uniq prefix from interactively-bound
- -- variables.
- let (dyDecls,dyNames,dyDisp) = M.dynamicEnv me
- let (fParams,fDecls,fNames,fDisp) = M.focusedEnv me
- return ( fParams
- , dyDecls `mappend` fDecls
- , dyNames `M.shadowing` fNames
- , dyDisp `mappend` fDisp)
-
- -- -- the subtle part here is removing the #Uniq prefix from
- -- -- interactively-bound variables, and also excluding any that are
- -- -- shadowed and thus can no longer be referenced
- -- let (fDecls,fNames,fDisp) = M.focusedEnv me
- -- edecls = M.ifDecls dyDecls
- -- -- is this QName something the user might actually type?
- -- isShadowed (qn@(P.QName (Just (P.unModName -> ['#':_])) name), _) =
- -- case Map.lookup localName neExprs of
- -- Nothing -> False
- -- Just uniqueNames -> isNamed uniqueNames
- -- where localName = P.QName Nothing name
- -- isNamed us = any (== qn) (map M.qname us)
- -- neExprs = M.neExprs (M.deNames (M.meDynEnv me))
- -- isShadowed _ = False
- -- unqual ((P.QName _ name), ifds) = (P.QName Nothing name, ifds)
- -- edecls' = Map.fromList
- -- . map unqual
- -- . filter isShadowed
- -- $ Map.toList edecls
- -- return (decls `mappend` mempty { M.ifDecls = edecls' }, names `mappend` dyNames)
-
-getVars :: REPL (Map.Map M.Name M.IfaceDecl)
-getVars = do
- (_,decls,_,_) <- getFocusedEnv
- return (M.ifDecls decls)
-
-getTSyns :: REPL (Map.Map M.Name T.TySyn)
-getTSyns = do
- (_,decls,_,_) <- getFocusedEnv
- return (M.ifTySyns decls)
-
-getNewtypes :: REPL (Map.Map M.Name T.Newtype)
-getNewtypes = do
- (_,decls,_,_) <- getFocusedEnv
- return (M.ifNewtypes decls)
+getFocusedEnv :: REPL M.ModContext
+getFocusedEnv = M.focusedEnv <$> getModuleEnv
-- | Get visible variable names.
+-- This is used for command line completition.
getExprNames :: REPL [String]
getExprNames =
- do (_,_, fNames, _) <- getFocusedEnv
+ do fNames <- M.mctxNames <$> getFocusedEnv
return (map (show . pp) (Map.keys (M.neExprs fNames)))
-- | Get visible type signature names.
+-- This is used for command line completition.
getTypeNames :: REPL [String]
getTypeNames =
- do (_,_, fNames, _) <- getFocusedEnv
+ do fNames <- M.mctxNames <$> getFocusedEnv
return (map (show . pp) (Map.keys (M.neTypes fNames)))
-- | Return a list of property names, sorted by position in the file.
getPropertyNames :: REPL ([M.Name],NameDisp)
getPropertyNames =
- do (_,decls,_,names) <- getFocusedEnv
- let xs = M.ifDecls decls
+ do fe <- getFocusedEnv
+ let xs = M.ifDecls (M.mctxDecls fe)
ps = sortBy (comparing (from . M.nameLoc))
- $ [ x | (x,d) <- Map.toList xs, T.PragmaProperty `elem` M.ifDeclPragmas d ]
+ [ x | (x,d) <- Map.toList xs,
+ T.PragmaProperty `elem` M.ifDeclPragmas d ]
- return (ps, names)
+ return (ps, M.mctxNameDisp fe)
getModNames :: REPL [I.ModName]
getModNames =
@@ -639,7 +638,7 @@
| otherwise ->
rPutStrLn ("Failed to parse boolean for field, `" ++ name ++ "`")
where
- doCheck v = do (r,ws) <- io (optCheck opt v)
+ doCheck v = do (r,ws) <- optCheck opt v
case r of
Just err -> rPutStrLn err
Nothing -> do mapM_ rPutStrLn ws
@@ -730,12 +729,12 @@
insert m d = insertTrie (optName d) d m
-- | Returns maybe an error, and some warnings
-type Checker = EnvVal -> IO (Maybe String, [String])
+type Checker = EnvVal -> REPL (Maybe String, [String])
noCheck :: Checker
noCheck _ = return (Nothing, [])
-noWarns :: Maybe String -> IO (Maybe String, [String])
+noWarns :: Maybe String -> REPL (Maybe String, [String])
noWarns mb = return (mb, [])
data OptionDescr = OptionDescr
@@ -766,7 +765,7 @@
"The maximum number of :sat solutions to display (\"all\" for no limit)."
, simpleOpt "prover" (EnvString "z3") checkProver $
"The external SMT solver for ':prove' and ':sat'\n(" ++ proverListString ++ ")."
- , simpleOpt "warnDefaulting" (EnvBool True) noCheck
+ , simpleOpt "warnDefaulting" (EnvBool False) noCheck
"Choose whether to display warnings when defaulting."
, simpleOpt "warnShadowing" (EnvBool True) noCheck
"Choose whether to display warnings when shadowing symbols."
@@ -790,7 +789,11 @@
, OptionDescr "tc-debug" (EnvNum 0)
noCheck
- "Enable type-checker debugging output." $
+ (unlines
+ [ "Enable type-checker debugging output:"
+ , " * 0 no debug output"
+ , " * 1 show type-checker debug info"
+ , " * >1 show type-checker debug info and interactions with SMT solver"]) $
\case EnvNum n -> do me <- getModuleEnv
let cfg = M.meSolverConfig me
setModuleEnv me { M.meSolverConfig = cfg{ T.solverVerbose = n } }
@@ -804,6 +807,9 @@
EnvBool False -> setIt M.NoCoreLint
_ -> return ()
+ , simpleOpt "hash-consing" (EnvBool True) noCheck
+ "Enable hash-consing in the What4 symbolic backends."
+
, simpleOpt "prover-stats" (EnvBool True) noCheck
"Enable prover timing statistics."
@@ -812,9 +818,48 @@
, simpleOpt "show-examples" (EnvBool True) noCheck
"Print the (counter) example after :sat or :prove"
+
+ , simpleOpt "fp-base" (EnvNum 16) checkBase
+ "The base to display floating point numbers at (2, 8, 10, or 16)."
+
+ , simpleOpt "fp-format" (EnvString "free") checkPPFloatFormat
+ $ unlines
+ [ "Specifies the format to use when showing floating point numbers:"
+ , " * free show using as many digits as needed"
+ , " * free+exp like `free` but always show exponent"
+ , " * .NUM show NUM (>=1) digits after floating point"
+ , " * NUM show using NUM (>=1) significant digits"
+ , " * NUM+exp like NUM but always show exponent"
+ ]
+
+ , simpleOpt "ignore-safety" (EnvBool False) noCheck
+ "Ignore safety predicates when performing :sat or :prove checks"
]
+parsePPFloatFormat :: String -> Maybe PPFloatFormat
+parsePPFloatFormat s =
+ case s of
+ "free" -> Just $ FloatFree AutoExponent
+ "free+exp" -> Just $ FloatFree ForceExponent
+ '.' : xs -> FloatFrac <$> readMaybe xs
+ _ | (as,res) <- break (== '+') s
+ , Just n <- readMaybe as
+ , Just e <- case res of
+ "+exp" -> Just ForceExponent
+ "" -> Just AutoExponent
+ _ -> Nothing
+ -> Just (FloatFixed n e)
+ _ -> Nothing
+
+checkPPFloatFormat :: Checker
+checkPPFloatFormat val =
+ case val of
+ EnvString s | Just _ <- parsePPFloatFormat s -> noWarns Nothing
+ _ -> noWarns $ Just "Failed to parse `fp-format`"
+
+
+
-- | Check the value to the `base` option.
checkBase :: Checker
checkBase val = case val of
@@ -832,22 +877,30 @@
checkProver :: Checker
checkProver val = case val of
- EnvString s
- | s `notElem` proverNames ->
- noWarns $ Just $ "Prover must be " ++ proverListString
- | s `elem` ["offline", "any"] -> noWarns Nothing
+ EnvString (map toLower -> s)
+ | s `elem` W4.proverNames ->
+ io (W4.setupProver s) >>= \case
+ Left msg -> noWarns (Just msg)
+ Right (ws, cfg) ->
+ do modifyRW_ (\rw -> rw{ eProverConfig = Right cfg })
+ return (Nothing, ws)
+ | s `elem` SBV.proverNames ->
+ io (SBV.setupProver s) >>= \case
+ Left msg -> noWarns (Just msg)
+ Right (ws, cfg) ->
+ do modifyRW_ (\rw -> rw{ eProverConfig = Left cfg })
+ return (Nothing, ws)
+
| otherwise ->
- do let prover = lookupProver s
- available <- sbvCheckSolverInstallation prover
- let ws = if available
- then []
- else ["Warning: " ++ s ++ " installation not found"]
- return (Nothing, ws)
+ noWarns $ Just $ "Prover must be " ++ proverListString
_ -> noWarns $ Just "unable to parse a value for prover"
+allProvers :: [String]
+allProvers = SBV.proverNames ++ W4.proverNames
+
proverListString :: String
-proverListString = concatMap (++ ", ") (init proverNames) ++ "or " ++ last proverNames
+proverListString = concatMap (++ ", ") (init allProvers) ++ "or " ++ last allProvers
checkSatNum :: Checker
checkSatNum val = case val of
@@ -901,4 +954,3 @@
case mPath of
Nothing -> return (Just Z3NotFound)
Just _ -> return Nothing
-
diff --git a/src/Cryptol/Symbolic.hs b/src/Cryptol/Symbolic.hs
--- a/src/Cryptol/Symbolic.hs
+++ b/src/Cryptol/Symbolic.hs
@@ -7,6 +7,8 @@
-- Portability : portable
{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ImplicitParams #-}
+{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
@@ -14,76 +16,41 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ViewPatterns #-}
-module Cryptol.Symbolic where
+module Cryptol.Symbolic
+ ( ProverCommand(..)
+ , QueryType(..)
+ , SatNum(..)
+ , ProverResult(..)
+ , ProverStats
+ , CounterExampleType(..)
+ -- * FinType
+ , FinType(..)
+ , finType
+ , unFinType
+ , predArgTypes
+ ) where
-import Control.Monad.IO.Class
-import Control.Monad (replicateM, when, zipWithM, foldM)
-import Control.Monad.Writer (WriterT, runWriterT, tell, lift)
-import Data.List (intercalate, genericLength)
+
import Data.IORef(IORef)
-import qualified Control.Exception as X
-import qualified Data.SBV.Dynamic as SBV
-import Data.SBV (Timing(SaveTiming))
-import Data.SBV.Internals (showTDiff)
-import qualified Cryptol.ModuleSystem as M hiding (getPrimMap)
-import qualified Cryptol.ModuleSystem.Env as M
-import qualified Cryptol.ModuleSystem.Base as M
-import qualified Cryptol.ModuleSystem.Monad as M
-
-import Cryptol.Symbolic.Prims
-import Cryptol.Symbolic.Value
-
-import qualified Cryptol.Eval as Eval
-import qualified Cryptol.Eval.Monad as Eval
-import qualified Cryptol.Eval.Type as Eval
-import qualified Cryptol.Eval.Value as Eval
-import Cryptol.Eval.Env (GenEvalEnv(..))
-import Cryptol.TypeCheck.AST
-import Cryptol.Utils.Ident (Ident)
-import Cryptol.Utils.PP
-import Cryptol.Utils.Panic(panic)
-import Cryptol.Utils.Logger(logPutStrLn)
+import qualified Cryptol.Eval.Concrete as Concrete
+import Cryptol.TypeCheck.AST
+import Cryptol.Eval.Type (TValue(..), evalType)
+import Cryptol.Utils.Ident (Ident)
+import Cryptol.Utils.RecordMap
+import Cryptol.Utils.PP
import Prelude ()
import Prelude.Compat
-
import Data.Time (NominalDiffTime)
-type EvalEnv = GenEvalEnv SBool SWord
-
-
--- External interface ----------------------------------------------------------
-
-proverConfigs :: [(String, SBV.SMTConfig)]
-proverConfigs =
- [ ("cvc4" , SBV.cvc4 )
- , ("yices" , SBV.yices )
- , ("z3" , SBV.z3 )
- , ("boolector", SBV.boolector)
- , ("mathsat" , SBV.mathSAT )
- , ("abc" , SBV.abc )
- , ("offline" , SBV.defaultSMTCfg )
- , ("any" , SBV.defaultSMTCfg )
- ]
-
-proverNames :: [String]
-proverNames = map fst proverConfigs
-
-lookupProver :: String -> SBV.SMTConfig
-lookupProver s =
- case lookup s proverConfigs of
- Just cfg -> cfg
- -- should be caught by UI for setting prover user variable
- Nothing -> panic "Cryptol.Symbolic" [ "invalid prover: " ++ s ]
-
-type SatResult = [(Type, Expr, Eval.Value)]
+type SatResult = [(Type, Expr, Concrete.Value)]
data SatNum = AllSat | SomeSat Int
deriving (Show)
-data QueryType = SatQuery SatNum | ProveQuery
+data QueryType = SatQuery SatNum | ProveQuery | SafetyQuery
deriving (Show)
data ProverCommand = ProverCommand {
@@ -106,211 +73,57 @@
-- ^ The typechecked expression to evaluate
, pcSchema :: Schema
-- ^ The 'Schema' of @pcExpr@
+ , pcIgnoreSafety :: Bool
+ -- ^ Should we ignore safety predicates?
}
type ProverStats = NominalDiffTime
+-- | A @:prove@ command can fail either because some
+-- input causes the predicate to violate a safety assertion,
+-- or because the predicate returns false for some input.
+data CounterExampleType = SafetyViolation | PredicateFalsified
+
-- | A prover result is either an error message, an empty result (eg
-- for the offline prover), a counterexample or a lazy list of
-- satisfying assignments.
data ProverResult = AllSatResult [SatResult] -- LAZY
| ThmResult [Type]
+ | CounterExample CounterExampleType SatResult
| EmptyResult
| ProverError String
-satSMTResults :: SBV.SatResult -> [SBV.SMTResult]
-satSMTResults (SBV.SatResult r) = [r]
-allSatSMTResults :: SBV.AllSatResult -> [SBV.SMTResult]
-allSatSMTResults (SBV.AllSatResult (_, _, _, rs)) = rs
-thmSMTResults :: SBV.ThmResult -> [SBV.SMTResult]
-thmSMTResults (SBV.ThmResult r) = [r]
-
-proverError :: String -> M.ModuleCmd (Maybe SBV.Solver, ProverResult)
-proverError msg (_,modEnv) =
- return (Right ((Nothing, ProverError msg), modEnv), [])
-
-satProve :: ProverCommand -> M.ModuleCmd (Maybe SBV.Solver, ProverResult)
-satProve ProverCommand {..} =
- protectStack proverError $ \(evo,modEnv) ->
-
- M.runModuleM (evo,modEnv) $ do
- let (isSat, mSatNum) = case pcQueryType of
- ProveQuery -> (False, Nothing)
- SatQuery sn -> case sn of
- SomeSat n -> (True, Just n)
- AllSat -> (True, Nothing)
- let extDgs = allDeclGroups modEnv ++ pcExtraDecls
- provers <-
- case pcProverName of
- "any" -> M.io SBV.sbvAvailableSolvers
- _ -> return [(lookupProver pcProverName) { SBV.transcript = pcSmtFile
- , SBV.allSatMaxModelCount = mSatNum
- }]
-
-
- let provers' = [ p { SBV.timing = SaveTiming pcProverStats
- , SBV.verbose = pcVerbose
- , SBV.validateModel = pcValidate
- } | p <- provers ]
- let tyFn = if isSat then existsFinType else forallFinType
- let lPutStrLn = M.withLogger logPutStrLn
- let doEval :: MonadIO m => Eval.Eval a -> m a
- doEval m = liftIO $ Eval.runEval evo m
- let runProver fn tag e = do
- case provers of
- [prover] -> do
- when pcVerbose $
- lPutStrLn $ "Trying proof with " ++
- show (SBV.name (SBV.solver prover))
- res <- M.io (fn prover e)
- when pcVerbose $
- lPutStrLn $ "Got result from " ++
- show (SBV.name (SBV.solver prover))
- return (Just (SBV.name (SBV.solver prover)), tag res)
- _ ->
- return ( Nothing
- , [ SBV.ProofError
- prover
- [":sat with option prover=any requires option satNum=1"]
- Nothing
- | prover <- provers ]
- )
- runProvers fn tag e = do
- when pcVerbose $
- lPutStrLn $ "Trying proof with " ++
- intercalate ", " (map (show . SBV.name . SBV.solver) provers)
- (firstProver, timeElapsed, res) <- M.io (fn provers' e)
- when pcVerbose $
- lPutStrLn $ "Got result from " ++ show firstProver ++
- ", time: " ++ showTDiff timeElapsed
- return (Just firstProver, tag res)
- let runFn = case pcQueryType of
- ProveQuery -> runProvers SBV.proveWithAny thmSMTResults
- SatQuery sn -> case sn of
- SomeSat 1 -> runProvers SBV.satWithAny satSMTResults
- _ -> runProver SBV.allSatWith allSatSMTResults
- let addAsm = case pcQueryType of
- ProveQuery -> \x y -> SBV.svOr (SBV.svNot x) y
- SatQuery _ -> \x y -> SBV.svAnd x y
- case predArgTypes pcSchema of
- Left msg -> return (Nothing, ProverError msg)
- Right ts -> do when pcVerbose $ lPutStrLn "Simulating..."
- v <- doEval $ do env <- Eval.evalDecls extDgs mempty
- Eval.evalExpr env pcExpr
- prims <- M.getPrimMap
- runRes <- runFn $ do
- (args, asms) <- runWriterT (mapM tyFn ts)
- b <- doEval (fromVBit <$>
- foldM fromVFun v (map Eval.ready args))
- return (foldr addAsm b asms)
- let (firstProver, results) = runRes
- esatexprs <- case results of
- -- allSat can return more than one as long as
- -- they're satisfiable
- (SBV.Satisfiable {} : _) -> do
- tevss <- mapM mkTevs results
- return $ AllSatResult tevss
- where
- mkTevs result = do
- let Right (_, cvs) = SBV.getModelAssignment result
- (vs, _) = parseValues ts cvs
- sattys = unFinType <$> ts
- satexprs <-
- doEval (zipWithM (Eval.toExpr prims) sattys vs)
- case zip3 sattys <$> (sequence satexprs) <*> pure vs of
- Nothing ->
- panic "Cryptol.Symbolic.sat"
- [ "unable to make assignment into expression" ]
- Just tevs -> return $ tevs
- -- prove returns only one
- [SBV.Unsatisfiable {}] ->
- return $ ThmResult (unFinType <$> ts)
- -- unsat returns empty
- [] -> return $ ThmResult (unFinType <$> ts)
- -- otherwise something is wrong
- _ -> return $ ProverError (rshow results)
- where rshow | isSat = show . SBV.AllSatResult . (False,False,False,)
- | otherwise = show . SBV.ThmResult . head
- return (firstProver, esatexprs)
-
-satProveOffline :: ProverCommand -> M.ModuleCmd (Either String String)
-satProveOffline ProverCommand {..} =
- protectStack (\msg (_,modEnv) -> return (Right (Left msg, modEnv), [])) $
- \(evOpts,modEnv) -> do
- let isSat = case pcQueryType of
- ProveQuery -> False
- SatQuery _ -> True
- let extDgs = allDeclGroups modEnv ++ pcExtraDecls
- let tyFn = if isSat then existsFinType else forallFinType
- let addAsm = if isSat then SBV.svAnd else \x y -> SBV.svOr (SBV.svNot x) y
- case predArgTypes pcSchema of
- Left msg -> return (Right (Left msg, modEnv), [])
- Right ts ->
- do when pcVerbose $ logPutStrLn (Eval.evalLogger evOpts) "Simulating..."
- v <- liftIO $ Eval.runEval evOpts $
- do env <- Eval.evalDecls extDgs mempty
- Eval.evalExpr env pcExpr
- smtlib <- SBV.generateSMTBenchmark isSat $ do
- (args, asms) <- runWriterT (mapM tyFn ts)
- b <- liftIO $ Eval.runEval evOpts
- (fromVBit <$> foldM fromVFun v (map Eval.ready args))
- return (foldr addAsm b asms)
- return (Right (Right smtlib, modEnv), [])
-
-protectStack :: (String -> M.ModuleCmd a)
- -> M.ModuleCmd a
- -> M.ModuleCmd a
-protectStack mkErr cmd modEnv =
- X.catchJust isOverflow (cmd modEnv) handler
- where isOverflow X.StackOverflow = Just ()
- isOverflow _ = Nothing
- msg = "Symbolic evaluation failed to terminate."
- handler () = mkErr msg modEnv
-
-parseValues :: [FinType] -> [SBV.CV] -> ([Eval.Value], [SBV.CV])
-parseValues [] cvs = ([], cvs)
-parseValues (t : ts) cvs = (v : vs, cvs'')
- where (v, cvs') = parseValue t cvs
- (vs, cvs'') = parseValues ts cvs'
-
-parseValue :: FinType -> [SBV.CV] -> (Eval.Value, [SBV.CV])
-parseValue FTBit [] = panic "Cryptol.Symbolic.parseValue" [ "empty FTBit" ]
-parseValue FTBit (cv : cvs) = (Eval.VBit (SBV.cvToBool cv), cvs)
-parseValue FTInteger cvs =
- case SBV.genParse SBV.KUnbounded cvs of
- Just (x, cvs') -> (Eval.VInteger x, cvs')
- Nothing -> panic "Cryptol.Symbolic.parseValue" [ "no integer" ]
-parseValue (FTIntMod _) cvs = parseValue FTInteger cvs
-parseValue (FTSeq 0 FTBit) cvs = (Eval.word 0 0, cvs)
-parseValue (FTSeq n FTBit) cvs =
- case SBV.genParse (SBV.KBounded False n) cvs of
- Just (x, cvs') -> (Eval.word (toInteger n) x, cvs')
- Nothing -> (VWord (genericLength vs) $ return $ Eval.WordVal $
- Eval.packWord (map fromVBit vs), cvs')
- where (vs, cvs') = parseValues (replicate n FTBit) cvs
-parseValue (FTSeq n t) cvs =
- (Eval.VSeq (toInteger n) $ Eval.finiteSeqMap (map Eval.ready vs)
- , cvs'
- )
- where (vs, cvs') = parseValues (replicate n t) cvs
-parseValue (FTTuple ts) cvs = (Eval.VTuple (map Eval.ready vs), cvs')
- where (vs, cvs') = parseValues ts cvs
-parseValue (FTRecord fs) cvs = (Eval.VRecord (zip ns (map Eval.ready vs)), cvs')
- where (ns, ts) = unzip fs
- (vs, cvs') = parseValues ts cvs
+predArgTypes :: QueryType -> Schema -> Either String [FinType]
+predArgTypes qtype schema@(Forall ts ps ty)
+ | null ts && null ps =
+ case go <$> (evalType mempty ty) of
+ Right (Just fts) -> Right fts
+ _ | SafetyQuery <- qtype -> Left $ "Expected finite result type:\n" ++ show (pp schema)
+ | otherwise -> Left $ "Not a valid predicate type:\n" ++ show (pp schema)
+ | otherwise = Left $ "Not a monomorphic type:\n" ++ show (pp schema)
+ where
+ go :: TValue -> Maybe [FinType]
+ go TVBit = Just []
+ go (TVFun ty1 ty2) = (:) <$> finType ty1 <*> go ty2
+ go tv
+ | Just _ <- finType tv
+ , SafetyQuery <- qtype
+ = Just []
-allDeclGroups :: M.ModuleEnv -> [DeclGroup]
-allDeclGroups = concatMap mDecls . M.loadedNonParamModules
+ | otherwise
+ = Nothing
data FinType
= FTBit
| FTInteger
| FTIntMod Integer
+ | FTRational
+ | FTFloat Integer Integer
| FTSeq Int FinType
| FTTuple [FinType]
- | FTRecord [(Ident, FinType)]
+ | FTRecord (RecordMap Ident FinType)
numType :: Integer -> Maybe Int
numType n
@@ -320,13 +133,15 @@
finType :: TValue -> Maybe FinType
finType ty =
case ty of
- Eval.TVBit -> Just FTBit
- Eval.TVInteger -> Just FTInteger
- Eval.TVIntMod n -> Just (FTIntMod n)
- Eval.TVSeq n t -> FTSeq <$> numType n <*> finType t
- Eval.TVTuple ts -> FTTuple <$> traverse finType ts
- Eval.TVRec fields -> FTRecord <$> traverse (traverseSnd finType) fields
- Eval.TVAbstract {} -> Nothing
+ TVBit -> Just FTBit
+ TVInteger -> Just FTInteger
+ TVIntMod n -> Just (FTIntMod n)
+ TVRational -> Just FTRational
+ TVFloat e p -> Just (FTFloat e p)
+ TVSeq n t -> FTSeq <$> numType n <*> finType t
+ TVTuple ts -> FTTuple <$> traverse finType ts
+ TVRec fields -> FTRecord <$> traverse finType fields
+ TVAbstract {} -> Nothing
_ -> Nothing
unFinType :: FinType -> Type
@@ -335,56 +150,8 @@
FTBit -> tBit
FTInteger -> tInteger
FTIntMod n -> tIntMod (tNum n)
+ FTRational -> tRational
+ FTFloat e p -> tFloat (tNum e) (tNum p)
FTSeq l ety -> tSeq (tNum l) (unFinType ety)
FTTuple ftys -> tTuple (unFinType <$> ftys)
- FTRecord fs -> tRec (zip fns tys)
- where
- fns = fst <$> fs
- tys = unFinType . snd <$> fs
-
-predArgTypes :: Schema -> Either String [FinType]
-predArgTypes schema@(Forall ts ps ty)
- | null ts && null ps =
- case go <$> (Eval.evalType mempty ty) of
- Right (Just fts) -> Right fts
- _ -> Left $ "Not a valid predicate type:\n" ++ show (pp schema)
- | otherwise = Left $ "Not a monomorphic type:\n" ++ show (pp schema)
- where
- go :: TValue -> Maybe [FinType]
- go Eval.TVBit = Just []
- go (Eval.TVFun ty1 ty2) = (:) <$> finType ty1 <*> go ty2
- go _ = Nothing
-
-inBoundsIntMod :: Integer -> SInteger -> SBool
-inBoundsIntMod n x =
- SBV.svAnd (SBV.svLessEq (Eval.integerLit 0) x) (SBV.svLessThan x (Eval.integerLit n))
-
-forallFinType :: FinType -> WriterT [SBool] SBV.Symbolic Value
-forallFinType ty =
- case ty of
- FTBit -> VBit <$> lift forallSBool_
- FTInteger -> VInteger <$> lift forallSInteger_
- FTIntMod n -> do x <- lift forallSInteger_
- tell [inBoundsIntMod n x]
- return (VInteger x)
- FTSeq 0 FTBit -> return $ Eval.word 0 0
- FTSeq n FTBit -> VWord (toInteger n) . return . Eval.WordVal <$> lift (forallBV_ n)
- FTSeq n t -> do vs <- replicateM n (forallFinType t)
- return $ VSeq (toInteger n) $ Eval.finiteSeqMap (map Eval.ready vs)
- FTTuple ts -> VTuple <$> mapM (fmap Eval.ready . forallFinType) ts
- FTRecord fs -> VRecord <$> mapM (traverseSnd (fmap Eval.ready . forallFinType)) fs
-
-existsFinType :: FinType -> WriterT [SBool] SBV.Symbolic Value
-existsFinType ty =
- case ty of
- FTBit -> VBit <$> lift existsSBool_
- FTInteger -> VInteger <$> lift existsSInteger_
- FTIntMod n -> do x <- lift existsSInteger_
- tell [inBoundsIntMod n x]
- return (VInteger x)
- FTSeq 0 FTBit -> return $ Eval.word 0 0
- FTSeq n FTBit -> VWord (toInteger n) . return . Eval.WordVal <$> lift (existsBV_ n)
- FTSeq n t -> do vs <- replicateM n (existsFinType t)
- return $ VSeq (toInteger n) $ Eval.finiteSeqMap (map Eval.ready vs)
- FTTuple ts -> VTuple <$> mapM (fmap Eval.ready . existsFinType) ts
- FTRecord fs -> VRecord <$> mapM (traverseSnd (fmap Eval.ready . existsFinType)) fs
+ FTRecord fs -> tRec (unFinType <$> fs)
diff --git a/src/Cryptol/Symbolic/Prims.hs b/src/Cryptol/Symbolic/Prims.hs
deleted file mode 100644
--- a/src/Cryptol/Symbolic/Prims.hs
+++ /dev/null
@@ -1,623 +0,0 @@
--- |
--- Module : Cryptol.Symbolic.Prims
--- Copyright : (c) 2013-2016 Galois, Inc.
--- License : BSD3
--- Maintainer : cryptol@galois.com
--- Stability : provisional
--- Portability : portable
-
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE PatternGuards #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE Rank2Types #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE TypeSynonymInstances #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
-module Cryptol.Symbolic.Prims where
-
-import Control.Monad (unless)
-import Data.Bits
-import qualified Data.Sequence as Seq
-import qualified Data.Foldable as Fold
-
-import Cryptol.Eval.Monad (Eval(..), ready, invalidIndex, cryUserError)
-import Cryptol.Eval.Type (finNat', TValue(..))
-import Cryptol.Eval.Value (BitWord(..), EvalPrims(..), enumerateSeqMap, SeqMap(..),
- reverseSeqMap, wlam, nlam, WordValue(..),
- asWordVal, fromWordVal, fromBit,
- enumerateWordValue, enumerateWordValueRev,
- wordValueSize,
- updateWordValue,
- updateSeqMap, lookupSeqMap, memoMap )
-import Cryptol.Prims.Eval (binary, unary, arithUnary,
- arithBinary, Binary, BinArith,
- logicBinary, logicUnary, zeroV,
- ccatV, splitAtV, joinV, ecSplitV,
- reverseV, infFromV, infFromThenV,
- fromToV, fromThenToV,
- transposeV, indexPrim,
- ecToIntegerV, ecFromIntegerV,
- ecNumberV, updatePrim, randomV, liftWord,
- cmpValue, lg2)
-import Cryptol.Symbolic.Value
-import Cryptol.TypeCheck.AST (Decl(..))
-import Cryptol.TypeCheck.Solver.InfNat (Nat'(..), widthInteger)
-import Cryptol.ModuleSystem.Name (asPrim)
-import Cryptol.Utils.Ident (Ident,mkIdent)
-
-import qualified Data.SBV as SBV
-import qualified Data.SBV.Dynamic as SBV
-import qualified Data.Map as Map
-import qualified Data.Text as T
-
-import Prelude ()
-import Prelude.Compat
-import Control.Monad (join)
-
-traverseSnd :: Functor f => (a -> f b) -> (t, a) -> f (t, b)
-traverseSnd f (x, y) = (,) x <$> f y
-
--- Primitives ------------------------------------------------------------------
-
-instance EvalPrims SBool SWord SInteger where
- evalPrim Decl { dName = n, .. } =
- do prim <- asPrim n
- Map.lookup prim primTable
-
- iteValue b x1 x2
- | Just b' <- SBV.svAsBool b = if b' then x1 else x2
- | otherwise = do v1 <- x1
- v2 <- x2
- iteSValue b v1 v2
-
--- See also Cryptol.Prims.Eval.primTable
-primTable :: Map.Map Ident Value
-primTable = Map.fromList $ map (\(n, v) -> (mkIdent (T.pack n), v))
- [ ("True" , VBit SBV.svTrue)
- , ("False" , VBit SBV.svFalse)
- , ("number" , ecNumberV) -- Converts a numeric type into its corresponding value.
- -- { val, rep } (Literal val rep) => rep
- , ("+" , binary (arithBinary (liftBinArith SBV.svPlus) (liftBin SBV.svPlus)
- sModAdd)) -- {a} (Arith a) => a -> a -> a
- , ("-" , binary (arithBinary (liftBinArith SBV.svMinus) (liftBin SBV.svMinus)
- sModSub)) -- {a} (Arith a) => a -> a -> a
- , ("*" , binary (arithBinary (liftBinArith SBV.svTimes) (liftBin SBV.svTimes)
- sModMult)) -- {a} (Arith a) => a -> a -> a
- , ("/" , binary (arithBinary (liftBinArith SBV.svQuot) (liftBin SBV.svQuot)
- (liftModBin SBV.svQuot))) -- {a} (Arith a) => a -> a -> a
- , ("%" , binary (arithBinary (liftBinArith SBV.svRem) (liftBin SBV.svRem)
- (liftModBin SBV.svRem))) -- {a} (Arith a) => a -> a -> a
- , ("^^" , binary (arithBinary sExp (liftBin SBV.svExp)
- sModExp)) -- {a} (Arith a) => a -> a -> a
- , ("lg2" , unary (arithUnary sLg2 svLg2 svModLg2)) -- {a} (Arith a) => a -> a
- , ("negate" , unary (arithUnary (\_ -> ready . SBV.svUNeg) (ready . SBV.svUNeg)
- (const (ready . SBV.svUNeg))))
- , ("<" , binary (cmpBinary cmpLt cmpLt cmpLt (cmpMod cmpLt) SBV.svFalse))
- , (">" , binary (cmpBinary cmpGt cmpGt cmpGt (cmpMod cmpGt) SBV.svFalse))
- , ("<=" , binary (cmpBinary cmpLtEq cmpLtEq cmpLtEq (cmpMod cmpLtEq) SBV.svTrue))
- , (">=" , binary (cmpBinary cmpGtEq cmpGtEq cmpGtEq (cmpMod cmpGtEq) SBV.svTrue))
- , ("==" , binary (cmpBinary cmpEq cmpEq cmpEq cmpModEq SBV.svTrue))
- , ("!=" , binary (cmpBinary cmpNotEq cmpNotEq cmpNotEq cmpModNotEq SBV.svFalse))
- , ("<$" , let boolFail = evalPanic "<$" ["Attempted signed comparison on bare Bit values"]
- intFail = evalPanic "<$" ["Attempted signed comparison on Integer values"]
- in binary (cmpBinary boolFail cmpSignedLt intFail (const intFail) SBV.svFalse))
- , ("/$" , binary (arithBinary (liftBinArith signedQuot) (liftBin SBV.svQuot)
- (liftModBin SBV.svQuot))) -- {a} (Arith a) => a -> a -> a
- , ("%$" , binary (arithBinary (liftBinArith signedRem) (liftBin SBV.svRem)
- (liftModBin SBV.svRem)))
- , (">>$" , sshrV)
- , ("&&" , binary (logicBinary SBV.svAnd SBV.svAnd))
- , ("||" , binary (logicBinary SBV.svOr SBV.svOr))
- , ("^" , binary (logicBinary SBV.svXOr SBV.svXOr))
- , ("complement" , unary (logicUnary SBV.svNot SBV.svNot))
- , ("zero" , tlam zeroV)
- , ("toInteger" , ecToIntegerV)
- , ("fromInteger" , ecFromIntegerV (const id))
- , ("fromZ" , nlam $ \ modulus ->
- lam $ \ x -> do
- val <- x
- case (modulus, val) of
- (Nat n, VInteger i) -> return $ VInteger (SBV.svRem i (integerLit n))
- _ -> evalPanic "fromZ" ["Invalid arguments"])
- , ("<<" , logicShift "<<"
- SBV.svShiftLeft
- (\sz i shft ->
- case sz of
- Inf -> Just (i+shft)
- Nat n
- | i+shft >= n -> Nothing
- | otherwise -> Just (i+shft)))
- , (">>" , logicShift ">>"
- SBV.svShiftRight
- (\_sz i shft ->
- if i-shft < 0 then Nothing else Just (i-shft)))
- , ("<<<" , logicShift "<<<"
- SBV.svRotateLeft
- (\sz i shft ->
- case sz of
- Inf -> evalPanic "cannot rotate infinite sequence" []
- Nat n -> Just ((i+shft) `mod` n)))
- , (">>>" , logicShift ">>>"
- SBV.svRotateRight
- (\sz i shft ->
- case sz of
- Inf -> evalPanic "cannot rotate infinite sequence" []
- Nat n -> Just ((i+n-shft) `mod` n)))
-
- , ("carry" , liftWord carry)
- , ("scarry" , liftWord scarry)
-
- , ("#" , -- {a,b,d} (fin a) => [a] d -> [b] d -> [a + b] d
- nlam $ \ front ->
- nlam $ \ back ->
- tlam $ \ elty ->
- lam $ \ l -> return $
- lam $ \ r -> join (ccatV front back elty <$> l <*> r))
-
- , ("splitAt" ,
- nlam $ \ front ->
- nlam $ \ back ->
- tlam $ \ a ->
- lam $ \ x ->
- splitAtV front back a =<< x)
-
- , ("join" ,
- nlam $ \ parts ->
- nlam $ \ (finNat' -> each) ->
- tlam $ \ a ->
- lam $ \ x ->
- joinV parts each a =<< x)
-
- , ("split" , ecSplitV)
-
- , ("reverse" , nlam $ \_a ->
- tlam $ \_b ->
- lam $ \xs -> reverseV =<< xs)
-
- , ("transpose" , nlam $ \a ->
- nlam $ \b ->
- tlam $ \c ->
- lam $ \xs -> transposeV a b c =<< xs)
-
- , ("fromTo" , fromToV)
- , ("fromThenTo" , fromThenToV)
- , ("infFrom" , infFromV)
- , ("infFromThen" , infFromThenV)
-
- , ("@" , indexPrim indexFront_bits indexFront)
- , ("!" , indexPrim indexBack_bits indexBack)
-
- , ("update" , updatePrim updateFrontSym_word updateFrontSym)
- , ("updateEnd" , updatePrim updateBackSym_word updateBackSym)
-
- -- {at,len} (fin len) => [len][8] -> at
- , ("error" ,
- tlam $ \at ->
- nlam $ \(finNat' -> _len) ->
- VFun $ \_msg ->
- return $ zeroV at) -- error/undefined, is arbitrarily translated to 0
-
- , ("random" ,
- tlam $ \a ->
- wlam $ \x ->
- case SBV.svAsInteger x of
- Just i -> return $ randomV a i
- Nothing -> cryUserError "cannot evaluate 'random' with symbolic inputs")
-
- -- The trace function simply forces its first two
- -- values before returing the third in the symbolic
- -- evaluator.
- , ("trace",
- nlam $ \_n ->
- tlam $ \_a ->
- tlam $ \_b ->
- lam $ \s -> return $
- lam $ \x -> return $
- lam $ \y -> do
- _ <- s
- _ <- x
- y)
- ]
-
-
--- | Barrel-shifter algorithm. Takes a list of bits in big-endian order.
-shifter :: Monad m => (SBool -> a -> a -> a) -> (a -> Integer -> m a) -> a -> [SBool] -> m a
-shifter mux op = go
- where
- go x [] = return x
- go x (b : bs) = do
- x' <- op x (2 ^ length bs)
- go (mux b x' x) bs
-
-logicShift :: String
- -> (SWord -> SWord -> SWord)
- -> (Nat' -> Integer -> Integer -> Maybe Integer)
- -> Value
-logicShift nm wop reindex =
- nlam $ \_m ->
- nlam $ \_n ->
- tlam $ \a ->
- VFun $ \xs -> return $
- VFun $ \y -> do
- idx <- fromWordVal "logicShift" =<< y
-
- xs >>= \case
- VWord w x ->
- return $ VWord w $ do
- x >>= \case
- WordVal x' -> WordVal . wop x' <$> asWordVal idx
- BitsVal bs0 ->
- do idx_bits <- enumerateWordValue idx
- let op bs shft = return $ Seq.fromFunction (Seq.length bs) $ \i ->
- case reindex (Nat w) (toInteger i) shft of
- Nothing -> return $ bitLit False
- Just i' -> Seq.index bs (fromInteger i')
- BitsVal <$> shifter (mergeBits True) op bs0 idx_bits
- LargeBitsVal n bs0 ->
- do idx_bits <- enumerateWordValue idx
- let op bs shft = memoMap $ IndexSeqMap $ \i ->
- case reindex (Nat w) i shft of
- Nothing -> return $ VBit $ bitLit False
- Just i' -> lookupSeqMap bs i'
- LargeBitsVal n <$> shifter (mergeSeqMap True) op bs0 idx_bits
-
- VSeq w vs0 ->
- do idx_bits <- enumerateWordValue idx
- let op vs shft = memoMap $ IndexSeqMap $ \i ->
- case reindex (Nat w) i shft of
- Nothing -> return $ zeroV a
- Just i' -> lookupSeqMap vs i'
- VSeq w <$> shifter (mergeSeqMap True) op vs0 idx_bits
-
- VStream vs0 ->
- do idx_bits <- enumerateWordValue idx
- let op vs shft = memoMap $ IndexSeqMap $ \i ->
- case reindex Inf i shft of
- Nothing -> return $ zeroV a
- Just i' -> lookupSeqMap vs i'
- VStream <$> shifter (mergeSeqMap True) op vs0 idx_bits
-
- _ -> evalPanic "expected sequence value in shift operation" [nm]
-
-
-indexFront :: Maybe Integer
- -> TValue
- -> SeqMap SBool SWord SInteger
- -> SWord
- -> Eval Value
-indexFront mblen a xs idx
- | Just i <- SBV.svAsInteger idx
- = lookupSeqMap xs i
-
- | Just n <- mblen
- , TVSeq wlen TVBit <- a
- = do wvs <- traverse (fromWordVal "indexFront" =<<) (enumerateSeqMap n xs)
- case asWordList wvs of
- Just ws ->
- return $ VWord wlen $ ready $ WordVal $ SBV.svSelect ws (wordLit wlen 0) idx
- Nothing -> foldr f def idxs
-
- | otherwise
- = foldr f def idxs
-
- where
- k = SBV.kindOf idx
- w = SBV.intSizeOf idx
- def = ready $ zeroV a
- f n y = iteValue (SBV.svEqual idx (SBV.svInteger k n)) (lookupSeqMap xs n) y
- idxs = case mblen of
- Just n | n < 2^w -> [0 .. n-1]
- _ -> [0 .. 2^w - 1]
-
-
-indexBack :: Maybe Integer
- -> TValue
- -> SeqMap SBool SWord SInteger
- -> SWord
- -> Eval Value
-indexBack (Just n) a xs idx = indexFront (Just n) a (reverseSeqMap n xs) idx
-indexBack Nothing _ _ _ = evalPanic "Expected finite sequence" ["indexBack"]
-
-indexFront_bits :: Maybe Integer
- -> TValue
- -> SeqMap SBool SWord SInteger
- -> Seq.Seq SBool
- -> Eval Value
-indexFront_bits mblen a xs bits0 = go 0 (length bits0) (Fold.toList bits0)
- where
- go :: Integer -> Int -> [SBool] -> Eval Value
- go i _k []
- -- For indices out of range, return 0 arbitrarily
- | Just n <- mblen
- , i >= n
- = return $ zeroV a
-
- | otherwise
- = lookupSeqMap xs i
-
- go i k (b:bs)
- | Just n <- mblen
- , (i `shiftL` k) >= n
- = return $ zeroV a
-
- | otherwise
- = iteValue b (go ((i `shiftL` 1) + 1) (k-1) bs)
- (go (i `shiftL` 1) (k-1) bs)
-
-indexBack_bits :: Maybe Integer
- -> TValue
- -> SeqMap SBool SWord SInteger
- -> Seq.Seq SBool
- -> Eval Value
-indexBack_bits (Just n) a xs idx = indexFront_bits (Just n) a (reverseSeqMap n xs) idx
-indexBack_bits Nothing _ _ _ = evalPanic "Expected finite sequence" ["indexBack_bits"]
-
-
--- | Compare a symbolic word value with a concrete integer.
-wordValueEqualsInteger :: WordValue SBool SWord SInteger -> Integer -> Eval SBool
-wordValueEqualsInteger wv i
- | wordValueSize wv < widthInteger i = return SBV.svFalse
- | otherwise =
- case wv of
- WordVal w -> return $ SBV.svEqual w (literalSWord (SBV.intSizeOf w) i)
- _ -> bitsAre i <$> enumerateWordValueRev wv -- little-endian
- where
- bitsAre :: Integer -> [SBool] -> SBool
- bitsAre n [] = SBV.svBool (n == 0)
- bitsAre n (b : bs) = SBV.svAnd (bitIs (odd n) b) (bitsAre (n `div` 2) bs)
-
- bitIs :: Bool -> SBool -> SBool
- bitIs b x = if b then x else SBV.svNot x
-
-lazyMergeBit :: SBool -> Eval SBool -> Eval SBool -> Eval SBool
-lazyMergeBit c x y =
- case SBV.svAsBool c of
- Just True -> x
- Just False -> y
- Nothing -> mergeBit False c <$> x <*> y
-
-updateFrontSym
- :: Nat'
- -> TValue
- -> SeqMap SBool SWord SInteger
- -> WordValue SBool SWord SInteger
- -> Eval (GenValue SBool SWord SInteger)
- -> Eval (SeqMap SBool SWord SInteger)
-updateFrontSym len _eltTy vs wv val =
- case wv of
- WordVal w | Just j <- SBV.svAsInteger w ->
- do case len of
- Inf -> return ()
- Nat n -> unless (j < n) (invalidIndex j)
- return $ updateSeqMap vs j val
- _ ->
- return $ IndexSeqMap $ \i ->
- do b <- wordValueEqualsInteger wv i
- iteValue b val (lookupSeqMap vs i)
-
-updateFrontSym_word
- :: Nat'
- -> TValue
- -> WordValue SBool SWord SInteger
- -> WordValue SBool SWord SInteger
- -> Eval (GenValue SBool SWord SInteger)
- -> Eval (WordValue SBool SWord SInteger)
-updateFrontSym_word Inf _ _ _ _ = evalPanic "Expected finite sequence" ["updateFrontSym_bits"]
-updateFrontSym_word (Nat n) eltTy bv wv val =
- case wv of
- WordVal w | Just j <- SBV.svAsInteger w ->
- do unless (j < n) (invalidIndex j)
- updateWordValue bv j (fromVBit <$> val)
- _ ->
- case bv of
- WordVal bw -> return $ BitsVal $ Seq.mapWithIndex f bs
- where bs = fmap return $ Seq.fromList $ unpackWord bw
- BitsVal bs -> return $ BitsVal $ Seq.mapWithIndex f bs
- LargeBitsVal l vs -> LargeBitsVal l <$> updateFrontSym (Nat n) eltTy vs wv val
- where
- f :: Int -> Eval SBool -> Eval SBool
- f i x = do c <- wordValueEqualsInteger wv (toInteger i)
- lazyMergeBit c (fromBit =<< val) x
-
-updateBackSym
- :: Nat'
- -> TValue
- -> SeqMap SBool SWord SInteger
- -> WordValue SBool SWord SInteger
- -> Eval (GenValue SBool SWord SInteger)
- -> Eval (SeqMap SBool SWord SInteger)
-updateBackSym Inf _ _ _ _ = evalPanic "Expected finite sequence" ["updateBackSym"]
-updateBackSym (Nat n) _eltTy vs wv val =
- case wv of
- WordVal w | Just j <- SBV.svAsInteger w ->
- do unless (j < n) (invalidIndex j)
- return $ updateSeqMap vs (n - 1 - j) val
- _ ->
- return $ IndexSeqMap $ \i ->
- do b <- wordValueEqualsInteger wv (n - 1 - i)
- iteValue b val (lookupSeqMap vs i)
-
-updateBackSym_word
- :: Nat'
- -> TValue
- -> WordValue SBool SWord SInteger
- -> WordValue SBool SWord SInteger
- -> Eval (GenValue SBool SWord SInteger)
- -> Eval (WordValue SBool SWord SInteger)
-updateBackSym_word Inf _ _ _ _ = evalPanic "Expected finite sequence" ["updateBackSym_bits"]
-updateBackSym_word (Nat n) eltTy bv wv val = do
- case wv of
- WordVal w | Just j <- SBV.svAsInteger w ->
- do unless (j < n) (invalidIndex j)
- updateWordValue bv (n - 1 - j) (fromVBit <$> val)
- _ ->
- case bv of
- WordVal bw -> return $ BitsVal $ Seq.mapWithIndex f bs
- where bs = fmap return $ Seq.fromList $ unpackWord bw
- BitsVal bs -> return $ BitsVal $ Seq.mapWithIndex f bs
- LargeBitsVal l vs -> LargeBitsVal l <$> updateBackSym (Nat n) eltTy vs wv val
- where
- f :: Int -> Eval SBool -> Eval SBool
- f i x = do c <- wordValueEqualsInteger wv (n - 1 - toInteger i)
- lazyMergeBit c (fromBit =<< val) x
-
-asBitList :: [Eval SBool] -> Maybe [SBool]
-asBitList = go id
- where go :: ([SBool] -> [SBool]) -> [Eval SBool] -> Maybe [SBool]
- go f [] = Just (f [])
- go f (Ready b:vs) = go (f . (b:)) vs
- go _ _ = Nothing
-
-
-asWordList :: [WordValue SBool SWord SInteger] -> Maybe [SWord]
-asWordList = go id
- where go :: ([SWord] -> [SWord]) -> [WordValue SBool SWord SInteger] -> Maybe [SWord]
- go f [] = Just (f [])
- go f (WordVal x :vs) = go (f . (x:)) vs
- go f (BitsVal bs:vs) =
- case asBitList (Fold.toList bs) of
- Just xs -> go (f . (packWord xs:)) vs
- Nothing -> Nothing
- go _f (LargeBitsVal _ _ : _) = Nothing
-
-liftBinArith :: (SWord -> SWord -> SWord) -> BinArith SWord
-liftBinArith op _ x y = ready $ op x y
-
-liftBin :: (a -> b -> c) -> a -> b -> Eval c
-liftBin op x y = ready $ op x y
-
-liftModBin :: (SInteger -> SInteger -> a) -> Integer -> SInteger -> SInteger -> Eval a
-liftModBin op modulus x y = ready $ op (SBV.svRem x m) (SBV.svRem y m)
- where m = integerLit modulus
-
-sExp :: Integer -> SWord -> SWord -> Eval SWord
-sExp _w x y = ready $ go (reverse (unpackWord y)) -- bits in little-endian order
- where go [] = literalSWord (SBV.intSizeOf x) 1
- go (b : bs) = SBV.svIte b (SBV.svTimes x s) s
- where a = go bs
- s = SBV.svTimes a a
-
-sModAdd :: Integer -> SInteger -> SInteger -> Eval SInteger
-sModAdd modulus x y =
- case (SBV.svAsInteger x, SBV.svAsInteger y) of
- (Just i, Just j) -> ready $ integerLit ((i + j) `mod` modulus)
- _ -> ready $ SBV.svPlus x y
-
-sModSub :: Integer -> SInteger -> SInteger -> Eval SInteger
-sModSub modulus x y =
- case (SBV.svAsInteger x, SBV.svAsInteger y) of
- (Just i, Just j) -> ready $ integerLit ((i - j) `mod` modulus)
- _ -> ready $ SBV.svMinus x y
-
-sModMult :: Integer -> SInteger -> SInteger -> Eval SInteger
-sModMult modulus x y =
- case (SBV.svAsInteger x, SBV.svAsInteger y) of
- (Just i, Just j) -> ready $ integerLit ((i * j) `mod` modulus)
- _ -> ready $ SBV.svTimes x y
-
-sModExp :: Integer -> SInteger -> SInteger -> Eval SInteger
-sModExp modulus x y = ready $ SBV.svExp x (SBV.svRem y m)
- where m = integerLit modulus
-
--- | Ceiling (log_2 x)
-sLg2 :: Integer -> SWord -> Eval SWord
-sLg2 _w x = ready $ 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)
-
--- | Ceiling (log_2 x)
-svLg2 :: SInteger -> Eval SInteger
-svLg2 x =
- case SBV.svAsInteger x of
- Just n -> ready $ SBV.svInteger SBV.KUnbounded (lg2 n)
- Nothing -> evalPanic "cannot compute lg2 of symbolic unbounded integer" []
-
-svModLg2 :: Integer -> SInteger -> Eval SInteger
-svModLg2 modulus x = svLg2 (SBV.svRem x m)
- where m = integerLit modulus
-
--- Cmp -------------------------------------------------------------------------
-
-cmpEq :: SWord -> SWord -> Eval SBool -> Eval SBool
-cmpEq x y k = SBV.svAnd (SBV.svEqual x y) <$> k
-
-cmpNotEq :: SWord -> SWord -> Eval SBool -> Eval SBool
-cmpNotEq x y k = SBV.svOr (SBV.svNotEqual x y) <$> k
-
-cmpSignedLt :: SWord -> SWord -> Eval SBool -> Eval SBool
-cmpSignedLt x y k = SBV.svOr (SBV.svLessThan sx sy) <$> (cmpEq sx sy k)
- where sx = SBV.svSign x
- sy = SBV.svSign y
-
-cmpLt, cmpGt :: SWord -> SWord -> Eval SBool -> Eval SBool
-cmpLt x y k = SBV.svOr (SBV.svLessThan x y) <$> (cmpEq x y k)
-cmpGt x y k = SBV.svOr (SBV.svGreaterThan x y) <$> (cmpEq x y k)
-
-cmpLtEq, cmpGtEq :: SWord -> SWord -> Eval SBool -> Eval SBool
-cmpLtEq x y k = SBV.svAnd (SBV.svLessEq x y) <$> (cmpNotEq x y k)
-cmpGtEq x y k = SBV.svAnd (SBV.svGreaterEq x y) <$> (cmpNotEq x y k)
-
-cmpMod ::
- (SInteger -> SInteger -> Eval SBool -> Eval SBool) ->
- (Integer -> SInteger -> SInteger -> Eval SBool -> Eval SBool)
-cmpMod cmp modulus x y k = cmp (SBV.svRem x m) (SBV.svRem y m) k
- where m = integerLit modulus
-
-cmpModEq :: Integer -> SInteger -> SInteger -> Eval SBool -> Eval SBool
-cmpModEq m x y k = SBV.svAnd (svDivisible m (SBV.svMinus x y)) <$> k
-
-cmpModNotEq :: Integer -> SInteger -> SInteger -> Eval SBool -> Eval SBool
-cmpModNotEq m x y k = SBV.svOr (SBV.svNot (svDivisible m (SBV.svMinus x y))) <$> k
-
-svDivisible :: Integer -> SInteger -> SBool
-svDivisible m x = SBV.svEqual (SBV.svRem x (integerLit m)) (integerLit 0)
-
-cmpBinary :: (SBool -> SBool -> Eval SBool -> Eval SBool)
- -> (SWord -> SWord -> Eval SBool -> Eval SBool)
- -> (SInteger -> SInteger -> Eval SBool -> Eval SBool)
- -> (Integer -> SInteger -> SInteger -> Eval SBool -> Eval SBool)
- -> SBool -> Binary SBool SWord SInteger
-cmpBinary fb fw fi fz b ty v1 v2 = VBit <$> cmpValue fb fw fi fz ty v1 v2 (return b)
-
--- Signed arithmetic -----------------------------------------------------------
-
-signedQuot :: SWord -> SWord -> SWord
-signedQuot x y = SBV.svUnsign (SBV.svQuot (SBV.svSign x) (SBV.svSign y))
-
-signedRem :: SWord -> SWord -> SWord
-signedRem x y = SBV.svUnsign (SBV.svRem (SBV.svSign x) (SBV.svSign y))
-
-
-sshrV :: Value
-sshrV =
- nlam $ \_n ->
- nlam $ \_k ->
- wlam $ \x -> return $
- wlam $ \y ->
- case SBV.svAsInteger y of
- Just i ->
- let z = SBV.svUnsign (SBV.svShr (SBV.svSign x) (fromInteger i))
- in return . VWord (toInteger (SBV.intSizeOf x)) . ready . WordVal $ z
- Nothing ->
- let z = SBV.svUnsign (SBV.svShiftRight (SBV.svSign x) y)
- in return . VWord (toInteger (SBV.intSizeOf x)) . ready . WordVal $ z
-
-carry :: SWord -> SWord -> Eval Value
-carry x y = return $ VBit c
- where
- c = SBV.svLessThan (SBV.svPlus x y) x
-
-scarry :: SWord -> SWord -> Eval Value
-scarry x y = return $ VBit sc
- where
- n = SBV.intSizeOf x
- z = SBV.svPlus (SBV.svSign x) (SBV.svSign y)
- xsign = SBV.svTestBit x (n-1)
- ysign = SBV.svTestBit y (n-1)
- zsign = SBV.svTestBit z (n-1)
- sc = SBV.svAnd (SBV.svEqual xsign ysign) (SBV.svNotEqual xsign zsign)
diff --git a/src/Cryptol/Symbolic/SBV.hs b/src/Cryptol/Symbolic/SBV.hs
new file mode 100644
--- /dev/null
+++ b/src/Cryptol/Symbolic/SBV.hs
@@ -0,0 +1,553 @@
+-- |
+-- Module : Cryptol.Symbolic.SBV
+-- Copyright : (c) 2013-2016 Galois, Inc.
+-- License : BSD3
+-- Maintainer : cryptol@galois.com
+-- Stability : provisional
+-- Portability : portable
+
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ImplicitParams #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module Cryptol.Symbolic.SBV
+ ( SBVProverConfig
+ , defaultProver
+ , proverNames
+ , setupProver
+ , satProve
+ , satProveOffline
+ , SBVPortfolioException(..)
+ ) where
+
+
+import Control.Concurrent.Async
+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 Data.Maybe (fromMaybe)
+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.Internals as SBV (SBV(..))
+import qualified Data.SBV.Dynamic as SBV
+import Data.SBV (Timing(SaveTiming))
+
+import qualified Cryptol.ModuleSystem as M hiding (getPrimMap)
+import qualified Cryptol.ModuleSystem.Env as M
+import qualified Cryptol.ModuleSystem.Base as M
+import qualified Cryptol.ModuleSystem.Monad as M
+
+import qualified Cryptol.Eval.Backend as Eval
+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.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
+ SBVError err -> liftIO (X.throwIO err)
+ SBVResult p x -> pure (p, x)
+
+-- External interface ----------------------------------------------------------
+
+proverConfigs :: [(String, SBV.SMTConfig)]
+proverConfigs =
+ [ ("cvc4" , SBV.cvc4 )
+ , ("yices" , SBV.yices )
+ , ("z3" , SBV.z3 )
+ , ("boolector", SBV.boolector)
+ , ("mathsat" , SBV.mathSAT )
+ , ("abc" , SBV.abc )
+ , ("offline" , SBV.defaultSMTCfg )
+ , ("any" , SBV.defaultSMTCfg )
+
+ , ("sbv-cvc4" , SBV.cvc4 )
+ , ("sbv-yices" , SBV.yices )
+ , ("sbv-z3" , SBV.z3 )
+ , ("sbv-boolector", SBV.boolector)
+ , ("sbv-mathsat" , SBV.mathSAT )
+ , ("sbv-abc" , SBV.abc )
+ , ("sbv-offline" , SBV.defaultSMTCfg )
+ , ("sbv-any" , SBV.defaultSMTCfg )
+ ]
+
+newtype SBVPortfolioException
+ = SBVPortfolioException [Either X.SomeException (Maybe String,String)]
+
+instance Show SBVPortfolioException where
+ show (SBVPortfolioException exs) =
+ unlines ("All solvers in the portfolio failed!" : map f exs)
+ where
+ f (Left e) = X.displayException e
+ f (Right (Nothing, msg)) = msg
+ f (Right (Just nm, msg)) = nm ++ ": " ++ msg
+
+instance X.Exception SBVPortfolioException
+
+data SBVProverConfig
+ = SBVPortfolio [SBV.SMTConfig]
+ | SBVProverConfig SBV.SMTConfig
+
+defaultProver :: SBVProverConfig
+defaultProver = SBVProverConfig SBV.z3
+
+-- | The names of all the solvers supported by SBV
+proverNames :: [String]
+proverNames = map fst proverConfigs
+
+setupProver :: String -> IO (Either String ([String], SBVProverConfig))
+setupProver nm
+ | nm `elem` ["any","sbv-any"] =
+ do ps <- SBV.sbvAvailableSolvers
+ case ps of
+ [] -> pure (Left "SBV could not find any provers")
+ _ -> let msg = "SBV found the following solvers: " ++ show (map (SBV.name . SBV.solver) ps) in
+ pure (Right ([msg], SBVPortfolio ps))
+
+ -- special case, we search for two different yices binaries
+ | nm `elem` ["yices","sbv-yices"] = tryCfgs SBV.yices ["yices-smt2", "yices_smt2"]
+
+ | otherwise =
+ case lookup nm proverConfigs of
+ Just cfg -> tryCfgs cfg []
+ Nothing -> pure (Left ("unknown solver name: " ++ nm))
+
+ where
+ tryCfgs cfg (e:es) =
+ do let cfg' = cfg{ SBV.solver = (SBV.solver cfg){ SBV.executable = e } }
+ ok <- SBV.sbvCheckSolverInstallation cfg'
+ if ok then pure (Right ([], SBVProverConfig cfg')) else tryCfgs cfg es
+
+ tryCfgs cfg [] =
+ do ok <- SBV.sbvCheckSolverInstallation cfg
+ pure (Right (ws ok, SBVProverConfig cfg))
+
+ ws ok = if ok then [] else notFound
+ notFound = ["Warning: " ++ nm ++ " installation not found"]
+
+satSMTResults :: SBV.SatResult -> [SBV.SMTResult]
+satSMTResults (SBV.SatResult r) = [r]
+
+allSatSMTResults :: SBV.AllSatResult -> [SBV.SMTResult]
+allSatSMTResults (SBV.AllSatResult (_, _, _, rs)) = rs
+
+thmSMTResults :: SBV.ThmResult -> [SBV.SMTResult]
+thmSMTResults (SBV.ThmResult r) = [r]
+
+proverError :: String -> M.ModuleCmd (Maybe String, ProverResult)
+proverError msg (_, _, modEnv) =
+ return (Right ((Nothing, ProverError msg), modEnv), [])
+
+
+isFailedResult :: [SBV.SMTResult] -> Maybe String
+isFailedResult [] = Just "Solver returned no results!"
+isFailedResult (r:_) =
+ case r of
+ SBV.Unknown _cfg rsn -> Just ("Solver returned UNKNOWN " ++ show rsn)
+ SBV.ProofError _ ms _ -> Just (unlines ("Solver error" : ms))
+ _ -> Nothing
+
+runSingleProver ::
+ ProverCommand ->
+ (String -> IO ()) ->
+ SBV.SMTConfig ->
+ (SBV.SMTConfig -> SBV.Symbolic SBV.SVal -> IO res) ->
+ (res -> [SBV.SMTResult]) ->
+ SBV.Symbolic SBV.SVal ->
+ IO (Maybe String, [SBV.SMTResult])
+runSingleProver ProverCommand{..} lPutStrLn prover callSolver processResult e = do
+ when pcVerbose $
+ lPutStrLn $ "Trying proof with " ++
+ show (SBV.name (SBV.solver prover))
+ res <- callSolver prover e
+
+ when pcVerbose $
+ lPutStrLn $ "Got result from " ++
+ show (SBV.name (SBV.solver prover))
+ return (Just (show (SBV.name (SBV.solver prover))), processResult res)
+
+runMultiProvers ::
+ ProverCommand ->
+ (String -> IO ()) ->
+ [SBV.SMTConfig] ->
+ (SBV.SMTConfig -> SBV.Symbolic SBV.SVal -> IO res) ->
+ (res -> [SBV.SMTResult]) ->
+ SBV.Symbolic SBV.SVal ->
+ IO (Maybe String, [SBV.SMTResult])
+runMultiProvers pc lPutStrLn provers callSolver processResult e = do
+ as <- mapM async [ runSingleProver pc lPutStrLn p callSolver processResult e
+ | p <- provers
+ ]
+ waitForResults [] as
+
+ where
+ waitForResults exs [] = X.throw (SBVPortfolioException exs)
+ waitForResults exs as =
+ do (winner, result) <- waitAnyCatch as
+ let others = filter (/= winner) as
+ case result of
+ Left ex ->
+ waitForResults (Left ex:exs) others
+ Right r@(nm, rs)
+ | Just msg <- isFailedResult rs ->
+ waitForResults (Right (nm, msg) : exs) others
+ | otherwise ->
+ do forM_ others (\a -> X.throwTo (asyncThreadId a) ExitSuccess)
+ return r
+
+-- | 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 proverConfig pc@ProverCommand{..} lPutStrLn x =
+ do let mSatNum = case pcQueryType of
+ SatQuery (SomeSat n) -> Just n
+ SatQuery AllSat -> Nothing
+ ProveQuery -> Nothing
+ SafetyQuery -> Nothing
+
+ case proverConfig of
+ SBVPortfolio ps ->
+ let ps' = [ p { SBV.transcript = pcSmtFile
+ , SBV.timing = SaveTiming pcProverStats
+ , SBV.verbose = pcVerbose
+ , SBV.validateModel = pcValidate
+ }
+ | p <- ps
+ ] in
+
+ case pcQueryType of
+ ProveQuery -> runMultiProvers pc lPutStrLn ps' SBV.proveWith thmSMTResults x
+ SafetyQuery -> runMultiProvers pc lPutStrLn ps' SBV.proveWith thmSMTResults x
+ SatQuery (SomeSat 1) -> runMultiProvers pc lPutStrLn ps' SBV.satWith satSMTResults x
+ _ -> return (Nothing,
+ [SBV.ProofError p
+ [":sat with option prover=any requires option satNum=1"]
+ Nothing
+ | p <- ps])
+
+ SBVProverConfig p ->
+ let p' = p { SBV.transcript = pcSmtFile
+ , SBV.allSatMaxModelCount = mSatNum
+ , SBV.timing = SaveTiming pcProverStats
+ , SBV.verbose = pcVerbose
+ , SBV.validateModel = pcValidate
+ } in
+ case pcQueryType of
+ ProveQuery -> runSingleProver pc lPutStrLn p' SBV.proveWith thmSMTResults x
+ SafetyQuery -> runSingleProver pc lPutStrLn p' SBV.proveWith thmSMTResults x
+ SatQuery (SomeSat 1) -> runSingleProver pc lPutStrLn p' SBV.satWith satSMTResults x
+ SatQuery _ -> runSingleProver pc lPutStrLn p' SBV.allSatWith allSatSMTResults x
+
+
+-- | Prepare a symbolic query by symbolically simulating the expression found in
+-- the @ProverQuery@. The result will either be an error or a list of the types
+-- of the symbolic inputs and the symbolic value to supply to the solver.
+--
+-- Note that the difference between sat and prove queries is reflected later
+-- in `runProver` where we call different SBV methods depending on the mode,
+-- so we do _not_ negate the goal here. Moreover, assumptions are added
+-- using conjunction for sat queries and implication for prove queries.
+--
+-- For safety properties, we want to add them as an additional goal
+-- when we do prove queries, and an additional assumption when we do
+-- sat queries. In both cases, the safety property is combined with
+-- 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
+
+ -- 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
+
+ -- The `addAsm` function is used to combine assumptions that
+ -- arise from the types of symbolic variables (e.g. Z n values
+ -- are assumed to be integers in the range `0 <= x < n`) with
+ -- the main content of the query. We use conjunction or implication
+ -- depending on the type of query.
+ let addAsm = case pcQueryType of
+ ProveQuery -> \x y -> SBV.svOr (SBV.svNot x) y
+ 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 ->
+ do when pcVerbose $ logPutStrLn (Eval.evalLogger evo) "Simulating..."
+ pure $ Right $ (ts,
+ do -- Compute the symbolic inputs, and any domain constraints needed
+ -- according to their types.
+ (args, asms) <- runWriterT (mapM tyFn 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)
+ case pcQueryType of
+ SafetyQuery ->
+ do Eval.forceValue appliedVal
+ pure SBV.svTrue
+ _ -> pure (Eval.fromVBit appliedVal)
+
+ -- Ignore the safety condition if the flag is set and we are not
+ -- doing a safety query
+ let safety' = case pcQueryType of
+ SafetyQuery -> safety
+ _ | pcIgnoreSafety -> SBV.svTrue
+ | otherwise -> safety
+
+ -- "observe" the value of the safety predicate. This makes its value
+ -- avaliable in the resulting model.
+ SBV.sObserve "safety" (SBV.SBV safety' :: SBV.SBV Bool)
+
+ return (foldr addAsm (SBV.svAnd safety' b) asms))
+
+
+-- | 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 =
+ do let isSat = case pcQueryType of
+ ProveQuery -> False
+ SafetyQuery -> False
+ SatQuery _ -> True
+
+ prims <- M.getPrimMap
+
+ case results of
+ -- allSat can return more than one as long as
+ -- they're satisfiable
+ (SBV.Satisfiable {} : _) | isSat -> do
+ tevss <- map snd <$> mapM (mkTevs prims) results
+ return $ AllSatResult tevss
+
+ -- prove should only have one counterexample
+ [r@SBV.Satisfiable{}] -> do
+ (safety, res) <- mkTevs prims r
+ let cexType = if safety then PredicateFalsified else SafetyViolation
+ return $ CounterExample cexType res
+
+ -- prove returns only one
+ [SBV.Unsatisfiable {}] ->
+ return $ ThmResult (unFinType <$> ts)
+
+ -- unsat returns empty
+ [] -> return $ ThmResult (unFinType <$> ts)
+
+ -- otherwise something is wrong
+ _ -> return $ ProverError (rshow results)
+ where rshow | isSat = show . SBV.AllSatResult . (False,False,False,)
+ | otherwise = show . SBV.ThmResult . head
+
+ where
+ mkTevs prims result = do
+ -- It's a bit fragile, but the value of the safety predicate seems
+ -- 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)
+
+
+-- | Execute a symbolic ':prove' or ':sat' command.
+--
+-- This command returns a pair: the first element is the name of the
+-- solver that completes the given query (if any) along with the result
+-- of executing the query.
+satProve :: SBVProverConfig -> ProverCommand -> M.ModuleCmd (Maybe String, ProverResult)
+satProve proverCfg pc@ProverCommand {..} =
+ protectStack proverError $ \(evo, byteReader, modEnv) ->
+
+ M.runModuleM (evo, byteReader, modEnv) $ do
+
+ let lPutStrLn = logPutStrLn (Eval.evalLogger evo)
+
+ M.io (prepareQuery evo modEnv 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
+ return (firstProver, esatexprs)
+
+-- | Execute a symbolic ':prove' or ':sat' command when the prover is
+-- set to offline. This only prepares the SMT input file for the
+-- solver and does not actually invoke the solver.
+--
+-- This method returns either an error message or the text of
+-- the SMT input file corresponding to the given prover command.
+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), [])
+
+
+protectStack :: (String -> M.ModuleCmd a)
+ -> M.ModuleCmd a
+ -> M.ModuleCmd a
+protectStack mkErr cmd modEnv =
+ X.catchJust isOverflow (cmd modEnv) handler
+ where isOverflow X.StackOverflow = Just ()
+ isOverflow _ = Nothing
+ msg = "Symbolic evaluation failed to terminate."
+ handler () = mkErr msg modEnv
+
+-- | 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 [] cvs = ([], cvs)
+parseValues (t : ts) cvs = (v : vs, cvs'')
+ where (v, cvs') = parseValue t cvs
+ (vs, cvs'') = parseValues ts cvs'
+
+-- | 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 FTBit [] = panic "Cryptol.Symbolic.parseValue" [ "empty FTBit" ]
+parseValue FTBit (cv : cvs) = (Eval.VBit (SBV.cvToBool cv), cvs)
+parseValue FTInteger cvs =
+ case SBV.genParse SBV.KUnbounded cvs of
+ Just (x, cvs') -> (Eval.VInteger 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)
+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'
+ )
+ where (vs, cvs') = parseValues (replicate n t) cvs
+parseValue (FTTuple ts) cvs = (Eval.VTuple (map Eval.ready vs), cvs')
+ where (vs, cvs') = parseValues ts cvs
+parseValue (FTRecord r) cvs = (Eval.VRecord r', cvs')
+ where (ns, ts) = unzip $ canonicalFields r
+ (vs, cvs') = parseValues ts cvs
+ fs = zip ns (map Eval.ready vs)
+ r' = recordFromFieldsWithDisplay (displayOrder r) fs
+
+parseValue (FTFloat e p) cvs =
+ (Eval.VFloat Concrete.BF { Concrete.bfValue = bfNaN
+ , Concrete.bfExpWidth = e
+ , Concrete.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
+
+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
diff --git a/src/Cryptol/Symbolic/Value.hs b/src/Cryptol/Symbolic/Value.hs
deleted file mode 100644
--- a/src/Cryptol/Symbolic/Value.hs
+++ /dev/null
@@ -1,250 +0,0 @@
--- |
--- Module : Cryptol.Symbolic.Value
--- Copyright : (c) 2013-2016 Galois, Inc.
--- License : BSD3
--- Maintainer : cryptol@galois.com
--- Stability : provisional
--- Portability : portable
-
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE PatternGuards #-}
-{-# LANGUAGE TypeSynonymInstances #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-module Cryptol.Symbolic.Value
- ( SBool, SWord, SInteger
- , literalSWord
- , fromBitsLE
- , forallBV_, existsBV_
- , forallSBool_, existsSBool_
- , forallSInteger_, existsSInteger_
- , Value
- , TValue, isTBit, tvSeq
- , GenValue(..), lam, tlam, toStream, toFinSeq, toSeq
- , fromVBit, fromVFun, fromVPoly, fromVTuple, fromVRecord, lookupRecord
- , fromSeq, fromVWord
- , evalPanic
- , iteSValue, mergeValue, mergeWord, mergeBit, mergeBits, mergeSeqMap
- , mergeWord'
- )
- where
-
-import Data.Bits (bit, complement)
-import Data.List (foldl')
-import qualified Data.Sequence as Seq
-
-import Data.SBV (symbolicEnv)
-import Data.SBV.Dynamic
-
---import Cryptol.Eval.Monad
-import Cryptol.Eval.Type (TValue(..), isTBit, tvSeq)
-import Cryptol.Eval.Monad (Eval, ready)
-import Cryptol.Eval.Value ( GenValue(..), BitWord(..), lam, tlam, toStream,
- toFinSeq, toSeq, WordValue(..),
- fromSeq, fromVBit, fromVWord, fromVFun, fromVPoly,
- fromVTuple, fromVRecord, lookupRecord, SeqMap(..),
- ppBV, BV(..), integerToChar, lookupSeqMap, memoMap,
- wordValueSize, asBitsMap)
-import Cryptol.Utils.Panic (panic)
-import Cryptol.Utils.PP
-
-import Control.Monad.Trans (liftIO)
-
--- SBool and SWord -------------------------------------------------------------
-
-type SBool = SVal
-type SWord = SVal
-type SInteger = SVal
-
-fromBitsLE :: [SBool] -> SWord
-fromBitsLE bs = foldl' f (literalSWord 0 0) bs
- where f w b = svJoin (svToWord1 b) w
-
-literalSWord :: Int -> Integer -> SWord
-literalSWord w i = svInteger (KBounded False w) i
-
-forallBV_ :: Int -> Symbolic SWord
-forallBV_ w = symbolicEnv >>= liftIO . svMkSymVar (Just ALL) (KBounded False w) Nothing
-
-existsBV_ :: Int -> Symbolic SWord
-existsBV_ w = symbolicEnv >>= liftIO . svMkSymVar (Just EX) (KBounded False w) Nothing
-
-forallSBool_ :: Symbolic SBool
-forallSBool_ = symbolicEnv >>= liftIO . svMkSymVar (Just ALL) KBool Nothing
-
-existsSBool_ :: Symbolic SBool
-existsSBool_ = symbolicEnv >>= liftIO . svMkSymVar (Just EX) KBool Nothing
-
-forallSInteger_ :: Symbolic SBool
-forallSInteger_ = symbolicEnv >>= liftIO . svMkSymVar (Just ALL) KUnbounded Nothing
-
-existsSInteger_ :: Symbolic SBool
-existsSInteger_ = symbolicEnv >>= liftIO . svMkSymVar (Just EX) KUnbounded Nothing
-
--- Values ----------------------------------------------------------------------
-
-type Value = GenValue SBool SWord SInteger
-
--- Symbolic Conditionals -------------------------------------------------------
-
-iteSValue :: SBool -> Value -> Value -> Eval Value
-iteSValue c x y =
- case svAsBool c of
- Just True -> return x
- Just False -> return y
- Nothing -> mergeValue True c x y
-
-mergeBit :: Bool
- -> SBool
- -> SBool
- -> SBool
- -> SBool
-mergeBit f c b1 b2 = svSymbolicMerge KBool f c b1 b2
-
-mergeWord :: Bool
- -> SBool
- -> WordValue SBool SWord SInteger
- -> WordValue SBool SWord SInteger
- -> WordValue SBool SWord SInteger
-mergeWord f c (WordVal w1) (WordVal w2) =
- WordVal $ svSymbolicMerge (kindOf w1) f c w1 w2
-mergeWord f c (WordVal w1) (BitsVal ys) =
- BitsVal $ mergeBits f c (Seq.fromList $ map ready $ unpackWord w1) ys
-mergeWord f c (BitsVal xs) (WordVal w2) =
- BitsVal $ mergeBits f c xs (Seq.fromList $ map ready $ unpackWord w2)
-mergeWord f c (BitsVal xs) (BitsVal ys) =
- BitsVal $ mergeBits f c xs ys
-mergeWord f c w1 w2 =
- LargeBitsVal (wordValueSize w1) (mergeSeqMap f c (asBitsMap w1) (asBitsMap w2))
-
-mergeWord' :: Bool
- -> SBool
- -> Eval (WordValue SBool SWord SInteger)
- -> Eval (WordValue SBool SWord SInteger)
- -> Eval (WordValue SBool SWord SInteger)
-mergeWord' f c x y = mergeWord f c <$> x <*> y
-
-mergeBits :: Bool
- -> SBool
- -> Seq.Seq (Eval SBool)
- -> Seq.Seq (Eval SBool)
- -> Seq.Seq (Eval SBool)
-mergeBits f c bs1 bs2 = Seq.zipWith mergeBit' bs1 bs2
- where mergeBit' b1 b2 = mergeBit f c <$> b1 <*> b2
-
-mergeInteger :: Bool
- -> SBool
- -> SInteger
- -> SInteger
- -> SInteger
-mergeInteger f c x y = svSymbolicMerge KUnbounded f c x y
-
-mergeValue :: Bool -> SBool -> Value -> Value -> Eval Value
-mergeValue f c v1 v2 =
- case (v1, v2) of
- (VRecord fs1, VRecord fs2) -> pure $ VRecord $ zipWith mergeField fs1 fs2
- (VTuple vs1 , VTuple vs2 ) -> pure $ VTuple $ zipWith (mergeValue' f c) vs1 vs2
- (VBit b1 , VBit b2 ) -> pure $ VBit $ mergeBit f c b1 b2
- (VInteger i1, VInteger i2) -> pure $ VInteger $ mergeInteger f c i1 i2
- (VWord n1 w1, VWord n2 w2 ) | n1 == n2 -> pure $ VWord n1 $ mergeWord' f c w1 w2
- (VSeq n1 vs1, VSeq n2 vs2 ) | n1 == n2 -> VSeq n1 <$> memoMap (mergeSeqMap f c vs1 vs2)
- (VStream vs1, VStream vs2) -> VStream <$> memoMap (mergeSeqMap f c vs1 vs2)
- (VFun f1 , VFun f2 ) -> pure $ VFun $ \x -> mergeValue' f c (f1 x) (f2 x)
- (VPoly f1 , VPoly f2 ) -> pure $ VPoly $ \x -> mergeValue' f c (f1 x) (f2 x)
- (_ , _ ) -> panic "Cryptol.Symbolic.Value"
- [ "mergeValue: incompatible values" ]
- where
- mergeField (n1, x1) (n2, x2)
- | n1 == n2 = (n1, mergeValue' f c x1 x2)
- | otherwise = panic "Cryptol.Symbolic.Value"
- [ "mergeValue.mergeField: incompatible values" ]
-
-mergeValue' :: Bool -> SBool -> Eval Value -> Eval Value -> Eval Value
-mergeValue' f c x1 x2 =
- do v1 <- x1
- v2 <- x2
- mergeValue f c v1 v2
-
-mergeSeqMap :: Bool -> SBool -> SeqMap SBool SWord SInteger -> SeqMap SBool SWord SInteger -> SeqMap SBool SWord SInteger
-mergeSeqMap f c x y =
- IndexSeqMap $ \i ->
- do xi <- lookupSeqMap x i
- yi <- lookupSeqMap y i
- mergeValue f c xi yi
-
--- Symbolic Big-endian Words -------------------------------------------------------
-
-instance BitWord SBool SWord SInteger where
- wordLen v = toInteger (intSizeOf v)
- wordAsChar v = integerToChar <$> svAsInteger v
-
- ppBit v
- | Just b <- svAsBool v = text $! if b then "True" else "False"
- | otherwise = text "?"
- ppWord opts v
- | Just x <- svAsInteger v = ppBV opts (BV (wordLen v) x)
- | otherwise = text "[?]"
- ppInteger _opts v
- | Just x <- svAsInteger v = integer x
- | otherwise = text "[?]"
-
- bitLit b = svBool b
- wordLit n x = svInteger (KBounded False (fromInteger n)) x
- integerLit x = svInteger KUnbounded x
-
- wordBit x idx = svTestBit x (intSizeOf x - 1 - fromInteger idx)
-
- wordUpdate x idx b = 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 = fromBitsLE (reverse bs)
- unpackWord x = [ svTestBit x i | i <- reverse [0 .. intSizeOf x - 1] ]
-
- joinWord x y = svJoin x y
-
- splitWord _leftW rightW w =
- ( svExtract (intSizeOf w - 1) (fromInteger rightW) w
- , svExtract (fromInteger rightW - 1) 0 w
- )
-
- extractWord len start w =
- svExtract (fromInteger start + fromInteger len - 1) (fromInteger start) w
-
- wordPlus = svPlus
- wordMinus = svMinus
- wordMult = svTimes
-
- intPlus = svPlus
- intMinus = svMinus
- intMult = svTimes
-
- intModPlus _m = svPlus
- intModMinus _m = svMinus
- intModMult _m = svTimes
-
- wordToInt = svToInteger
- wordFromInt = svFromInteger
-
--- TODO: implement this properly in SBV using "bv2int"
-svToInteger :: SWord -> SInteger
-svToInteger w =
- case svAsInteger w of
- Nothing -> svFromIntegral KUnbounded w
- Just x -> svInteger KUnbounded x
-
--- TODO: implement this properly in SBV using "int2bv"
-svFromInteger :: Integer -> SInteger -> SWord
-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)
diff --git a/src/Cryptol/Symbolic/What4.hs b/src/Cryptol/Symbolic/What4.hs
new file mode 100644
--- /dev/null
+++ b/src/Cryptol/Symbolic/What4.hs
@@ -0,0 +1,621 @@
+-- |
+-- Module : Cryptol.Symbolic.What4
+-- Copyright : (c) 2013-2020 Galois, Inc.
+-- License : BSD3
+-- Maintainer : cryptol@galois.com
+-- Stability : provisional
+-- Portability : portable
+
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ImplicitParams #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module Cryptol.Symbolic.What4
+ ( W4ProverConfig
+ , defaultProver
+ , proverNames
+ , setupProver
+ , satProve
+ , satProveOffline
+ , W4Exception(..)
+ ) where
+
+import Control.Concurrent.Async
+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.NonEmpty (NonEmpty(..))
+import qualified Data.List.NonEmpty as NE
+import System.Exit
+
+import qualified Cryptol.ModuleSystem as M hiding (getPrimMap)
+import qualified Cryptol.ModuleSystem.Env as M
+import qualified Cryptol.ModuleSystem.Base as M
+import qualified Cryptol.ModuleSystem.Monad as M
+
+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 qualified What4.Config as W4
+import qualified What4.Interface as W4
+import qualified What4.Expr.Builder as W4
+import qualified What4.Expr.GroundEval as W4
+import qualified What4.SatResult as W4
+import qualified What4.SWord as SW
+import What4.Solver
+import qualified What4.Solver.Adapter as W4
+
+import qualified Data.BitVector.Sized as BV
+import Data.Parameterized.Nonce
+
+
+import Prelude ()
+import Prelude.Compat
+
+data W4Exception
+ = W4Ex X.SomeException
+ | W4PortfolioFailure [ (Either X.SomeException (Maybe String, String)) ]
+
+instance Show W4Exception where
+ show (W4Ex e) = X.displayException e
+ show (W4PortfolioFailure exs) =
+ unlines ("All solveres in the portfolio failed!":map f exs)
+ where
+ f (Left e) = X.displayException e
+ f (Right (Nothing, msg)) = msg
+ f (Right (Just nm, msg)) = nm ++ ": " ++ msg
+
+instance X.Exception W4Exception
+
+rethrowW4Exception :: IO a -> IO a
+rethrowW4Exception m = X.catchJust f m (X.throwIO . W4Ex)
+ where
+ f e
+ | Just ( _ :: X.AsyncException) <- X.fromException e = Nothing
+ | Just ( _ :: Eval.Unsupported) <- X.fromException e = Nothing
+ | otherwise = Just e
+
+protectStack :: (String -> M.ModuleCmd a)
+ -> M.ModuleCmd a
+ -> M.ModuleCmd a
+protectStack mkErr cmd modEnv =
+ rethrowW4Exception $
+ X.catchJust isOverflow (cmd modEnv) handler
+ where isOverflow X.StackOverflow = Just ()
+ isOverflow _ = Nothing
+ msg = "Symbolic evaluation failed to terminate."
+ 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
+ W4Error err -> liftIO (X.throwIO err)
+ W4Result p x -> pure res { w4Result = (p,x) }
+
+
+data AnAdapter = AnAdapter (forall st. SolverAdapter st)
+
+data W4ProverConfig
+ = W4ProverConfig AnAdapter
+ | W4Portfolio (NonEmpty AnAdapter)
+
+proverConfigs :: [(String, W4ProverConfig)]
+proverConfigs =
+ [ ("w4-cvc4" , W4ProverConfig (AnAdapter cvc4Adapter) )
+ , ("w4-yices" , W4ProverConfig (AnAdapter yicesAdapter) )
+ , ("w4-z3" , W4ProverConfig (AnAdapter z3Adapter) )
+ , ("w4-boolector", W4ProverConfig (AnAdapter boolectorAdapter) )
+ , ("w4-offline" , W4ProverConfig (AnAdapter z3Adapter) )
+ , ("w4-any" , allSolvers)
+ ]
+
+allSolvers :: W4ProverConfig
+allSolvers = W4Portfolio
+ $ AnAdapter z3Adapter :|
+ [ AnAdapter cvc4Adapter
+ , AnAdapter boolectorAdapter
+ , AnAdapter yicesAdapter
+ ]
+
+defaultProver :: W4ProverConfig
+defaultProver = W4ProverConfig (AnAdapter z3Adapter)
+
+proverNames :: [String]
+proverNames = map fst proverConfigs
+
+setupProver :: String -> IO (Either String ([String], W4ProverConfig))
+setupProver nm =
+ rethrowW4Exception $
+ case lookup nm proverConfigs of
+ Just cfg@(W4ProverConfig p) ->
+ do st <- tryAdapter p
+ let ws = case st of
+ Nothing -> []
+ Just ex -> [ "Warning: solver interaction failed with " ++ nm, " " ++ show ex ]
+ pure (Right (ws, cfg))
+
+ Just (W4Portfolio ps) ->
+ filterAdapters (NE.toList ps) >>= \case
+ [] -> pure (Left "What4 could not communicate with any provers!")
+ (p:ps') ->
+ let msg = "What4 found the following solvers: " ++ show (adapterNames (p:ps')) in
+ pure (Right ([msg], W4Portfolio (p:|ps')))
+
+ Nothing -> pure (Left ("unknown solver name: " ++ nm))
+
+ where
+ adapterNames [] = []
+ adapterNames (AnAdapter adpt : ps) =
+ solver_adapter_name adpt : adapterNames ps
+
+ filterAdapters [] = pure []
+ filterAdapters (p:ps) =
+ tryAdapter p >>= \case
+ Just _err -> filterAdapters ps
+ Nothing -> (p:) <$> filterAdapters ps
+
+ tryAdapter (AnAdapter adpt) =
+ do sym <- W4.newExprBuilder W4.FloatIEEERepr CryptolState globalNonceGenerator
+ W4.extendConfig (W4.solver_adapter_config_options adpt) (W4.getConfiguration sym)
+ W4.smokeTest sym adpt
+
+
+
+proverError :: String -> M.ModuleCmd (Maybe String, ProverResult)
+proverError msg (_, _, modEnv) =
+ return (Right ((Nothing, ProverError msg), modEnv), [])
+
+
+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
+ W4ProverConfig p -> setupAnAdapter p
+ W4Portfolio ps -> mapM_ setupAnAdapter ps
+
+ where
+ setupAnAdapter (AnAdapter adpt) =
+ W4.extendConfig (W4.solver_adapter_config_options adpt) (W4.getConfiguration sym)
+
+
+-- | Simulate and manipulate query into a form suitable to be sent
+-- to a solver.
+prepareQuery ::
+ W4.IsSymExprBuilder sym =>
+ sym ->
+ ProverCommand ->
+ M.ModuleT IO (Either String
+ ([FinType],[VarShape 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
+ liftIO
+ do -- add the collected definitions to the goal
+ let (safety,prop') = w4Result res
+ b <- W4.andPred sym (w4Defs res) prop'
+
+ -- Ignore the safety condition if the flag is set
+ let safety' = if pcIgnoreSafety then W4.truePred sym else safety
+
+ Right <$>
+ case pcQueryType of
+ ProveQuery ->
+ do q <- W4.notPred sym =<< W4.andPred sym safety' b
+ pure (ts,args,safety',q)
+
+ SafetyQuery ->
+ do q <- W4.notPred sym safety
+ pure (ts,args,safety,q)
+
+ SatQuery _ ->
+ do q <- W4.andPred sym safety' b
+ pure (ts,args,safety',q)
+ where
+ simulate args =
+ do let lPutStrLn = M.withLogger logPutStrLn
+ when pcVerbose (lPutStrLn "Simulating...")
+ evo <- M.getEvalOpts
+ 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
+ appliedVal <-
+ foldM Eval.fromVFun v (map (pure . varToSymValue sym) args)
+
+ case pcQueryType of
+ SafetyQuery ->
+ do Eval.forceValue appliedVal
+ pure (W4.truePred sym)
+
+ _ -> pure (Eval.fromVBit appliedVal)
+
+
+
+
+
+satProve ::
+ W4ProverConfig ->
+ Bool ->
+ ProverCommand ->
+ M.ModuleCmd (Maybe String, ProverResult)
+
+satProve solverCfg hashConsing ProverCommand {..} =
+ protectStack proverError \(evo, byteReader, modEnv) ->
+ M.runModuleM (evo, byteReader, modEnv)
+ do sym <- liftIO makeSym
+ logData <- M.withLogger doLog ()
+ start <- liftIO getCurrentTime
+ query <- prepareQuery sym ProverCommand { .. }
+ primMap <- M.getPrimMap
+ liftIO
+ do result <- runProver sym evo 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
+
+ doLog lg () =
+ pure
+ defaultLogData
+ { logCallbackVerbose = \i msg -> when (i > 2) (logPutStrLn lg msg)
+ , logReason = "solver query"
+ }
+
+ runProver sym evo 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
+ (Just safety) query
+
+ SafetyQuery ->
+ singleQuery sym solverCfg evo primMap logData ts args
+ (Just safety) query
+
+ SatQuery num ->
+ multiSATQuery sym solverCfg evo primMap logData ts args
+ query num
+
+
+
+satProveOffline ::
+ W4ProverConfig ->
+ Bool ->
+ ProverCommand ->
+ ((Handle -> IO ()) -> IO ()) ->
+ M.ModuleCmd (Maybe String)
+
+satProveOffline (W4Portfolio (p:|_)) hashConsing cmd outputContinuation =
+ satProveOffline (W4ProverConfig p) hashConsing cmd outputContinuation
+
+satProveOffline (W4ProverConfig (AnAdapter adpt)) hashConsing ProverCommand {..} outputContinuation =
+ protectStack onError \(evo,byteReader,modEnv) ->
+ M.runModuleM (evo,byteReader,modEnv)
+ do sym <- liftIO makeSym
+ ok <- prepareQuery sym ProverCommand { .. }
+ 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])
+ return Nothing
+ where
+ makeSym =
+ do sym <- W4.newExprBuilder W4.FloatIEEERepr CryptolState
+ globalNonceGenerator
+ W4.extendConfig (W4.solver_adapter_config_options adpt)
+ (W4.getConfiguration sym)
+ when hashConsing (W4.startCaching sym)
+ pure sym
+
+ onError msg (_,_,modEnv) = pure (Right (Just msg, modEnv), [])
+
+
+decSatNum :: SatNum -> SatNum
+decSatNum (SomeSat n) | n > 0 = SomeSat (n-1)
+decSatNum n = n
+
+
+multiSATQuery ::
+ sym ~ W4.ExprBuilder t CryptolState fm =>
+ sym ->
+ W4ProverConfig ->
+ Eval.EvalOpts ->
+ PrimMap ->
+ W4.LogData ->
+ [FinType] ->
+ [VarShape 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 (W4Portfolio _) _evo _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 ->
+ 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
+ return (Right (model, blockingPred))
+
+ case pres of
+ Left res -> pure (Just (solver_adapter_name adpt), res)
+ Right (mdl,block) ->
+ do mdls <- (mdl:) <$> computeMoreModels [block,query] (decSatNum satNum0)
+ return (Just (solver_adapter_name adpt), AllSatResult mdls)
+
+ where
+
+ 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 ->
+ case res of
+ W4.Unknown -> return []
+ W4.Unsat _ -> return []
+ W4.Sat (evalFn,_) ->
+ do model <- computeModel evo primMap evalFn ts args
+ return [model]
+
+ computeMoreModels qs satNum =
+ do pres <- W4.solver_adapter_check_sat adpt 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
+ return (Just (model, blockingPred))
+
+ case pres of
+ Nothing -> return []
+ Just (mdl, block) ->
+ (mdl:) <$> computeMoreModels (block:qs) (decSatNum satNum)
+
+singleQuery ::
+ sym ~ W4.ExprBuilder t CryptolState fm =>
+ sym ->
+ W4ProverConfig ->
+ Eval.EvalOpts ->
+ PrimMap ->
+ W4.LogData ->
+ [FinType] ->
+ [VarShape 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
+ | p <- NE.toList ps
+ ]
+ waitForResults [] as
+
+ where
+ waitForResults exs [] = X.throwIO (W4PortfolioFailure exs)
+ waitForResults exs as =
+ do (winner, result) <- waitAnyCatch as
+ let others = filter (/= winner) as
+ case result of
+ Left ex ->
+ waitForResults (Left ex:exs) others
+ Right (nm, ProverError err) ->
+ waitForResults (Right (nm,err) : exs) others
+ Right r ->
+ 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 ->
+ 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
+ case msafe of
+ Just s ->
+ do s' <- W4.groundEval evalFn s
+ let cexType = if s' then PredicateFalsified else SafetyViolation
+ return (CounterExample cexType model)
+ Nothing -> return (AllSatResult [ model ])
+
+ return (Just (W4.solver_adapter_name adpt), pres)
+
+
+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 ->
+ 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)
+
+varToConcreteValue ::
+ W4.GroundEvalFn t ->
+ VarShape (W4.ExprBuilder t CryptolState fm) ->
+ IO Concrete.Value
+varToConcreteValue 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))))
+ 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
+ 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
+
+ VarFinSeq n vs ->
+ do vs' <- mapM (varToConcreteValue evalFn) vs
+ pure (Eval.VSeq (toInteger n) (Eval.finiteSeqMap Concrete.Concrete (map pure vs')))
+ VarTuple vs ->
+ do vs' <- mapM (varToConcreteValue evalFn) vs
+ pure (Eval.VTuple (map pure vs'))
+ VarRecord fs ->
+ do fs' <- traverse (varToConcreteValue evalFn) fs
+ pure (Eval.VRecord (fmap pure fs'))
+
diff --git a/src/Cryptol/Testing/Concrete.hs b/src/Cryptol/Testing/Concrete.hs
deleted file mode 100644
--- a/src/Cryptol/Testing/Concrete.hs
+++ /dev/null
@@ -1,187 +0,0 @@
--- |
--- Module : Cryptol.Testing.Concrete
--- Copyright : (c) 2013-2016 Galois, Inc.
--- License : BSD3
--- Maintainer : cryptol@galois.com
--- Stability : provisional
--- Portability : portable
-
-{-# LANGUAGE RecordWildCards #-}
-module Cryptol.Testing.Concrete where
-
-import Control.Monad (join, liftM2)
-
-import Cryptol.Eval.Monad
-import Cryptol.Eval.Value
-import Cryptol.TypeCheck.AST
-import Cryptol.Utils.Panic (panic)
-
-import qualified Control.Exception as X
-import Data.List(genericReplicate)
-
-import Prelude ()
-import Prelude.Compat
-
--- | 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
- = Pass
- | FailFalse [Value]
- | FailError EvalError [Value]
-
-isPass :: TestResult -> Bool
-isPass Pass = True
-isPass _ = False
-
--- | Apply a testable value to some arguments.
--- 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.
-runOneTest :: EvalOpts -> Value -> [Value] -> IO TestResult
-runOneTest evOpts v0 vs0 = run `X.catch` handle
- where
- run = do
- result <- runEval evOpts (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 _) [] = panic "Not enough arguments while applying function"
- []
- go (VBit b) [] = return b
- go v vs = do vdoc <- ppValue defaultPPOpts v
- vsdocs <- mapM (ppValue defaultPPOpts) vs
- panic "Type error while running test" $
- [ "Function:"
- , show vdoc
- , "Arguments:"
- ] ++ map show vsdocs
-
-{- | Given a (function) type, compute all possible inputs for it.
-We also return the 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 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 <$> mapM (typeSize . snd) fs
- TCon (TC tc) ts ->
- case (tc, ts) of
- (TCNum _, _) -> Nothing
- (TCInf, _) -> Nothing
- (TCBit, _) -> Just 2
- (TCInteger, _) -> Nothing
- (TCIntMod, [sz]) -> case tNoUser sz of
- TCon (TC (TCNum n)) _ -> Just n
- _ -> Nothing
- (TCIntMod, _) -> 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
-
-
-{- | Returns all the values in a type. Returns an empty list of values,
-for types where 'typeSize' returned 'Nothing'. -}
-typeValues :: Type -> [Value]
-typeValues ty =
- case ty of
- TVar _ -> []
- TUser _ _ t -> typeValues t
- TRec fs -> [ VRecord xs
- | xs <- sequence [ [ (f,ready v) | v <- typeValues t ]
- | (f,t) <- fs ]
- ]
- TCon (TC tc) ts ->
- case tc of
- TCNum _ -> []
- TCInf -> []
- TCBit -> [ VBit False, VBit True ]
- TCInteger -> []
- TCIntMod ->
- case map tNoUser ts of
- [ TCon (TC (TCNum n)) _ ] | 0 < n ->
- [ VInteger x | x <- [ 0 .. n - 1 ] ]
- _ -> []
- 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 (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 _ _ -> []
-
---------------------------------------------------------------------------------
--- 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
- , reportTestsRun :: Integer
- , reportTestsPossible :: Maybe Integer
- }
-
-runTests :: Monad m => TestSpec m s -> s -> m TestReport
-runTests TestSpec {..} st0 = go 0 st0
- 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
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,29 +9,43 @@
-- This module generates random values for Cryptol types.
{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE Trustworthy #-}
+{-# LANGUAGE TypeFamilies #-}
module Cryptol.Testing.Random where
-import Cryptol.Eval.Monad (ready,runEval,EvalOpts)
-import Cryptol.Eval.Value (BV(..),Value,GenValue(..),SeqMap(..), WordValue(..), BitWord(..))
-import qualified Cryptol.Testing.Concrete as Conc
-import Cryptol.TypeCheck.AST (Type(..), TCon(..), TC(..), tNoUser, tIsFun)
+import qualified Control.Exception as X
+import Control.Monad (join, liftM2)
+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.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 Control.Monad (forM,join)
-import Data.List (unfoldr, genericTake, genericIndex)
-import System.Random (RandomGen, split, random, randomR)
-import qualified Data.Sequence as Seq
+import Cryptol.Utils.RecordMap
-type Gen g b w i = Integer -> g -> (GenValue b w i, g)
+type Gen g x = Integer -> g -> (SEval x (GenValue x), g)
{- | Apply a testable value to some randomly-generated arguments.
- Returns `Nothing` if the function returned `True`, or
- `Just counterexample` if it returned `False`.
+ Returns @Nothing@ if the function returned @True@, or
+ @Just counterexample@ if it returned @False@.
Please note that this function assumes that the generators match
the supplied value, otherwise we'll panic.
@@ -39,28 +53,30 @@
runOneTest :: RandomGen g
=> EvalOpts -- ^ how to evaluate things
-> Value -- ^ Function under test
- -> [Gen g Bool BV Integer] -- ^ Argument generators
+ -> [Gen g Concrete] -- ^ Argument generators
-> Integer -- ^ Size
-> g
- -> IO (Conc.TestResult, g)
+ -> IO (TestResult, g)
runOneTest evOpts 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')
- result <- Conc.runOneTest evOpts fun args
+ args' <- runEval evOpts (sequence args)
+ result <- evalTest evOpts fun args'
return (result, g1)
returnOneTest :: RandomGen g
=> EvalOpts -- ^ How to evaluate things
-> Value -- ^ Function to be used to calculate tests
- -> [Gen g Bool BV Integer] -- ^ Argument generators
+ -> [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 =
do let (args, g1) = foldr mkArg ([], g0) argGens
mkArg argGen (as, g) = let (a, g') = argGen sz g in (a:as, g')
- result <- runEval evOpts (go fun args)
- return (args, result, g1)
+ args' <- runEval evOpts (sequence args)
+ result <- runEval evOpts (go fun args')
+ return (args', result, g1)
where
go (VFun f) (v : vs) = join (go <$> (f (ready v)) <*> pure vs)
go (VFun _) [] = panic "Cryptol.Testing.Random" ["Not enough arguments to function while generating tests"]
@@ -72,7 +88,7 @@
returnTests :: RandomGen g
=> g -- ^ The random generator state
-> EvalOpts -- ^ How to evaluate things
- -> [Gen g Bool BV Integer] -- ^ Generators for the function arguments
+ -> [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
@@ -87,136 +103,383 @@
return ((inputs, output) : more)
{- | Given a (function) type, compute generators for the function's
-arguments. This is like @testableType@, but allows the result to be
+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 Bool BV Integer]
+dumpableType :: forall g. RandomGen g => Type -> Maybe [Gen g Concrete]
dumpableType ty =
case tIsFun ty of
Just (t1, t2) ->
- do g <- randomValue t1
- as <- testableType t2
+ do g <- randomValue Concrete t1
+ as <- testableTypeGenerators t2
return (g : as)
Nothing ->
- do (_ :: Gen g Bool BV Integer) <- randomValue ty
+ 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. -}
-testableType :: RandomGen g => Type -> Maybe [Gen g Bool BV Integer]
-testableType ty =
+testableTypeGenerators :: RandomGen g => Type -> Maybe [Gen g Concrete]
+testableTypeGenerators ty =
case tNoUser ty of
TCon (TC TCFun) [t1,t2] ->
- do g <- randomValue t1
- as <- testableType t2
+ do g <- randomValue Concrete t1
+ as <- testableTypeGenerators t2
return (g : as)
TCon (TC TCBit) [] -> return []
_ -> Nothing
+{-# SPECIALIZE randomValue ::
+ RandomGen g => Concrete -> Type -> 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 :: (BitWord b w i, RandomGen g) => Type -> Maybe (Gen g b w i)
-randomValue ty =
+randomValue :: (Backend sym, RandomGen g) => sym -> Type -> Maybe (Gen g sym)
+randomValue sym ty =
case ty of
TCon tc ts ->
case (tc, map (tRebuild' False) ts) of
- (TC TCBit, []) -> Just randomBit
+ (TC TCBit, []) -> Just (randomBit sym)
- (TC TCInteger, []) -> Just randomInteger
+ (TC TCInteger, []) -> Just (randomInteger sym)
+ (TC TCRational, []) -> Just (randomRational sym)
+
(TC TCIntMod, [TCon (TC (TCNum n)) []]) ->
- do return (randomIntMod 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 el
+ do mk <- randomValue sym el
return (randomStream mk)
(TC TCSeq, [TCon (TC (TCNum n)) [], TCon (TC TCBit) []]) ->
- return (randomWord n)
+ return (randomWord sym n)
(TC TCSeq, [TCon (TC (TCNum n)) [], el]) ->
- do mk <- randomValue el
+ do mk <- randomValue sym el
return (randomSequence n mk)
(TC (TCTuple _), els) ->
- do mks <- mapM randomValue els
+ do mks <- mapM (randomValue sym) els
return (randomTuple mks)
_ -> Nothing
TVar _ -> Nothing
- TUser _ _ t -> randomValue t
- TRec fs -> do gs <- forM fs $ \(l,t) -> do g <- randomValue t
- return (l,g)
+ TUser _ _ t -> randomValue sym t
+ TRec fs -> do gs <- traverse (randomValue sym) fs
return (randomRecord gs)
+{-# INLINE randomBit #-}
+
-- | Generate a random bit value.
-randomBit :: (BitWord b w i, RandomGen g) => Gen g b w i
-randomBit _ g =
+randomBit :: (Backend sym, RandomGen g) => sym -> Gen g sym
+randomBit sym _ g =
let (b,g1) = random g
- in (VBit (bitLit b), g1)
+ in (pure (VBit (bitLit sym b)), g1)
+{-# INLINE randomSize #-}
+
randomSize :: RandomGen g => Int -> Int -> g -> (Int, g)
randomSize k n g
| p == 1 = (n, g')
| otherwise = randomSize k (n + 1) g'
where (p, g') = randomR (1, k) g
+{-# INLINE randomInteger #-}
+
-- | Generate a random integer value. The size parameter is assumed to
-- vary between 1 and 100, and we use it to generate smaller numbers
-- first.
-randomInteger :: (BitWord b w i, RandomGen g) => Gen g b w i
-randomInteger w g =
+randomInteger :: (Backend sym, RandomGen g) => sym -> Gen g sym
+randomInteger sym w g =
let (n, g1) = if w < 100 then (fromInteger w, g) else randomSize 8 100 g
- (x, g2) = randomR (- 256^n, 256^n) g1
- in (VInteger (integerLit x), g2)
+ (i, g2) = randomR (- 256^n, 256^n) g1
+ in (VInteger <$> integerLit sym i, g2)
-randomIntMod :: (BitWord b w i, RandomGen g) => Integer -> Gen g b w i
-randomIntMod modulus _ g =
- let (x, g') = randomR (0, modulus-1) g
- in (VInteger (integerLit x), g')
+{-# INLINE randomIntMod #-}
+randomIntMod :: (Backend sym, RandomGen g) => sym -> Integer -> Gen g sym
+randomIntMod sym modulus _ g =
+ let (i, g') = randomR (0, modulus-1) g
+ in (VInteger <$> integerLit sym i, g')
+
+{-# INLINE randomRational #-}
+
+randomRational :: (Backend sym, RandomGen g) => sym -> Gen g sym
+randomRational sym w g =
+ let (sz, g1) = if w < 100 then (fromInteger w, g) else randomSize 8 100 g
+ (n, g2) = randomR (- 256^sz, 256^sz) g1
+ (d, g3) = randomR ( 1, 256^sz) g2
+ in (do n' <- integerLit sym n
+ d' <- integerLit sym d
+ pure (VRational (SRational n' d'))
+ , g3)
+
+{-# INLINE randomWord #-}
+
-- | Generate a random word of the given length (i.e., a value of type @[w]@)
-- The size parameter is assumed to vary between 1 and 100, and we use
-- it to generate smaller numbers first.
-randomWord :: (BitWord b w i, RandomGen g) => Integer -> Gen g b w i
-randomWord w _sz g =
+randomWord :: (Backend sym, RandomGen g) => sym -> Integer -> Gen g sym
+randomWord sym w _sz g =
let (val, g1) = randomR (0,2^w-1) g
- in (VWord w (ready (WordVal (wordLit w val))), g1)
+ in (return $ VWord w (WordVal <$> wordLit sym w val), g1)
+{-# INLINE randomStream #-}
+
-- | Generate a random infinite stream value.
-randomStream :: RandomGen g => Gen g b w i -> Gen g b w i
+randomStream :: (Backend sym, RandomGen g) => Gen g sym -> Gen g sym
randomStream mkElem sz g =
let (g1,g2) = split g
- in (VStream $ IndexSeqMap $ genericIndex (map ready (unfoldr (Just . mkElem sz) g1)), g2)
+ in (pure $ VStream $ IndexSeqMap $ genericIndex (unfoldr (Just . mkElem sz) g1), g2)
+{-# INLINE randomSequence #-}
+
{- | Generate a random sequence. This should be used for sequences
other than bits. For sequences of bits use "randomWord". -}
-randomSequence :: RandomGen g => Integer -> Gen g b w i -> Gen g b w i
+randomSequence :: (Backend sym, RandomGen g) => Integer -> Gen g sym -> Gen g sym
randomSequence w mkElem sz g0 = do
let (g1,g2) = split g0
let f g = let (x,g') = mkElem sz g
- in seq x (Just (ready x, g'))
+ in seq x (Just (x, g'))
let xs = Seq.fromList $ genericTake w $ unfoldr f g1
- seq xs (VSeq w $ IndexSeqMap $ (Seq.index xs . fromInteger), g2)
+ seq xs (pure $ VSeq w $ IndexSeqMap $ (Seq.index xs . fromInteger), g2)
+{-# INLINE randomTuple #-}
+
-- | Generate a random tuple value.
-randomTuple :: RandomGen g => [Gen g b w i] -> Gen g b w i
+randomTuple :: (Backend sym, RandomGen g) => [Gen g sym] -> Gen g sym
randomTuple gens sz = go [] gens
where
- go els [] g = (VTuple (reverse els), g)
+ go els [] g = (pure $ VTuple (reverse els), g)
go els (mkElem : more) g =
let (v, g1) = mkElem sz g
- in seq v (go (ready v : els) more g1)
+ in seq v (go (v : els) more g1)
+{-# INLINE randomRecord #-}
+
-- | Generate a random record value.
-randomRecord :: RandomGen g => [(Ident, Gen g b w i)] -> Gen g b w i
-randomRecord gens sz = go [] gens
+randomRecord :: (Backend sym, RandomGen g) => RecordMap Ident (Gen g sym) -> Gen g sym
+randomRecord gens sz g0 =
+ let (g', m) = recordMapAccum mk g0 gens in (pure $ VRecord m, g')
where
- go els [] g = (VRecord (reverse els), g)
- go els ((l,mkElem) : more) g =
- let (v, g1) = mkElem sz g
- in seq v (go ((l,ready v) : els) more g1)
+ mk g gen =
+ let (v, g') = gen sz g
+ in seq v (g', v)
+randomFloat ::
+ (Backend sym, RandomGen g) =>
+ sym ->
+ Integer {- ^ Exponent width -} ->
+ Integer {- ^ Precision width -} ->
+ Gen g sym
+randomFloat sym e p w g =
+ ( VFloat <$> fpLit sym e p (nu % de)
+ , g3
+ )
+ where
+ -- XXX: we never generat NaN
+ -- XXX: Not sure that we need such big integers, we should probably
+ -- use `e` and `p` as a guide.
+ (n, g1) = if w < 100 then (fromInteger w, g) else randomSize 8 100 g
+ (nu, g2) = randomR (- 256^n, 256^n) g1
+ (de, g3) = randomR (1, 256^n) g2
+
+
+
+-- 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
+ = Pass
+ | FailFalse [Value]
+ | FailError EvalError [Value]
+
+isPass :: TestResult -> Bool
+isPass Pass = True
+isPass _ = False
+
+-- | Apply a testable value to some arguments.
+-- 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
+ where
+ run = do
+ result <- runEval evOpts (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 _) [] = panic "Not enough arguments while applying function"
+ []
+ go (VBit b) [] = return b
+ go v vs = do vdoc <- ppValue Concrete defaultPPOpts v
+ vsdocs <- mapM (ppValue Concrete defaultPPOpts) vs
+ panic "Type error while running test" $
+ [ "Function:"
+ , show vdoc
+ , "Arguments:"
+ ] ++ map show vsdocs
+
+{- | Given a (function) type, compute all possible inputs for it.
+We also return the 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 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
+
+
+{- | Returns all the values in a type. Returns an empty list of values,
+for types where 'typeSize' returned 'Nothing'. -}
+typeValues :: Type -> [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 _ _ -> []
+
+--------------------------------------------------------------------------------
+-- 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
+ , reportTestsRun :: Integer
+ , reportTestsPossible :: Maybe Integer
+ }
+
+runTests :: Monad m => TestSpec m s -> s -> m TestReport
+runTests TestSpec {..} st0 = go 0 st0
+ 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
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
@@ -16,6 +16,7 @@
import Cryptol.ModuleSystem.Name(toParamInstName,asParamName,nameIdent
,paramModRecParam)
import Cryptol.Utils.Ident(paramInstModName)
+import Cryptol.Utils.RecordMap(recordFromFields)
{-
Note that we have to be careful when doing this transformation on
@@ -182,7 +183,7 @@
paramRecTy :: Params -> Type
-paramRecTy ps = tRec [ (nameIdent x, t) | (x,t) <- pFuns ps ]
+paramRecTy ps = tRec (recordFromFields [ (nameIdent x, t) | (x,t) <- pFuns ps ])
nameInst :: Inp -> Name -> [Type] -> Int -> Expr
@@ -231,7 +232,7 @@
EList es t -> EList (inst ps es) (inst ps t)
ETuple es -> ETuple (inst ps es)
- ERec fs -> ERec [ (f,inst ps e) | (f,e) <- fs ]
+ 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)
@@ -301,7 +302,7 @@
TVar x | Just x' <- isTParam ps x -> TVar (TVBound x')
| otherwise -> ty
- TRec xs -> TRec [ (f,inst ps t) | (f,t) <- xs ]
+ TRec xs -> TRec (fmap (inst ps) xs)
instance Inst TySyn where
inst ps ts = ts { tsConstraints = inst ps (tsConstraints ts)
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
@@ -10,62 +10,62 @@
-- slow down in some cases. What's the problem? Consider the following (common)
-- patterns:
--
--- fibs = [0,1] # [ x + y | x <- fibs, y <- drop`{1} fibs ]
+-- > fibs = [0,1] # [ x + y | x <- fibs, y <- drop`{1} fibs ]
--
--- The type of `fibs` is:
+-- The type of @fibs@ is:
--
--- {a} (a >= 1, fin a) => [inf][a]
+-- > {a} (a >= 1, fin a) => [inf][a]
--
--- Here `a` is the number of bits to be used in the values computed by `fibs`.
--- When we evaluate `fibs`, `a` becomes a parameter to `fibs`, which works
--- except that now `fibs` is a function, and we don't get any of the memoization
+-- Here @a@ is the number of bits to be used in the values computed by @fibs@.
+-- When we evaluate @fibs@, @a@ becomes a parameter to @fibs@, which works
+-- except that now @fibs@ is a function, and we don't get any of the memoization
-- we might expect! What looked like an efficient implementation has all
-- of a sudden become exponential!
--
--- Note that this is only a problem for polymorphic values: if `fibs` was
+-- Note that this is only a problem for polymorphic values: if @fibs@ was
-- already a function, it would not be that surprising that it does not
-- get cached.
--
-- So, to avoid this, we try to spot recursive polymorphic values,
-- where the recursive occurrences have the exact same type parameters
--- as the definition. For example, this is the case in `fibs`: each
--- recursive call to `fibs` is instantiated with exactly the same
--- type parameter (i.e., `a`). The rewrite we do is as follows:
+-- as the definition. For example, this is the case in @fibs@: each
+-- recursive call to @fibs@ is instantiated with exactly the same
+-- type parameter (i.e., @a@). The rewrite we do is as follows:
--
--- fibs : {a} (a >= 1, fin a) => [inf][a]
--- fibs = \{a} (a >= 1, fin a) -> fibs'
--- where fibs' : [inf][a]
--- fibs' = [0,1] # [ x + y | x <- fibs', y <- drop`{1} fibs' ]
+-- > fibs : {a} (a >= 1, fin a) => [inf][a]
+-- > fibs = \{a} (a >= 1, fin a) -> fibs'
+-- > where fibs' : [inf][a]
+-- > fibs' = [0,1] # [ x + y | x <- fibs', y <- drop`{1} fibs' ]
--
-- After the rewrite, the recursion is monomorphic (i.e., we are always using
--- the same type). As a result, `fibs'` is an ordinary recursive value,
+-- the same type). As a result, @fibs'@ is an ordinary recursive value,
-- where we get the benefit of caching.
--
-- The rewrite is a bit more complex, when there are multiple mutually
-- recursive functions. Here is an example:
--
--- zig : {a} (a >= 2, fin a) => [inf][a]
--- zig = [1] # zag
---
--- zag : {a} (a >= 2, fin a) => [inf][a]
--- zag = [2] # zig
+-- > zig : {a} (a >= 2, fin a) => [inf][a]
+-- > zig = [1] # zag
+-- >
+-- > zag : {a} (a >= 2, fin a) => [inf][a]
+-- > zag = [2] # zig
--
-- This gets rewritten to:
--
--- newName : {a} (a >= 2, fin a) => ([inf][a], [inf][a])
--- newName = \{a} (a >= 2, fin a) -> (zig', zag')
--- where
--- zig' : [inf][a]
--- zig' = [1] # zag'
---
--- zag' : [inf][a]
--- zag' = [2] # zig'
---
--- zig : {a} (a >= 2, fin a) => [inf][a]
--- zig = \{a} (a >= 2, fin a) -> (newName a <> <> ).1
---
--- zag : {a} (a >= 2, fin a) => [inf][a]
--- zag = \{a} (a >= 2, fin a) -> (newName a <> <> ).2
+-- > newName : {a} (a >= 2, fin a) => ([inf][a], [inf][a])
+-- > newName = \{a} (a >= 2, fin a) -> (zig', zag')
+-- > where
+-- > zig' : [inf][a]
+-- > zig' = [1] # zag'
+-- >
+-- > zag' : [inf][a]
+-- > zag' = [2] # zig'
+-- >
+-- > zig : {a} (a >= 2, fin a) => [inf][a]
+-- > zig = \{a} (a >= 2, fin a) -> (newName a <> <> ).1
+-- >
+-- > zag : {a} (a >= 2, fin a) => [inf][a]
+-- > zag = \{a} (a >= 2, fin a) -> (newName a <> <> ).2
--
-- NOTE: We are assuming that no capture would occur with binders.
-- For values, this is because we replaces things with freshly chosen variables.
@@ -92,8 +92,8 @@
import Prelude ()
import Prelude.Compat
-{- (f,t,n) |--> x means that when we spot instantiations of `f` with `ts` and
-`n` proof argument, we should replace them with `Var x` -}
+{- (f,t,n) |--> x means that when we spot instantiations of @f@ with @ts@ and
+@n@ proof argument, we should replace them with @Var x@ -}
newtype RewMap' a = RM (Map Name (TypesMap (Map Int a)))
type RewMap = RewMap' Name
@@ -181,8 +181,7 @@
EList es t -> EList <$> mapM go es <*> return t
ETuple es -> ETuple <$> mapM go es
- ERec fs -> ERec <$> (forM fs $ \(f,e) -> do e1 <- go e
- return (f,e1))
+ 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
EIf e1 e2 e3 -> EIf <$> go e1 <*> go e2 <*> go e3
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
@@ -23,13 +23,10 @@
import MonadLib hiding (mapM)
-import Prelude ()
-import Prelude.Compat
-
-- Specializer Monad -----------------------------------------------------------
--- | A Name should have an entry in the SpecCache iff it is
--- specializable. Each Name starts out with an empty TypesMap.
+-- | A 'Name' should have an entry in the 'SpecCache' iff it is
+-- specializable. Each 'Name' starts out with an empty 'TypesMap'.
type SpecCache = Map Name (Decl, TypesMap (Name, Maybe Decl))
-- | The specializer monad.
@@ -58,24 +55,24 @@
-- Specializer -----------------------------------------------------------------
--- | Add a `where` clause to the given expression containing
+-- | Add a @where@ clause to the given expression containing
-- type-specialized versions of all functions called (transitively) by
-- the body of the expression.
specialize :: Expr -> M.ModuleCmd Expr
-specialize expr (ev,modEnv) = run $ do
+specialize expr (ev, byteReader, modEnv) = run $ do
let extDgs = allDeclGroups modEnv
let (tparams, expr') = destETAbs expr
spec' <- specializeEWhere expr' extDgs
return (foldr ETAbs spec' tparams)
where
- run = M.runModuleT (ev,modEnv) . fmap fst . runSpecT Map.empty
+ run = M.runModuleT (ev, byteReader, modEnv) . fmap fst . runSpecT Map.empty
specializeExpr :: Expr -> SpecM Expr
specializeExpr expr =
case expr of
EList es t -> EList <$> traverse specializeExpr es <*> pure t
ETuple es -> ETuple <$> traverse specializeExpr es
- ERec fs -> ERec <$> traverse (traverseSnd specializeExpr) fs
+ 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
EIf e1 e2 e3 -> EIf <$> specializeExpr e1 <*> specializeExpr e2 <*> specializeExpr e3
@@ -88,13 +85,13 @@
e' <- specializeExpr e
setSpecCache cache
return (ETAbs t e')
- -- We need to make sure that after processing `e`, no specialized
- -- decls mentioning type variable `t` escape outside the
- -- `ETAbs`. To avoid this, we reset to an empty SpecCache while we
- -- run `specializeExpr e`, and restore it afterward: this
+ -- We need to make sure that after processing @e@, no specialized
+ -- decls mentioning type variable @t@ escape outside the
+ -- 'ETAbs'. To avoid this, we reset to an empty 'SpecCache' while we
+ -- run @'specializeExpr' e@, and restore it afterward: this
-- effectively prevents the specializer from registering any type
- -- instantiations involving `t` for any decls bound outside the
- -- scope of `t`.
+ -- instantiations involving @t@ for any decls bound outside the
+ -- scope of @t@.
ETApp {} -> specializeConst expr
EApp e1 e2 -> EApp <$> specializeExpr e1 <*> specializeExpr e2
EAbs qn t e -> EAbs qn t <$> specializeExpr e
@@ -144,9 +141,9 @@
modifySpecCache (Map.union savedCache . flip Map.difference newCache)
return (result, dgs', nameTable)
--- | Compute the specialization of `EWhere e dgs`. A decl within `dgs`
+-- | Compute the specialization of @'EWhere' e dgs@. A decl within @dgs@
-- is replicated once for each monomorphic type instance at which it
--- is used; decls not mentioned in `e` (even monomorphic ones) are
+-- is used; decls not mentioned in @e@ (even monomorphic ones) are
-- simply dropped.
specializeEWhere :: Expr -> [DeclGroup] -> SpecM Expr
specializeEWhere e dgs = do
@@ -224,7 +221,7 @@
-- Any top-level declarations in the current module can be found in the
-- ModuleEnv's LoadedModules, and so we can count of freshName to avoid
-- collisions with them. Any generated name for a
--- specialized function will be qualified with the current @ModName@, so genned
+-- specialized function will be qualified with the current 'ModName', so genned
-- names will not collide with local decls either.
-- freshName :: Name -> [Type] -> SpecM Name
-- freshName n [] = return n
@@ -322,12 +319,12 @@
| otherwise = return $ Forall [] [] (apSubst sub ty)
where sub = listParamSubst (zip params ts)
--- | Reduce `length ts` outermost type abstractions and `n` proof abstractions.
+-- | Reduce @length ts@ outermost type abstractions and @n@ proof abstractions.
instantiateExpr :: [Type] -> Int -> Expr -> SpecM Expr
instantiateExpr [] 0 e = return e
instantiateExpr [] n (EProofAbs _ e) = instantiateExpr [] (n - 1) e
instantiateExpr (t : ts) n (ETAbs param e) =
- instantiateExpr ts n (apSubst (singleSubst (tpVar param) t) e)
+ instantiateExpr ts n (apSubst (singleTParamSubst param t) e)
instantiateExpr _ _ _ = fail "instantiateExpr: wrong number of type/proof arguments"
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
@@ -36,7 +36,8 @@
import Cryptol.Parser.AST ( Selector(..),Pragma(..)
, Import(..), ImportSpec(..), ExportType(..)
, Fixity(..))
-import Cryptol.Utils.Ident (Ident,isInfixIdent,ModName,packIdent)
+import Cryptol.Utils.Ident (Ident,isInfixIdent,ModName,PrimIdent,prelPrim)
+import Cryptol.Utils.RecordMap
import Cryptol.TypeCheck.PP
import Cryptol.TypeCheck.Type
@@ -103,7 +104,7 @@
data Expr = EList [Expr] Type -- ^ List value (with type of elements)
| ETuple [Expr] -- ^ Tuple value
- | ERec [(Ident,Expr)] -- ^ Record 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.
@@ -124,13 +125,13 @@
{- | Proof abstraction. Because we don't keep proofs around
we don't need to name the assumption, but we still need to
- record the assumption. The assumption is the `Type` term,
- which should be of kind `KProp`.
+ record the assumption. The assumption is the 'Type' term,
+ which should be of kind 'KProp'.
-}
| EProofAbs {- x -} Prop Expr
- {- | If `e : p => t`, then `EProofApp e : t`,
- as long as we can prove `p`.
+ {- | If @e : p => t@, then @EProofApp e : t@,
+ as long as we can prove @p@.
We don't record the actual proofs, as they are not
used for anything. It may be nice to keep them around
@@ -176,22 +177,21 @@
--------------------------------------------------------------------------------
--- | Construct a primitive, given a map to the unique names of the Cryptol
--- module.
-ePrim :: PrimMap -> Ident -> Expr
+-- | Construct a primitive, given a map to the unique primitive name.
+ePrim :: PrimMap -> PrimIdent -> Expr
ePrim pm n = EVar (lookupPrimDecl n pm)
--- | Make an expression that is `error` pre-applied to a type and a message.
+-- | Make an expression that is @error@ pre-applied to a type and a message.
eError :: PrimMap -> Type -> String -> Expr
eError prims t str =
- EApp (ETApp (ETApp (ePrim prims (packIdent "error")) t)
+ EApp (ETApp (ETApp (ePrim prims (prelPrim "error")) t)
(tNum (length str))) (eString prims str)
eString :: PrimMap -> String -> Expr
eString prims str = EList (map (eChar prims) str) tChar
eChar :: PrimMap -> Char -> Expr
-eChar prims c = ETApp (ETApp (ePrim prims (packIdent "number")) (tNum v)) (tWord (tNum w))
+eChar prims c = ETApp (ETApp (ePrim prims (prelPrim "number")) (tNum v)) (tWord (tNum w))
where v = fromEnum c
w = 8 :: Int
@@ -207,7 +207,7 @@
ETuple es -> parens $ sep $ punctuate comma $ map ppW es
ERec fs -> braces $ sep $ punctuate comma
- [ pp f <+> text "=" <+> ppW e | (f,e) <- fs ]
+ [ pp f <+> text "=" <+> ppW e | (f,e) <- displayFields fs ]
ESel e sel -> ppWP 4 e <+> text "." <.> pp sel
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
@@ -6,7 +6,7 @@
import Cryptol.Parser.Position(Located(..))
import qualified Cryptol.Parser.AST as P
-import Cryptol.ModuleSystem.Name(Name,nameIdent,nameLoc)
+import Cryptol.ModuleSystem.Name (nameIdent, nameLoc)
import Cryptol.ModuleSystem.InstantiateModule(instantiateModule)
import Cryptol.TypeCheck.AST
import Cryptol.TypeCheck.Monad
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
@@ -1,15 +1,17 @@
module Cryptol.TypeCheck.Default where
import qualified Data.Set as Set
+import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe(mapMaybe)
import Data.List((\\),nub)
-import Control.Monad(guard)
+import Control.Monad(guard,mzero)
+import Control.Applicative((<|>))
import Cryptol.TypeCheck.Type
-import Cryptol.TypeCheck.SimpType(tMax,tWidth)
-import Cryptol.TypeCheck.Error(Warning(..))
-import Cryptol.TypeCheck.Subst(Subst,apSubst,listSubst,substBinds,singleSubst)
+import Cryptol.TypeCheck.SimpType(tMax)
+import Cryptol.TypeCheck.Error(Warning(..), Error(..))
+import Cryptol.TypeCheck.Subst(Subst,apSubst,listSubst,substBinds,uncheckedSingleSubst)
import Cryptol.TypeCheck.InferTypes(Goal,goal,Goals(..),goalsFromList)
import Cryptol.TypeCheck.Solver.SMT(Solver,tryGetModel,shrinkModel)
import Cryptol.Utils.Panic(panic)
@@ -17,16 +19,37 @@
--------------------------------------------------------------------------------
--- | We default constraints of the form @Literal t a@ to @a := [width t]@
+-- | We default constraints of the form @Literal t a@ and @FLiteral m n r a@.
+--
+-- For @Literal t a@ we examine the context of constraints on the type @a@
+-- to decide how to default. If @Logic a@ is required,
+-- we cannot do any defaulting. Otherwise, we default
+-- to either @Integer@ or @Rational@. In particular, if
+-- we need to satisfy the @Field a@, constraint, we choose
+-- @Rational@ and otherwise we choose @Integer@.
+--
+-- For @FLiteral t a@ we always default to @Rational@.
defaultLiterals :: [TVar] -> [Goal] -> ([TVar], Subst, [Warning])
defaultLiterals as gs = let (binds,warns) = unzip (mapMaybe tryDefVar as)
in (as \\ map fst binds, listSubst binds, warns)
where
gSet = goalsFromList gs
+ allProps = saturatedPropSet gSet
+ flitCandidates = flitDefaultCandidates gSet
+
tryDefVar a =
- do gt <- Map.lookup a (literalGoals gSet)
+ -- 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
- defT = tWord (tWidth (goal gt))
w = DefaultingTo d defT
guard (not (Set.member a (fvs defT))) -- Currently shouldn't happen
-- but future proofing.
@@ -34,8 +57,17 @@
-- to depend on
return ((a,defT),w)
-
-
+flitDefaultCandidates :: Goals -> Map TVar ((TVar,Type),Warning)
+flitDefaultCandidates gs =
+ Map.fromList (mapMaybe flitCandidate (Set.toList (goalSet gs)))
+ where
+ 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))
--------------------------------------------------------------------------------
@@ -72,7 +104,7 @@
( [TVar] -- non-defaulted
, [Goal] -- new constraints
, Subst -- improvements from defaulting
- , [Warning] -- warnings about defaulting
+ , [Error] -- width defaulting errors
)
improveByDefaultingWithPure as ps =
classify (Map.fromList [ (a,([],Set.empty)) | a <- as ]) [] [] ps
@@ -86,19 +118,20 @@
let -- First, we use the `leqs` to choose some definitions.
(defs, newOthers) = select [] [] (fvs others) (Map.toList leqs)
su = listSubst defs
- warn (x,t) =
+ names = substBinds su
+ mkErr (x,t) =
case x of
- TVFree _ _ _ d -> DefaultingTo d t
+ TVFree _ _ _ d
+ | Just 0 <- tIsNum t -> AmbiguousSize d Nothing
+ | otherwise -> AmbiguousSize d (Just t)
TVBound {} -> panic "Crypto.TypeCheck.Infer"
[ "tryDefault attempted to default a quantified variable."
]
- names = substBinds su
-
in ( [ a | a <- as, not (a `Set.member` names) ]
, newOthers ++ others ++ nub (apSubst su fins)
, su
- , map warn defs
+ , map mkErr defs
)
@@ -152,7 +185,7 @@
let ty = case ts of
[] -> tNum (0::Int)
_ -> foldr1 tMax ts
- su1 = singleSubst x ty
+ su1 = uncheckedSingleSubst x ty
in ( (x,ty) : [ (y,apSubst su1 t) | (y,t) <- yes ]
, no -- We know that `x` does not appear here
, otherFree -- We know that `x` did not appear here either
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
@@ -18,6 +18,7 @@
import Cryptol.TypeCheck.Subst
import Cryptol.ModuleSystem.Name(Name)
import Cryptol.Utils.Ident(Ident)
+import Cryptol.Utils.RecordMap
cleanupErrors :: [(Range,Error)] -> [(Range,Error)]
cleanupErrors = dropErrorsFromSameLoc
@@ -83,10 +84,10 @@
| RecursiveType Type Type
-- ^ Unification results in a recursive type
- | UnsolvedGoals Bool [Goal]
+ | UnsolvedGoals (Maybe TCErrorMessage) [Goal]
-- ^ A constraint that we could not solve
- -- The boolean indicates if we know that this constraint
- -- is impossible.
+ -- If we have `TCErrorMess` than the goal is impossible
+ -- for the given reason
| UnsolvedDelayedCt DelayedCt
-- ^ A constraint (with context) that we could not solve
@@ -113,6 +114,10 @@
| RepeatedTypeParameter Ident [Range]
+ | AmbiguousSize TVarInfo (Maybe Type)
+ -- ^ 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).
deriving (Show, Generic, NFData)
instance TVars Warning where
@@ -151,6 +156,7 @@
UndefinedTypeParameter {} -> err
RepeatedTypeParameter {} -> err
+ AmbiguousSize x t -> AmbiguousSize x (apSubst su t)
instance FVS Error where
@@ -175,7 +181,7 @@
CannotMixPositionalAndNamedTypeParams -> Set.empty
UndefinedTypeParameter {} -> Set.empty
RepeatedTypeParameter {} -> Set.empty
-
+ AmbiguousSize _ t -> fvs t
instance PP Warning where
@@ -258,10 +264,15 @@
mismatchHint t1 t2)
UnsolvedGoals imp gs
- | imp ->
+ | Just msg <- imp ->
addTVarsDescsAfter names err $
nested "Unsolvable constraints:" $
- bullets (map (ppWithNames names) gs)
+ 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)
| noUni ->
addTVarsDescsAfter names err $
@@ -314,6 +325,13 @@
"Multiple definitions for type parameter `" <.> pp x <.> "`:"
$$ nest 2 (bullets (map pp rs))
+ AmbiguousSize x t ->
+ let sizeMsg =
+ case t of
+ Just t' -> "Must be at least:" <+> ppWithNames names t'
+ Nothing -> empty
+ in addTVarsDescsAfter names err ("Ambiguous numeric type:" <+> pp (tvarDesc x) $$ sizeMsg)
+
where
bullets xs = vcat [ "•" <+> d | d <- xs ]
@@ -327,8 +345,8 @@
mismatchHint (TRec fs1) (TRec fs2) =
hint "Missing" missing $$ hint "Unexpected" extra
where
- missing = map fst fs1 \\ map fst fs2
- extra = map fst fs2 \\ map fst fs1
+ missing = displayOrder fs1 \\ displayOrder fs2
+ extra = displayOrder fs2 \\ displayOrder fs1
hint _ [] = mempty
hint s [x] = text s <+> text "field" <+> pp x
hint s xs = text s <+> text "fields" <+> commaSep (map pp xs)
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
@@ -23,7 +23,10 @@
)
where
-import Cryptol.ModuleSystem.Name (asPrim,lookupPrimDecl,nameLoc)
+import qualified Data.Text as Text
+
+
+import Cryptol.ModuleSystem.Name (lookupPrimDecl,nameLoc)
import Cryptol.Parser.Position
import qualified Cryptol.Parser.AST as P
import qualified Cryptol.ModuleSystem.Exports as P
@@ -40,10 +43,10 @@
import Cryptol.TypeCheck.Instantiate
import Cryptol.TypeCheck.Depends
import Cryptol.TypeCheck.Subst (listSubst,apSubst,(@@),isEmptySubst)
-import Cryptol.TypeCheck.Solver.InfNat(genLog)
import Cryptol.Utils.Ident
import Cryptol.Utils.Panic(panic)
import Cryptol.Utils.PP
+import Cryptol.Utils.RecordMap
import qualified Data.Map as Map
import Data.Map (Map)
@@ -51,8 +54,9 @@
import Data.List(foldl',sortBy)
import Data.Either(partitionEithers)
import Data.Maybe(mapMaybe,isJust, fromMaybe)
-import Data.List(partition,find)
+import Data.List(partition)
import Data.Graph(SCC(..))
+import Data.Ratio(numerator,denominator)
import Data.Traversable(forM)
import Control.Monad(zipWithM,unless,foldM)
@@ -85,24 +89,25 @@
--- | Construct a primitive in the parsed AST.
+-- | Construct a Prelude primitive in the parsed AST.
mkPrim :: String -> InferM (P.Expr Name)
mkPrim str =
do nm <- mkPrim' str
return (P.EVar nm)
--- | Construct a primitive in the parsed AST.
+-- | Construct a Prelude primitive in the parsed AST.
mkPrim' :: String -> InferM Name
mkPrim' str =
do prims <- getPrimMap
- return (lookupPrimDecl (packIdent str) prims)
+ return (lookupPrimDecl (prelPrim (Text.pack str)) prims)
-desugarLiteral :: Bool -> P.Literal -> InferM (P.Expr Name)
-desugarLiteral fixDec lit =
+desugarLiteral :: P.Literal -> InferM (P.Expr Name)
+desugarLiteral lit =
do l <- curRange
numberPrim <- mkPrim "number"
+ fracPrim <- mkPrim "fraction"
let named (x,y) = P.NamedInst
P.Named { name = Located l (packIdent x), value = y }
number fs = P.EAppT numberPrim (map named fs)
@@ -115,19 +120,24 @@
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.CharLit -> [ ("rep", tBits (8 :: Integer)) ]
- P.DecLit
- | fixDec -> if num == 0
- then [ ("rep", tBits 0)]
- else case genLog num 2 of
- Just (x,_) -> [ ("rep", tBits (x + 1)) ]
- _ -> []
- | otherwise -> [ ]
+ 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))
+ in P.EAppT fracPrim [ arg numerator, arg denominator, rnd ]
+
+ P.ECChar c ->
+ number [ ("val", P.TNum (toInteger (fromEnum c)))
+ , ("rep", tBits (8 :: Integer)) ]
+
P.ECString s ->
- P.ETyped (P.EList [ P.ELit (P.ECNum (toInteger (fromEnum c))
- P.CharLit) | c <- s ])
+ P.ETyped (P.EList [ P.ELit (P.ECChar c) | c <- s ])
(P.TSeq P.TWild (P.TSeq (P.TNum 8) P.TBit))
@@ -146,7 +156,7 @@
checkHasType t tGoal
return e'
- P.ELit l -> do e <- desugarLiteral False l
+ P.ELit l -> do e <- desugarLiteral l
appTys e ts tGoal
@@ -236,7 +246,7 @@
checkE (P.EApp prim e) tGoal
P.ELit l@(P.ECNum _ P.DecLit) ->
- do e <- desugarLiteral False l
+ do e <- desugarLiteral l
-- NOTE: When 'l' is a decimal literal, 'desugarLiteral' does
-- not generate an instantiation for the 'rep' type argument
-- of the 'number' primitive. Therefore we explicitly
@@ -248,7 +258,7 @@
}
appTys e [arg] tGoal
- P.ELit l -> (`checkE` tGoal) =<< desugarLiteral False l
+ P.ELit l -> (`checkE` tGoal) =<< desugarLiteral l
P.ETuple es ->
do etys <- expectTuple (length es) tGoal
@@ -256,9 +266,9 @@
return (ETuple es')
P.ERecord fs ->
- do (ns,es,ts) <- unzip3 `fmap` expectRec fs tGoal
- es' <- zipWithM checkE es ts
- return (ERec (zip ns es'))
+ do es <- expectRec fs tGoal
+ es' <- traverse (uncurry checkE) es
+ return (ERec es')
P.EUpd x fs -> checkRecUpd x fs tGoal
@@ -320,16 +330,6 @@
P.EAppT e fs -> appTys e (map uncheckedTypeArg fs) tGoal
- P.EApp fun@(dropLoc -> P.EApp (dropLoc -> P.EVar c) _)
- arg@(dropLoc -> P.ELit l)
- | Just n <- asPrim c
- , n `elem` map packIdent [ "<<", ">>", "<<<", ">>>" , "@", "!" ] ->
- do newArg <- do l1 <- desugarLiteral True l
- return $ case arg of
- P.ELocated _ pos -> P.ELocated l1 pos
- _ -> l1
- checkE (P.EApp fun newArg) tGoal
-
P.EApp e1 e2 ->
do t1 <- newType (TypeOfArg Nothing) KType
e1' <- checkE e1 (tFun t1 tGoal)
@@ -477,39 +477,31 @@
where
genTys =forM [ 0 .. n - 1 ] $ \ i -> newType (TypeOfTupleField i) KType
-expectRec :: [P.Named a] -> Type -> InferM [(Ident,a,Type)]
+
+expectRec :: RecordMap Ident (Range, a) -> Type -> InferM (RecordMap Ident (a, Type))
expectRec fs ty =
case ty of
TUser _ _ ty' ->
expectRec fs ty'
- TRec ls | Just tys <- mapM checkField ls ->
- return tys
+ TRec ls
+ | Right r <- zipRecords (\_ (_rng,v) t -> (v,t)) fs ls -> pure r
_ ->
- do (tys,res) <- genTys
+ do res <- traverseRecordMap
+ (\nm (_rng,v) ->
+ do t <- newType (TypeOfRecordField nm) KType
+ return (v, t))
+ fs
+ let tys = fmap snd res
case ty of
TVar TVFree{} -> do ps <- unify ty (TRec tys)
newGoals CtExactType ps
_ -> recordError (TypeMismatch ty (TRec tys))
return res
- where
- checkField (n,t) =
- do f <- find (\f -> thing (P.name f) == n) fs
- return (thing (P.name f), P.value f, t)
- genTys =
- do res <- forM fs $ \ f ->
- do let field = thing (P.name f)
- t <- newType (TypeOfRecordField field) KType
- return (field, P.value f, t)
-
- let (ls,_,ts) = unzip3 res
- return (zip ls ts, res)
-
-
expectFin :: Int -> Type -> InferM ()
expectFin n ty =
case ty of
@@ -590,7 +582,7 @@
do (x, t) <- inferP desc p
ps <- unify tGoal (thing t)
let rng = fromMaybe emptyRange $ getLoc p
- let mkErr = recordError . UnsolvedGoals False . (:[])
+ let mkErr = recordError . UnsolvedGoals Nothing . (:[])
. Goal (CtPattern desc) rng
mapM_ mkErr ps
return (Located (srcRange t) x)
@@ -814,10 +806,11 @@
{- See if we might be able to default some of the potentially ambiguous
variables using the constraints that will be part of the newly
generalized schema. -}
- let (as0,here1,defSu,ws) = defaultAndSimplify maybeAmbig here0
+ let (as0,here1,defSu,ws,errs) = defaultAndSimplify maybeAmbig here0
extendSubst defSu
mapM_ recordWarning ws
+ mapM_ recordError errs
let here = map goal here1
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
@@ -18,6 +18,8 @@
{-# LANGUAGE ViewPatterns #-}
module Cryptol.TypeCheck.InferTypes where
+import Control.Monad(guard)
+
import Cryptol.Parser.Position
import Cryptol.ModuleSystem.Name (asPrim,nameLoc)
import Cryptol.TypeCheck.AST
@@ -25,10 +27,9 @@
import Cryptol.TypeCheck.Subst
import Cryptol.TypeCheck.TypePat
import Cryptol.TypeCheck.SimpType(tMax)
-import Cryptol.Utils.Ident (ModName, identText)
+import Cryptol.Utils.Ident (ModName, PrimIdent(..), preludeName)
import Cryptol.Utils.Panic(panic)
import Cryptol.Utils.Misc(anyJust)
-import Cryptol.Utils.Patterns(matchMaybe)
import Data.Set ( Set )
import qualified Data.Set as Set
@@ -60,6 +61,9 @@
{ goalSet :: Set Goal
-- ^ A bunch of goals, not including the ones in 'literalGoals'.
+ , saturatedPropSet :: Set Prop
+ -- ^ The set of nonliteral goals, saturated by all superclass implications
+
, literalGoals :: Map TVar LitGoal
-- ^ An entry @(a,t)@ corresponds to @Literal t a@.
} deriving (Show)
@@ -82,7 +86,7 @@
emptyGoals :: Goals
-emptyGoals = Goals { goalSet = Set.empty, literalGoals = Map.empty }
+emptyGoals = Goals { goalSet = Set.empty, saturatedPropSet = Set.empty, literalGoals = Map.empty }
nullGoals :: Goals -> Bool
nullGoals gs = Set.null (goalSet gs) && Map.null (literalGoals gs)
@@ -95,16 +99,33 @@
goalsFromList = foldr insertGoal emptyGoals
insertGoal :: Goal -> Goals -> Goals
-insertGoal g gs
+insertGoal g gls
| Just (a,newG) <- goalToLitGoal g =
- gs { literalGoals = Map.insertWith jn a newG (literalGoals gs) }
- | otherwise = gs { goalSet = Set.insert g (goalSet gs) }
+ -- XXX: here we are arbitrarily using the info of the first goal,
+ -- which could lead to a confusing location for a constraint.
+ let jn g1 g2 = g1 { goal = tMax (goal g1) (goal g2) } in
+ gls { literalGoals = Map.insertWith jn a newG (literalGoals gls)
+ , saturatedPropSet = Set.insert (pFin (TVar a)) (saturatedPropSet gls)
+ }
- where
- jn g1 g2 = g1 { goal = tMax (goal g1) (goal g2) }
- -- XXX: here we are arbitrarily using the info of the first goal,
- -- which could lead to a confusing location for a constraint.
+ -- If the goal is already implied by some other goal, skip it
+ | Set.member (goal g) (saturatedPropSet gls) = gls
+ -- Otherwise, it is not already implied, add it and saturate
+ | otherwise =
+ gls { goalSet = gs', saturatedPropSet = sps' }
+
+ where
+ ips = superclassSet (goal g)
+ igs = Set.map (\p -> g{ goal = p}) ips
+
+ -- remove all the goals that are implied by ips
+ gs' = Set.insert g (Set.difference (goalSet gls) igs)
+
+ -- add the goal and all its implied toals to the saturated set
+ sps' = Set.insert (goal g) (Set.union (saturatedPropSet gls) ips)
+
+
-- | Something that we need to find evidence for.
data Goal = Goal
{ goalSource :: ConstraintSource -- ^ What it is about
@@ -285,13 +306,17 @@
ppUse :: Expr -> Doc
ppUse expr =
case expr of
- EVar (asPrim -> Just prim)
- | identText prim == "number" -> "literal or demoted expression"
- | identText prim == "infFrom" -> "infinite enumeration"
- | identText prim == "infFromThen" -> "infinite enumeration (with step)"
- | identText prim == "fromTo" -> "finite enumeration"
- | identText prim == "fromThenTo" -> "finite enumeration"
+ EVar (isPrelPrim -> Just prim)
+ | prim == "number" -> "literal or demoted expression"
+ | prim == "infFrom" -> "infinite enumeration"
+ | prim == "infFromThen" -> "infinite enumeration (with step)"
+ | prim == "fromTo" -> "finite enumeration"
+ | prim == "fromThenTo" -> "finite enumeration"
_ -> "expression" <+> pp expr
+ where
+ isPrelPrim x = do PrimIdent p i <- asPrim x
+ guard (p == preludeName)
+ pure i
instance PP (WithNames Goal) where
ppPrec _ (WithNames g names) =
@@ -327,6 +352,3 @@
nest 2 (vcat (bullets (map (ppWithNames ns1) xs)))
ns1 = addTNames (dctForall d) names
-
-
-
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
@@ -30,6 +30,7 @@
import Cryptol.TypeCheck.Solve (simplifyAllConstraints)
import Cryptol.TypeCheck.Subst(listSubst,apSubst)
import Cryptol.Utils.Panic (panic)
+import Cryptol.Utils.RecordMap
import qualified Data.Map as Map
import Data.List(sortBy,groupBy)
@@ -52,7 +53,7 @@
-- XXX: We probably shouldn't do this, as we are changing what the
-- user is doing. We do it so that things are in a propal normal form,
-- but we should probably figure out another time to do this.
- let newPs = concatMap pSplitAnd $ map (simplify Map.empty)
+ let newPs = concatMap pSplitAnd $ map (simplify mempty)
$ map tRebuild ps1
return ( Forall xs1 newPs (tRebuild t1)
, [ g { goal = tRebuild (goal g) } | g <- gs ]
@@ -376,7 +377,7 @@
P.TTuple ts -> tcon (TC (TCTuple (length ts))) ts k
- P.TRecord fs -> do t1 <- TRec `fmap` mapM checkF fs
+ P.TRecord fs -> do t1 <- TRec <$> traverseRecordMap checkF fs
checkKind t1 k KType
P.TLocated t r1 -> kInRange r1 $ doCheckType t k
@@ -386,12 +387,11 @@
P.TInfix t x _ u-> doCheckType (P.TUser (thing x) [t, u]) k
- where
- checkF f = do t <- kInRange (srcRange (name f))
- $ doCheckType (value f) (Just KType)
- return (thing (name f), t)
-
+ P.TTyApp _fs -> panic "doCheckType"
+ ["TTyApp found when kind checking, but it should have been eliminated already"]
+ where
+ checkF _nm (rng,v) = kInRange rng $ doCheckType v (Just KType)
-- | Validate a parsed proposition.
checkProp :: P.Prop Name -- ^ Proposition that need to be checked
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
@@ -35,6 +35,7 @@
import Cryptol.Utils.Panic(panic)
import qualified Control.Applicative as A
+import qualified Control.Monad.Fail as Fail
import Control.Monad.Fix(MonadFix(..))
import qualified Data.Map as Map
import qualified Data.Set as Set
@@ -51,10 +52,6 @@
import GHC.Generics (Generic)
import Control.DeepSeq
-import Prelude ()
-import Prelude.Compat
-
-
-- | Information needed for type inference.
data InferInput = InferInput
{ inpRange :: Range -- ^ Location of program source
@@ -153,7 +150,7 @@
(cts,has) -> return $ InferFailed warns
$ cleanupErrors
[ ( goalRange g
- , UnsolvedGoals False [apSubst theSu g]
+ , UnsolvedGoals Nothing [apSubst theSu g]
) | g <- fromGoals cts ++ map hasGoal has
]
errs -> return $ InferFailed warns
@@ -192,7 +189,7 @@
{- NOTE: We assume no shadowing between these two, so it does not matter
where we look first. Similarly, we assume no shadowing with
- the existential type variable (in RW). See `checkTShadowing`. -}
+ the existential type variable (in RW). See 'checkTShadowing'. -}
, iTVars :: [TParam] -- ^ Type variable that are in scope
, iTSyns :: Map Name (DefLoc, TySyn) -- ^ Type synonyms that are in scope
@@ -218,7 +215,7 @@
, iSolvedHasLazy :: Map Int HasGoalSln
-- ^ NOTE: This field is lazy in an important way! It is the
- -- final version of `iSolvedHas` in `RW`, and the two are tied
+ -- final version of 'iSolvedHas' in 'RW', and the two are tied
-- together through recursion. The field is here so that we can
-- look thing up before they are defined, which is OK because we
-- don't need to know the results until everything is done.
@@ -263,8 +260,8 @@
-- Constraints that need solving
, iCts :: !Goals -- ^ Ordinary constraints
, iHasCts :: ![HasGoal]
- {- ^ Tuple/record projection constraints. The `Int` is the "name"
- of the constraint, used so that we can name it solution properly. -}
+ {- ^ Tuple/record projection constraints. The 'Int' is the "name"
+ of the constraint, used so that we can name its solution properly. -}
, iSupply :: !Supply
}
@@ -278,9 +275,11 @@
instance Monad InferM where
return x = IM (return x)
- fail x = IM (fail x)
IM m >>= f = IM (m >>= unIM . f)
+instance Fail.MonadFail InferM where
+ fail x = IM (fail x)
+
instance MonadFix InferM where
mfix f = IM (mfix (unIM . f))
@@ -311,7 +310,9 @@
-- | Report an error.
recordError :: Error -> InferM ()
recordError e =
- do r <- curRange
+ do r <- case e of
+ AmbiguousSize d _ -> return (tvarSource d)
+ _ -> curRange
IM $ sets_ $ \s -> s { iErrors = (r,e) : iErrors s }
recordWarning :: Warning -> InferM ()
@@ -388,9 +389,9 @@
simpGoal :: Goal -> InferM [Goal]
simpGoal g =
- case Simple.simplify Map.empty (goal g) of
- p | Just e <- tIsError p ->
- do recordError $ ErrorMsg $ text $ tcErrorMessage e
+ case Simple.simplify mempty (goal g) of
+ p | Just (e,t) <- tIsError p ->
+ do recordError $ UnsolvedGoals (Just e) [g { goal = t }]
return []
| ps <- pSplitAnd p -> return [ g { goal = pr } | pr <- ps ]
@@ -421,13 +422,13 @@
addHasGoal :: HasGoal -> InferM ()
addHasGoal g = IM $ sets_ $ \s -> s { iHasCts = g : iHasCts s }
--- | Get the `Has` constraints. Each of this should either be solved,
--- or added back using `addHasGoal`.
+-- | Get the @Has@ constraints. Each of this should either be solved,
+-- or added back using 'addHasGoal'.
getHasGoals :: InferM [HasGoal]
getHasGoals = do gs <- IM $ sets $ \s -> (iHasCts s, s { iHasCts = [] })
applySubst gs
--- | Specify the solution (`Expr -> Expr`) for the given constraint (`Int`).
+-- | Specify the solution (@Expr -> Expr@) for the given constraint ('Int').
solveHasGoal :: Int -> HasGoalSln -> InferM ()
solveHasGoal n e =
IM $ sets_ $ \s -> s { iSolvedHas = Map.insert n e (iSolvedHas s) }
@@ -535,7 +536,7 @@
getSubst = IM $ fmap iSubst get
-- | Add to the accumulated substitution, checking that the datatype
--- invariant for `Subst` is maintained.
+-- invariant for 'Subst' is maintained.
extendSubst :: Subst -> InferM ()
extendSubst su =
do mapM_ check (substToList su)
@@ -551,13 +552,7 @@
, "Type: " ++ show (pp ty)
]
TVFree _ _ tvs _ ->
- do let bounds tv =
- case tv of
- TVBound tp -> Set.singleton tp
- TVFree _ _ tps _ -> tps
- let vars = Set.unions (map bounds (Set.elems (fvs ty)))
- -- (Set.filter isBoundTV (fvs ty))
- let escaped = Set.difference vars tvs
+ do let escaped = Set.difference (freeParams ty) tvs
if Set.null escaped then return () else
panic "Cryptol.TypeCheck.Monad.extendSubst"
[ "Escaped quantified variables:"
@@ -835,10 +830,10 @@
instance Monad KindM where
return x = KM (return x)
- fail x = KM (fail x)
KM m >>= k = KM (m >>= unKM . k)
-
+instance Fail.MonadFail KindM where
+ fail x = KM (fail x)
{- | The arguments to this function are as follows:
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
@@ -19,6 +19,7 @@
import Cryptol.TypeCheck.AST
import Cryptol.Utils.Ident (Ident,unpackIdent)
+import Cryptol.Utils.RecordMap (canonicalFields)
import Cryptol.Parser.AST ( Located(..))
import Cryptol.ModuleSystem.Name
import Text.PrettyPrint hiding ((<>))
@@ -32,7 +33,7 @@
instance ShowParseable Expr where
showParseable (EList es _) = parens (text "EList" <+> showParseable es)
showParseable (ETuple es) = parens (text "ETuple" <+> showParseable es)
- showParseable (ERec ides) = parens (text "ERec" <+> showParseable ides)
+ 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 e <+> showParseable s
@@ -61,7 +62,7 @@
instance ShowParseable Type where
showParseable (TUser n lt t) = parens (text "TUser" <+> showParseable n <+> showParseable lt <+> showParseable t)
- showParseable (TRec lidt) = parens (text "TRec" <+> showParseable lidt)
+ showParseable (TRec lidt) = parens (text "TRec" <+> showParseable (canonicalFields lidt))
showParseable t = parens $ text $ show t
instance ShowParseable Selector where
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
@@ -17,13 +17,13 @@
import Cryptol.Parser.Position(thing)
import Cryptol.TypeCheck.AST
-import Cryptol.TypeCheck.Subst (apSubst, singleSubst)
+import Cryptol.TypeCheck.Subst (apSubst, singleTParamSubst)
import Cryptol.TypeCheck.Monad(InferInput(..))
import Cryptol.Utils.Ident
+import Cryptol.Utils.RecordMap
+import Data.List (sort)
import qualified Data.Set as Set
-import Data.List (sort, sortBy)
-import Data.Function (on)
import MonadLib
import qualified Control.Applicative as A
@@ -71,7 +71,7 @@
TVar tv -> lookupTVar tv
TRec fs ->
- do forM_ fs $ \(_,t) ->
+ do forM_ fs $ \t ->
do k <- checkType t
unless (k == KType) $ reportError $ KindMismatch KType k
return KType
@@ -156,8 +156,7 @@
fmap (tMono . tTuple) (mapM exprType es)
ERec fs ->
- do fs1 <- forM fs $ \(f,e) -> do t <- exprType e
- return (f,t)
+ do fs1 <- traverse exprType fs
return $ tMono $ TRec fs1
ESet e x v -> do ty <- exprType e
@@ -221,7 +220,7 @@
let k' = kindOf a
unless (k == k') $ reportError $ KindMismatch k' k
- let su = singleSubst (tpVar a) t
+ let su = singleTParamSubst a t
return $ Forall as (apSubst su ps) (apSubst su t1)
Forall [] _ _ -> reportError BadInstantiation
@@ -297,13 +296,13 @@
do case mb of
Nothing -> return ()
Just fs1 ->
- do let ns = sort (map fst fs)
+ do let ns = Set.toList (fieldSet fs)
ns1 = sort fs1
unless (ns == ns1) $
reportError $ UnexpectedRecordShape ns1 ns
- case lookup f fs of
- Nothing -> reportError $ MissingField f $ map fst fs
+ case lookupField f fs of
+ Nothing -> reportError $ MissingField f $ displayOrder fs
Just ft -> return ft
TCon (TC TCSeq) [s,elT] -> do res <- checkHas elT sel
@@ -370,11 +369,8 @@
TRec fs ->
case other of
TRec gs ->
- do let order = sortBy (compare `on` fst)
- fs1 = order fs
- gs1 = order gs
- unless (map fst fs1 == map fst gs1) err
- goMany (map snd fs1) (map snd gs1)
+ do unless (fieldSet fs == fieldSet gs) err
+ goMany (recordElements fs) (recordElements gs)
_ -> err
@@ -467,7 +463,6 @@
instance Monad TcM where
return a = TcM (return a)
- fail x = TcM (fail x)
TcM m >>= f = TcM (do a <- m
let TcM m1 = f a
m1)
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
@@ -7,7 +7,6 @@
import Cryptol.TypeCheck.TypePat
import Cryptol.TypeCheck.Solver.InfNat
import Control.Monad(msum,guard)
-import Cryptol.TypeCheck.PP(pp)
tRebuild' :: Bool -> Type -> Type
@@ -19,7 +18,7 @@
| withUser -> TUser x xs (go t)
| otherwise -> go t
TVar _ -> ty
- TRec xs -> TRec [ (x, go y) | (x, y) <- xs ]
+ TRec xs -> TRec (fmap go xs)
TCon tc ts -> tCon tc (map go ts)
tRebuild :: Type -> Type
@@ -109,7 +108,7 @@
tSub :: Type -> Type -> Type
tSub x y
| Just t <- tOp TCSub (op2 nSub) [x,y] = t
- | tIsInf y = tBadNumber $ TCErrorMessage "Subtraction of `inf`."
+ | tIsInf y = tError (tf2 TCSub x y) "cannot subtract `inf`."
| Just 0 <- yNum = x
| Just k <- yNum
, TCon (TF TCAdd) [a,b] <- tNoUser x
@@ -166,33 +165,38 @@
tDiv :: Type -> Type -> Type
tDiv x y
| Just t <- tOp TCDiv (op2 nDiv) [x,y] = t
- | tIsInf x = tBadNumber $ TCErrorMessage "Division of `inf`."
- | Just 0 <- tIsNum y = tBadNumber $ TCErrorMessage "Division by 0."
+ | tIsInf x = bad "Cannot divide `inf`"
+ | Just 0 <- tIsNum y = bad "Cannot divide by 0"
| 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 = tBadNumber $ TCErrorMessage "Modulus of `inf`."
- | Just 0 <- tIsNum x = tBadNumber $ TCErrorMessage "Modulus by 0."
+ | tIsInf x = bad "Cannot compute remainder of `inf`"
+ | Just 0 <- tIsNum y = bad "Cannot divide modulo 0"
| 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 = tBadNumber $ TCErrorMessage "CeilDiv of `inf`."
- | tIsInf y = tBadNumber $ TCErrorMessage "CeilDiv by `inf`."
- | Just 0 <- tIsNum y = tBadNumber $ TCErrorMessage "CeilDiv by 0."
+ | tIsInf x = bad "CeilDiv of `inf`"
+ | tIsInf y = bad "CeilDiv by `inf`"
+ | Just 0 <- tIsNum y = bad "CeilDiv by 0"
| 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 = tBadNumber $ TCErrorMessage "CeilMod of `inf`."
- | tIsInf y = tBadNumber $ TCErrorMessage "CeilMod by `inf`."
- | Just 0 <- tIsNum x = tBadNumber $ TCErrorMessage "CeilMod to size 0."
+ | tIsInf x = bad "CeilMod of `inf`"
+ | tIsInf y = bad "CeilMod by `inf`"
+ | Just 0 <- tIsNum x = bad "CeilMod to size 0"
| otherwise = tf2 TCCeilMod x y
+ where bad = tError (tf2 TCCeilMod x y)
+
tExp :: Type -> Type -> Type
tExp x y
| Just t <- tOp TCExp (total (op2 nExp)) [x,y] = t
@@ -302,15 +306,12 @@
-- | Common checks: check for error, or simple full evaluation.
tOp :: TFun -> ([Nat'] -> Maybe Nat') -> [Type] -> Maybe Type
tOp tf f ts
- | Just e <- msum (map tIsError ts) = Just (tBadNumber e)
+ | Just (TCErrorMessage e,t) <- msum (map tIsError ts) = Just (tError t e)
| Just xs <- mapM tIsNat' ts =
Just $ case f xs of
- Nothing -> tBadNumber (err xs)
+ Nothing -> tError (TCon (TF tf) (map tNat' xs)) "invalid type"
Just n -> tNat' n
| otherwise = Nothing
- where
- err xs = TCErrorMessage $
- "Invalid type: " ++ show (pp (TCon (TF tf) (map tNat' xs)))
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
@@ -7,16 +7,21 @@
import Cryptol.TypeCheck.Solver.Numeric.Fin(cryIsFinType)
import Cryptol.TypeCheck.Solver.Numeric(cryIsEqual, cryIsNotEqual, cryIsGeq)
import Cryptol.TypeCheck.Solver.Class
- ( solveZeroInst, solveLogicInst, solveArithInst, solveCmpInst
- , solveSignedCmpInst, solveLiteralInst )
+ ( solveZeroInst, solveLogicInst, solveRingInst
+ , solveIntegralInst, solveFieldInst, solveRoundInst
+ , solveEqInst, solveCmpInst, solveSignedCmpInst
+ , solveLiteralInst
+ , solveValidFloat, solveFLiteralInst
+ )
import Cryptol.Utils.Debug(ppTrace)
import Cryptol.TypeCheck.PP
+
simplify :: Ctxt -> Prop -> Prop
simplify ctxt p =
case simplifyStep ctxt p of
- Unsolvable e -> pError e
+ Unsolvable (TCErrorMessage e) -> tError p e
Unsolved -> dbg msg p
where msg = text "unsolved:" <+> pp p
SolvedIf ps -> dbg msg $ pAnd (map (simplify ctxt) ps)
@@ -39,11 +44,18 @@
TCon (PC PZero) [ty] -> solveZeroInst ty
TCon (PC PLogic) [ty] -> solveLogicInst ty
- TCon (PC PArith) [ty] -> solveArithInst ty
- TCon (PC PCmp) [ty] -> solveCmpInst ty
+ TCon (PC PRing) [ty] -> solveRingInst ty
+ TCon (PC PField) [ty] -> solveFieldInst ty
+ TCon (PC PIntegral) [ty] -> solveIntegralInst ty
+ TCon (PC PRound) [ty] -> solveRoundInst ty
+
+ TCon (PC PEq) [ty] -> solveEqInst ty
+ TCon (PC PCmp) [ty] -> solveCmpInst ty
TCon (PC PSignedCmp) [ty] -> solveSignedCmpInst ty
TCon (PC PLiteral) [t1,t2] -> solveLiteralInst t1 t2
+ TCon (PC PFLiteral) [t1,t2,t3,t4] -> solveFLiteralInst t1 t2 t3 t4
+ TCon (PC PValidFloat) [t1,t2] -> solveValidFloat t1 t2
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
@@ -30,11 +30,9 @@
import Cryptol.TypeCheck.Solver.Types
import Cryptol.TypeCheck.Solver.Selector(tryHasGoal)
-
import Cryptol.TypeCheck.Solver.SMT(Solver,proveImp,isNumeric)
import Cryptol.TypeCheck.Solver.Improve(improveProp,improveProps)
import Cryptol.TypeCheck.Solver.Numeric.Interval
-import Cryptol.Utils.PP (text,vcat,(<+>))
import Cryptol.Utils.Patterns(matchMaybe)
import Control.Applicative ((<|>))
@@ -49,13 +47,12 @@
-quickSolverIO :: Ctxt -> [Goal] -> IO (Either Goal (Subst,[Goal]))
+quickSolverIO :: Ctxt -> [Goal] ->
+ IO (Either (TCErrorMessage,Goal) (Subst,[Goal]))
quickSolverIO _ [] = return (Right (emptySubst, []))
quickSolverIO ctxt gs =
case quickSolver ctxt gs of
- Left err ->
- do msg (text "Contradiction:" <+> pp (goal err))
- return (Left err)
+ Left err -> return (Left err)
Right (su,gs') ->
do msg (vcat (map (pp . goal) gs' ++ [pp su]))
return (Right (su,gs'))
@@ -76,7 +73,7 @@
quickSolver :: Ctxt -- ^ Facts we can know
-> [Goal] -- ^ Need to solve these
- -> Either Goal (Subst,[Goal])
+ -> Either (TCErrorMessage,Goal) (Subst,[Goal])
-- ^ Left: contradicting goals,
-- Right: inferred types, unsolved goals.
quickSolver ctxt gs0 = go emptySubst [] gs0
@@ -88,9 +85,12 @@
Nothing -> Right (su,unsolved)
Just (newSu, subs) -> go (newSu @@ su) [] (subs ++ apSubst newSu unsolved)
+ 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 _ -> Left g
+ Unsolvable e -> Left (e,g)
Unsolved -> go su (g : unsolved) gs
SolvedIf subs ->
let cvt x = g { goal = x }
@@ -142,7 +142,12 @@
, goalRange = emptyRange
, goalSource = CtDefaulting } | p <- otherPs ]
+ 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))
@@ -155,15 +160,16 @@
(sProps sch)
-defaultAndSimplify :: [TVar] -> [Goal] -> ([TVar],[Goal],Subst,[Warning])
+defaultAndSimplify :: [TVar] -> [Goal] -> ([TVar],[Goal],Subst,[Warning],[Error])
defaultAndSimplify as gs =
- let (as1, gs1, su1, ws1) = defLit
- (as2, gs2, su2, ws2) = improveByDefaultingWithPure as1 gs1
- in (as2,gs2,su2 @@ su1, ws1 ++ ws2)
+ let (as1, gs1, su1, ws) = defLit
+ (as2, gs2, su2, errs) = improveByDefaultingWithPure as1 gs1
+ in (as2,gs2,su2 @@ su1, ws, errs)
+
where
defLit
| isEmptySubst su = nope
- | otherwise = case quickSolver Map.empty (apSubst su gs) of
+ | otherwise = case quickSolver mempty (apSubst su gs) of
Left _ -> nope -- hm?
Right (su1,gs1) -> (as1,gs1,su1@@su,ws)
where (as1,su,ws) = defaultLiterals as gs
@@ -178,8 +184,8 @@
case gs of
[] -> return ()
_ ->
- case quickSolver Map.empty gs of
- Left badG -> recordError (UnsolvedGoals True [badG])
+ case quickSolver mempty gs of
+ Left (msg,badG) -> recordError (UnsolvedGoals (Just msg) [badG])
Right (su,gs1) ->
do extendSubst su
addGoals gs1
@@ -207,9 +213,10 @@
do simplifyAllConstraints
gs <- getGoals
let vs = Set.toList (Set.filter isFreeTV (fvs gs))
- (_,gs1,su1,ws) = defaultAndSimplify vs gs
+ (_,gs1,su1,ws,errs) = defaultAndSimplify vs gs
extendSubst su1
mapM_ recordWarning ws
+ mapM_ recordError errs
cs <- getParamConstraints
case cs of
@@ -230,8 +237,8 @@
(mbErr,su) <- io (proveImplicationIO solver lnam evars
(extraAs ++ as) (extra ++ ps) gs)
case mbErr of
- Right ws -> mapM_ recordWarning ws
- Left err -> recordError err
+ Right ws -> mapM_ recordWarning ws
+ Left errs -> mapM_ recordError errs
return su
@@ -242,13 +249,13 @@
-> [TParam] -- ^ Type parameters
-> [Prop] -- ^ Assumed constraint
-> [Goal] -- ^ Collected constraints
- -> IO (Either Error [Warning], Subst)
+ -> IO (Either [Error] [Warning], Subst)
proveImplicationIO _ _ _ _ [] [] = return (Right [], emptySubst)
proveImplicationIO s f varsInEnv ps asmps0 gs0 =
- do let ctxt = assumptionIntervals Map.empty asmps
+ do let ctxt = buildSolverCtxt asmps
res <- quickSolverIO ctxt gs
case res of
- Left bad -> return (Left (UnsolvedGoals True [bad]), emptySubst)
+ Left (msg,bad) -> return (Left [UnsolvedGoals (Just msg) [bad]], emptySubst)
Right (su,[]) -> return (Right [], su)
Right (su,gs1) ->
do gs2 <- proveImp s asmps gs1
@@ -259,32 +266,34 @@
$ Set.toList
$ Set.difference (fvs (map goal gs3)) varsInEnv
case defaultAndSimplify free gs3 of
- (_,_,newSu,_)
+ (_,_,newSu,_,errs)
| isEmptySubst newSu ->
- return (err gs3, su) -- XXX: Old?
- (_,newGs,newSu,ws) ->
+ return (Left (err gs3:errs), su) -- XXX: Old?
+ (_,newGs,newSu,ws,errs) ->
do let su1 = newSu @@ su
(res1,su2) <- proveImplicationIO s f varsInEnv ps
(apSubst su1 asmps0) newGs
let su3 = su2 @@ su1
case res1 of
- Left bad -> return (Left bad, su3)
- Right ws1 -> return (Right (ws++ws1),su3)
+ Left bad -> return (Left (bad ++ errs), su3)
+ Right ws1
+ | null errs -> return (Right (ws++ws1),su3)
+ | otherwise -> return (Left errs, su3)
where
- err us = Left $ cleanupError
- $ UnsolvedDelayedCt
- $ DelayedCt { dctSource = f
- , dctForall = ps
- , dctAsmps = asmps0
- , dctGoals = us
- }
+ err us = cleanupError
+ $ UnsolvedDelayedCt
+ $ DelayedCt { dctSource = f
+ , dctForall = ps
+ , dctAsmps = asmps0
+ , dctGoals = us
+ }
asmps1 = concatMap pSplitAnd asmps0
(asmps,gs) =
let gs1 = [ g { goal = p } | g <- gs0, p <- pSplitAnd (goal g)
, notElem p asmps1 ]
- in case matchMaybe (improveProps True Map.empty asmps1) of
+ in case matchMaybe (improveProps True mempty asmps1) of
Nothing -> (asmps1,gs1)
Just (newSu,newAsmps) ->
( [ TVar x =#= t | (x,t) <- substToList newSu ]
@@ -308,9 +317,26 @@
-assumptionIntervals :: Ctxt -> [Prop] -> Ctxt
-assumptionIntervals as ps =
- case computePropIntervals as ps of
- NoChange -> as
- InvalidInterval {} -> as -- XXX: say something
- NewIntervals bs -> Map.union bs as
+buildSolverCtxt :: [Prop] -> Ctxt
+buildSolverCtxt ps0 =
+ SolverCtxt
+ { intervals = assumptionIntervals mempty ps0
+ , saturatedAsmps = saturateProps mempty ps0
+ }
+
+ where
+ saturateProps gs [] = gs
+ saturateProps gs (p:ps)
+ | Set.member p gs = saturateProps gs ps
+ | Just (n,_) <- pIsLiteral p =
+ let gs' = Set.fromList [p, pFin n] <> gs
+ in saturateProps gs' ps
+ | otherwise =
+ let gs' = Set.singleton p <> superclassSet p <> gs
+ in saturateProps gs' ps
+
+ assumptionIntervals as ps =
+ case computePropIntervals as ps of
+ NoChange -> as
+ InvalidInterval {} -> as -- XXX: say something
+ NewIntervals bs -> Map.union bs as
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
@@ -10,31 +10,60 @@
{-# LANGUAGE PatternGuards, OverloadedStrings #-}
module Cryptol.TypeCheck.Solver.Class
- ( classStep
- , solveZeroInst
+ ( solveZeroInst
, solveLogicInst
- , solveArithInst
+ , solveRingInst
+ , solveFieldInst
+ , solveIntegralInst
+ , solveRoundInst
+ , solveEqInst
, solveCmpInst
, solveSignedCmpInst
, solveLiteralInst
- , expandProp
+ , solveFLiteralInst
+ , solveValidFloat
) where
+import qualified LibBF as FP
+
import Cryptol.TypeCheck.Type
import Cryptol.TypeCheck.SimpType (tAdd,tWidth)
import Cryptol.TypeCheck.Solver.Types
import Cryptol.TypeCheck.PP
+import Cryptol.Utils.RecordMap
--- | Solve class constraints.
--- If not, then we return 'Nothing'.
--- If solved, then we return 'Just' a list of sub-goals.
-classStep :: Prop -> Solved
-classStep p = case tNoUser p of
- TCon (PC PLogic) [ty] -> solveLogicInst (tNoUser ty)
- TCon (PC PArith) [ty] -> solveArithInst (tNoUser ty)
- TCon (PC PCmp) [ty] -> solveCmpInst (tNoUser ty)
- _ -> Unsolved
+{- | This places constraints on the floating point numbers that
+we can work with. This is a bit of an odd check, as it is really
+a limitiation of the backend, and not the language itself.
+On the other hand, it helps us give sane results if one accidentally
+types a polymorphic float at the REPL. Hopefully, most users will
+stick to particular FP sizes, so this should be quite transparent.
+-}
+solveValidFloat :: Type -> Type -> Solved
+solveValidFloat e p
+ | Just _ <- knownSupportedFloat e p = SolvedIf []
+ | otherwise = Unsolved
+
+-- | Check that the type parameters correspond to a float that
+-- we support, and if so make the precision settings for the BigFloat library.
+knownSupportedFloat :: Type -> Type -> Maybe FP.BFOpts
+knownSupportedFloat et pt
+ | Just e <- tIsNum et, Just p <- tIsNum pt
+ , minExp <= e && e <= maxExp && minPrec <= p && p <= maxPrec =
+ Just (FP.expBits (fromInteger e) <> FP.precBits (fromInteger p)
+ <> FP.allowSubnormal)
+ | otherwise = Nothing
+ where
+ minExp = max 2 (toInteger FP.expBitsMin)
+ maxExp = toInteger FP.expBitsMax
+
+ minPrec = max 2 (toInteger FP.precBitsMin)
+ maxPrec = toInteger FP.precBitsMax
+
+
+
+
-- | Solve a Zero constraint by instance, if possible.
solveZeroInst :: Type -> Solved
solveZeroInst ty = case tNoUser ty of
@@ -51,6 +80,14 @@
-- Zero (Z n)
TCon (TC TCIntMod) [n] -> SolvedIf [ pFin n, n >== tOne ]
+ -- Zero Real
+
+ -- Zero Rational
+ TCon (TC TCRational) [] -> SolvedIf []
+
+ -- ValidVloat e p => Zero (Float e p)
+ TCon (TC TCFloat) [e,p] -> SolvedIf [ pValidFloat e p ]
+
-- Zero a => Zero [n]a
TCon (TC TCSeq) [_, a] -> SolvedIf [ pZero a ]
@@ -61,7 +98,7 @@
TCon (TC (TCTuple _)) es -> SolvedIf [ pZero e | e <- es ]
-- (Zero a, Zero b) => Zero { x1 : a, x2 : b }
- TRec fs -> SolvedIf [ pZero ety | (_,ety) <- fs ]
+ TRec fs -> SolvedIf [ pZero ety | ety <- recordElements fs ]
_ -> Unsolved
@@ -75,6 +112,26 @@
-- Logic Bit
TCon (TC TCBit) [] -> SolvedIf []
+ -- Logic Integer fails
+ TCon (TC TCInteger) [] ->
+ Unsolvable $
+ TCErrorMessage "Type 'Integer' does not support logical operations."
+
+ -- Logic (Z n) fails
+ TCon (TC TCIntMod) [_] ->
+ Unsolvable $
+ TCErrorMessage "Type 'Z' does not support logical operations."
+
+ -- Logic Rational fails
+ TCon (TC TCRational) [] ->
+ Unsolvable $
+ TCErrorMessage "Type 'Rational' does not support logical operations."
+
+ -- Logic (Float e p) fails
+ TCon (TC TCFloat) [_, _] ->
+ Unsolvable $
+ TCErrorMessage "Type 'Float' does not support logical operations."
+
-- Logic a => Logic [n]a
TCon (TC TCSeq) [_, a] -> SolvedIf [ pLogic a ]
@@ -85,47 +142,54 @@
TCon (TC (TCTuple _)) es -> SolvedIf [ pLogic e | e <- es ]
-- (Logic a, Logic b) => Logic { x1 : a, x2 : b }
- TRec fs -> SolvedIf [ pLogic ety | (_,ety) <- fs ]
+ TRec fs -> SolvedIf [ pLogic ety | ety <- recordElements fs ]
_ -> Unsolved
--- | Solve an Arith constraint by instance, if possible.
-solveArithInst :: Type -> Solved
-solveArithInst ty = case tNoUser ty of
+-- | Solve a Ring constraint by instance, if possible.
+solveRingInst :: Type -> Solved
+solveRingInst ty = case tNoUser ty of
- -- Arith Error -> fails
+ -- Ring Error -> fails
TCon (TError _ e) _ -> Unsolvable e
- -- Arith [n]e
- TCon (TC TCSeq) [n, e] -> solveArithSeq n e
+ -- Ring [n]e
+ TCon (TC TCSeq) [n, e] -> solveRingSeq n e
- -- Arith b => Arith (a -> b)
- TCon (TC TCFun) [_,b] -> SolvedIf [ pArith b ]
+ -- Ring b => Ring (a -> b)
+ TCon (TC TCFun) [_,b] -> SolvedIf [ pRing b ]
- -- (Arith a, Arith b) => Arith (a,b)
- TCon (TC (TCTuple _)) es -> SolvedIf [ pArith e | e <- es ]
+ -- (Ring a, Ring b) => Arith (a,b)
+ TCon (TC (TCTuple _)) es -> SolvedIf [ pRing e | e <- es ]
- -- Arith Bit fails
+ -- Ring Bit fails
TCon (TC TCBit) [] ->
- Unsolvable $ TCErrorMessage "Arithmetic cannot be done on individual bits."
+ Unsolvable $ TCErrorMessage "Type 'Bit' does not support ring operations."
- -- Arith Integer
+ -- Ring Integer
TCon (TC TCInteger) [] -> SolvedIf []
- -- Arith (Z n)
+ -- Ring (Z n)
TCon (TC TCIntMod) [n] -> SolvedIf [ pFin n, n >== tOne ]
- -- (Arith a, Arith b) => Arith { x1 : a, x2 : b }
- TRec fs -> SolvedIf [ pArith ety | (_,ety) <- fs ]
+ -- Ring Rational
+ TCon (TC TCRational) [] -> SolvedIf []
+ -- ValidFloat e p => Ring (Float e p)
+ TCon (TC TCFloat) [e,p] -> SolvedIf [ pValidFloat e p ]
+
+ -- (Ring a, Ring b) => Ring { x1 : a, x2 : b }
+ TRec fs -> SolvedIf [ pRing ety | ety <- recordElements fs ]
+
_ -> Unsolved
--- | Solve an Arith constraint for a sequence. The type passed here is the
+
+-- | Solve a Ring constraint for a sequence. The type passed here is the
-- element type of the sequence.
-solveArithSeq :: Type -> Type -> Solved
-solveArithSeq n ty = case tNoUser ty of
+solveRingSeq :: Type -> Type -> Solved
+solveRingSeq n ty = case tNoUser ty of
- -- fin n => Arith [n]Bit
+ -- fin n => Ring [n]Bit
TCon (TC TCBit) [] -> SolvedIf [ pFin n ]
-- variables are not solvable.
@@ -133,13 +197,187 @@
{- We are sure that the lenght is not `fin`, so the
special case for `Bit` does not apply.
Arith ty => Arith [n]ty -}
- TCon (TC TCInf) [] -> SolvedIf [ pArith ty ]
+ TCon (TC TCInf) [] -> SolvedIf [ pRing ty ]
_ -> Unsolved
- -- Arith ty => Arith [n]ty
- _ -> SolvedIf [ pArith ty ]
+ -- Ring ty => Ring [n]ty
+ _ -> SolvedIf [ pRing ty ]
+-- | Solve an Integral constraint by instance, if possible.
+solveIntegralInst :: Type -> Solved
+solveIntegralInst ty = case tNoUser ty of
+
+ -- Integral Error -> fails
+ TCon (TError _ e) _ -> Unsolvable e
+
+ -- Integral Bit fails
+ TCon (TC TCBit) [] ->
+ Unsolvable $ TCErrorMessage "Type 'Bit' is not an integral type."
+
+ -- Integral Integer
+ TCon (TC TCInteger) [] -> SolvedIf []
+
+ -- fin n => Integral [n]
+ TCon (TC TCSeq) [n, elTy] ->
+ case tNoUser elTy of
+ TCon (TC TCBit) [] -> SolvedIf [ pFin n ]
+ TVar _ -> Unsolved
+ _ -> Unsolvable $ TCErrorMessage $ show
+ $ "Type" <+> quotes (pp ty) <+> "is not an integral type."
+
+ TVar _ -> Unsolved
+
+ _ -> Unsolvable $ TCErrorMessage $ show
+ $ "Type" <+> quotes (pp ty) <+> "is not an integral type."
+
+
+-- | Solve a Field constraint by instance, if possible.
+solveFieldInst :: Type -> Solved
+solveFieldInst ty = case tNoUser ty of
+
+ -- Field Error -> fails
+ TCon (TError _ e) _ -> Unsolvable e
+
+ -- Field Bit fails
+ TCon (TC TCBit) [] ->
+ Unsolvable $
+ TCErrorMessage "Type 'Bit' does not support field operations."
+
+ -- Field Integer fails
+ TCon (TC TCInteger) [] ->
+ Unsolvable $
+ TCErrorMessage "Type 'Integer' does not support field operations."
+
+ -- Field Rational
+ TCon (TC TCRational) [] -> SolvedIf []
+
+ -- ValidFloat e p => Field (Float e p)
+ TCon (TC TCFloat) [e,p] -> SolvedIf [ pValidFloat e p ]
+
+ -- 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 ([n]a) fails
+ TCon (TC TCSeq) [_, _] ->
+ Unsolvable $
+ TCErrorMessage "Sequence types do not support field operations."
+
+ -- Field (a -> b) fails
+ TCon (TC TCFun) [_, _] ->
+ Unsolvable $
+ TCErrorMessage "Function types do not support field operations."
+
+ -- Field (a, b, ...) fails
+ TCon (TC (TCTuple _)) _ ->
+ Unsolvable $
+ TCErrorMessage "Tuple types do not support field operations."
+
+ -- Field {x : a, y : b, ...} fails
+ TRec _ ->
+ Unsolvable $
+ TCErrorMessage "Record types do not support field operations."
+
+ _ -> Unsolved
+
+
+-- | Solve a Round constraint by instance, if possible.
+solveRoundInst :: Type -> Solved
+solveRoundInst ty = case tNoUser ty of
+
+ -- Round Error -> fails
+ TCon (TError _ e) _ -> Unsolvable e
+
+ -- Round Bit fails
+ TCon (TC TCBit) [] ->
+ Unsolvable $
+ TCErrorMessage "Type 'Bit' does not support rounding operations."
+
+ -- Round Integer fails
+ TCon (TC TCInteger) [] ->
+ Unsolvable $
+ TCErrorMessage "Type 'Integer' does not support rounding operations."
+
+ -- Round (Z n) fails
+ TCon (TC TCIntMod) [_] ->
+ Unsolvable $
+ TCErrorMessage "Type 'Z' does not support rounding operations."
+
+ -- Round Rational
+ TCon (TC TCRational) [] -> SolvedIf []
+
+ -- ValidFloat e p => Round (Float e p)
+ TCon (TC TCFloat) [e,p] -> SolvedIf [ pValidFloat e p ]
+
+ -- Round Real
+
+ -- Round ([n]a) fails
+ TCon (TC TCSeq) [_, _] ->
+ Unsolvable $
+ TCErrorMessage "Sequence types do not support rounding operations."
+
+ -- Round (a -> b) fails
+ TCon (TC TCFun) [_, _] ->
+ Unsolvable $
+ TCErrorMessage "Function types do not support rounding operations."
+
+ -- Round (a, b, ...) fails
+ TCon (TC (TCTuple _)) _ ->
+ Unsolvable $
+ TCErrorMessage "Tuple types do not support rounding operations."
+
+ -- Round {x : a, y : b, ...} fails
+ TRec _ ->
+ Unsolvable $
+ TCErrorMessage "Record types do not support rounding operations."
+
+ _ -> Unsolved
+
+
+
+-- | Solve Eq constraints.
+solveEqInst :: Type -> Solved
+solveEqInst ty = case tNoUser ty of
+
+ -- Eq Error -> fails
+ TCon (TError _ e) _ -> Unsolvable e
+
+ -- eq Bit
+ TCon (TC TCBit) [] -> SolvedIf []
+
+ -- Eq Integer
+ TCon (TC TCInteger) [] -> SolvedIf []
+
+ -- Eq Rational
+ TCon (TC TCRational) [] -> SolvedIf []
+
+ -- ValidFloat e p => Eq (Float e p)
+ TCon (TC TCFloat) [e,p] -> SolvedIf [ pValidFloat e p ]
+
+ -- Eq (Z n)
+ TCon (TC TCIntMod) [n] -> SolvedIf [ pFin n, n >== tOne ]
+
+ -- (fin n, Eq a) => Eq [n]a
+ TCon (TC TCSeq) [n,a] -> SolvedIf [ pFin n, pEq a ]
+
+ -- (Eq a, Eq b) => Eq (a,b)
+ TCon (TC (TCTuple _)) es -> SolvedIf (map pEq es)
+
+ -- Eq (a -> b) fails
+ TCon (TC TCFun) [_,_] ->
+ Unsolvable $ TCErrorMessage "Function types do not support comparisons."
+
+ -- (Eq a, Eq b) => Eq { x:a, y:b }
+ TRec fs -> SolvedIf [ pEq e | e <- recordElements fs ]
+
+ _ -> Unsolved
+
+
-- | Solve Cmp constraints.
solveCmpInst :: Type -> Solved
solveCmpInst ty = case tNoUser ty of
@@ -153,9 +391,16 @@
-- Cmp Integer
TCon (TC TCInteger) [] -> SolvedIf []
- -- Cmp (Z n)
- TCon (TC TCIntMod) [n] -> SolvedIf [ pFin n, n >== tOne ]
+ -- Cmp Rational
+ TCon (TC TCRational) [] -> SolvedIf []
+ -- Cmp (Z n) fails
+ TCon (TC TCIntMod) [_] ->
+ Unsolvable $ TCErrorMessage "Type 'Z' does not support order comparisons."
+
+ -- ValidFloat e p => Cmp (Float e p)
+ TCon (TC TCFloat) [e,p] -> SolvedIf [ pValidFloat e p ]
+
-- (fin n, Cmp a) => Cmp [n]a
TCon (TC TCSeq) [n,a] -> SolvedIf [ pFin n, pCmp a ]
@@ -164,10 +409,10 @@
-- Cmp (a -> b) fails
TCon (TC TCFun) [_,_] ->
- Unsolvable $ TCErrorMessage "Comparisons may not be performed on functions."
+ Unsolvable $ TCErrorMessage "Function types do not support order comparisons."
-- (Cmp a, Cmp b) => Cmp { x:a, y:b }
- TRec fs -> SolvedIf [ pCmp e | (_,e) <- fs ]
+ TRec fs -> SolvedIf [ pCmp e | e <- recordElements fs ]
_ -> Unsolved
@@ -194,9 +439,31 @@
-- SignedCmp Error -> fails
TCon (TError _ e) _ -> Unsolvable e
- -- SignedCmp Bit
- TCon (TC TCBit) [] -> Unsolvable $ TCErrorMessage "Signed comparisons may not be performed on bits"
+ -- SignedCmp Bit fails
+ TCon (TC TCBit) [] ->
+ Unsolvable $
+ TCErrorMessage "Type 'Bit' does not support signed comparisons."
+ -- SignedCmp Integer fails
+ TCon (TC TCInteger) [] ->
+ Unsolvable $
+ TCErrorMessage "Type 'Integer' does not support signed comparisons."
+
+ -- SignedCmp (Z n) fails
+ TCon (TC TCIntMod) [_] ->
+ Unsolvable $
+ TCErrorMessage "Type 'Z' does not support signed comparisons."
+
+ -- SignedCmp Rational fails
+ TCon (TC TCRational) [] ->
+ Unsolvable $
+ TCErrorMessage "Type 'Rational' does not support signed comparisons."
+
+ -- SignedCmp (Float e p) fails
+ TCon (TC TCFloat) [_, _] ->
+ Unsolvable $
+ TCErrorMessage "Type 'Float' does not support signed comparisons."
+
-- SignedCmp for sequences
TCon (TC TCSeq) [n,a] -> solveSignedCmpSeq n a
@@ -205,14 +472,55 @@
-- SignedCmp (a -> b) fails
TCon (TC TCFun) [_,_] ->
- Unsolvable $ TCErrorMessage "Signed comparisons may not be performed on functions."
+ Unsolvable $
+ TCErrorMessage "Function types do not support signed comparisons."
-- (SignedCmp a, SignedCmp b) => SignedCmp { x:a, y:b }
- TRec fs -> SolvedIf [ pSignedCmp e | (_,e) <- fs ]
+ TRec fs -> SolvedIf [ pSignedCmp e | e <- recordElements fs ]
_ -> Unsolved
+-- | 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."
+
+ | otherwise =
+ case tNoUser ty of
+ TVar {} -> Unsolved
+
+ TCon (TError _ e) _ -> Unsolvable e
+
+ TCon (TC TCRational) [] ->
+ SolvedIf [ pFin numT, pFin denT, denT >== tOne ]
+
+ TCon (TC TCFloat) [e,p]
+ | Just 0 <- tIsNum rndT ->
+ SolvedIf [ pValidFloat e p
+ , pFin numT, pFin denT, denT >== tOne ]
+
+ | Just _ <- tIsNum rndT
+ , Just opts <- knownSupportedFloat e p
+ , Just n <- tIsNum numT
+ , 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)
+
+ | otherwise -> Unsolved
+
+ _ -> Unsolvable $ TCErrorMessage $ show
+ $ "Type" <+> quotes (pp ty) <+> "does not support fractional literals."
+
-- | Solve Literal constraints.
solveLiteralInst :: Type -> Type -> Solved
solveLiteralInst val ty
@@ -226,6 +534,24 @@
-- (fin val) => Literal val Integer
TCon (TC TCInteger) [] -> SolvedIf [ pFin val ]
+ -- (fin val) => Literal val Rational
+ TCon (TC TCRational) [] -> SolvedIf [ pFin val ]
+
+ -- ValidFloat e p => Literal val (Float e p) if `val` is representable
+ TCon (TC TCFloat) [e,p]
+ | Just n <- tIsNum val
+ , Just opts <- knownSupportedFloat e p ->
+ 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)
+
+ | otherwise -> Unsolved
+
+
+
-- (fin val, fin m, m >= val + 1) => Literal val (Z m)
TCon (TC TCIntMod) [modulus] ->
SolvedIf [ pFin val, pFin modulus, modulus >== tAdd val tOne ]
@@ -240,49 +566,6 @@
TVar _ -> Unsolved
_ -> Unsolvable $ TCErrorMessage $ show
- $ "Type" <+> quotes (pp ty) <+> "does not support literals."
-
-
--- | Add propositions that are implied by the given one.
--- The result contains the orignal proposition, and maybe some more.
-expandProp :: Prop -> [Prop]
-expandProp prop =
- prop :
- case tNoUser prop of
-
- TCon (PC pc) [ty] ->
- case (pc, tNoUser ty) of
-
- -- Arith [n]Bit => fin n
- -- (Arith [n]a, a/=Bit) => Arith a
- (PArith, TCon (TC TCSeq) [n,a])
- | TCon (TC TCBit) _ <- ty1 -> [pFin n]
- | TCon _ _ <- ty1 -> expandProp (pArith ty1)
- | TRec {} <- ty1 -> expandProp (pArith ty1)
- where
- ty1 = tNoUser a
-
- -- Arith (a -> b) => Arith b
- (PArith, TCon (TC TCFun) [_,b]) -> expandProp (pArith b)
-
- -- Arith (a,b) => (Arith a, Arith b)
- (PArith, TCon (TC (TCTuple _)) ts) -> concatMap (expandProp . pArith) ts
-
- -- Arith { x1 : a, x2 : b } => (Arith a, Arith b)
- (PArith, TRec fs) -> concatMap (expandProp . pArith. snd) fs
-
- -- Cmp [n]a => (fin n, Cmp a)
- (PCmp, TCon (TC TCSeq) [n,a]) -> pFin n : expandProp (pCmp a)
-
- -- Cmp (a,b) => (Cmp a, Cmp b)
- (PCmp, TCon (TC (TCTuple _)) ts) -> concatMap (expandProp . pCmp) ts
-
- -- Cmp { x:a, y:b } => (Cmp a, Cmp b)
- (PCmp, TRec fs) -> concatMap (expandProp . pCmp . snd) fs
-
- _ -> []
-
- _ -> []
-
+ $ "Type" <+> quotes (pp ty) <+> "does not support integer literals."
diff --git a/src/Cryptol/TypeCheck/Solver/Improve.hs b/src/Cryptol/TypeCheck/Solver/Improve.hs
--- a/src/Cryptol/TypeCheck/Solver/Improve.hs
+++ b/src/Cryptol/TypeCheck/Solver/Improve.hs
@@ -51,7 +51,7 @@
(_,b) <- aSeq t
a <- aTVar b
unless impSkol $ guard (isFreeTV a)
- let su = singleSubst a tBit
+ let su = uncheckedSingleSubst a tBit
return (su, [])
@@ -66,20 +66,22 @@
where
rewrite this other =
do x <- aTVar this
- guard (considerVar x && x `Set.notMember` fvs other)
- return (singleSubst x other, [])
+ guard (considerVar x)
+ case singleSubst x other of
+ Left _ -> mzero
+ Right su -> return (su, [])
<|>
do (v,s) <- isSum this
- guard (v `Set.notMember` fvs other)
- return (singleSubst v (Mk.tSub other s), [ other >== s ])
-
+ case singleSubst v (Mk.tSub other s) of
+ Left _ -> mzero
+ Right su -> return (su, [ other >== s ])
isSum t = do (v,s) <- matches t (anAdd, aTVar, __)
valid v s
<|> do (s,v) <- matches t (anAdd, __, aTVar)
valid v s
- valid v s = do let i = typeInterval fins s
+ valid v s = do let i = typeInterval (intervals fins) s
guard (considerVar v && v `Set.notMember` fvs s && iIsFin i)
return (v,s)
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
@@ -5,6 +5,7 @@
import Control.Applicative(Alternative(..))
import Control.Monad (guard,mzero)
+import qualified Control.Monad.Fail as Fail
import Data.List (sortBy)
import Cryptol.Utils.Patterns
@@ -81,7 +82,7 @@
return $ if p x y
then SolvedIf []
else Unsolvable $ TCErrorMessage
- $ "Unsolvable constraint: " ++
+ $ "It is not the case that " ++
show (pp (TCon (PC tf) [ tNat' x, tNat' y ])))
@@ -136,8 +137,8 @@
-- | Try to prove GEQ by considering the known intervals for the given types.
geqByInterval :: Ctxt -> Type -> Type -> Match Solved
geqByInterval ctxt x y =
- let ix = typeInterval ctxt x
- iy = typeInterval ctxt y
+ let ix = typeInterval (intervals ctxt) x
+ iy = typeInterval (intervals ctxt) y
in case (iLower ix, iUpper iy) of
(l,Just n) | l >= n -> return (SolvedIf [])
_ -> mzero
@@ -163,7 +164,7 @@
let lhs = preproc t1
rhs = preproc t2
in case check [] [] lhs rhs of
- Nothing -> fail ""
+ Nothing -> Fail.fail "tryCancelVar"
Just x -> return x
@@ -190,7 +191,7 @@
Nothing -> t : rest
cancelVar t = matchMaybe $ do x <- aTVar t
- guard (iIsPosFin (tvarInterval ctxt x))
+ guard (iIsPosFin (tvarInterval (intervals ctxt) x))
return x
-- cancellable variables go first, sorted alphabetically
@@ -285,7 +286,7 @@
-- (t1 + t2 = inf, fin t1) ~~~> t2 = inf
do guard (lk == Inf)
(a,b) <- anAdd ty
- let check x y = do guard (iIsFin (typeInterval ctxt x))
+ let check x y = do guard (iIsFin (typeInterval (intervals ctxt) x))
return $ SolvedIf [ y =#= tInf ]
check a b <|> check b a
<|>
@@ -376,8 +377,8 @@
do (x1,x2) <- anAdd x
aInf y
- let x1Fin = iIsFin (typeInterval ctxt x1)
- let x2Fin = iIsFin (typeInterval ctxt x2)
+ let x1Fin = iIsFin (typeInterval (intervals ctxt) x1)
+ let x2Fin = iIsFin (typeInterval (intervals ctxt) x2)
return $!
if | x1Fin ->
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
@@ -11,7 +11,6 @@
{-# LANGUAGE PatternGuards #-}
module Cryptol.TypeCheck.Solver.Numeric.Fin where
-import Data.Map (Map)
import qualified Data.Map as Map
import Cryptol.TypeCheck.Type
@@ -20,14 +19,15 @@
import Cryptol.TypeCheck.Solver.InfNat
-cryIsFin :: Map TVar Interval -> Prop -> Solved
-cryIsFin varInfo p =
+cryIsFin :: Ctxt -> Prop -> Solved
+cryIsFin ctxt p =
case pIsFin p of
- Just ty -> cryIsFinType varInfo ty
+ Just ty -> cryIsFinType ctxt ty
Nothing -> Unsolved
-cryIsFinType :: Map TVar Interval -> Type -> Solved
-cryIsFinType varInfo ty =
+cryIsFinType :: Ctxt -> Type -> Solved
+cryIsFinType ctxt ty =
+ let varInfo = intervals ctxt in
case tNoUser ty of
TVar x | Just i <- Map.lookup x varInfo
diff --git a/src/Cryptol/TypeCheck/Solver/Numeric/Interval.hs b/src/Cryptol/TypeCheck/Solver/Numeric/Interval.hs
--- a/src/Cryptol/TypeCheck/Solver/Numeric/Interval.hs
+++ b/src/Cryptol/TypeCheck/Solver/Numeric/Interval.hs
@@ -108,11 +108,11 @@
x <- tIsVar ty
return (x,iAnyFin)
- , do (l,r) <- pIsEq prop
+ , do (l,r) <- pIsEqual prop
x <- tIsVar l
return (x,typeInterval varInts r)
- , do (l,r) <- pIsEq prop
+ , do (l,r) <- pIsEqual prop
x <- tIsVar r
return (x,typeInterval varInts l)
@@ -137,6 +137,14 @@
upper -> upper
return (x, Interval { iLower = Nat 0, iUpper = ub })
+
+ , do (e,_) <- pIsValidFloat prop
+ x <- tIsVar e
+ pure (x, iAnyFin)
+
+ , do (_,p) <- pIsValidFloat prop
+ x <- tIsVar p
+ pure (x, iAnyFin)
]
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
@@ -17,6 +17,7 @@
import Cryptol.TypeCheck.Subst (listParamSubst, apSubst)
import Cryptol.Utils.Ident (Ident, packIdent)
import Cryptol.Utils.Panic(panic)
+import Cryptol.Utils.RecordMap
import Control.Monad(forM,guard)
@@ -26,7 +27,7 @@
do fields <- forM labels $ \l ->
do t <- newType (TypeOfRecordField l) KType
return (l,t)
- return (TRec fields)
+ return (TRec (recordFromFields fields))
tupleType :: Int -> InferM Type
tupleType n =
@@ -64,7 +65,7 @@
(RecordSel l _, ty) ->
case ty of
- TRec fs -> return (lookup l fs)
+ TRec fs -> return (lookupField l fs)
TCon (TC TCSeq) [len,el] -> liftSeq len el
TCon (TC TCFun) [t1,t2] -> liftFun t1 t2
TCon (TC (TCNewtype (UserTC x _))) ts ->
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,12 +1,24 @@
module Cryptol.TypeCheck.Solver.Types where
import Data.Map(Map)
+import Data.Set(Set)
import Cryptol.TypeCheck.Type
import Cryptol.TypeCheck.PP
import Cryptol.TypeCheck.Solver.Numeric.Interval
-type Ctxt = Map TVar Interval
+data Ctxt =
+ SolverCtxt
+ { intervals :: Map TVar Interval
+ , saturatedAsmps :: Set Prop
+ }
+
+instance Semigroup Ctxt where
+ SolverCtxt is1 as1 <> SolverCtxt is2 as2 = SolverCtxt (is1 <> is2) (as1 <> as2)
+
+instance Monoid Ctxt where
+ mempty = SolverCtxt mempty mempty
+
data Solved = SolvedIf [Prop] -- ^ Solved, assuming the sub-goals.
| Unsolved -- ^ We could not solve the goal.
diff --git a/src/Cryptol/TypeCheck/Solver/Utils.hs b/src/Cryptol/TypeCheck/Solver/Utils.hs
--- a/src/Cryptol/TypeCheck/Solver/Utils.hs
+++ b/src/Cryptol/TypeCheck/Solver/Utils.hs
@@ -15,7 +15,7 @@
--- | All ways to split a type in the form: `a + t1`, where `a` is a variable.
+-- | All ways to split a type in the form: @a + t1@, where @a@ is a variable.
splitVarSummands :: Type -> [(TVar,Type)]
splitVarSummands ty0 = [ (x,t1) | (x,t1) <- go ty0, tNum (0::Int) /= t1 ]
where
@@ -32,12 +32,12 @@
TCon _ _ -> [] -- XXX: we could do some distributivity etc
--- | Check if we can express a type in the form: `a + t1`.
+-- | Check if we can express a type in the form: @a + t1@.
splitVarSummand :: TVar -> Type -> Maybe Type
splitVarSummand a ty = listToMaybe [ t | (x,t) <- splitVarSummands ty, x == a ]
-{- | Check if we can express a type in the form: `k + t1`,
-where `k` is a constant > 0.
+{- | Check if we can express a type in the form: @k + t1@,
+where @k@ is a constant > 0.
This assumes that the type has been simplified already,
so that constants are floated to the left. -}
splitConstSummand :: Type -> Maybe (Integer, Type)
@@ -54,8 +54,8 @@
TCon (TC (TCNum k)) [] -> guard (k > 0) >> return (k, tNum (0::Int))
TCon {} -> Nothing
-{- | Check if we can express a type in the form: `k * t1`,
-where `k` is a constant > 1
+{- | Check if we can express a type in the form: @k * t1@,
+where @k@ is a constant > 1.
This assumes that the type has been simplified already,
so that constants are floated to the left. -}
splitConstFactor :: Type -> Maybe (Integer, Type)
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
@@ -14,7 +14,10 @@
module Cryptol.TypeCheck.Subst
( Subst
, emptySubst
+ , SubstError(..)
, singleSubst
+ , singleTParamSubst
+ , uncheckedSingleSubst
, (@@)
, defaultingSubst
, listSubst
@@ -47,12 +50,22 @@
-- | A 'Subst' value represents a substitution that maps each 'TVar'
-- to a 'Type'.
--
--- Invariant: If there is a mapping from @TVFree _ _ tps _@ to a type
--- @t@, then @t@ must not mention (directly or indirectly) any type
--- parameter that is not in @tps@. In particular, if @t@ contains a
--- variable @TVFree _ _ tps2 _@, then @tps2@ must be a subset of
+-- Invariant 1: If there is a mapping from @TVFree _ _ tps _@ to a
+-- type @t@, then @t@ must not mention (directly or indirectly) any
+-- type parameter that is not in @tps@. In particular, if @t@ contains
+-- a variable @TVFree _ _ tps2 _@, then @tps2@ must be a subset of
-- @tps@. This ensures that applying the substitution will not permit
-- any type parameter to escape from its scope.
+--
+-- Invariant 2: The substitution must be idempotent, in that applying
+-- a substitution to any 'Type' in the map should leave that 'Type'
+-- unchanged. In other words, 'Type' values in the range of a 'Subst'
+-- should not mention any 'TVar' in the domain of the 'Subst'. In
+-- particular, this implies that a substitution must not contain any
+-- recursive variable mappings.
+--
+-- Invariant 3: The substitution must be kind correct: Each 'TVar' in
+-- the substitution must map to a 'Type' of the same kind.
data Subst = S { suFreeMap :: !(IntMap.IntMap (TVar, Type))
, suBoundMap :: !(IntMap.IntMap (TVar, Type))
@@ -67,18 +80,42 @@
, suDefaulting = False
}
-singleSubst :: TVar -> Type -> Subst
-singleSubst v@(TVFree i _ _tps _) t =
+-- | Reasons to reject a single-variable substitution.
+data SubstError
+ = SubstRecursive
+ -- ^ 'TVar' maps to a type containing the same variable.
+ | SubstEscaped [TParam]
+ -- ^ 'TVar' maps to a type containing one or more out-of-scope bound variables.
+ | SubstKindMismatch Kind Kind
+ -- ^ 'TVar' maps to a type with a different kind.
+
+singleSubst :: TVar -> Type -> Either SubstError Subst
+singleSubst x t
+ | kindOf x /= kindOf t = Left (SubstKindMismatch (kindOf x) (kindOf t))
+ | x `Set.member` fvs t = Left SubstRecursive
+ | not (Set.null escaped) = Left (SubstEscaped (Set.toList escaped))
+ | otherwise = Right (uncheckedSingleSubst x t)
+ where
+ escaped =
+ case x of
+ TVBound _ -> Set.empty
+ TVFree _ _ scope _ -> freeParams t `Set.difference` scope
+
+uncheckedSingleSubst :: TVar -> Type -> Subst
+uncheckedSingleSubst v@(TVFree i _ _tps _) t =
S { suFreeMap = IntMap.singleton i (v, t)
, suBoundMap = IntMap.empty
, suDefaulting = False
}
-singleSubst v@(TVBound tp) t =
+uncheckedSingleSubst v@(TVBound tp) t =
S { suFreeMap = IntMap.empty
, suBoundMap = IntMap.singleton (tpUnique tp) (v, t)
, suDefaulting = False
}
+singleTParamSubst :: TParam -> Type -> Subst
+singleTParamSubst tp t = uncheckedSingleSubst (TVBound tp) t
+
(@@) :: Subst -> Subst -> Subst
s2 @@ s1
| isEmptySubst s2 =
@@ -169,14 +206,12 @@
do ss <- anyJust (apSubstMaybe su) ts
case t of
TF _ -> Just $! Simp.tCon t ss
- PC _ -> Just $! Simp.simplify Map.empty (TCon t ss)
+ 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)
- TRec fs -> TRec `fmap` anyJust fld fs
- where fld (x,t) = do t1 <- apSubstMaybe su t
- return (x,t1)
+ TRec fs -> TRec `fmap` (anyJust (apSubstMaybe su) fs)
TVar x -> applySubstToVar su x
lookupSubst :: TVar -> Subst -> Maybe Type
@@ -299,7 +334,7 @@
EVar {} -> expr
ETuple es -> ETuple (map go es)
- ERec fs -> ERec [ (f, go e) | (f,e) <- fs ]
+ 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
@@ -327,4 +362,3 @@
instance TVars Module where
apSubst su m = m { mDecls = apSubst su (mDecls m) }
-
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
@@ -6,8 +6,8 @@
import Control.DeepSeq
import Cryptol.Parser.Selector
-import Cryptol.Parser.Fixity
import qualified Cryptol.ModuleSystem.Name as M
+import Cryptol.Utils.Fixity
import Cryptol.Utils.Ident
import Cryptol.Utils.PP
@@ -42,16 +42,26 @@
case M.nameInfo nm of
M.Declared m _
| m == preludeName -> Map.lookup (M.nameIdent nm) builtInTypes
+ | m == floatName -> Map.lookup (M.nameIdent nm) builtInFloat
+ | m == arrayName -> Map.lookup (M.nameIdent nm) builtInArray
_ -> Nothing
where
x ~> y = (packIdent x, y)
+ -- Built-in types from Float.cry
+ builtInFloat = Map.fromList
+ [ "Float" ~> TC TCFloat
+ , "ValidFloat" ~> PC PValidFloat
+ ]
+
+ -- Built-in types from Cryptol.cry
builtInTypes = Map.fromList
[ -- Types
"inf" ~> TC TCInf
, "Bit" ~> TC TCBit
, "Integer" ~> TC TCInteger
+ , "Rational" ~> TC TCRational
, "Z" ~> TC TCIntMod
-- Predicate contstructors
@@ -61,10 +71,15 @@
, "fin" ~> PC PFin
, "Zero" ~> PC PZero
, "Logic" ~> PC PLogic
- , "Arith" ~> PC PArith
+ , "Ring" ~> PC PRing
+ , "Integral" ~> PC PIntegral
+ , "Field" ~> PC PField
+ , "Round" ~> PC PRound
+ , "Eq" ~> PC PEq
, "Cmp" ~> PC PCmp
, "SignedCmp" ~> PC PSignedCmp
, "Literal" ~> PC PLiteral
+ , "FLiteral" ~> PC PFLiteral
-- Type functions
, "+" ~> TF TCAdd
@@ -81,9 +96,14 @@
, "lengthFromThenTo" ~> TF TCLenFromThenTo
]
+ -- Built-in types from Array.cry
+ builtInArray = Map.fromList
+ [ "Array" ~> TC TCArray
+ ]
+
--------------------------------------------------------------------------------
infixr 5 :->
@@ -114,7 +134,10 @@
TCInf -> KNum
TCBit -> KType
TCInteger -> KType
+ TCRational -> KType
+ TCFloat -> KNum :-> KNum :-> KType
TCIntMod -> KNum :-> KType
+ TCArray -> KType :-> KType :-> KType
TCSeq -> KNum :-> KType :-> KType
TCFun -> KType :-> KType :-> KType
TCTuple n -> foldr (:->) KType (replicate n KType)
@@ -131,10 +154,16 @@
PHas _ -> KType :-> KType :-> KProp
PZero -> KType :-> KProp
PLogic -> KType :-> KProp
- PArith -> KType :-> KProp
+ PRing -> KType :-> KProp
+ PIntegral -> KType :-> KProp
+ PField -> KType :-> KProp
+ PRound -> KType :-> KProp
+ PEq -> KType :-> KProp
PCmp -> KType :-> KProp
PSignedCmp -> KType :-> KProp
PLiteral -> KNum :-> KType :-> KProp
+ PFLiteral -> KNum :-> KNum :-> KNum :-> KType :-> KProp
+ PValidFloat -> KNum :-> KNum :-> KProp
PAnd -> KProp :-> KProp :-> KProp
PTrue -> KProp
@@ -174,11 +203,19 @@
| PHas Selector -- ^ @Has sel type field@ does not appear in schemas
| PZero -- ^ @Zero _@
| PLogic -- ^ @Logic _@
- | PArith -- ^ @Arith _@
+ | PRing -- ^ @Ring _@
+ | PIntegral -- ^ @Integral _@
+ | PField -- ^ @Field _@
+ | PRound -- ^ @Round _@
+ | PEq -- ^ @Eq _@
| PCmp -- ^ @Cmp _@
| PSignedCmp -- ^ @SignedCmp _@
| PLiteral -- ^ @Literal _ _@
+ | PFLiteral -- ^ @FLiteral _ _ _@
+ | PValidFloat -- ^ @ValidFloat _ _@ constraints on supported
+ -- floating point representaitons
+
| PAnd -- ^ This is useful when simplifying things in place
| PTrue -- ^ Ditto
deriving (Show, Eq, Ord, Generic, NFData)
@@ -189,7 +226,10 @@
| TCInf -- ^ Inf
| TCBit -- ^ Bit
| TCInteger -- ^ Integer
+ | TCFloat -- ^ Float
| TCIntMod -- ^ @Z _@
+ | TCRational -- ^ @Rational@
+ | TCArray -- ^ @Array _ _@
| TCSeq -- ^ @[_] _@
| TCFun -- ^ @_ -> _@
| TCTuple Int -- ^ @(_, _, _)@
@@ -271,10 +311,16 @@
PHas sel -> parens (ppSelector sel)
PZero -> text "Zero"
PLogic -> text "Logic"
- PArith -> text "Arith"
+ PRing -> text "Ring"
+ PIntegral -> text "Integral"
+ PField -> text "Field"
+ PRound -> text "Round"
+ PEq -> text "Eq"
PCmp -> text "Cmp"
PSignedCmp -> text "SignedCmp"
PLiteral -> text "Literal"
+ PFLiteral -> text "FLiteral"
+ PValidFloat -> text "ValidFloat"
PTrue -> text "True"
PAnd -> text "(&&)"
@@ -286,6 +332,9 @@
TCBit -> text "Bit"
TCInteger -> text "Integer"
TCIntMod -> text "Z"
+ TCRational -> text "Rational"
+ TCArray -> text "Array"
+ TCFloat -> text "Float"
TCSeq -> text "[]"
TCFun -> text "(->)"
TCTuple 0 -> text "()"
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
@@ -12,20 +12,20 @@
import Control.DeepSeq
import qualified Data.IntMap as IntMap
+import Data.Maybe (fromMaybe)
import Data.Set (Set)
import qualified Data.Set as Set
-import Data.List(sortBy)
-import Data.Ord(comparing)
import Cryptol.Parser.Selector
-import Cryptol.Parser.Fixity
import Cryptol.Parser.Position(Range,emptyRange)
import Cryptol.ModuleSystem.Name
-import Cryptol.Utils.Ident (Ident)
+import Cryptol.Utils.Ident (Ident, isInfixIdent, exprModName)
import Cryptol.TypeCheck.TCon
import Cryptol.TypeCheck.PP
import Cryptol.TypeCheck.Solver.InfNat
+import Cryptol.Utils.Fixity
import Cryptol.Utils.Panic(panic)
+import Cryptol.Utils.RecordMap
import Prelude
infix 4 =#=, >==
@@ -99,10 +99,10 @@
{- ^ This is just a type annotation, for a type that
was written as a type synonym. It is useful so that we
can use it to report nicer errors.
- Example: `TUser T ts t` is really just the type `t` that
- was written as `T ts` by the user. -}
+ Example: @TUser T ts t@ is really just the type @t@ that
+ was written as @T ts@ by the user. -}
- | TRec ![(Ident,Type)]
+ | TRec !(RecordMap Ident Type)
-- ^ Record type
deriving (Show, Generic, NFData)
@@ -157,7 +157,7 @@
DefinitionOf x -> Just x
_ -> Nothing
--- | The type is supposed to be of kind `KProp`
+-- | The type is supposed to be of kind 'KProp'.
type Prop = Type
@@ -234,16 +234,14 @@
--------------------------------------------------------------------------------
--- Syntactic equality, ignoring type synonyms and record order
+-- | Syntactic equality, ignoring type synonyms and record order.
instance Eq Type where
TUser _ _ x == y = x == y
x == TUser _ _ y = y == x
TCon x xs == TCon y ys = x == y && xs == ys
TVar x == TVar y = x == y
-
- TRec xs == TRec ys = norm xs == norm ys
- where norm = sortBy (comparing fst)
+ TRec xs == TRec ys = xs == ys
_ == _ = False
@@ -261,9 +259,7 @@
(TCon {}, _) -> LT
(_,TCon {}) -> GT
- (TRec xs, TRec ys) -> compare (norm xs) (norm ys)
- where norm = sortBy (comparing fst)
-
+ (TRec xs, TRec ys) -> compare xs ys
instance Eq TParam where
@@ -279,11 +275,32 @@
type SType = Type
+--------------------------------------------------------------------
+-- Superclass
+-- | Compute the set of all @Prop@s that are implied by the
+-- given prop via superclass constraints.
+superclassSet :: Prop -> Set Prop
+superclassSet (TCon (PC p0) [t]) = go p0
+ where
+ super p = Set.insert (TCon (PC p) [t]) (go p)
+
+ go PRing = super PZero
+ go PLogic = super PZero
+ go PField = super PRing
+ go PIntegral = super PRing
+ go PRound = super PField <> super PCmp
+ go PCmp = super PEq
+ go PSignedCmp = super PEq
+ go _ = mempty
+
+superclassSet _ = mempty
+
+
newtypeConType :: Newtype -> Schema
newtypeConType nt =
Forall as (ntConstraints nt)
- $ TRec (ntFields nt) `tFun` TCon (newtypeTyCon nt) (map (TVar . tpVar) as)
+ $ TRec (recordFromFields (ntFields nt)) `tFun` TCon (newtypeTyCon nt) (map (TVar . tpVar) as)
where
as = ntParams nt
@@ -291,7 +308,15 @@
abstractTypeTC :: AbstractType -> TCon
abstractTypeTC at =
case builtInType (atName at) of
- Just tcon -> tcon
+ Just tcon
+ | kindOf tcon == atKind at -> tcon
+ | otherwise ->
+ panic "abstractTypeTC"
+ [ "Mismatch between built-in and declared type."
+ , "Name: " ++ pretty (atName at)
+ , "Declared: " ++ pretty (atKind at)
+ , "Built-in: " ++ pretty (kindOf tcon)
+ ]
_ -> TC $ TCAbstract $ UserTC (atName at) (atKind at)
instance Eq TVar where
@@ -318,10 +343,11 @@
isBoundTV _ = False
-tIsError :: Type -> Maybe TCErrorMessage
+tIsError :: Type -> Maybe (TCErrorMessage,Type)
tIsError ty = case tNoUser ty of
- TCon (TError _ x) _ -> Just x
- _ -> Nothing
+ TCon (TError _ x) [t] -> Just (x,t)
+ TCon (TError _ _) _ -> panic "tIsError" ["Malformed error"]
+ _ -> Nothing
tIsNat' :: Type -> Maybe Nat'
tIsNat' ty =
@@ -372,7 +398,7 @@
TCon (TC (TCTuple _)) ts -> Just ts
_ -> Nothing
-tIsRec :: Type -> Maybe [(Ident, Type)]
+tIsRec :: Type -> Maybe (RecordMap Ident Type)
tIsRec ty = case tNoUser ty of
TRec fs -> Just fs
_ -> Nothing
@@ -400,10 +426,10 @@
TCon (PC PGeq) [t1,t2] -> Just (t1,t2)
_ -> Nothing
-pIsEq :: Prop -> Maybe (Type,Type)
-pIsEq ty = case tNoUser ty of
- TCon (PC PEqual) [t1,t2] -> Just (t1,t2)
- _ -> Nothing
+pIsEqual :: Prop -> Maybe (Type,Type)
+pIsEqual ty = case tNoUser ty of
+ TCon (PC PEqual) [t1,t2] -> Just (t1,t2)
+ _ -> Nothing
pIsZero :: Prop -> Maybe Type
pIsZero ty = case tNoUser ty of
@@ -415,11 +441,31 @@
TCon (PC PLogic) [t1] -> Just t1
_ -> Nothing
-pIsArith :: Prop -> Maybe Type
-pIsArith ty = case tNoUser ty of
- TCon (PC PArith) [t1] -> Just t1
+pIsRing :: Prop -> Maybe Type
+pIsRing ty = case tNoUser ty of
+ TCon (PC PRing) [t1] -> Just t1
+ _ -> Nothing
+
+pIsField :: Prop -> Maybe Type
+pIsField ty = case tNoUser ty of
+ TCon (PC PField) [t1] -> Just t1
_ -> Nothing
+pIsIntegral :: Prop -> Maybe Type
+pIsIntegral ty = case tNoUser ty of
+ TCon (PC PIntegral) [t1] -> Just t1
+ _ -> Nothing
+
+pIsRound :: Prop -> Maybe Type
+pIsRound ty = case tNoUser ty of
+ TCon (PC PRound) [t1] -> Just t1
+ _ -> Nothing
+
+pIsEq :: Prop -> Maybe Type
+pIsEq ty = case tNoUser ty of
+ TCon (PC PEq) [t1] -> Just t1
+ _ -> Nothing
+
pIsCmp :: Prop -> Maybe Type
pIsCmp ty = case tNoUser ty of
TCon (PC PCmp) [t1] -> Just t1
@@ -435,6 +481,11 @@
TCon (PC PLiteral) [t1, t2] -> Just (t1, t2)
_ -> Nothing
+pIsFLiteral :: Prop -> Maybe (Type,Type,Type,Type)
+pIsFLiteral ty = case tNoUser ty of
+ TCon (PC PFLiteral) [t1,t2,t3,t4] -> Just (t1,t2,t3,t4)
+ _ -> Nothing
+
pIsTrue :: Prop -> Bool
pIsTrue ty = case tNoUser ty of
TCon (PC PTrue) _ -> True
@@ -445,6 +496,11 @@
TCon (TF TCWidth) [t1] -> Just t1
_ -> Nothing
+pIsValidFloat :: Prop -> Maybe (Type,Type)
+pIsValidFloat ty = case tNoUser ty of
+ TCon (PC PValidFloat) [a,b] -> Just (a,b)
+ _ -> Nothing
+
--------------------------------------------------------------------------------
@@ -477,9 +533,18 @@
tInteger :: Type
tInteger = TCon (TC TCInteger) []
+tRational :: Type
+tRational = TCon (TC TCRational) []
+
+tFloat :: Type -> Type -> Type
+tFloat e p = TCon (TC TCFloat) [ e, p ]
+
tIntMod :: Type -> Type
tIntMod n = TCon (TC TCIntMod) [n]
+tArray :: Type -> Type -> Type
+tArray a b = TCon (TC TCArray) [a, b]
+
tWord :: Type -> Type
tWord a = tSeq a tBit
@@ -492,7 +557,7 @@
tString :: Int -> Type
tString len = tSeq (tNum len) tChar
-tRec :: [(Ident,Type)] -> Type
+tRec :: RecordMap Ident Type -> Type
tRec = TRec
tTuple :: [Type] -> Type
@@ -516,13 +581,12 @@
--------------------------------------------------------------------------------
-- Construction of type functions
--- | Make a malformed numeric type.
-tBadNumber :: TCErrorMessage -> Type
-tBadNumber = tError KNum
-
--- | Make an error value of the given type.
-tError :: Kind -> TCErrorMessage -> Type
-tError k msg = TCon (TError k msg) []
+-- | 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]
+ where k = kindOf t
+ msg = TCErrorMessage s
tf1 :: TFun -> Type -> Type
tf1 f x = TCon (TF f) [x]
@@ -581,9 +645,21 @@
pLogic :: Type -> Prop
pLogic t = TCon (PC PLogic) [t]
-pArith :: Type -> Prop
-pArith t = TCon (PC PArith) [t]
+pRing :: Type -> Prop
+pRing t = TCon (PC PRing) [t]
+pIntegral :: Type -> Prop
+pIntegral t = TCon (PC PIntegral) [t]
+
+pField :: Type -> Prop
+pField t = TCon (PC PField) [t]
+
+pRound :: Type -> Prop
+pRound t = TCon (PC PRound) [t]
+
+pEq :: Type -> Prop
+pEq t = TCon (PC PEq) [t]
+
pCmp :: Type -> Prop
pCmp t = TCon (PC PCmp) [t]
@@ -597,7 +673,7 @@
(>==) :: Type -> Type -> Prop
x >== y = TCon (PC PGeq) [x,y]
--- | A `Has` constraint, used for tuple and record selection.
+-- | A @Has@ constraint, used for tuple and record selection.
pHas :: Selector -> Type -> Type -> Prop
pHas l ty fi = TCon (PC (PHas l)) [ty,fi]
@@ -629,18 +705,25 @@
pFin ty =
case tNoUser ty of
TCon (TC (TCNum _)) _ -> pTrue
- TCon (TC TCInf) _ -> pError (TCErrorMessage "`inf` is not finite.")
+ TCon (TC TCInf) _ -> tError (TCon (PC PFin) [ty]) "`inf` is not finite"
+ -- XXX: should we be doing this here??
_ -> TCon (PC PFin) [ty]
--- | Make a malformed property.
-pError :: TCErrorMessage -> Prop
-pError msg = TCon (TError KProp msg) []
+pValidFloat :: Type -> Type -> Type
+pValidFloat e p = TCon (PC PValidFloat) [e,p]
+
--------------------------------------------------------------------------------
noFreeVariables :: FVS t => t -> Bool
noFreeVariables = all (not . isFreeTV) . Set.toList . fvs
+freeParams :: FVS t => t -> Set TParam
+freeParams x = Set.unions (map params (Set.toList (fvs x)))
+ where
+ params (TVFree _ _ tps _) = tps
+ params (TVBound tp) = Set.singleton tp
+
class FVS t where
fvs :: t -> Set TVar
@@ -652,7 +735,7 @@
TCon _ ts -> fvs ts
TVar x -> Set.singleton x
TUser _ _ t -> go t
- TRec fs -> fvs (map snd fs)
+ TRec fs -> fvs (recordElements fs)
instance FVS a => FVS (Maybe a) where
fvs Nothing = Set.empty
@@ -751,13 +834,22 @@
-
+-- | The precedence levels used by this pretty-printing instance
+-- correspond with parser non-terminals as follows:
+--
+-- * 0-1: @type@
+--
+-- * 2: @infix_type@
+--
+-- * 3: @app_type@
+--
+-- * 4: @atype@
instance PP (WithNames Type) where
ppPrec prec ty0@(WithNames ty nmMap) =
case ty of
TVar a -> ppWithNames nmMap a
TRec fs -> braces $ fsep $ punctuate comma
- [ pp l <+> text ":" <+> go 0 t | (l,t) <- fs ]
+ [ pp l <+> text ":" <+> go 0 t | (l,t) <- displayFields fs ]
_ | Just tinf <- isTInfix ty0 -> optParens (prec > 2)
$ ppInfix 2 isTInfix tinf
@@ -771,6 +863,8 @@
(TCInf, []) -> text "inf"
(TCBit, []) -> text "Bit"
(TCInteger, []) -> text "Integer"
+ (TCRational, []) -> text "Rational"
+
(TCIntMod, [n]) -> optParens (prec > 3) $ text "Z" <+> go 4 n
(TCSeq, [t1,TCon (TC TCBit) []]) -> brackets (go 0 t1)
@@ -782,23 +876,28 @@
(TCTuple _, fs) -> parens $ fsep $ punctuate comma $ map (go 0) fs
- (_, _) -> pp tc <+> fsep (map (go 4) ts)
+ (_, _) -> optParens (prec > 3) $ pp tc <+> fsep (map (go 4) ts)
TCon (PC pc) ts ->
case (pc,ts) of
(PEqual, [t1,t2]) -> go 0 t1 <+> text "==" <+> go 0 t2
(PNeq , [t1,t2]) -> go 0 t1 <+> text "!=" <+> go 0 t2
(PGeq, [t1,t2]) -> go 0 t1 <+> text ">=" <+> go 0 t2
- (PFin, [t1]) -> text "fin" <+> (go 4 t1)
+ (PFin, [t1]) -> optParens (prec > 3) $ text "fin" <+> (go 4 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)))
- (PArith, [t1]) -> pp pc <+> go 4 t1
+ (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
+
(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
- (_, _) -> pp pc <+> fsep (map (go 4) ts)
+ (_, _) -> optParens (prec > 3) $ pp pc <+> fsep (map (go 4) ts)
TCon f ts -> optParens (prec > 3)
$ pp f <+> fsep (map (go 4) ts)
@@ -809,18 +908,15 @@
isTInfix (WithNames (TCon tc [ieLeft',ieRight']) _) =
do let ieLeft = WithNames ieLeft' nmMap
ieRight = WithNames ieRight' nmMap
- (ieOp,fi) <- infixPrimTy tc
- let ieAssoc = fAssoc fi
- iePrec = fLevel fi
+ (ieOp, ieFixity) <- infixPrimTy tc
return Infix { .. }
- isTInfix (WithNames (TUser n [ieLeft',ieRight'] _) _) =
- do let ieLeft = WithNames ieLeft' nmMap
- ieRight = WithNames ieRight' nmMap
- fi <- nameFixity n
- let ieAssoc = fAssoc fi
- iePrec = fLevel fi
- ieOp = nameIdent n
+ isTInfix (WithNames (TUser n [ieLeft',ieRight'] _) _)
+ | isInfixIdent (nameIdent n) =
+ do let ieLeft = WithNames ieLeft' nmMap
+ ieRight = WithNames ieRight' nmMap
+ ieFixity = fromMaybe defaultFixity (nameFixity n)
+ ieOp = nameIdent n
return Infix { .. }
isTInfix _ = Nothing
@@ -856,7 +952,10 @@
LenOfSeq -> mk "n"
TypeParamInstNamed _ i -> using i
TypeParamInstPos f n -> mk (sh f ++ "_" ++ show n)
- DefinitionOf x -> using x
+ DefinitionOf x ->
+ case nameInfo x of
+ Declared m SystemName | m == exprModName -> mk "it"
+ _ -> using x
LenOfCompGen -> mk "n"
TypeOfArg mb -> mk (case mb of
Nothing -> "arg"
@@ -902,5 +1001,3 @@
Just n -> "type of" <+> ordinal n <+> "function argument"
TypeOfRes -> "type of function result"
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
@@ -21,14 +21,13 @@
import Cryptol.TypeCheck.AST
import Cryptol.Utils.Ident
+import Cryptol.Utils.RecordMap
import qualified Data.Map as Map
import Data.Map (Map)
import Data.Maybe(fromMaybe,maybeToList)
import Control.Monad((<=<))
-import Data.List(sortBy)
import Data.Maybe (isNothing)
-import Data.Ord(comparing)
class TrieMap m k | m -> k where
emptyTM :: m a
@@ -131,7 +130,7 @@
TUser _ _ t -> lookupTM t
TVar x -> lookupTM x . tvar
TCon c ts -> lookupTM ts <=< lookupTM c . tcon
- TRec fs -> let (xs,ts) = unzip $ sortBy (comparing fst) fs
+ TRec fs -> let (xs,ts) = unzip $ canonicalFields fs
in lookupTM ts <=< lookupTM xs . trec
alterTM ty f m =
@@ -139,16 +138,20 @@
TUser _ _ t -> alterTM t f m
TVar x -> m { tvar = alterTM x f (tvar m) }
TCon c ts -> m { tcon = alterTM c (updSub ts f) (tcon m) }
- TRec fs -> let (xs,ts) = unzip $ sortBy (comparing fst) fs
+ TRec fs -> let (xs,ts) = unzip $ canonicalFields fs
in m { trec = alterTM xs (updSub ts f) (trec m) }
toListTM m =
[ (TVar x, v) | (x,v) <- toListTM (tvar m) ] ++
[ (TCon c ts, v) | (c,m1) <- toListTM (tcon m)
, (ts,v) <- toListTM m1 ] ++
- [ (TRec (zip fs ts), v) | (fs,m1) <- toListTM (trec m)
- , (ts,v) <- toListTM m1 ]
+ -- NB: this step loses 'displayOrder' information.
+ -- It's not clear if we should try to fix this.
+ [ (TRec (recordFromFields (zip fs ts)), v)
+ | (fs,m1) <- toListTM (trec m)
+ , (ts,v) <- toListTM m1 ]
+
unionTM f m1 m2 = TM { tvar = unionTM f (tvar m1) (tvar m2)
, tcon = unionTM (unionTM f) (tcon m1) (tcon m2)
, trec = unionTM (unionTM f) (trec m1) (trec m2)
@@ -159,7 +162,9 @@
, tcon = mapWithKeyTM (\c l -> mapMaybeWithKeyTM
(\ts a -> f (TCon c ts) a) l) (tcon m)
, trec = mapWithKeyTM (\fs l -> mapMaybeWithKeyTM
- (\ts a -> f (TRec (zip fs ts)) a) l) (trec m)
+ (\ts a -> f (TRec (recordFromFields (zip fs ts))) a) l) (trec m)
+ -- NB: this step loses 'displayOrder' information.
+ -- It's not clear if we should try to fix this.
}
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
@@ -18,6 +18,7 @@
import Cryptol.TypeCheck.Subst
import Cryptol.Utils.Panic
import Cryptol.Utils.PP
+import Cryptol.Utils.RecordMap
import Data.Map (Map)
import qualified Data.Map as Map
@@ -31,7 +32,7 @@
-- Monomorphic fragment
EList es t -> tSeq (tNum (length es)) t
ETuple es -> tTuple (map (fastTypeOf tyenv) es)
- ERec fields -> tRec [ (name, fastTypeOf tyenv e) | (name, e) <- fields ]
+ ERec fields -> tRec (fmap (fastTypeOf tyenv) fields)
ESel e sel -> typeSelect (fastTypeOf tyenv e) sel
ESet e _ _ -> fastTypeOf tyenv e
EIf _ e _ -> fastTypeOf tyenv e
@@ -68,7 +69,7 @@
ETApp e t -> case fastSchemaOf tyenv e of
Forall (tparam : tparams) props ty
-> Forall tparams (map (plainSubst s) props) (plainSubst s ty)
- where s = singleSubst (tpVar tparam) t
+ where s = singleTParamSubst tparam t
_ -> panic "Cryptol.TypeCheck.TypeOf.fastSchemaOf"
[ "ETApp body with no type parameters" ]
-- When calling 'fastSchemaOf' on a
@@ -114,7 +115,7 @@
case ty of
TCon tc ts -> TCon tc (map (plainSubst s) ts)
TUser f ts t -> TUser f (map (plainSubst s) ts) (plainSubst s t)
- TRec fs -> TRec [ (x, plainSubst s t) | (x, t) <- fs ]
+ TRec fs -> TRec (fmap (plainSubst s) fs)
TVar x -> apSubst s (TVar x)
-- | Yields the return type of the selector on the given argument type.
@@ -123,7 +124,7 @@
typeSelect (tIsTuple -> Just ts) (TupleSel i _)
| i < length ts = ts !! i
typeSelect (TRec fields) (RecordSel n _)
- | Just ty <- lookup n fields = ty
+ | Just ty <- lookupField n fields = ty
typeSelect (tIsSeq -> Just (_, a)) ListSel{} = a
typeSelect (tIsSeq -> Just (n, a)) sel@TupleSel{} = tSeq n (typeSelect a sel)
typeSelect (tIsSeq -> Just (n, a)) sel@RecordSel{} = tSeq n (typeSelect a sel)
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
@@ -20,8 +20,6 @@
, (|->|)
, aFin, (|=|), (|/=|), (|>=|)
- , aCmp, aArith
-
, aAnd
, aTrue
@@ -34,6 +32,7 @@
import Control.Monad
import Cryptol.Utils.Ident (Ident)
import Cryptol.Utils.Patterns
+import Cryptol.Utils.RecordMap
import Cryptol.TypeCheck.Type
import Cryptol.TypeCheck.Solver.InfNat
@@ -149,7 +148,7 @@
TCon (TC (TCTuple _)) ts -> return ts
_ -> mzero
-aRec :: Pat Type [(Ident, Type)]
+aRec :: Pat Type (RecordMap Ident Type)
aRec = \a -> case tNoUser a of
TRec fs -> return fs
_ -> mzero
@@ -169,12 +168,6 @@
(|>=|) :: Pat Prop (Type,Type)
(|>=|) = tp PGeq ar2
-
-aCmp :: Pat Prop Type
-aCmp = tp PCmp ar1
-
-aArith :: Pat Prop Type
-aArith = tp PArith ar1
aAnd :: Pat Prop (Prop,Prop)
aAnd = tp PAnd ar2
diff --git a/src/Cryptol/TypeCheck/Unify.hs b/src/Cryptol/TypeCheck/Unify.hs
--- a/src/Cryptol/TypeCheck/Unify.hs
+++ b/src/Cryptol/TypeCheck/Unify.hs
@@ -13,10 +13,9 @@
import Cryptol.TypeCheck.AST
import Cryptol.TypeCheck.Subst
+import Cryptol.Utils.RecordMap
import Control.Monad.Writer (Writer, writer, runWriter)
-import Data.Ord(comparing)
-import Data.List(sortBy)
import qualified Data.Set as Set
import Prelude ()
@@ -73,11 +72,7 @@
isNum = k1 == KNum
mgu (TRec fs1) (TRec fs2)
- | ns1 == ns2 = mguMany ts1 ts2
- where
- (ns1,ts1) = sortFields fs1
- (ns2,ts2) = sortFields fs2
- sortFields = unzip . sortBy (comparing fst)
+ | fieldSet fs1 == fieldSet fs2 = mguMany (recordElements fs1) (recordElements fs2)
mgu t1 t2
| not (k1 == k2) = uniError $ UniKindMismatch k1 k2
@@ -110,22 +105,21 @@
| otherwise = uniError $ UniKindMismatch k (kindOf t)
where k = kindOf v
-bindVar x@(TVFree _ _ xscope _) (TVar y@(TVFree _ _ yscope _))
- | xscope `Set.isProperSubsetOf` yscope = return (singleSubst y (TVar x), [])
-
-bindVar x@(TVFree _ k inScope _d) t
- | not (k == kindOf t) = uniError $ UniKindMismatch k (kindOf t)
- | recTy && k == KType = uniError $ UniRecursive x t
- | not (Set.null escaped) = uniError $ UniNonPolyDepends x $ Set.toList escaped
- | recTy = return (emptySubst, [TVar x =#= t])
- | otherwise = return (singleSubst x t, [])
- where
- escaped = freeParams t `Set.difference` inScope
- recTy = x `Set.member` fvs t
-
+bindVar x@(TVFree _ xk xscope _) (tNoUser -> TVar y@(TVFree _ yk yscope _))
+ | xscope `Set.isProperSubsetOf` yscope, xk == yk =
+ return (uncheckedSingleSubst y (TVar x), [])
+ -- In this case, we can add the reverse binding y ~> x to the
+ -- substitution, but the instantiation x ~> y would be forbidden
+ -- because it would allow y to escape from its scope.
-freeParams :: FVS t => t -> Set.Set TParam
-freeParams x = Set.unions (map params (Set.toList (fvs x)))
- where
- params (TVFree _ _ tps _) = tps
- params (TVBound tp) = Set.singleton tp
+bindVar x t =
+ case singleSubst x t of
+ Left SubstRecursive
+ | kindOf x == KType -> uniError $ UniRecursive x t
+ | otherwise -> return (emptySubst, [TVar x =#= t])
+ Left (SubstEscaped tps) ->
+ uniError $ UniNonPolyDepends x tps
+ Left (SubstKindMismatch k1 k2) ->
+ uniError $ UniKindMismatch k1 k2
+ Right su ->
+ return (su, [])
diff --git a/src/Cryptol/Utils/Fixity.hs b/src/Cryptol/Utils/Fixity.hs
new file mode 100644
--- /dev/null
+++ b/src/Cryptol/Utils/Fixity.hs
@@ -0,0 +1,55 @@
+-- |
+-- Module : Cryptol.Utils.Fixity
+-- Copyright : (c) 2013-2016 Galois, Inc.
+-- License : BSD3
+-- Maintainer : cryptol@galois.com
+-- Stability : provisional
+-- Portability : portable
+
+{-# LANGUAGE Safe #-}
+
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+module Cryptol.Utils.Fixity
+ ( Assoc(..)
+ , Fixity(..)
+ , defaultFixity
+ , FixityCmp(..)
+ , compareFixity
+ ) where
+
+import GHC.Generics (Generic)
+import Control.DeepSeq
+
+-- | Information about associativity.
+data Assoc = LeftAssoc | RightAssoc | NonAssoc
+ deriving (Show, Eq, Generic, NFData)
+
+data Fixity = Fixity { fAssoc :: !Assoc, fLevel :: !Int }
+ deriving (Eq, Generic, NFData, Show)
+
+data FixityCmp = FCError
+ | FCLeft
+ | FCRight
+ deriving (Show, Eq)
+
+-- | Let @op1@ have fixity @f1@ and @op2@ have fixity @f2. Then
+-- @compareFixity f1 f2@ determines how to parse the infix expression
+-- @x op1 y op2 z@.
+--
+-- * @FCLeft@: @(x op1 y) op2 z@
+-- * @FCRight@: @x op1 (y op2 z)@
+-- * @FCError@: no parse
+compareFixity :: Fixity -> Fixity -> FixityCmp
+compareFixity (Fixity a1 p1) (Fixity a2 p2) =
+ case compare p1 p2 of
+ GT -> FCLeft
+ LT -> FCRight
+ EQ -> case (a1, a2) of
+ (LeftAssoc, LeftAssoc) -> FCLeft
+ (RightAssoc, RightAssoc) -> FCRight
+ _ -> FCError
+
+-- | The fixity used when none is provided.
+defaultFixity :: Fixity
+defaultFixity = Fixity LeftAssoc 100
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,6 +16,8 @@
, modNameChunks
, packModName
, preludeName
+ , floatName
+ , arrayName
, interactiveName
, noModuleName
, exprModName
@@ -36,6 +38,12 @@
, identText
, modParamIdent
+ -- * Identifiers for primitived
+ , PrimIdent(..)
+ , prelPrim
+ , floatPrim
+ , arrayPrim
+
) where
import Control.DeepSeq (NFData)
@@ -100,6 +108,12 @@
preludeName :: ModName
preludeName = packModName ["Cryptol"]
+floatName :: ModName
+floatName = packModName ["Float"]
+
+arrayName :: ModName
+arrayName = packModName ["Array"]
+
interactiveName :: ModName
interactiveName = packModName [""]
@@ -158,4 +172,24 @@
modParamIdent (Ident x t) = Ident x (T.append (T.pack "module parameter ") t)
+--------------------------------------------------------------------------------
+{- | A way to identify primitives: we used to use just 'Ident', but this
+isn't good anymore as now we have primitives in multiple modules.
+This is used as a key when we need to lookup details about a specific
+primitive. Also, this is intended to mostly be used internally, so
+we don't store the fixity flag of the `Ident` -}
+data PrimIdent = PrimIdent ModName T.Text
+ deriving (Eq,Ord,Show,Generic)
+
+-- | A shortcut to make (non-infix) primitives in the prelude.
+prelPrim :: T.Text -> PrimIdent
+prelPrim = PrimIdent preludeName
+
+floatPrim :: T.Text -> PrimIdent
+floatPrim = PrimIdent floatName
+
+arrayPrim :: T.Text -> PrimIdent
+arrayPrim = PrimIdent arrayName
+
+instance NFData PrimIdent
diff --git a/src/Cryptol/Utils/PP.hs b/src/Cryptol/Utils/PP.hs
--- a/src/Cryptol/Utils/PP.hs
+++ b/src/Cryptol/Utils/PP.hs
@@ -13,6 +13,7 @@
{-# LANGUAGE OverloadedStrings #-}
module Cryptol.Utils.PP where
+import Cryptol.Utils.Fixity
import Cryptol.Utils.Ident
import Control.DeepSeq
import Control.Monad (mplus)
@@ -122,7 +123,7 @@
class PP a => PPName a where
-- | Fixity information for infix operators
- ppNameFixity :: a -> Maybe (Assoc, Int)
+ ppNameFixity :: a -> Maybe Fixity
-- | Print a name in prefix: @f a b@ or @(+) a b)@
ppPrefixName :: a -> Doc
@@ -141,17 +142,12 @@
| otherwise = body
--- | Information about associativity.
-data Assoc = LeftAssoc | RightAssoc | NonAssoc
- deriving (Show, Eq, Generic, NFData)
-
-- | Information about an infix expression of some sort.
data Infix op thing = Infix
- { ieOp :: op -- ^ operator
- , ieLeft :: thing -- ^ left argument
- , ieRight :: thing -- ^ right argument
- , iePrec :: Int -- ^ operator precedence
- , ieAssoc :: Assoc -- ^ operator associativity
+ { ieOp :: op -- ^ operator
+ , ieLeft :: thing -- ^ left argument
+ , ieRight :: thing -- ^ right argument
+ , ieFixity :: Fixity -- ^ operator fixity
}
commaSep :: [Doc] -> Doc
@@ -166,14 +162,15 @@
-> Infix op thing -- ^ Pretty print this infix expression
-> Doc
ppInfix lp isInfix expr =
- sep [ ppSub (wrapSub LeftAssoc ) (ieLeft expr) <+> pp (ieOp expr)
- , ppSub (wrapSub RightAssoc) (ieRight expr) ]
+ sep [ ppSub wrapL (ieLeft expr) <+> pp (ieOp expr)
+ , ppSub wrapR (ieRight expr) ]
where
- wrapSub dir p = p < iePrec expr || p == iePrec expr && ieAssoc expr /= dir
+ wrapL f = compareFixity f (ieFixity expr) /= FCLeft
+ wrapR f = compareFixity (ieFixity expr) f /= FCRight
- ppSub w e
- | Just e1 <- isInfix e = optParens (w (iePrec e1)) (ppInfix lp isInfix e1)
- ppSub _ e = ppPrec lp e
+ ppSub w e
+ | Just e1 <- isInfix e = optParens (w (ieFixity e1)) (ppInfix lp isInfix e1)
+ ppSub _ e = ppPrec lp e
@@ -300,3 +297,7 @@
ppPrec _ LeftAssoc = text "left-associative"
ppPrec _ RightAssoc = text "right-associative"
ppPrec _ NonAssoc = text "non-associative"
+
+instance PP Fixity where
+ ppPrec _ (Fixity assoc level) =
+ text "precedence" <+> int level <.> comma <+> pp assoc
diff --git a/src/Cryptol/Utils/Patterns.hs b/src/Cryptol/Utils/Patterns.hs
--- a/src/Cryptol/Utils/Patterns.hs
+++ b/src/Cryptol/Utils/Patterns.hs
@@ -5,6 +5,7 @@
module Cryptol.Utils.Patterns where
import Control.Monad(liftM,liftM2,ap,MonadPlus(..),guard)
+import qualified Control.Monad.Fail as Fail
import Control.Applicative(Alternative(..))
newtype Match b = Match (forall r. r -> (b -> r) -> r)
@@ -17,10 +18,12 @@
(<*>) = ap
instance Monad Match where
- fail _ = empty
Match m >>= f = Match $ \no yes -> m no $ \a ->
let Match n = f a in
n no yes
+
+instance Fail.MonadFail Match where
+ fail _ = empty
instance Alternative Match where
empty = Match $ \no _ -> no
diff --git a/src/Cryptol/Utils/RecordMap.hs b/src/Cryptol/Utils/RecordMap.hs
new file mode 100644
--- /dev/null
+++ b/src/Cryptol/Utils/RecordMap.hs
@@ -0,0 +1,202 @@
+-- |
+-- Module : Cryptol.Utils.RecordMap
+-- Copyright : (c) 2020 Galois, Inc.
+-- License : BSD3
+-- Maintainer : cryptol@galois.com
+-- Stability : provisional
+-- Portability : portable
+--
+-- This module implements an "order insensitive" datastructure for
+-- record types and values. For most purposes, we want to deal with
+-- record fields in a canonical order; but for user interaction
+-- purposes, we generally want to display the fields in the order they
+-- were specified by the user (in source files, at the REPL, etc.).
+
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Cryptol.Utils.RecordMap
+ ( RecordMap
+ , displayOrder
+ , canonicalFields
+ , displayFields
+ , recordElements
+ , fieldSet
+ , recordFromFields
+ , recordFromFieldsErr
+ , recordFromFieldsWithDisplay
+ , lookupField
+ , adjustField
+ , traverseRecordMap
+ , mapWithFieldName
+ , zipRecordsM
+ , zipRecords
+ , recordMapAccum
+ ) where
+
+import Control.DeepSeq
+import Control.Monad.Except
+import Data.Functor.Identity
+import Data.Set (Set)
+import Data.Map (Map)
+import qualified Data.Map.Strict as Map
+import qualified Data.Map.Merge.Strict as Map
+
+import Cryptol.Utils.Panic
+
+-- | An "order insensitive" datastructure.
+-- The fields can be accessed either according
+-- to a "canonical" order, or based on a
+-- "display" order, which matches the order
+-- in which the fields were originally specified.
+data RecordMap a b =
+ RecordMap
+ { recordMap :: !(Map a b)
+ , _displayOrder :: [a]
+ }
+-- RecordMap Invariant:
+-- The `displayOrder` field should contain exactly the
+-- same set of field names as the keys of `recordMap`.
+-- Moreover, each field name should occur at most once.
+
+instance (Ord a, Eq b) => Eq (RecordMap a b) where
+ a == b = recordMap a == recordMap b
+
+instance (Ord a, Ord b) => Ord (RecordMap a b) where
+ compare a b = compare (recordMap a) (recordMap b)
+
+instance (Show a, Ord a, Show b) => Show (RecordMap a b) where
+ show = show . displayFields
+
+instance (NFData a, NFData b) => NFData (RecordMap a b) where
+ rnf = rnf . canonicalFields
+
+
+-- | Return the fields in this record as a set.
+fieldSet :: Ord a => RecordMap a b -> Set a
+fieldSet r = Map.keysSet (recordMap r)
+
+-- | The order in which the fields originally appeared.
+displayOrder :: RecordMap a b -> [a]
+displayOrder r = _displayOrder r
+
+-- | Retrieve the elements of the record in canonical order
+-- of the field names
+recordElements :: RecordMap a b -> [b]
+recordElements = map snd . canonicalFields
+
+-- | Return a list of field/value pairs in canonical order.
+canonicalFields :: RecordMap a b -> [(a,b)]
+canonicalFields = Map.toList . recordMap
+
+-- | Return a list of field/value pairs in display order.
+displayFields :: (Show a, Ord a) => RecordMap a b -> [(a,b)]
+displayFields r = map find (displayOrder r)
+ where
+ find x =
+ case Map.lookup x (recordMap r) of
+ Just v -> (x, v)
+ Nothing ->
+ panic "displayFields"
+ ["Could not find field in recordMap " ++ show x
+ , "Display order: " ++ show (displayOrder r)
+ , "Canonical order:" ++ show (map fst (canonicalFields r))
+ ]
+
+-- | Generate a record from a list of field/value pairs.
+-- Precondition: each field identifier appears at most
+-- once in the given list.
+recordFromFields :: (Show a, Ord a) => [(a,b)] -> RecordMap a b
+recordFromFields xs =
+ case recordFromFieldsErr xs of
+ Left (x,_) ->
+ panic "recordFromFields"
+ ["Repeated field value: " ++ show x]
+ Right r -> r
+
+-- | Generate a record from a list of field/value pairs.
+-- If any field name is repeated, the first repeated name/value
+-- pair is returned. Otherwise the constructed record is returned.
+recordFromFieldsErr :: (Show a, Ord a) => [(a,b)] -> Either (a,b) (RecordMap a b)
+recordFromFieldsErr xs0 = loop mempty xs0
+ where
+ loop m [] = Right (RecordMap m (map fst xs0))
+ loop m ((x,v):xs)
+ | Just _ <- Map.lookup x m = Left (x,v)
+ | otherwise = loop (Map.insert x v m) xs
+
+-- | Generate a record from a list of field/value pairs,
+-- and also provide the "display" order for the fields directly.
+-- Precondition: each field identifier appears at most once in each
+-- list, and a field name appears in the display order iff it appears
+-- in the field list.
+recordFromFieldsWithDisplay :: (Show a, Ord a) => [a] -> [(a,b)] -> RecordMap a b
+recordFromFieldsWithDisplay dOrd fs = r { _displayOrder = dOrd }
+ where
+ r = recordFromFields fs
+
+-- | Lookup the value of a field
+lookupField :: Ord a => a -> RecordMap a b -> Maybe b
+lookupField x m = Map.lookup x (recordMap m)
+
+-- | Update the value of a field by applying the given function.
+-- If the field is not present in the record, return Nothing.
+adjustField :: forall a b. Ord a => a -> (b -> b) -> RecordMap a b -> Maybe (RecordMap a b)
+adjustField x f r = mkRec <$> Map.alterF f' x (recordMap r)
+ where
+ mkRec m = r{ recordMap = m }
+
+ f' :: Maybe b -> Maybe (Maybe b)
+ f' Nothing = Nothing
+ f' (Just v) = Just (Just (f v))
+
+-- | Traverse the elements of the given record map in canonical
+-- order, applying the given action.
+traverseRecordMap :: Applicative t =>
+ (a -> b -> t c) -> RecordMap a b -> t (RecordMap a c)
+traverseRecordMap f r =
+ (\m -> RecordMap m (displayOrder r)) <$> Map.traverseWithKey f (recordMap r)
+
+-- | Apply the given function to each element of a record.
+mapWithFieldName :: (a -> b -> c) -> RecordMap a b -> RecordMap a c
+mapWithFieldName f = runIdentity . traverseRecordMap (\a b -> Identity (f a b))
+
+instance Functor (RecordMap a) where
+ fmap f = mapWithFieldName (\_ -> f)
+
+instance Foldable (RecordMap a) where
+ foldMap f = foldMap (f . snd) . canonicalFields
+
+instance Traversable (RecordMap a) where
+ traverse f = traverseRecordMap (\_ -> f)
+
+-- | The function recordMapAccum threads an accumulating argument through
+-- the map in canonical order of fields.
+recordMapAccum :: (a -> b -> (a,c)) -> a -> RecordMap k b -> (a, RecordMap k c)
+recordMapAccum f z r = (a, r{ recordMap = m' })
+ where
+ (a, m') = Map.mapAccum f z (recordMap r)
+
+-- | Zip together the fields of two records using the provided action.
+-- If some field is present in one record, but not the other,
+-- an @Either a a@ will be returned, indicating which record is missing
+-- the field, and returning the name of the missing field.
+--
+-- The @displayOrder@ of the resulting record will be taken from the first
+-- argument (rather arbitrarily).
+zipRecordsM :: forall t a b c d. (Ord a, Monad t) =>
+ (a -> b -> c -> t d) -> RecordMap a b -> RecordMap a c -> t (Either (Either a a) (RecordMap a d))
+zipRecordsM f r1 r2 = runExceptT (mkRec <$> zipMap (recordMap r1) (recordMap r2))
+ where
+ mkRec m = RecordMap m (displayOrder r1)
+
+ zipMap :: Map a b -> Map a c -> ExceptT (Either a a) t (Map a d)
+ zipMap = Map.mergeA missingLeft missingRight matched
+ missingLeft = Map.traverseMissing (\a _b -> throwError (Left a))
+ missingRight = Map.traverseMissing (\a _c -> throwError (Right a))
+ matched = Map.zipWithAMatched (\a b c -> lift (f a b c))
+
+-- | Pure version of `zipRecordsM`
+zipRecords :: forall a b c d. Ord a =>
+ (a -> b -> c -> d) -> RecordMap a b -> RecordMap a c -> Either (Either a a) (RecordMap a d)
+zipRecords f r1 r2 = runIdentity (zipRecordsM (\a b c -> Identity (f a b c)) r1 r2)
diff --git a/utils/CryHtml.hs b/utils/CryHtml.hs
--- a/utils/CryHtml.hs
+++ b/utils/CryHtml.hs
@@ -52,6 +52,7 @@
cl tok =
case tok of
Num {} -> "number"
+ Frac {} -> "number"
Ident {} -> "identifier"
KW {} -> "keyword"
Op {} -> "operator"