mirror of
https://github.com/GaloisInc/cryptol.git
synced 2024-09-11 14:06:13 +03:00
Initial support for floating point computation
This commit is contained in:
parent
7caf72abb4
commit
0047eaf77a
3
.gitmodules
vendored
3
.gitmodules
vendored
@ -4,3 +4,6 @@
|
|||||||
[submodule "dependencies/what4"]
|
[submodule "dependencies/what4"]
|
||||||
path = dependencies/what4
|
path = dependencies/what4
|
||||||
url = https://github.com/GaloisInc/what4.git
|
url = https://github.com/GaloisInc/what4.git
|
||||||
|
[submodule "dependencies/libBF-hs"]
|
||||||
|
path = dependencies/libBF-hs
|
||||||
|
url = git@github.com:GaloisInc/libBF-hs.git
|
||||||
|
@ -1,6 +1,7 @@
|
|||||||
packages:
|
packages:
|
||||||
cryptol.cabal
|
cryptol.cabal
|
||||||
tests
|
tests
|
||||||
|
dependencies/libBF-hs
|
||||||
|
|
||||||
optional-packages:
|
optional-packages:
|
||||||
dependencies/what4/what4
|
dependencies/what4/what4
|
||||||
|
@ -56,6 +56,7 @@ library
|
|||||||
gitrev >= 1.0,
|
gitrev >= 1.0,
|
||||||
GraphSCC >= 1.0.4,
|
GraphSCC >= 1.0.4,
|
||||||
heredoc >= 0.2,
|
heredoc >= 0.2,
|
||||||
|
libBF,
|
||||||
monad-control >= 1.0,
|
monad-control >= 1.0,
|
||||||
monadLib >= 3.7.2,
|
monadLib >= 3.7.2,
|
||||||
parameterized-utils >= 2.0.2,
|
parameterized-utils >= 2.0.2,
|
||||||
@ -157,6 +158,8 @@ library
|
|||||||
Cryptol.Eval.Arch,
|
Cryptol.Eval.Arch,
|
||||||
Cryptol.Eval.Backend,
|
Cryptol.Eval.Backend,
|
||||||
Cryptol.Eval.Concrete,
|
Cryptol.Eval.Concrete,
|
||||||
|
Cryptol.Eval.Concrete.Float,
|
||||||
|
Cryptol.Eval.Concrete.FloatHelpers,
|
||||||
Cryptol.Eval.Concrete.Value,
|
Cryptol.Eval.Concrete.Value,
|
||||||
Cryptol.Eval.Env,
|
Cryptol.Eval.Env,
|
||||||
Cryptol.Eval.Generic,
|
Cryptol.Eval.Generic,
|
||||||
@ -166,6 +169,9 @@ library
|
|||||||
Cryptol.Eval.Type,
|
Cryptol.Eval.Type,
|
||||||
Cryptol.Eval.Value,
|
Cryptol.Eval.Value,
|
||||||
Cryptol.Eval.What4,
|
Cryptol.Eval.What4,
|
||||||
|
Cryptol.Eval.What4.Value,
|
||||||
|
Cryptol.Eval.What4.Float,
|
||||||
|
Cryptol.Eval.What4.SFloat,
|
||||||
|
|
||||||
Cryptol.Testing.Random,
|
Cryptol.Testing.Random,
|
||||||
|
|
||||||
|
1
dependencies/libBF-hs
vendored
Submodule
1
dependencies/libBF-hs
vendored
Submodule
@ -0,0 +1 @@
|
|||||||
|
Subproject commit 20335b895358d81f1f7ad093dac6f80aa6afecf6
|
@ -197,6 +197,22 @@ primitive fromThenTo : {first, next, last, a, len}
|
|||||||
, first != next
|
, first != next
|
||||||
, lengthFromThenTo first next last == len) => [len]a
|
, lengthFromThenTo first next last == len) => [len]a
|
||||||
|
|
||||||
|
// Fractional Literals ---------------------
|
||||||
|
|
||||||
|
/** 'FLiteral n d r a' asserts that the type `a' contains the
|
||||||
|
fraction `n/d`. 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 -------------------------------------------------------
|
// The Zero class -------------------------------------------------------
|
||||||
|
|
||||||
|
155
lib/Float.cry
Normal file
155
lib/Float.cry
Normal file
@ -0,0 +1,155 @@
|
|||||||
|
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)
|
||||||
|
*---------------------------------------------------------------------- */
|
||||||
|
|
||||||
|
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 =.=
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
/* ----------------------------------------------------------------------
|
||||||
|
* 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
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
@ -63,10 +63,10 @@ import Prelude.Compat
|
|||||||
type EvalEnv = GenEvalEnv Concrete
|
type EvalEnv = GenEvalEnv Concrete
|
||||||
|
|
||||||
type EvalPrims sym =
|
type EvalPrims sym =
|
||||||
( Backend sym, ?evalPrim :: Ident -> Maybe (GenValue sym) )
|
( Backend sym, ?evalPrim :: PrimIdent -> Maybe (GenValue sym) )
|
||||||
|
|
||||||
type ConcPrims =
|
type ConcPrims =
|
||||||
?evalPrim :: Ident -> Maybe (GenValue Concrete)
|
?evalPrim :: PrimIdent -> Maybe (GenValue Concrete)
|
||||||
|
|
||||||
-- Expression Evaluation -------------------------------------------------------
|
-- Expression Evaluation -------------------------------------------------------
|
||||||
|
|
||||||
@ -426,6 +426,7 @@ etaDelay sym msg env0 Forall{ sVars = vs0, sType = tp0 } = goTpVars env0 vs0
|
|||||||
case tp of
|
case tp of
|
||||||
TVBit -> v
|
TVBit -> v
|
||||||
TVInteger -> v
|
TVInteger -> v
|
||||||
|
TVFloat {} -> v
|
||||||
TVIntMod _ -> v
|
TVIntMod _ -> v
|
||||||
TVRational -> v
|
TVRational -> v
|
||||||
TVArray{} -> v
|
TVArray{} -> v
|
||||||
|
@ -6,6 +6,7 @@ module Cryptol.Eval.Backend
|
|||||||
, invalidIndex
|
, invalidIndex
|
||||||
, cryUserError
|
, cryUserError
|
||||||
, cryNoPrimError
|
, cryNoPrimError
|
||||||
|
, FPArith2
|
||||||
|
|
||||||
-- * Rationals
|
-- * Rationals
|
||||||
, SRational(..)
|
, SRational(..)
|
||||||
@ -213,6 +214,7 @@ class MonadIO (SEval sym) => Backend sym where
|
|||||||
type SBit sym :: Type
|
type SBit sym :: Type
|
||||||
type SWord sym :: Type
|
type SWord sym :: Type
|
||||||
type SInteger sym :: Type
|
type SInteger sym :: Type
|
||||||
|
type SFloat sym :: Type
|
||||||
type SEval sym :: Type -> Type
|
type SEval sym :: Type -> Type
|
||||||
|
|
||||||
-- ==== Evaluation monad operations ====
|
-- ==== Evaluation monad operations ====
|
||||||
@ -260,6 +262,10 @@ class MonadIO (SEval sym) => Backend sym where
|
|||||||
-- | Pretty-print an integer value
|
-- | Pretty-print an integer value
|
||||||
ppInteger :: sym -> PPOpts -> SInteger sym -> Doc
|
ppInteger :: sym -> PPOpts -> SInteger sym -> Doc
|
||||||
|
|
||||||
|
-- | Pretty-print a floating-point value
|
||||||
|
ppFloat :: sym -> PPOpts -> SFloat sym -> Doc
|
||||||
|
|
||||||
|
|
||||||
-- ==== Identifying literal values ====
|
-- ==== Identifying literal values ====
|
||||||
|
|
||||||
-- | Determine if this symbolic bit is a boolean literal
|
-- | Determine if this symbolic bit is a boolean literal
|
||||||
@ -297,6 +303,14 @@ class MonadIO (SEval sym) => Backend sym where
|
|||||||
Integer {- ^ Value -} ->
|
Integer {- ^ Value -} ->
|
||||||
SEval sym (SInteger sym)
|
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 ====
|
-- ==== If/then/else operations ====
|
||||||
iteBit :: sym -> SBit sym -> SBit sym -> SBit sym -> SEval sym (SBit sym)
|
iteBit :: sym -> SBit sym -> SBit sym -> SBit sym -> SEval sym (SBit sym)
|
||||||
iteWord :: sym -> SBit sym -> SWord sym -> SWord sym -> SEval sym (SWord sym)
|
iteWord :: sym -> SBit sym -> SWord sym -> SWord sym -> SEval sym (SWord sym)
|
||||||
@ -650,3 +664,37 @@ class MonadIO (SEval sym) => Backend sym where
|
|||||||
SInteger sym ->
|
SInteger sym ->
|
||||||
SInteger sym ->
|
SInteger sym ->
|
||||||
SEval sym (SBit 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)
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
@ -9,6 +9,7 @@
|
|||||||
{-# LANGUAGE BangPatterns #-}
|
{-# LANGUAGE BangPatterns #-}
|
||||||
{-# LANGUAGE LambdaCase #-}
|
{-# LANGUAGE LambdaCase #-}
|
||||||
{-# LANGUAGE NamedFieldPuns #-}
|
{-# LANGUAGE NamedFieldPuns #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE PatternGuards #-}
|
{-# LANGUAGE PatternGuards #-}
|
||||||
{-# LANGUAGE Rank2Types #-}
|
{-# LANGUAGE Rank2Types #-}
|
||||||
{-# LANGUAGE RecordWildCards #-}
|
{-# LANGUAGE RecordWildCards #-}
|
||||||
@ -27,13 +28,16 @@ import Control.Monad (join,guard,zipWithM)
|
|||||||
import Data.List(sortBy)
|
import Data.List(sortBy)
|
||||||
import Data.Ord(comparing)
|
import Data.Ord(comparing)
|
||||||
import Data.Bits (Bits(..))
|
import Data.Bits (Bits(..))
|
||||||
|
import Data.Ratio(numerator,denominator)
|
||||||
import MonadLib( ChoiceT, findOne, lift )
|
import MonadLib( ChoiceT, findOne, lift )
|
||||||
|
import qualified LibBF as FP
|
||||||
|
|
||||||
import qualified Data.Map.Strict as Map
|
import qualified Data.Map.Strict as Map
|
||||||
import qualified Data.Text as T
|
|
||||||
|
|
||||||
import Cryptol.TypeCheck.Solver.InfNat (Nat'(..))
|
import Cryptol.TypeCheck.Solver.InfNat (Nat'(..))
|
||||||
import Cryptol.Eval.Backend
|
import Cryptol.Eval.Backend
|
||||||
|
import Cryptol.Eval.Concrete.Float(floatPrims)
|
||||||
|
import Cryptol.Eval.Concrete.FloatHelpers(bfValue)
|
||||||
import Cryptol.Eval.Concrete.Value
|
import Cryptol.Eval.Concrete.Value
|
||||||
import Cryptol.Eval.Generic hiding (logicShift)
|
import Cryptol.Eval.Generic hiding (logicShift)
|
||||||
import Cryptol.Eval.Monad
|
import Cryptol.Eval.Monad
|
||||||
@ -43,7 +47,7 @@ import Cryptol.ModuleSystem.Name
|
|||||||
import Cryptol.Testing.Random (randomV)
|
import Cryptol.Testing.Random (randomV)
|
||||||
import Cryptol.TypeCheck.AST as AST
|
import Cryptol.TypeCheck.AST as AST
|
||||||
import Cryptol.Utils.Panic (panic)
|
import Cryptol.Utils.Panic (panic)
|
||||||
import Cryptol.Utils.Ident (Ident,mkIdent)
|
import Cryptol.Utils.Ident (PrimIdent,prelPrim,floatPrim)
|
||||||
import Cryptol.Utils.PP
|
import Cryptol.Utils.PP
|
||||||
import Cryptol.Utils.Logger(logPrint)
|
import Cryptol.Utils.Logger(logPrint)
|
||||||
|
|
||||||
@ -59,7 +63,8 @@ toExpr :: PrimMap -> AST.Type -> Value -> Eval (Maybe AST.Expr)
|
|||||||
toExpr prims t0 v0 = findOne (go t0 v0)
|
toExpr prims t0 v0 = findOne (go t0 v0)
|
||||||
where
|
where
|
||||||
|
|
||||||
prim n = ePrim prims (mkIdent (T.pack n))
|
prim n = ePrim prims (prelPrim n)
|
||||||
|
|
||||||
|
|
||||||
go :: AST.Type -> Value -> ChoiceT Eval Expr
|
go :: AST.Type -> Value -> ChoiceT Eval Expr
|
||||||
go ty val = case (tNoUser ty, val) of
|
go ty val = case (tNoUser ty, val) of
|
||||||
@ -81,6 +86,9 @@ toExpr prims t0 v0 = findOne (go t0 v0)
|
|||||||
do let n' = ETApp (ETApp (prim "number") (tNum n)) (TCon (TC TCInteger) [])
|
do let n' = ETApp (ETApp (prim "number") (tNum n)) (TCon (TC TCInteger) [])
|
||||||
d' = ETApp (ETApp (prim "number") (tNum d)) (TCon (TC TCInteger) [])
|
d' = ETApp (ETApp (prim "number") (tNum d)) (TCon (TC TCInteger) [])
|
||||||
return $ EApp (EApp (prim "ratio") n') d'
|
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
|
(TCon (TC TCSeq) [a,b], VSeq 0 _) -> do
|
||||||
guard (a == tZero)
|
guard (a == tZero)
|
||||||
return $ EList [] b
|
return $ EList [] b
|
||||||
@ -102,15 +110,36 @@ toExpr prims t0 v0 = findOne (go t0 v0)
|
|||||||
, render doc
|
, 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 ------------------------------------------------------------------
|
-- Primitives ------------------------------------------------------------------
|
||||||
|
|
||||||
evalPrim :: Ident -> Maybe Value
|
evalPrim :: PrimIdent -> Maybe Value
|
||||||
evalPrim prim = Map.lookup prim primTable
|
evalPrim prim = Map.lookup prim primTable
|
||||||
|
|
||||||
primTable :: Map.Map Ident Value
|
primTable :: Map.Map PrimIdent Value
|
||||||
primTable = let sym = Concrete in
|
primTable = let sym = Concrete in
|
||||||
Map.fromList $ map (\(n, v) -> (mkIdent (T.pack n), v))
|
Map.union (floatPrims sym) $
|
||||||
|
Map.fromList $ map (\(n, v) -> (prelPrim n, v))
|
||||||
|
|
||||||
[ -- Literals
|
[ -- Literals
|
||||||
("True" , VBit (bitLit sym True))
|
("True" , VBit (bitLit sym True))
|
||||||
, ("False" , VBit (bitLit sym False))
|
, ("False" , VBit (bitLit sym False))
|
||||||
@ -118,6 +147,8 @@ primTable = let sym = Concrete in
|
|||||||
ecNumberV sym)
|
ecNumberV sym)
|
||||||
, ("ratio" , {-# SCC "Prelude::ratio" #-}
|
, ("ratio" , {-# SCC "Prelude::ratio" #-}
|
||||||
ratioV sym)
|
ratioV sym)
|
||||||
|
, ("fraction" , ecFractionV sym)
|
||||||
|
|
||||||
|
|
||||||
-- Zero
|
-- Zero
|
||||||
, ("zero" , {-# SCC "Prelude::zero" #-}
|
, ("zero" , {-# SCC "Prelude::zero" #-}
|
||||||
|
147
src/Cryptol/Eval/Concrete/Float.hs
Normal file
147
src/Cryptol/Eval/Concrete/Float.hs
Normal file
@ -0,0 +1,147 @@
|
|||||||
|
{-# Language BlockArguments #-}
|
||||||
|
{-# Language OverloadedStrings #-}
|
||||||
|
{-# Language BangPatterns #-}
|
||||||
|
-- | Concrete evaluations for floating point primitives.
|
||||||
|
module Cryptol.Eval.Concrete.Float where
|
||||||
|
|
||||||
|
import Data.Map(Map)
|
||||||
|
import Data.Bits(testBit,setBit,shiftL,shiftR,(.&.),(.|.))
|
||||||
|
import Data.Int(Int64)
|
||||||
|
import qualified Data.Map as Map
|
||||||
|
import LibBF
|
||||||
|
|
||||||
|
import Cryptol.Utils.Ident(PrimIdent, floatPrim)
|
||||||
|
import Cryptol.Utils.Panic(panic)
|
||||||
|
import Cryptol.Eval.Value
|
||||||
|
import Cryptol.Eval.Generic
|
||||||
|
import Cryptol.Eval.Concrete.Value
|
||||||
|
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
|
||||||
|
|
||||||
|
-- From Backend class
|
||||||
|
, "fpAdd" ~> fpBinArithV sym fpPlus
|
||||||
|
, "fpSub" ~> fpBinArithV sym fpMinus
|
||||||
|
, "fpMul" ~> fpBinArithV sym fpMult
|
||||||
|
, "fpDiv" ~> fpBinArithV sym fpDiv
|
||||||
|
]
|
||||||
|
|
||||||
|
|
||||||
|
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)
|
||||||
|
|
138
src/Cryptol/Eval/Concrete/FloatHelpers.hs
Normal file
138
src/Cryptol/Eval/Concrete/FloatHelpers.hs
Normal file
@ -0,0 +1,138 @@
|
|||||||
|
{-# Language BlockArguments #-}
|
||||||
|
module Cryptol.Eval.Concrete.FloatHelpers where
|
||||||
|
|
||||||
|
import Data.Ratio
|
||||||
|
import LibBF
|
||||||
|
|
||||||
|
import Cryptol.Utils.PP
|
||||||
|
import Cryptol.Utils.Panic(panic)
|
||||||
|
import Cryptol.Eval.Backend
|
||||||
|
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 ::
|
||||||
|
Backend sym =>
|
||||||
|
sym {- ^ backend -} ->
|
||||||
|
Integer {- ^ expoinent bits -} ->
|
||||||
|
Integer {- ^ precision bits -} ->
|
||||||
|
Integer {- ^ rounding mode, as defined in `Float.cry` -} ->
|
||||||
|
SEval sym BFOpts
|
||||||
|
fpOpts sym e p r =
|
||||||
|
case ok of
|
||||||
|
Just opts -> case fpRound r of
|
||||||
|
Just m -> pure (rnd m <> opts)
|
||||||
|
Nothing -> raiseError sym (BadRoundingMode r)
|
||||||
|
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)
|
||||||
|
|
||||||
|
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 -> Maybe RoundMode
|
||||||
|
fpRound n =
|
||||||
|
case n of
|
||||||
|
0 -> Just NearEven
|
||||||
|
1 -> Just NearAway
|
||||||
|
2 -> Just ToPosInf
|
||||||
|
3 -> Just ToNegInf
|
||||||
|
4 -> Just ToZero
|
||||||
|
_ -> Nothing
|
||||||
|
|
||||||
|
|
||||||
|
-- | Check that we didn't get an unexpected status.
|
||||||
|
fpCheckStatus :: Backend sym => sym -> (BigFloat,Status) -> SEval sym BigFloat
|
||||||
|
fpCheckStatus _sym (r,s) =
|
||||||
|
case s of
|
||||||
|
MemError -> panic "checkStatus" [ "libBF: Memory error" ]
|
||||||
|
_ -> pure r
|
||||||
|
|
||||||
|
|
||||||
|
-- | Pretty print a float
|
||||||
|
fpPP :: PPOpts -> BF -> Doc
|
||||||
|
fpPP opts bf = text $ bfToString base fmt num
|
||||||
|
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
|
||||||
|
|
||||||
|
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
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
-- | Make a literal
|
||||||
|
fpLit ::
|
||||||
|
Backend sym =>
|
||||||
|
sym ->
|
||||||
|
Integer {- ^ Exponent width -} ->
|
||||||
|
Integer {- ^ Precision width -} ->
|
||||||
|
Rational ->
|
||||||
|
SEval sym BF
|
||||||
|
fpLit sym e p r =
|
||||||
|
do opts <- fpOpts sym e p 0 -- round to nearest even
|
||||||
|
let num = bfFromInteger (numerator r)
|
||||||
|
res
|
||||||
|
| denominator r == 1 = bfRoundFloat opts num
|
||||||
|
| otherwise = bfDiv opts num (bfFromInteger (denominator r))
|
||||||
|
v <- fpCheckStatus sym res
|
||||||
|
pure BF { bfExpWidth = e, bfPrecWidth = p, bfValue = v }
|
||||||
|
|
||||||
|
|
||||||
|
fpToI :: RoundMode -> BigFloat -> Maybe Integer
|
||||||
|
fpToI r flt =
|
||||||
|
case bfToRep flt of
|
||||||
|
BFNaN -> Nothing
|
||||||
|
BFRep s num ->
|
||||||
|
case num of
|
||||||
|
Zero -> pure 0
|
||||||
|
Inf -> Nothing
|
||||||
|
Num i ev ->
|
||||||
|
pure
|
||||||
|
case r of
|
||||||
|
NearEven -> round $ addSign rat
|
||||||
|
NearAway -> addSign $ ceiling rat
|
||||||
|
ToPosInf -> ceiling $ addSign rat
|
||||||
|
ToNegInf -> floor $ addSign rat
|
||||||
|
ToZero -> truncate rat
|
||||||
|
_ -> panic "fpCvtToInteger"
|
||||||
|
["Unexpected rounding mode", show r]
|
||||||
|
where
|
||||||
|
rat = fromInteger i * 2 ^^ ev :: Rational
|
||||||
|
addSign :: Num a => a -> a
|
||||||
|
addSign = case s of
|
||||||
|
Pos -> id
|
||||||
|
Neg -> negate
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
@ -1,4 +1,4 @@
|
|||||||
-- |
|
-- |fpToInteger r e p f
|
||||||
-- Module : Cryptol.Eval.Concrete.Value
|
-- Module : Cryptol.Eval.Concrete.Value
|
||||||
-- Copyright : (c) 2013-2020 Galois, Inc.
|
-- Copyright : (c) 2013-2020 Galois, Inc.
|
||||||
-- License : BSD3
|
-- License : BSD3
|
||||||
@ -7,6 +7,7 @@
|
|||||||
-- Portability : portable
|
-- Portability : portable
|
||||||
|
|
||||||
{-# LANGUAGE BangPatterns #-}
|
{-# LANGUAGE BangPatterns #-}
|
||||||
|
{-# LANGUAGE BlockArguments #-}
|
||||||
{-# LANGUAGE LambdaCase #-}
|
{-# LANGUAGE LambdaCase #-}
|
||||||
{-# LANGUAGE NamedFieldPuns #-}
|
{-# LANGUAGE NamedFieldPuns #-}
|
||||||
{-# LANGUAGE PatternGuards #-}
|
{-# LANGUAGE PatternGuards #-}
|
||||||
@ -32,13 +33,16 @@ module Cryptol.Eval.Concrete.Value
|
|||||||
, Value
|
, Value
|
||||||
, Concrete(..)
|
, Concrete(..)
|
||||||
, liftBinIntMod
|
, liftBinIntMod
|
||||||
|
, fpBinArith
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import qualified Control.Exception as X
|
import qualified Control.Exception as X
|
||||||
import Data.Bits
|
import Data.Bits
|
||||||
import Numeric (showIntAtBase)
|
import Numeric (showIntAtBase)
|
||||||
|
import qualified LibBF as FP
|
||||||
|
|
||||||
import qualified Cryptol.Eval.Arch as Arch
|
import qualified Cryptol.Eval.Arch as Arch
|
||||||
|
import qualified Cryptol.Eval.Concrete.FloatHelpers as FP
|
||||||
import Cryptol.Eval.Monad
|
import Cryptol.Eval.Monad
|
||||||
import Cryptol.Eval.Value
|
import Cryptol.Eval.Value
|
||||||
import Cryptol.TypeCheck.Solver.InfNat (genLog)
|
import Cryptol.TypeCheck.Solver.InfNat (genLog)
|
||||||
@ -131,6 +135,7 @@ instance Backend Concrete where
|
|||||||
type SBit Concrete = Bool
|
type SBit Concrete = Bool
|
||||||
type SWord Concrete = BV
|
type SWord Concrete = BV
|
||||||
type SInteger Concrete = Integer
|
type SInteger Concrete = Integer
|
||||||
|
type SFloat Concrete = FP.BF
|
||||||
type SEval Concrete = Eval
|
type SEval Concrete = Eval
|
||||||
|
|
||||||
raiseError _ err = io (X.throwIO err)
|
raiseError _ err = io (X.throwIO err)
|
||||||
@ -164,6 +169,8 @@ instance Backend Concrete where
|
|||||||
|
|
||||||
ppInteger _ _opts i = integer i
|
ppInteger _ _opts i = integer i
|
||||||
|
|
||||||
|
ppFloat _ = FP.fpPP
|
||||||
|
|
||||||
bitLit _ b = b
|
bitLit _ b = b
|
||||||
bitAsLit _ b = Just b
|
bitAsLit _ b = Just b
|
||||||
|
|
||||||
@ -313,9 +320,63 @@ instance Backend Concrete where
|
|||||||
znNegate _ 0 _ = evalPanic "znNegate" ["0 modulus not allowed"]
|
znNegate _ 0 _ = evalPanic "znNegate" ["0 modulus not allowed"]
|
||||||
znNegate _ m x = pure $! (negate x) `mod` m
|
znNegate _ m x = pure $! (negate x) `mod` m
|
||||||
|
|
||||||
|
------------------------------------------------------------------------
|
||||||
|
-- Floating Point
|
||||||
|
fpLit = FP.fpLit
|
||||||
|
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 sym e p (bvVal r)
|
||||||
|
v <- FP.fpCheckStatus sym (FP.bfRoundInt opts (FP.bfFromInteger x))
|
||||||
|
pure FP.BF { FP.bfExpWidth = e, FP.bfPrecWidth = p, FP.bfValue = v }
|
||||||
|
fpToInteger = fpCvtToInteger
|
||||||
|
|
||||||
|
|
||||||
{-# INLINE liftBinIntMod #-}
|
{-# INLINE liftBinIntMod #-}
|
||||||
liftBinIntMod :: Monad m =>
|
liftBinIntMod :: Monad m =>
|
||||||
(Integer -> Integer -> Integer) -> Integer -> Integer -> Integer -> m Integer
|
(Integer -> Integer -> Integer) -> Integer -> Integer -> Integer -> m Integer
|
||||||
liftBinIntMod op m x y
|
liftBinIntMod op m x y
|
||||||
| m == 0 = evalPanic "znArithmetic" ["0 modulus not allowed"]
|
| m == 0 = evalPanic "znArithmetic" ["0 modulus not allowed"]
|
||||||
| otherwise = pure $ (op x y) `mod` m
|
| 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 sym (FP.bfExpWidth x) (FP.bfPrecWidth x) (bvVal r)
|
||||||
|
v <- FP.fpCheckStatus sym (fun opts (FP.bfValue x) (FP.bfValue y))
|
||||||
|
pure x { FP.bfValue = v }
|
||||||
|
|
||||||
|
fpCvtToInteger ::
|
||||||
|
Concrete ->
|
||||||
|
String ->
|
||||||
|
SWord Concrete {- ^ Rounding mode -} ->
|
||||||
|
SFloat Concrete ->
|
||||||
|
SEval Concrete (SInteger Concrete)
|
||||||
|
fpCvtToInteger sym fun (bvVal -> rnd) (FP.bfValue -> flt) =
|
||||||
|
case FP.fpRound rnd of
|
||||||
|
Nothing -> raiseError sym (BadRoundingMode rnd)
|
||||||
|
Just mode ->
|
||||||
|
case FP.fpToI mode flt of
|
||||||
|
Just i -> pure i
|
||||||
|
Nothing -> raiseError sym (BadValue fun)
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
@ -7,6 +7,7 @@
|
|||||||
-- Portability : portable
|
-- Portability : portable
|
||||||
|
|
||||||
{-# LANGUAGE LambdaCase #-}
|
{-# LANGUAGE LambdaCase #-}
|
||||||
|
{-# LANGUAGE BlockArguments #-}
|
||||||
{-# LANGUAGE Safe #-}
|
{-# LANGUAGE Safe #-}
|
||||||
{-# LANGUAGE TupleSections #-}
|
{-# LANGUAGE TupleSections #-}
|
||||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
@ -26,6 +27,7 @@ import Control.Monad (join, unless)
|
|||||||
|
|
||||||
import Data.Bits (testBit)
|
import Data.Bits (testBit)
|
||||||
import Data.Maybe (fromMaybe)
|
import Data.Maybe (fromMaybe)
|
||||||
|
import Data.Ratio ((%))
|
||||||
|
|
||||||
import Cryptol.TypeCheck.AST
|
import Cryptol.TypeCheck.AST
|
||||||
import Cryptol.TypeCheck.Solver.InfNat (Nat'(..),nMul,widthInteger)
|
import Cryptol.TypeCheck.Solver.InfNat (Nat'(..),nMul,widthInteger)
|
||||||
@ -52,6 +54,7 @@ mkLit sym ty i =
|
|||||||
TVIntMod m
|
TVIntMod m
|
||||||
| m == 0 -> evalPanic "mkLit" ["0 modulus not allowed"]
|
| m == 0 -> evalPanic "mkLit" ["0 modulus not allowed"]
|
||||||
| otherwise -> VInteger <$> integerLit sym (i `mod` m)
|
| 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
|
TVSeq w TVBit -> pure $ word sym w i
|
||||||
TVRational -> VRational <$> (intToRational sym =<< integerLit sym i)
|
TVRational -> VRational <$> (intToRational sym =<< integerLit sym i)
|
||||||
_ -> evalPanic "Cryptol.Eval.Prim.evalConst"
|
_ -> evalPanic "Cryptol.Eval.Prim.evalConst"
|
||||||
@ -74,11 +77,12 @@ ecNumberV sym =
|
|||||||
]
|
]
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
{-# SPECIALIZE intV :: Concrete -> Integer -> TValue -> Eval (GenValue Concrete)
|
{-# SPECIALIZE intV :: Concrete -> Integer -> TValue -> Eval (GenValue Concrete)
|
||||||
#-}
|
#-}
|
||||||
intV :: Backend sym => sym -> SInteger sym -> TValue -> SEval sym (GenValue sym)
|
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)
|
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 #-}
|
{-# SPECIALIZE ratioV :: Concrete -> GenValue Concrete #-}
|
||||||
ratioV :: Backend sym => sym -> GenValue sym
|
ratioV :: Backend sym => sym -> GenValue sym
|
||||||
@ -89,6 +93,26 @@ ratioV sym =
|
|||||||
y' <- fromVInteger <$> y
|
y' <- fromVInteger <$> y
|
||||||
VRational <$> ratio sym x' 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 #-}
|
{-# SPECIALIZE fromZV :: Concrete -> GenValue Concrete #-}
|
||||||
fromZV :: Backend sym => sym -> GenValue sym
|
fromZV :: Backend sym => sym -> GenValue sym
|
||||||
fromZV sym =
|
fromZV sym =
|
||||||
@ -124,6 +148,7 @@ type BinWord sym = Integer -> SWord sym -> SWord sym -> SEval sym (SWord sym)
|
|||||||
(SInteger Concrete -> SInteger Concrete -> SEval Concrete (SInteger Concrete)) ->
|
(SInteger Concrete -> SInteger Concrete -> SEval Concrete (SInteger Concrete)) ->
|
||||||
(Integer -> 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)) ->
|
(SRational Concrete -> SRational Concrete -> SEval Concrete (SRational Concrete)) ->
|
||||||
|
(SFloat Concrete -> SFloat Concrete -> SEval Concrete (SFloat Concrete)) ->
|
||||||
Binary Concrete
|
Binary Concrete
|
||||||
#-}
|
#-}
|
||||||
|
|
||||||
@ -134,8 +159,9 @@ ringBinary :: forall sym.
|
|||||||
(SInteger sym -> SInteger sym -> SEval sym (SInteger sym)) ->
|
(SInteger sym -> SInteger sym -> SEval sym (SInteger sym)) ->
|
||||||
(Integer -> 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)) ->
|
(SRational sym -> SRational sym -> SEval sym (SRational sym)) ->
|
||||||
|
(SFloat sym -> SFloat sym -> SEval sym (SFloat sym)) ->
|
||||||
Binary sym
|
Binary sym
|
||||||
ringBinary sym opw opi opz opq = loop
|
ringBinary sym opw opi opz opq opfp = loop
|
||||||
where
|
where
|
||||||
loop' :: TValue
|
loop' :: TValue
|
||||||
-> SEval sym (GenValue sym)
|
-> SEval sym (GenValue sym)
|
||||||
@ -157,6 +183,9 @@ ringBinary sym opw opi opz opq = loop
|
|||||||
TVIntMod n ->
|
TVIntMod n ->
|
||||||
VInteger <$> opz n (fromVInteger l) (fromVInteger r)
|
VInteger <$> opz n (fromVInteger l) (fromVInteger r)
|
||||||
|
|
||||||
|
TVFloat {} ->
|
||||||
|
VFloat <$> opfp (fromVFloat l) (fromVFloat r)
|
||||||
|
|
||||||
TVRational ->
|
TVRational ->
|
||||||
VRational <$> opq (fromVRational l) (fromVRational r)
|
VRational <$> opq (fromVRational l) (fromVRational r)
|
||||||
|
|
||||||
@ -209,6 +238,7 @@ type UnaryWord sym = Integer -> SWord sym -> SEval sym (SWord sym)
|
|||||||
(SInteger Concrete -> SEval Concrete (SInteger Concrete)) ->
|
(SInteger Concrete -> SEval Concrete (SInteger Concrete)) ->
|
||||||
(Integer -> SInteger Concrete -> SEval Concrete (SInteger Concrete)) ->
|
(Integer -> SInteger Concrete -> SEval Concrete (SInteger Concrete)) ->
|
||||||
(SRational Concrete -> SEval Concrete (SRational Concrete)) ->
|
(SRational Concrete -> SEval Concrete (SRational Concrete)) ->
|
||||||
|
(SFloat Concrete -> SEval Concrete (SFloat Concrete)) ->
|
||||||
Unary Concrete
|
Unary Concrete
|
||||||
#-}
|
#-}
|
||||||
ringUnary :: forall sym.
|
ringUnary :: forall sym.
|
||||||
@ -218,8 +248,9 @@ ringUnary :: forall sym.
|
|||||||
(SInteger sym -> SEval sym (SInteger sym)) ->
|
(SInteger sym -> SEval sym (SInteger sym)) ->
|
||||||
(Integer -> SInteger sym -> SEval sym (SInteger sym)) ->
|
(Integer -> SInteger sym -> SEval sym (SInteger sym)) ->
|
||||||
(SRational sym -> SEval sym (SRational sym)) ->
|
(SRational sym -> SEval sym (SRational sym)) ->
|
||||||
|
(SFloat sym -> SEval sym (SFloat sym)) ->
|
||||||
Unary sym
|
Unary sym
|
||||||
ringUnary sym opw opi opz opq = loop
|
ringUnary sym opw opi opz opq opfp = loop
|
||||||
where
|
where
|
||||||
loop' :: TValue -> SEval sym (GenValue sym) -> SEval sym (GenValue sym)
|
loop' :: TValue -> SEval sym (GenValue sym) -> SEval sym (GenValue sym)
|
||||||
loop' ty v = loop ty =<< v
|
loop' ty v = loop ty =<< v
|
||||||
@ -236,6 +267,9 @@ ringUnary sym opw opi opz opq = loop
|
|||||||
TVIntMod n ->
|
TVIntMod n ->
|
||||||
VInteger <$> opz n (fromVInteger v)
|
VInteger <$> opz n (fromVInteger v)
|
||||||
|
|
||||||
|
TVFloat {} ->
|
||||||
|
VFloat <$> opfp (fromVFloat v)
|
||||||
|
|
||||||
TVRational ->
|
TVRational ->
|
||||||
VRational <$> opq (fromVRational v)
|
VRational <$> opq (fromVRational v)
|
||||||
|
|
||||||
@ -277,6 +311,7 @@ ringUnary sym opw opi opz opq = loop
|
|||||||
SEval Concrete (SInteger Concrete) ->
|
SEval Concrete (SInteger Concrete) ->
|
||||||
(Integer -> SEval Concrete (SInteger Concrete)) ->
|
(Integer -> SEval Concrete (SInteger Concrete)) ->
|
||||||
SEval Concrete (SRational Concrete) ->
|
SEval Concrete (SRational Concrete) ->
|
||||||
|
(Integer -> Integer -> SEval Concrete (SFloat Concrete)) ->
|
||||||
TValue ->
|
TValue ->
|
||||||
SEval Concrete (GenValue Concrete)
|
SEval Concrete (GenValue Concrete)
|
||||||
#-}
|
#-}
|
||||||
@ -288,9 +323,10 @@ ringNullary :: forall sym.
|
|||||||
SEval sym (SInteger sym) ->
|
SEval sym (SInteger sym) ->
|
||||||
(Integer -> SEval sym (SInteger sym)) ->
|
(Integer -> SEval sym (SInteger sym)) ->
|
||||||
SEval sym (SRational sym) ->
|
SEval sym (SRational sym) ->
|
||||||
|
(Integer -> Integer -> SEval sym (SFloat sym)) ->
|
||||||
TValue ->
|
TValue ->
|
||||||
SEval sym (GenValue sym)
|
SEval sym (GenValue sym)
|
||||||
ringNullary sym opw opi opz opq = loop
|
ringNullary sym opw opi opz opq opfp = loop
|
||||||
where
|
where
|
||||||
loop :: TValue -> SEval sym (GenValue sym)
|
loop :: TValue -> SEval sym (GenValue sym)
|
||||||
loop ty =
|
loop ty =
|
||||||
@ -301,6 +337,8 @@ ringNullary sym opw opi opz opq = loop
|
|||||||
|
|
||||||
TVIntMod n -> VInteger <$> opz n
|
TVIntMod n -> VInteger <$> opz n
|
||||||
|
|
||||||
|
TVFloat e p -> VFloat <$> opfp e p
|
||||||
|
|
||||||
TVRational -> VRational <$> opq
|
TVRational -> VRational <$> opq
|
||||||
|
|
||||||
TVArray{} -> evalPanic "arithNullary" ["Array not in class Ring"]
|
TVArray{} -> evalPanic "arithNullary" ["Array not in class Ring"]
|
||||||
@ -374,39 +412,43 @@ fromIntegerV sym =
|
|||||||
|
|
||||||
{-# INLINE addV #-}
|
{-# INLINE addV #-}
|
||||||
addV :: Backend sym => sym -> Binary sym
|
addV :: Backend sym => sym -> Binary sym
|
||||||
addV sym = ringBinary sym opw opi opz opq
|
addV sym = ringBinary sym opw opi opz opq opfp
|
||||||
where
|
where
|
||||||
opw _w x y = wordPlus sym x y
|
opw _w x y = wordPlus sym x y
|
||||||
opi x y = intPlus sym x y
|
opi x y = intPlus sym x y
|
||||||
opz m x y = znPlus sym m x y
|
opz m x y = znPlus sym m x y
|
||||||
opq x y = rationalAdd sym x y
|
opq x y = rationalAdd sym x y
|
||||||
|
opfp x y = fpRndMode sym >>= \r -> fpPlus sym r x y
|
||||||
|
|
||||||
{-# INLINE subV #-}
|
{-# INLINE subV #-}
|
||||||
subV :: Backend sym => sym -> Binary sym
|
subV :: Backend sym => sym -> Binary sym
|
||||||
subV sym = ringBinary sym opw opi opz opq
|
subV sym = ringBinary sym opw opi opz opq opfp
|
||||||
where
|
where
|
||||||
opw _w x y = wordMinus sym x y
|
opw _w x y = wordMinus sym x y
|
||||||
opi x y = intMinus sym x y
|
opi x y = intMinus sym x y
|
||||||
opz m x y = znMinus sym m x y
|
opz m x y = znMinus sym m x y
|
||||||
opq x y = rationalSub sym x y
|
opq x y = rationalSub sym x y
|
||||||
|
opfp x y = fpRndMode sym >>= \r -> fpMinus sym r x y
|
||||||
|
|
||||||
{-# INLINE negateV #-}
|
{-# INLINE negateV #-}
|
||||||
negateV :: Backend sym => sym -> Unary sym
|
negateV :: Backend sym => sym -> Unary sym
|
||||||
negateV sym = ringUnary sym opw opi opz opq
|
negateV sym = ringUnary sym opw opi opz opq opfp
|
||||||
where
|
where
|
||||||
opw _w x = wordNegate sym x
|
opw _w x = wordNegate sym x
|
||||||
opi x = intNegate sym x
|
opi x = intNegate sym x
|
||||||
opz m x = znNegate sym m x
|
opz m x = znNegate sym m x
|
||||||
opq x = rationalNegate sym x
|
opq x = rationalNegate sym x
|
||||||
|
opfp x = fpNeg sym x
|
||||||
|
|
||||||
{-# INLINE mulV #-}
|
{-# INLINE mulV #-}
|
||||||
mulV :: Backend sym => sym -> Binary sym
|
mulV :: Backend sym => sym -> Binary sym
|
||||||
mulV sym = ringBinary sym opw opi opz opq
|
mulV sym = ringBinary sym opw opi opz opq opfp
|
||||||
where
|
where
|
||||||
opw _w x y = wordMult sym x y
|
opw _w x y = wordMult sym x y
|
||||||
opi x y = intMult sym x y
|
opi x y = intMult sym x y
|
||||||
opz m x y = znMult sym m x y
|
opz m x y = znMult sym m x y
|
||||||
opq x y = rationalMul sym x y
|
opq x y = rationalMul sym x y
|
||||||
|
opfp x y = fpRndMode sym >>= \r -> fpMult sym r x y
|
||||||
|
|
||||||
--------------------------------------------------
|
--------------------------------------------------
|
||||||
-- Integral
|
-- Integral
|
||||||
@ -504,6 +546,12 @@ recipV sym =
|
|||||||
lam $ \x ->
|
lam $ \x ->
|
||||||
case a of
|
case a of
|
||||||
TVRational -> VRational <$> (rationalRecip sym . fromVRational =<< x)
|
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"]
|
_ -> evalPanic "recip" [show a ++ "is not a Field"]
|
||||||
|
|
||||||
{-# SPECIALIZE fieldDivideV :: Concrete -> GenValue Concrete #-}
|
{-# SPECIALIZE fieldDivideV :: Concrete -> GenValue Concrete #-}
|
||||||
@ -517,6 +565,11 @@ fieldDivideV sym =
|
|||||||
do x' <- fromVRational <$> x
|
do x' <- fromVRational <$> x
|
||||||
y' <- fromVRational <$> y
|
y' <- fromVRational <$> y
|
||||||
VRational <$> rationalDivide sym x' 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"]
|
_ -> evalPanic "recip" [show a ++ "is not a Field"]
|
||||||
|
|
||||||
--------------------------------------------------------------
|
--------------------------------------------------------------
|
||||||
@ -526,43 +579,56 @@ fieldDivideV sym =
|
|||||||
Concrete ->
|
Concrete ->
|
||||||
String ->
|
String ->
|
||||||
(SRational Concrete -> SEval Concrete (SInteger Concrete)) ->
|
(SRational Concrete -> SEval Concrete (SInteger Concrete)) ->
|
||||||
|
(SFloat Concrete -> SEval Concrete (SInteger Concrete)) ->
|
||||||
Unary Concrete #-}
|
Unary Concrete #-}
|
||||||
|
|
||||||
roundOp :: Backend sym => sym -> String -> (SRational sym -> SEval sym (SInteger sym)) -> Unary sym
|
roundOp ::
|
||||||
roundOp _sym nm qop ty v =
|
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
|
case ty of
|
||||||
TVRational -> VInteger <$> (qop (fromVRational v))
|
TVRational -> VInteger <$> (qop (fromVRational v))
|
||||||
|
TVFloat _ _ -> VInteger <$> opfp (fromVFloat v)
|
||||||
_ -> evalPanic nm [show ty ++ " is not a Field"]
|
_ -> evalPanic nm [show ty ++ " is not a Field"]
|
||||||
|
|
||||||
{-# INLINE floorV #-}
|
{-# INLINE floorV #-}
|
||||||
floorV :: Backend sym => sym -> Unary sym
|
floorV :: Backend sym => sym -> Unary sym
|
||||||
floorV sym = roundOp sym "floor" opq
|
floorV sym = roundOp sym "floor" opq opfp
|
||||||
where
|
where
|
||||||
opq = rationalFloor sym
|
opq = rationalFloor sym
|
||||||
|
opfp = \x -> fpRndRTN sym >>= \r -> fpToInteger sym "floor" r x
|
||||||
|
|
||||||
{-# INLINE ceilingV #-}
|
{-# INLINE ceilingV #-}
|
||||||
ceilingV :: Backend sym => sym -> Unary sym
|
ceilingV :: Backend sym => sym -> Unary sym
|
||||||
ceilingV sym = roundOp sym "ceiling" opq
|
ceilingV sym = roundOp sym "ceiling" opq opfp
|
||||||
where
|
where
|
||||||
opq = rationalCeiling sym
|
opq = rationalCeiling sym
|
||||||
|
opfp = \x -> fpRndRTP sym >>= \r -> fpToInteger sym "ceiling" r x
|
||||||
|
|
||||||
{-# INLINE truncV #-}
|
{-# INLINE truncV #-}
|
||||||
truncV :: Backend sym => sym -> Unary sym
|
truncV :: Backend sym => sym -> Unary sym
|
||||||
truncV sym = roundOp sym "trunc" opq
|
truncV sym = roundOp sym "trunc" opq opfp
|
||||||
where
|
where
|
||||||
opq = rationalTrunc sym
|
opq = rationalTrunc sym
|
||||||
|
opfp = \x -> fpRndRTZ sym >>= \r -> fpToInteger sym "trunc" r x
|
||||||
|
|
||||||
{-# INLINE roundAwayV #-}
|
{-# INLINE roundAwayV #-}
|
||||||
roundAwayV :: Backend sym => sym -> Unary sym
|
roundAwayV :: Backend sym => sym -> Unary sym
|
||||||
roundAwayV sym = roundOp sym "roundAway" opq
|
roundAwayV sym = roundOp sym "roundAway" opq opfp
|
||||||
where
|
where
|
||||||
opq = rationalRoundAway sym
|
opq = rationalRoundAway sym
|
||||||
|
opfp = \x -> fpRndRNA sym >>= \r -> fpToInteger sym "roundAway" r x
|
||||||
|
|
||||||
{-# INLINE roundToEvenV #-}
|
{-# INLINE roundToEvenV #-}
|
||||||
roundToEvenV :: Backend sym => sym -> Unary sym
|
roundToEvenV :: Backend sym => sym -> Unary sym
|
||||||
roundToEvenV sym = roundOp sym "roundToEven" opq
|
roundToEvenV sym = roundOp sym "roundToEven" opq opfp
|
||||||
where
|
where
|
||||||
opq = rationalRoundToEven sym
|
opq = rationalRoundToEven sym
|
||||||
|
opfp = \x -> fpRndRNE sym >>= \r -> fpToInteger sym "roundToEven" r x
|
||||||
|
|
||||||
--------------------------------------------------------------
|
--------------------------------------------------------------
|
||||||
-- Logic
|
-- Logic
|
||||||
@ -617,6 +683,7 @@ smodV sym =
|
|||||||
(SInteger Concrete -> SInteger 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) ->
|
(Integer -> SInteger Concrete -> SInteger Concrete -> SEval Concrete a -> SEval Concrete a) ->
|
||||||
(SRational Concrete -> SRational 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)
|
(TValue -> GenValue Concrete -> GenValue Concrete -> SEval Concrete a -> SEval Concrete a)
|
||||||
#-}
|
#-}
|
||||||
|
|
||||||
@ -628,13 +695,15 @@ cmpValue ::
|
|||||||
(SInteger sym -> SInteger 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) ->
|
(Integer -> SInteger sym -> SInteger sym -> SEval sym a -> SEval sym a) ->
|
||||||
(SRational sym -> SRational 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)
|
(TValue -> GenValue sym -> GenValue sym -> SEval sym a -> SEval sym a)
|
||||||
cmpValue sym fb fw fi fz fq = cmp
|
cmpValue sym fb fw fi fz fq ff = cmp
|
||||||
where
|
where
|
||||||
cmp ty v1 v2 k =
|
cmp ty v1 v2 k =
|
||||||
case ty of
|
case ty of
|
||||||
TVBit -> fb (fromVBit v1) (fromVBit v2) k
|
TVBit -> fb (fromVBit v1) (fromVBit v2) k
|
||||||
TVInteger -> fi (fromVInteger v1) (fromVInteger 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
|
TVIntMod n -> fz n (fromVInteger v1) (fromVInteger v2) k
|
||||||
TVRational -> fq (fromVRational v1) (fromVRational v2) k
|
TVRational -> fq (fromVRational v1) (fromVRational v2) k
|
||||||
TVArray{} -> panic "Cryptol.Prims.Value.cmpValue"
|
TVArray{} -> panic "Cryptol.Prims.Value.cmpValue"
|
||||||
@ -679,35 +748,38 @@ bitGreaterThan sym x y = bitLessThan sym y x
|
|||||||
|
|
||||||
{-# INLINE valEq #-}
|
{-# INLINE valEq #-}
|
||||||
valEq :: Backend sym => sym -> TValue -> GenValue sym -> GenValue sym -> SEval sym (SBit sym)
|
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 ty v1 v2 (pure $ bitLit sym True)
|
valEq sym ty v1 v2 = cmpValue sym fb fw fi fz fq ff ty v1 v2 (pure $ bitLit sym True)
|
||||||
where
|
where
|
||||||
fb x y k = eqCombine sym (bitEq sym x y) k
|
fb x y k = eqCombine sym (bitEq sym x y) k
|
||||||
fw x y k = eqCombine sym (wordEq 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
|
fi x y k = eqCombine sym (intEq sym x y) k
|
||||||
fz m x y k = eqCombine sym (znEq sym m 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
|
fq x y k = eqCombine sym (rationalEq sym x y) k
|
||||||
|
ff x y k = eqCombine sym (fpEq sym x y) k
|
||||||
|
|
||||||
{-# INLINE valLt #-}
|
{-# INLINE valLt #-}
|
||||||
valLt :: Backend sym =>
|
valLt :: Backend sym =>
|
||||||
sym -> TValue -> GenValue sym -> GenValue sym -> SBit sym -> SEval sym (SBit 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 ty v1 v2 (pure final)
|
valLt sym ty v1 v2 final = cmpValue sym fb fw fi fz fq ff ty v1 v2 (pure final)
|
||||||
where
|
where
|
||||||
fb x y k = lexCombine sym (bitLessThan sym x y) (bitEq sym x y) k
|
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
|
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
|
fi x y k = lexCombine sym (intLessThan sym x y) (intEq sym x y) k
|
||||||
fz _ _ _ _ = panic "valLt" ["Z_n is not in `Cmp`"]
|
fz _ _ _ _ = panic "valLt" ["Z_n is not in `Cmp`"]
|
||||||
fq x y k = lexCombine sym (rationalLessThan sym x y) (rationalEq sym x y) k
|
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 #-}
|
{-# INLINE valGt #-}
|
||||||
valGt :: Backend sym =>
|
valGt :: Backend sym =>
|
||||||
sym -> TValue -> GenValue sym -> GenValue sym -> SBit sym -> SEval sym (SBit 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 ty v1 v2 (pure final)
|
valGt sym ty v1 v2 final = cmpValue sym fb fw fi fz fq ff ty v1 v2 (pure final)
|
||||||
where
|
where
|
||||||
fb x y k = lexCombine sym (bitGreaterThan sym x y) (bitEq sym x y) k
|
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
|
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
|
fi x y k = lexCombine sym (intGreaterThan sym x y) (intEq sym x y) k
|
||||||
fz _ _ _ _ = panic "valGt" ["Z_n is not in `Cmp`"]
|
fz _ _ _ _ = panic "valGt" ["Z_n is not in `Cmp`"]
|
||||||
fq x y k = lexCombine sym (rationalGreaterThan sym x y) (rationalEq sym x y) k
|
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 #-}
|
{-# INLINE eqCombine #-}
|
||||||
eqCombine :: Backend sym =>
|
eqCombine :: Backend sym =>
|
||||||
@ -755,13 +827,14 @@ greaterThanEqV sym ty v1 v2 = VBit <$> valGt sym ty v1 v2 (bitLit sym True)
|
|||||||
|
|
||||||
{-# INLINE signedLessThanV #-}
|
{-# INLINE signedLessThanV #-}
|
||||||
signedLessThanV :: Backend sym => sym -> Binary sym
|
signedLessThanV :: Backend sym => sym -> Binary sym
|
||||||
signedLessThanV sym ty v1 v2 = VBit <$> cmpValue sym fb fw fi fz fq ty v1 v2 (pure $ bitLit sym False)
|
signedLessThanV sym ty v1 v2 = VBit <$> cmpValue sym fb fw fi fz fq ff ty v1 v2 (pure $ bitLit sym False)
|
||||||
where
|
where
|
||||||
fb _ _ _ = panic "signedLessThan" ["Attempted to perform signed comparison on bit type"]
|
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
|
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"]
|
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"]
|
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"]
|
fq _ _ _ = panic "signedLessThan" ["Attempted to perform signed comparison on Rational type"]
|
||||||
|
ff _ _ _ = panic "signedLessThan" ["Attempted to perform signed comparison on Float"]
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
@ -794,6 +867,10 @@ zeroV sym ty = case ty of
|
|||||||
|
|
||||||
TVArray{} -> evalPanic "zeroV" ["Array not in class Zero"]
|
TVArray{} -> evalPanic "zeroV" ["Array not in class Zero"]
|
||||||
|
|
||||||
|
-- floating point
|
||||||
|
TVFloat e p ->
|
||||||
|
VFloat <$> fpLit sym e p 0
|
||||||
|
|
||||||
-- sequences
|
-- sequences
|
||||||
TVSeq w ety
|
TVSeq w ety
|
||||||
| isTBit ety -> pure $ word sym w 0
|
| isTBit ety -> pure $ word sym w 0
|
||||||
@ -1199,6 +1276,7 @@ logicBinary sym opb opw = loop
|
|||||||
TVRational -> evalPanic "logicBinary" ["Rational not in class Logic"]
|
TVRational -> evalPanic "logicBinary" ["Rational not in class Logic"]
|
||||||
TVArray{} -> evalPanic "logicBinary" ["Array not in class Logic"]
|
TVArray{} -> evalPanic "logicBinary" ["Array not in class Logic"]
|
||||||
|
|
||||||
|
TVFloat {} -> evalPanic "logicBinary" ["Float not in class Logic"]
|
||||||
TVSeq w aty
|
TVSeq w aty
|
||||||
-- words
|
-- words
|
||||||
| isTBit aty
|
| isTBit aty
|
||||||
@ -1274,6 +1352,7 @@ logicUnary sym opb opw = loop
|
|||||||
|
|
||||||
TVInteger -> evalPanic "logicUnary" ["Integer not in class Logic"]
|
TVInteger -> evalPanic "logicUnary" ["Integer not in class Logic"]
|
||||||
TVIntMod _ -> evalPanic "logicUnary" ["Z 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"]
|
TVRational -> evalPanic "logicBinary" ["Rational not in class Logic"]
|
||||||
TVArray{} -> evalPanic "logicUnary" ["Array not in class Logic"]
|
TVArray{} -> evalPanic "logicUnary" ["Array not in class Logic"]
|
||||||
|
|
||||||
@ -1719,6 +1798,7 @@ errorV sym ty msg = case ty of
|
|||||||
TVIntMod _ -> cryUserError sym msg
|
TVIntMod _ -> cryUserError sym msg
|
||||||
TVRational -> cryUserError sym msg
|
TVRational -> cryUserError sym msg
|
||||||
TVArray{} -> cryUserError sym msg
|
TVArray{} -> cryUserError sym msg
|
||||||
|
TVFloat {} -> cryUserError sym msg
|
||||||
|
|
||||||
-- sequences
|
-- sequences
|
||||||
TVSeq w ety
|
TVSeq w ety
|
||||||
@ -1837,3 +1917,33 @@ mergeSeqMap :: Backend sym =>
|
|||||||
mergeSeqMap sym c x y =
|
mergeSeqMap sym c x y =
|
||||||
IndexSeqMap $ \i ->
|
IndexSeqMap $ \i ->
|
||||||
iteValue sym c (lookupSeqMap x i) (lookupSeqMap y i)
|
iteValue sym c (lookupSeqMap x i) (lookupSeqMap y i)
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
-- 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 -}
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
@ -9,6 +9,7 @@
|
|||||||
{-# LANGUAGE Safe #-}
|
{-# LANGUAGE Safe #-}
|
||||||
{-# LANGUAGE DeriveDataTypeable #-}
|
{-# LANGUAGE DeriveDataTypeable #-}
|
||||||
{-# LANGUAGE DeriveFunctor #-}
|
{-# LANGUAGE DeriveFunctor #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
module Cryptol.Eval.Monad
|
module Cryptol.Eval.Monad
|
||||||
( -- * Evaluation monad
|
( -- * Evaluation monad
|
||||||
@ -17,6 +18,8 @@ module Cryptol.Eval.Monad
|
|||||||
, EvalOpts(..)
|
, EvalOpts(..)
|
||||||
, getEvalOpts
|
, getEvalOpts
|
||||||
, PPOpts(..)
|
, PPOpts(..)
|
||||||
|
, PPFloatFormat(..)
|
||||||
|
, PPFloatExp(..)
|
||||||
, defaultPPOpts
|
, defaultPPOpts
|
||||||
, io
|
, io
|
||||||
, delayFill
|
, delayFill
|
||||||
@ -54,10 +57,25 @@ data PPOpts = PPOpts
|
|||||||
{ useAscii :: Bool
|
{ useAscii :: Bool
|
||||||
, useBase :: Int
|
, useBase :: Int
|
||||||
, useInfLength :: 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
|
||||||
defaultPPOpts = PPOpts { useAscii = False, useBase = 10, useInfLength = 5 }
|
defaultPPOpts = PPOpts { useAscii = False, useBase = 10, useInfLength = 5
|
||||||
|
, useFPBase = 16
|
||||||
|
, useFPFormat = FloatFree AutoExponent
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
-- | Some options for evalutaion
|
-- | Some options for evalutaion
|
||||||
data EvalOpts = EvalOpts
|
data EvalOpts = EvalOpts
|
||||||
@ -194,6 +212,8 @@ data EvalError
|
|||||||
| UserError String -- ^ Call to the Cryptol @error@ primitive
|
| UserError String -- ^ Call to the Cryptol @error@ primitive
|
||||||
| LoopError String -- ^ Detectable nontermination
|
| LoopError String -- ^ Detectable nontermination
|
||||||
| NoPrim Name -- ^ Primitive with no implementation
|
| NoPrim Name -- ^ Primitive with no implementation
|
||||||
|
| BadRoundingMode Integer -- ^ Invalid rounding mode
|
||||||
|
| BadValue String -- ^ Value outside the domain of a partial function.
|
||||||
deriving (Typeable,Show)
|
deriving (Typeable,Show)
|
||||||
|
|
||||||
instance PP EvalError where
|
instance PP EvalError where
|
||||||
@ -208,6 +228,8 @@ instance PP EvalError where
|
|||||||
text "word too wide for memory:" <+> integer w <+> text "bits"
|
text "word too wide for memory:" <+> integer w <+> text "bits"
|
||||||
UserError x -> text "Run-time error:" <+> text x
|
UserError x -> text "Run-time error:" <+> text x
|
||||||
LoopError x -> text "<<loop>>" <+> text x
|
LoopError x -> text "<<loop>>" <+> text x
|
||||||
|
BadRoundingMode r -> "invalid rounding mode" <+> integer r
|
||||||
|
BadValue x -> "invalid input for" <+> backticks (text x)
|
||||||
NoPrim x -> text "unimplemented primitive:" <+> pp x
|
NoPrim x -> text "unimplemented primitive:" <+> pp x
|
||||||
|
|
||||||
instance X.Exception EvalError
|
instance X.Exception EvalError
|
||||||
|
@ -8,6 +8,7 @@
|
|||||||
> -- Portability : portable
|
> -- Portability : portable
|
||||||
>
|
>
|
||||||
> {-# LANGUAGE PatternGuards #-}
|
> {-# LANGUAGE PatternGuards #-}
|
||||||
|
> {-# LANGUAGE BlockArguments #-}
|
||||||
>
|
>
|
||||||
> module Cryptol.Eval.Reference
|
> module Cryptol.Eval.Reference
|
||||||
> ( Value(..)
|
> ( Value(..)
|
||||||
@ -19,6 +20,7 @@
|
|||||||
>
|
>
|
||||||
> import Control.Applicative (liftA2)
|
> import Control.Applicative (liftA2)
|
||||||
> import Data.Bits
|
> import Data.Bits
|
||||||
|
> import Data.Ratio((%))
|
||||||
> import Data.List
|
> import Data.List
|
||||||
> (genericDrop, genericIndex, genericLength, genericReplicate, genericSplitAt,
|
> (genericDrop, genericIndex, genericLength, genericReplicate, genericSplitAt,
|
||||||
> genericTake, sortBy)
|
> genericTake, sortBy)
|
||||||
@ -26,6 +28,8 @@
|
|||||||
> import Data.Map (Map)
|
> import Data.Map (Map)
|
||||||
> import qualified Data.Map as Map
|
> import qualified Data.Map as Map
|
||||||
> import qualified Data.Text as T (pack)
|
> import qualified Data.Text as T (pack)
|
||||||
|
> import LibBF (BigFloat)
|
||||||
|
> import qualified LibBF as FP
|
||||||
>
|
>
|
||||||
> import Cryptol.ModuleSystem.Name (asPrim)
|
> import Cryptol.ModuleSystem.Name (asPrim)
|
||||||
> import Cryptol.TypeCheck.Solver.InfNat (Nat'(..), nAdd, nMin, nMul)
|
> import Cryptol.TypeCheck.Solver.InfNat (Nat'(..), nAdd, nMin, nMul)
|
||||||
@ -33,7 +37,9 @@
|
|||||||
> import Cryptol.Eval.Monad (EvalError(..), PPOpts(..))
|
> import Cryptol.Eval.Monad (EvalError(..), PPOpts(..))
|
||||||
> import Cryptol.Eval.Type (TValue(..), isTBit, evalValType, evalNumType, tvSeq)
|
> import Cryptol.Eval.Type (TValue(..), isTBit, evalValType, evalNumType, tvSeq)
|
||||||
> import Cryptol.Eval.Concrete (mkBv, ppBV, lg2)
|
> import Cryptol.Eval.Concrete (mkBv, ppBV, lg2)
|
||||||
> import Cryptol.Utils.Ident (Ident, mkIdent)
|
> import Cryptol.Eval.Concrete.FloatHelpers(fpPP,fpToI,BF(..),fpRound)
|
||||||
|
> import Cryptol.Eval.Concrete.Float(floatFromBits,floatToBits)
|
||||||
|
> import Cryptol.Utils.Ident (Ident,PrimIdent, prelPrim, floatPrim)
|
||||||
> import Cryptol.Utils.Panic (panic)
|
> import Cryptol.Utils.Panic (panic)
|
||||||
> import Cryptol.Utils.PP
|
> import Cryptol.Utils.PP
|
||||||
>
|
>
|
||||||
@ -68,6 +74,7 @@ are as follows:
|
|||||||
| `Integer` | integers | `TVInteger` |
|
| `Integer` | integers | `TVInteger` |
|
||||||
| `Z n` | integers modulo n | `TVIntMod n` |
|
| `Z n` | integers modulo n | `TVIntMod n` |
|
||||||
| `Rational` | rationals | `TVRational` |
|
| `Rational` | rationals | `TVRational` |
|
||||||
|
| `Float e p` | floating point | `TVFloat` |
|
||||||
| `Array` | arrays | `TVArray` |
|
| `Array` | arrays | `TVArray` |
|
||||||
| `[n]a` | finite lists | `TVSeq n a` |
|
| `[n]a` | finite lists | `TVSeq n a` |
|
||||||
| `[inf]a` | infinite lists | `TVStream a` |
|
| `[inf]a` | infinite lists | `TVStream a` |
|
||||||
@ -123,6 +130,7 @@ terms by providing an evaluator to an appropriate `Value` type.
|
|||||||
> = VBit (Either EvalError Bool) -- ^ @ Bit @ booleans
|
> = VBit (Either EvalError Bool) -- ^ @ Bit @ booleans
|
||||||
> | VInteger (Either EvalError Integer) -- ^ @ Integer @ or @Z n@ integers
|
> | VInteger (Either EvalError Integer) -- ^ @ Integer @ or @Z n@ integers
|
||||||
> | VRational (Either EvalError Rational) -- ^ @ Rational @ rationals
|
> | VRational (Either EvalError Rational) -- ^ @ Rational @ rationals
|
||||||
|
> | VFloat (Either EvalError BF) -- ^ Floating point numbers
|
||||||
> | VList Nat' [Value] -- ^ @ [n]a @ finite or infinite lists
|
> | VList Nat' [Value] -- ^ @ [n]a @ finite or infinite lists
|
||||||
> | VTuple [Value] -- ^ @ ( .. ) @ tuples
|
> | VTuple [Value] -- ^ @ ( .. ) @ tuples
|
||||||
> | VRecord [(Ident, Value)] -- ^ @ { .. } @ records
|
> | VRecord [(Ident, Value)] -- ^ @ { .. } @ records
|
||||||
@ -177,6 +185,7 @@ cpo that represents any given schema.
|
|||||||
> TVInteger -> VInteger (fromVInteger val)
|
> TVInteger -> VInteger (fromVInteger val)
|
||||||
> TVIntMod _ -> VInteger (fromVInteger val)
|
> TVIntMod _ -> VInteger (fromVInteger val)
|
||||||
> TVRational -> VRational (fromVRational val)
|
> TVRational -> VRational (fromVRational val)
|
||||||
|
> TVFloat _ _ -> VFloat (fromVFloat' val)
|
||||||
> TVArray{} -> evalPanic "copyByTValue" ["Unsupported Array type"]
|
> TVArray{} -> evalPanic "copyByTValue" ["Unsupported Array type"]
|
||||||
> TVSeq w ety -> VList (Nat w) (map (go ety) (copyList w (fromVList val)))
|
> TVSeq w ety -> VList (Nat w) (map (go ety) (copyList w (fromVList val)))
|
||||||
> TVStream ety -> VList Inf (map (go ety) (copyStream (fromVList val)))
|
> TVStream ety -> VList Inf (map (go ety) (copyStream (fromVList val)))
|
||||||
@ -209,6 +218,19 @@ Operations on Values
|
|||||||
> fromVRational :: Value -> Either EvalError Rational
|
> fromVRational :: Value -> Either EvalError Rational
|
||||||
> fromVRational (VRational i) = i
|
> fromVRational (VRational i) = i
|
||||||
> fromVRational _ = evalPanic "fromVRational" ["Expected a rational"]
|
> 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@.
|
> -- | Destructor for @VList@.
|
||||||
> fromVList :: Value -> [Value]
|
> fromVList :: Value -> [Value]
|
||||||
@ -410,6 +432,7 @@ down to the individual bits.
|
|||||||
> VBit b -> VBit (condBit c b (fromVBit r))
|
> VBit b -> VBit (condBit c b (fromVBit r))
|
||||||
> VInteger i -> VInteger (condBit c i (fromVInteger r))
|
> VInteger i -> VInteger (condBit c i (fromVInteger r))
|
||||||
> VRational x -> VRational (condBit c x (fromVRational 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))
|
> VList n vs -> VList n (zipWith (condValue c) vs (fromVList r))
|
||||||
> VTuple vs -> VTuple (zipWith (condValue c) vs (fromVTuple r))
|
> VTuple vs -> VTuple (zipWith (condValue c) vs (fromVTuple r))
|
||||||
> VRecord fs -> VRecord [ (f, condValue c v (lookupRecord f r)) | (f, v) <- fs ]
|
> VRecord fs -> VRecord [ (f, condValue c v (lookupRecord f r)) | (f, v) <- fs ]
|
||||||
@ -572,8 +595,14 @@ by corresponding typeclasses
|
|||||||
|
|
||||||
* Miscellaneous: `error`, `random`, `trace`
|
* Miscellaneous: `error`, `random`, `trace`
|
||||||
|
|
||||||
> primTable :: Map Ident Value
|
> primTable :: Map PrimIdent Value
|
||||||
> primTable = Map.fromList $ map (\(n, v) -> (mkIdent (T.pack n), v))
|
> primTable = Map.unions
|
||||||
|
> [ cryptolPrimTable
|
||||||
|
> , floatPrimTable
|
||||||
|
> ]
|
||||||
|
|
||||||
|
> cryptolPrimTable :: Map PrimIdent Value
|
||||||
|
> cryptolPrimTable = Map.fromList $ map (\(n, v) -> (prelPrim (T.pack n), v))
|
||||||
>
|
>
|
||||||
> -- Literals
|
> -- Literals
|
||||||
> [ ("True" , VBit (Right True))
|
> [ ("True" , VBit (Right True))
|
||||||
@ -581,6 +610,10 @@ by corresponding typeclasses
|
|||||||
> , ("number" , vFinPoly $ \val ->
|
> , ("number" , vFinPoly $ \val ->
|
||||||
> VPoly $ \a ->
|
> VPoly $ \a ->
|
||||||
> literal val a)
|
> literal val a)
|
||||||
|
> , ("fraction" , vFinPoly \top ->
|
||||||
|
> vFinPoly \bot ->
|
||||||
|
> vFinPoly \rnd ->
|
||||||
|
> VPoly \a -> fraction top bot rnd a)
|
||||||
> -- Zero
|
> -- Zero
|
||||||
> , ("zero" , VPoly zero)
|
> , ("zero" , VPoly zero)
|
||||||
>
|
>
|
||||||
@ -591,13 +624,26 @@ by corresponding typeclasses
|
|||||||
> , ("complement" , unary (logicUnary not))
|
> , ("complement" , unary (logicUnary not))
|
||||||
>
|
>
|
||||||
> -- Ring
|
> -- Ring
|
||||||
> , ("+" , binary (ringBinary (\x y -> Right (x + y)) (\x y -> Right (x + y))) )
|
> , ("+" , binary (ringBinary
|
||||||
> , ("-" , binary (ringBinary (\x y -> Right (x - y)) (\x y -> Right (x - y))) )
|
> (\x y -> Right (x + y))
|
||||||
> , ("*" , binary (ringBinary (\x y -> Right (x * y)) (\x y -> Right (x * y))) )
|
> (\x y -> Right (x + y))
|
||||||
> , ("negate" , unary (ringUnary (\x -> Right (- x)) (\x -> Right (- x))))
|
> (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 ->
|
> , ("fromInteger", VPoly $ \a ->
|
||||||
> VFun $ \x ->
|
> VFun $ \x ->
|
||||||
> ringNullary (fromVInteger x) (fromInteger <$> fromVInteger x) a)
|
> ringNullary (fromVInteger x)
|
||||||
|
> (fromInteger <$> fromVInteger x)
|
||||||
|
> (\e p -> fpFromInteger e p <$> fromVInteger x)
|
||||||
|
> a)
|
||||||
>
|
>
|
||||||
> -- Integral
|
> -- Integral
|
||||||
> , ("toInteger" , VPoly $ \a ->
|
> , ("toInteger" , VPoly $ \a ->
|
||||||
@ -612,15 +658,28 @@ by corresponding typeclasses
|
|||||||
> ringExp aty a (cryToInteger ety e))
|
> ringExp aty a (cryToInteger ety e))
|
||||||
>
|
>
|
||||||
> -- Field
|
> -- Field
|
||||||
> , ("/." , binary (fieldBinary ratDiv))
|
> , ("/." , binary (fieldBinary ratDiv
|
||||||
> , ("recip" , unary (fieldUnary ratRecip))
|
> (fpBin FP.bfDiv fpImplicitRound)
|
||||||
|
> ))
|
||||||
|
|
||||||
|
> , ("recip" , unary (fieldUnary ratRecip fpRecip))
|
||||||
>
|
>
|
||||||
> -- Round
|
> -- Round
|
||||||
> , ("floor" , unary (roundUnary floor))
|
> , ("floor" , unary (roundUnary floor
|
||||||
> , ("ceiling" , unary (roundUnary ceiling))
|
> (fpToInteger "floor" FP.ToNegInf)
|
||||||
> , ("trunc" , unary (roundUnary truncate))
|
> ))
|
||||||
> , ("roundAway" , unary (roundUnary roundAwayRat))
|
> , ("ceiling" , unary (roundUnary ceiling
|
||||||
> , ("roundToEven", unary (roundUnary round))
|
> (fpToInteger "ceiling" FP.ToPosInf)
|
||||||
|
> ))
|
||||||
|
> , ("trunc" , unary (roundUnary truncate
|
||||||
|
> (fpToInteger "trunc" FP.ToZero)
|
||||||
|
> ))
|
||||||
|
> , ("roundAway", unary (roundUnary roundAwayRat
|
||||||
|
> (fpToInteger "roundAway" FP.Away)
|
||||||
|
> ))
|
||||||
|
> , ("roundToEven", unary (roundUnary round
|
||||||
|
> (fpToInteger "roundToEven" FP.NearEven)
|
||||||
|
> ))
|
||||||
>
|
>
|
||||||
> -- Comparison
|
> -- Comparison
|
||||||
> , ("<" , binary (cmpOrder (\o -> o == LT)))
|
> , ("<" , binary (cmpOrder (\o -> o == LT)))
|
||||||
@ -759,6 +818,8 @@ by corresponding typeclasses
|
|||||||
> VFun $ \_x ->
|
> VFun $ \_x ->
|
||||||
> VFun $ \y -> y)
|
> VFun $ \y -> y)
|
||||||
> ]
|
> ]
|
||||||
|
>
|
||||||
|
|
||||||
>
|
>
|
||||||
> unary :: (TValue -> Value -> Value) -> Value
|
> unary :: (TValue -> Value -> Value) -> Value
|
||||||
> unary f = VPoly $ \ty -> VFun $ \x -> f ty x
|
> unary f = VPoly $ \ty -> VFun $ \x -> f ty x
|
||||||
@ -824,6 +885,7 @@ where the given error is "pushed down" into the leaf types.
|
|||||||
> cryError e TVInteger = VInteger (Left e)
|
> cryError e TVInteger = VInteger (Left e)
|
||||||
> cryError e TVIntMod{} = VInteger (Left e)
|
> cryError e TVIntMod{} = VInteger (Left e)
|
||||||
> cryError e TVRational = VRational (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 _ TVArray{} = evalPanic "error" ["Array type not supported in `error`"]
|
||||||
> cryError e (TVSeq n ety) = VList (Nat n) (genericReplicate n (cryError e ety))
|
> 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 (TVStream ety) = VList Inf (repeat (cryError e ety))
|
||||||
@ -849,6 +911,7 @@ For functions, `zero` returns the constant function that returns
|
|||||||
> zero TVInteger = VInteger (Right 0)
|
> zero TVInteger = VInteger (Right 0)
|
||||||
> zero TVIntMod{} = VInteger (Right 0)
|
> zero TVIntMod{} = VInteger (Right 0)
|
||||||
> zero TVRational = VRational (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 TVArray{} = evalPanic "zero" ["Array type not in `Zero`"]
|
||||||
> zero (TVSeq n ety) = VList (Nat n) (genericReplicate n (zero ety))
|
> zero (TVSeq n ety) = VList (Nat n) (genericReplicate n (zero ety))
|
||||||
> zero (TVStream ety) = VList Inf (repeat (zero ety))
|
> zero (TVStream ety) = VList Inf (repeat (zero ety))
|
||||||
@ -876,6 +939,22 @@ Given a literal integer, construct a value of a type that can represent that lit
|
|||||||
> go ty = evalPanic "literal" [show ty ++ " cannot represent literals"]
|
> 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 $ fpCheckStatus val
|
||||||
|
> where val = FP.bfDiv opts (FP.bfFromInteger top) (FP.bfFromInteger btm)
|
||||||
|
> opts = fpOpts e p fpImplicitRound
|
||||||
|
> _ -> evalPanic "fraction" [show ty ++ " cannot represent " ++
|
||||||
|
> show top ++ "/" ++ show btm]
|
||||||
|
|
||||||
|
|
||||||
Logic
|
Logic
|
||||||
-----
|
-----
|
||||||
|
|
||||||
@ -902,6 +981,7 @@ at the same positions.
|
|||||||
> TVIntMod _ -> evalPanic "logicUnary" ["Z not in class Logic"]
|
> TVIntMod _ -> evalPanic "logicUnary" ["Z not in class Logic"]
|
||||||
> TVArray{} -> evalPanic "logicUnary" ["Array not in class Logic"]
|
> TVArray{} -> evalPanic "logicUnary" ["Array not in class Logic"]
|
||||||
> TVRational -> evalPanic "logicUnary" ["Rational 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`"]
|
> TVAbstract{} -> evalPanic "logicUnary" ["Abstract type not in `Logic`"]
|
||||||
|
|
||||||
> logicBinary :: (Bool -> Bool -> Bool) -> TValue -> Value -> Value -> Value
|
> logicBinary :: (Bool -> Bool -> Bool) -> TValue -> Value -> Value -> Value
|
||||||
@ -921,6 +1001,7 @@ at the same positions.
|
|||||||
> TVIntMod _ -> evalPanic "logicBinary" ["Z not in class Logic"]
|
> TVIntMod _ -> evalPanic "logicBinary" ["Z not in class Logic"]
|
||||||
> TVArray{} -> evalPanic "logicBinary" ["Array not in class Logic"]
|
> TVArray{} -> evalPanic "logicBinary" ["Array not in class Logic"]
|
||||||
> TVRational -> evalPanic "logicBinary" ["Rational 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`"]
|
> TVAbstract{} -> evalPanic "logicBinary" ["Abstract type not in `Logic`"]
|
||||||
|
|
||||||
|
|
||||||
@ -937,8 +1018,9 @@ False]`, but to `[error "foo", error "foo"]`.
|
|||||||
> ringNullary ::
|
> ringNullary ::
|
||||||
> Either EvalError Integer ->
|
> Either EvalError Integer ->
|
||||||
> Either EvalError Rational ->
|
> Either EvalError Rational ->
|
||||||
|
> (Integer -> Integer -> Either EvalError BigFloat) ->
|
||||||
> TValue -> Value
|
> TValue -> Value
|
||||||
> ringNullary i q = go
|
> ringNullary i q fl = go
|
||||||
> where
|
> where
|
||||||
> go :: TValue -> Value
|
> go :: TValue -> Value
|
||||||
> go ty =
|
> go ty =
|
||||||
@ -951,6 +1033,8 @@ False]`, but to `[error "foo", error "foo"]`.
|
|||||||
> VInteger (flip mod n <$> i)
|
> VInteger (flip mod n <$> i)
|
||||||
> TVRational ->
|
> TVRational ->
|
||||||
> VRational q
|
> VRational q
|
||||||
|
> TVFloat e p ->
|
||||||
|
> VFloat (fpToBF e p <$> fl e p)
|
||||||
> TVArray{} ->
|
> TVArray{} ->
|
||||||
> evalPanic "arithNullary" ["Array not in class Ring"]
|
> evalPanic "arithNullary" ["Array not in class Ring"]
|
||||||
> TVSeq w a
|
> TVSeq w a
|
||||||
@ -970,8 +1054,9 @@ False]`, but to `[error "foo", error "foo"]`.
|
|||||||
> ringUnary ::
|
> ringUnary ::
|
||||||
> (Integer -> Either EvalError Integer) ->
|
> (Integer -> Either EvalError Integer) ->
|
||||||
> (Rational -> Either EvalError Rational) ->
|
> (Rational -> Either EvalError Rational) ->
|
||||||
|
> (Integer -> Integer -> BigFloat -> Either EvalError BigFloat) ->
|
||||||
> TValue -> Value -> Value
|
> TValue -> Value -> Value
|
||||||
> ringUnary iop qop = go
|
> ringUnary iop qop flop = go
|
||||||
> where
|
> where
|
||||||
> go :: TValue -> Value -> Value
|
> go :: TValue -> Value -> Value
|
||||||
> go ty val =
|
> go ty val =
|
||||||
@ -986,6 +1071,8 @@ False]`, but to `[error "foo", error "foo"]`.
|
|||||||
> VInteger $ appOp1 (\i -> flip mod n <$> iop i) (fromVInteger val)
|
> VInteger $ appOp1 (\i -> flip mod n <$> iop i) (fromVInteger val)
|
||||||
> TVRational ->
|
> TVRational ->
|
||||||
> VRational $ appOp1 qop (fromVRational val)
|
> VRational $ appOp1 qop (fromVRational val)
|
||||||
|
> TVFloat e p ->
|
||||||
|
> VFloat (fpToBF e p <$> appOp1 (flop e p) (fromVFloat val))
|
||||||
> TVSeq w a
|
> TVSeq w a
|
||||||
> | isTBit a -> vWord w (iop =<< fromVWord val)
|
> | isTBit a -> vWord w (iop =<< fromVWord val)
|
||||||
> | otherwise -> VList (Nat w) (map (go a) (fromVList val))
|
> | otherwise -> VList (Nat w) (map (go a) (fromVList val))
|
||||||
@ -1003,8 +1090,9 @@ False]`, but to `[error "foo", error "foo"]`.
|
|||||||
> ringBinary ::
|
> ringBinary ::
|
||||||
> (Integer -> Integer -> Either EvalError Integer) ->
|
> (Integer -> Integer -> Either EvalError Integer) ->
|
||||||
> (Rational -> Rational -> Either EvalError Rational) ->
|
> (Rational -> Rational -> Either EvalError Rational) ->
|
||||||
|
> (Integer -> Integer -> BigFloat -> BigFloat -> Either EvalError BigFloat) ->
|
||||||
> TValue -> Value -> Value -> Value
|
> TValue -> Value -> Value -> Value
|
||||||
> ringBinary iop qop = go
|
> ringBinary iop qop flop = go
|
||||||
> where
|
> where
|
||||||
> go :: TValue -> Value -> Value -> Value
|
> go :: TValue -> Value -> Value -> Value
|
||||||
> go ty l r =
|
> go ty l r =
|
||||||
@ -1017,6 +1105,8 @@ False]`, but to `[error "foo", error "foo"]`.
|
|||||||
> VInteger $ appOp2 (\i j -> flip mod n <$> iop i j) (fromVInteger l) (fromVInteger r)
|
> VInteger $ appOp2 (\i j -> flip mod n <$> iop i j) (fromVInteger l) (fromVInteger r)
|
||||||
> TVRational ->
|
> TVRational ->
|
||||||
> VRational $ appOp2 qop (fromVRational l) (fromVRational r)
|
> VRational $ appOp2 qop (fromVRational l) (fromVRational r)
|
||||||
|
> TVFloat e p ->
|
||||||
|
> VFloat $ fpToBF e p <$> appOp2 (flop e p) (fromVFloat l) (fromVFloat r)
|
||||||
> TVArray{} ->
|
> TVArray{} ->
|
||||||
> evalPanic "arithBinary" ["Array not in class Ring"]
|
> evalPanic "arithBinary" ["Array not in class Ring"]
|
||||||
> TVSeq w a
|
> TVSeq w a
|
||||||
@ -1056,9 +1146,12 @@ Integral
|
|||||||
>
|
>
|
||||||
> ringExp :: TValue -> Value -> Either EvalError Integer -> Value
|
> ringExp :: TValue -> Value -> Either EvalError Integer -> Value
|
||||||
> ringExp a _ (Left e) = cryError e a
|
> ringExp a _ (Left e) = cryError e a
|
||||||
> ringExp a v (Right i) = foldl mul (literal 1 a) (genericReplicate i v)
|
> ringExp a v (Right i) = foldl (ringMul a) (literal 1 a) (genericReplicate i v)
|
||||||
> where
|
>
|
||||||
> mul = ringBinary (\x y -> Right (x * y)) (\x y -> Right (x * y)) a
|
> 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
|
Signed bitvector division (`/$`) and remainder (`%$`) are defined so
|
||||||
@ -1085,16 +1178,22 @@ Types that represent fields are have, in addition to the ring operations
|
|||||||
a recipricol operator and a field division operator (not to be
|
a recipricol operator and a field division operator (not to be
|
||||||
confused with integral division).
|
confused with integral division).
|
||||||
|
|
||||||
> fieldUnary :: (Rational -> Either EvalError Rational) -> TValue -> Value -> Value
|
> fieldUnary :: (Rational -> Either EvalError Rational) ->
|
||||||
> fieldUnary qop ty v = case ty of
|
> (Integer -> Integer -> BigFloat -> Either EvalError BigFloat) ->
|
||||||
> TVRational -> VRational $ appOp1 qop (fromVRational v)
|
> 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"]
|
> _ -> evalPanic "fieldUnary" [show ty ++ " is not a Field type"]
|
||||||
>
|
>
|
||||||
> fieldBinary ::
|
> fieldBinary ::
|
||||||
> (Rational -> Rational -> Either EvalError Rational) ->
|
> (Rational -> Rational -> Either EvalError Rational) ->
|
||||||
|
> (Integer -> Integer -> BigFloat -> BigFloat -> Either EvalError BigFloat) ->
|
||||||
> TValue -> Value -> Value -> Value
|
> TValue -> Value -> Value -> Value
|
||||||
> fieldBinary qop ty l r = case ty of
|
> fieldBinary qop flop ty l r = case ty of
|
||||||
> TVRational -> VRational $ appOp2 qop (fromVRational l) (fromVRational r)
|
> 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"]
|
> _ -> evalPanic "fieldBinary" [show ty ++ " is not a Field type"]
|
||||||
>
|
>
|
||||||
> ratDiv :: Rational -> Rational -> Either EvalError Rational
|
> ratDiv :: Rational -> Rational -> Either EvalError Rational
|
||||||
@ -1109,9 +1208,12 @@ confused with integral division).
|
|||||||
Round
|
Round
|
||||||
-----
|
-----
|
||||||
|
|
||||||
> roundUnary :: (Rational -> Integer) -> TValue -> Value -> Value
|
> roundUnary :: (Rational -> Integer) ->
|
||||||
> roundUnary op ty v = case ty of
|
> (Integer -> Integer -> BigFloat -> Either EvalError Integer) ->
|
||||||
|
> TValue -> Value -> Value
|
||||||
|
> roundUnary op flop ty v = case ty of
|
||||||
> TVRational -> VInteger (op <$> fromVRational v)
|
> TVRational -> VInteger (op <$> fromVRational v)
|
||||||
|
> TVFloat e p -> VInteger (flop e p =<< fromVFloat v)
|
||||||
> _ -> evalPanic "roundUnary" [show ty ++ " is not a Round type"]
|
> _ -> evalPanic "roundUnary" [show ty ++ " is not a Round type"]
|
||||||
>
|
>
|
||||||
|
|
||||||
@ -1162,6 +1264,8 @@ bits to the *left* of that position are equal.
|
|||||||
> compare <$> fromVInteger l <*> fromVInteger r
|
> compare <$> fromVInteger l <*> fromVInteger r
|
||||||
> TVRational ->
|
> TVRational ->
|
||||||
> compare <$> fromVRational l <*> fromVRational r
|
> compare <$> fromVRational l <*> fromVRational r
|
||||||
|
> TVFloat{} ->
|
||||||
|
> compare <$> fromVFloat l <*> fromVFloat r
|
||||||
> TVArray{} ->
|
> TVArray{} ->
|
||||||
> evalPanic "lexCompare" ["invalid type"]
|
> evalPanic "lexCompare" ["invalid type"]
|
||||||
> TVSeq _w ety ->
|
> TVSeq _w ety ->
|
||||||
@ -1209,6 +1313,8 @@ fields are compared in alphabetical order.
|
|||||||
> evalPanic "lexSignedCompare" ["invalid type"]
|
> evalPanic "lexSignedCompare" ["invalid type"]
|
||||||
> TVRational ->
|
> TVRational ->
|
||||||
> evalPanic "lexSignedCompare" ["invalid type"]
|
> evalPanic "lexSignedCompare" ["invalid type"]
|
||||||
|
> TVFloat{} ->
|
||||||
|
> evalPanic "lexSignedCompare" ["invalid type"]
|
||||||
> TVArray{} ->
|
> TVArray{} ->
|
||||||
> evalPanic "lexSignedCompare" ["invalid type"]
|
> evalPanic "lexSignedCompare" ["invalid type"]
|
||||||
> TVSeq _w ety
|
> TVSeq _w ety
|
||||||
@ -1389,6 +1495,113 @@ length of the list produces a run-time error.
|
|||||||
> updateAt (x : xs) i y = x : updateAt xs (i - 1) y
|
> 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
|
||||||
|
|
||||||
|
The function `fpOpts` deifnes an object specifying the precision and rounding
|
||||||
|
mode to be used during a floating point computation. We assume that its
|
||||||
|
aruments are known to be within the limits imposed by the concrete
|
||||||
|
library used to perform the computation.
|
||||||
|
|
||||||
|
> fpOpts :: Integer -> Integer -> FP.RoundMode -> FP.BFOpts
|
||||||
|
> fpOpts e p r = FP.expBits (fromInteger e) <>
|
||||||
|
> FP.precBits (fromInteger p) <>
|
||||||
|
> FP.rnd r
|
||||||
|
|
||||||
|
Most floating point computations produce a result and some additional
|
||||||
|
information about what happened while computing. The function
|
||||||
|
`fpCheckStatus` examines this status and reports erorrs in unusual situations.
|
||||||
|
|
||||||
|
> fpCheckStatus :: (FP.BigFloat, FP.Status) -> FP.BigFloat
|
||||||
|
> fpCheckStatus (r,s) =
|
||||||
|
> case s of
|
||||||
|
> FP.MemError -> panic "fpCheckStatus" [ "Out of memory" ]
|
||||||
|
> _ -> r
|
||||||
|
|
||||||
|
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 = fpCheckStatus . FP.bfRoundFloat opts . FP.bfFromInteger
|
||||||
|
> where opts = fpOpts e p fpImplicitRound
|
||||||
|
|
||||||
|
> fpToInteger ::
|
||||||
|
> String -> FP.RoundMode ->
|
||||||
|
> Integer -> Integer ->
|
||||||
|
> BigFloat -> Either EvalError Integer
|
||||||
|
> fpToInteger fun r _ _ f =
|
||||||
|
> case fpToI r f of
|
||||||
|
> Nothing -> Left (BadValue fun)
|
||||||
|
> Just i -> Right i
|
||||||
|
|
||||||
|
|
||||||
|
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 (fpCheckStatus (f (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 = Right (fpCheckStatus (FP.bfDiv opts (FP.bfFromInteger 1) x))
|
||||||
|
> where opts = 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 (floatFromBits e p <$> fromVWord bvv)
|
||||||
|
>
|
||||||
|
> , "fpToBits" ~> vFinPoly \e -> vFinPoly \p -> VFun \fpv ->
|
||||||
|
> vWord (e + p) (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)
|
||||||
|
>
|
||||||
|
> , "fpAdd" ~> fpArith FP.bfAdd
|
||||||
|
> , "fpSub" ~> fpArith FP.bfSub
|
||||||
|
> , "fpMul" ~> fpArith FP.bfMul
|
||||||
|
> , "fpDiv" ~> fpArith FP.bfDiv
|
||||||
|
> ]
|
||||||
|
> where
|
||||||
|
> (~>) = (,)
|
||||||
|
> fpArith f = vFinPoly \e -> vFinPoly \p ->
|
||||||
|
> VFun \vr -> VFun \xv -> VFun \yv ->
|
||||||
|
> VFloat do r <- fromVWord vr
|
||||||
|
> rnd <- case fpRound r of
|
||||||
|
> Just r' -> pure r'
|
||||||
|
> Nothing -> Left (BadRoundingMode r)
|
||||||
|
> x <- fromVFloat xv
|
||||||
|
> y <- fromVFloat yv
|
||||||
|
> fpToBF e p <$> fpBin f rnd e p x y
|
||||||
|
|
||||||
|
|
||||||
Error Handling
|
Error Handling
|
||||||
--------------
|
--------------
|
||||||
|
|
||||||
@ -1409,6 +1622,7 @@ Pretty Printing
|
|||||||
> VBit b -> text (either show show b)
|
> VBit b -> text (either show show b)
|
||||||
> VInteger i -> text (either show show i)
|
> VInteger i -> text (either show show i)
|
||||||
> VRational q -> text (either show show q)
|
> VRational q -> text (either show show q)
|
||||||
|
> VFloat fl -> text (either show (show . fpPP opts) fl)
|
||||||
> VList l vs ->
|
> VList l vs ->
|
||||||
> case l of
|
> case l of
|
||||||
> Inf -> ppList (map (ppValue opts) (take (useInfLength opts) vs) ++ [text "..."])
|
> Inf -> ppList (map (ppValue opts) (take (useInfLength opts) vs) ++ [text "..."])
|
||||||
|
@ -141,7 +141,7 @@ instance Backend SBV where
|
|||||||
type SBit SBV = SVal
|
type SBit SBV = SVal
|
||||||
type SWord SBV = SVal
|
type SWord SBV = SVal
|
||||||
type SInteger SBV = SVal
|
type SInteger SBV = SVal
|
||||||
|
type SFloat SBV = () -- XXX: not implemented
|
||||||
type SEval SBV = SBVEval
|
type SEval SBV = SBVEval
|
||||||
|
|
||||||
raiseError _ err = SBVEval (pure (SBVError err))
|
raiseError _ err = SBVEval (pure (SBVError err))
|
||||||
@ -312,6 +312,23 @@ instance Backend SBV where
|
|||||||
znMult _ m a b = sModMult m a b
|
znMult _ m a b = sModMult m a b
|
||||||
znNegate _ m a = sModNegate m a
|
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 :: SWord SBV -> SInteger SBV
|
||||||
svToInteger w =
|
svToInteger w =
|
||||||
case svAsInteger w of
|
case svAsInteger w of
|
||||||
@ -333,18 +350,20 @@ evalPanic cxt = panic ("[Symbolic]" ++ cxt)
|
|||||||
|
|
||||||
-- Primitives ------------------------------------------------------------------
|
-- Primitives ------------------------------------------------------------------
|
||||||
|
|
||||||
evalPrim :: Ident -> Maybe Value
|
evalPrim :: PrimIdent -> Maybe Value
|
||||||
evalPrim prim = Map.lookup prim primTable
|
evalPrim prim = Map.lookup prim primTable
|
||||||
|
|
||||||
-- See also Cryptol.Eval.Concrete.primTable
|
-- See also Cryptol.Eval.Concrete.primTable
|
||||||
primTable :: Map.Map Ident Value
|
primTable :: Map.Map PrimIdent Value
|
||||||
primTable = let sym = SBV in
|
primTable = let sym = SBV in
|
||||||
Map.fromList $ map (\(n, v) -> (mkIdent (T.pack n), v))
|
Map.fromList $ map (\(n, v) -> (prelPrim (T.pack n), v))
|
||||||
|
|
||||||
[ -- Literals
|
[ -- Literals
|
||||||
("True" , VBit (bitLit sym True))
|
("True" , VBit (bitLit sym True))
|
||||||
, ("False" , VBit (bitLit sym False))
|
, ("False" , VBit (bitLit sym False))
|
||||||
, ("number" , ecNumberV sym) -- Converts a numeric type into its corresponding value.
|
, ("number" , ecNumberV sym) -- Converts a numeric type into its corresponding value.
|
||||||
-- { val, rep } (Literal val rep) => rep
|
-- { val, rep } (Literal val rep) => rep
|
||||||
|
, ("fraction" , ecFractionV sym)
|
||||||
, ("ratio" , ratioV sym)
|
, ("ratio" , ratioV sym)
|
||||||
|
|
||||||
-- Zero
|
-- Zero
|
||||||
|
@ -29,6 +29,7 @@ import Control.DeepSeq
|
|||||||
data TValue
|
data TValue
|
||||||
= TVBit -- ^ @ Bit @
|
= TVBit -- ^ @ Bit @
|
||||||
| TVInteger -- ^ @ Integer @
|
| TVInteger -- ^ @ Integer @
|
||||||
|
| TVFloat Integer Integer -- ^ @ Float e p @
|
||||||
| TVIntMod Integer -- ^ @ Z n @
|
| TVIntMod Integer -- ^ @ Z n @
|
||||||
| TVRational -- ^ @Rational@
|
| TVRational -- ^ @Rational@
|
||||||
| TVArray TValue TValue -- ^ @ Array a b @
|
| TVArray TValue TValue -- ^ @ Array a b @
|
||||||
@ -46,6 +47,7 @@ tValTy tv =
|
|||||||
case tv of
|
case tv of
|
||||||
TVBit -> tBit
|
TVBit -> tBit
|
||||||
TVInteger -> tInteger
|
TVInteger -> tInteger
|
||||||
|
TVFloat e p -> tFloat (tNum e) (tNum p)
|
||||||
TVIntMod n -> tIntMod (tNum n)
|
TVIntMod n -> tIntMod (tNum n)
|
||||||
TVRational -> tRational
|
TVRational -> tRational
|
||||||
TVArray a b -> tArray (tValTy a) (tValTy b)
|
TVArray a b -> tArray (tValTy a) (tValTy b)
|
||||||
@ -107,6 +109,7 @@ evalType env ty =
|
|||||||
(TCBit, []) -> Right $ TVBit
|
(TCBit, []) -> Right $ TVBit
|
||||||
(TCInteger, []) -> Right $ TVInteger
|
(TCInteger, []) -> Right $ TVInteger
|
||||||
(TCRational, []) -> Right $ TVRational
|
(TCRational, []) -> Right $ TVRational
|
||||||
|
(TCFloat, [e,p])-> Right $ TVFloat (inum e) (inum p)
|
||||||
(TCIntMod, [n]) -> case num n of
|
(TCIntMod, [n]) -> case num n of
|
||||||
Inf -> evalPanic "evalType" ["invalid type Z inf"]
|
Inf -> evalPanic "evalType" ["invalid type Z inf"]
|
||||||
Nat m -> Right $ TVIntMod m
|
Nat m -> Right $ TVIntMod m
|
||||||
@ -134,6 +137,10 @@ evalType env ty =
|
|||||||
where
|
where
|
||||||
val = evalValType env
|
val = evalValType env
|
||||||
num = evalNumType 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 *).
|
-- | Evaluation for value types (kind *).
|
||||||
evalValType :: HasCallStack => TypeEnv -> Type -> TValue
|
evalValType :: HasCallStack => TypeEnv -> Type -> TValue
|
||||||
|
@ -34,8 +34,10 @@ module Cryptol.Eval.Value
|
|||||||
, word
|
, word
|
||||||
, lam
|
, lam
|
||||||
, wlam
|
, wlam
|
||||||
|
, flam
|
||||||
, tlam
|
, tlam
|
||||||
, nlam
|
, nlam
|
||||||
|
, ilam
|
||||||
, toStream
|
, toStream
|
||||||
, toFinSeq
|
, toFinSeq
|
||||||
, toSeq
|
, toSeq
|
||||||
@ -44,6 +46,7 @@ module Cryptol.Eval.Value
|
|||||||
, fromVBit
|
, fromVBit
|
||||||
, fromVInteger
|
, fromVInteger
|
||||||
, fromVRational
|
, fromVRational
|
||||||
|
, fromVFloat
|
||||||
, fromVSeq
|
, fromVSeq
|
||||||
, fromSeq
|
, fromSeq
|
||||||
, fromWordVal
|
, fromWordVal
|
||||||
@ -102,6 +105,7 @@ import Cryptol.Eval.Type
|
|||||||
|
|
||||||
import Cryptol.TypeCheck.Solver.InfNat(Nat'(..))
|
import Cryptol.TypeCheck.Solver.InfNat(Nat'(..))
|
||||||
import Cryptol.Utils.Ident (Ident)
|
import Cryptol.Utils.Ident (Ident)
|
||||||
|
import Cryptol.Utils.Panic(panic)
|
||||||
import Cryptol.Utils.PP
|
import Cryptol.Utils.PP
|
||||||
|
|
||||||
import Data.List(genericIndex)
|
import Data.List(genericIndex)
|
||||||
@ -298,6 +302,7 @@ data GenValue sym
|
|||||||
| VBit !(SBit sym) -- ^ @ Bit @
|
| VBit !(SBit sym) -- ^ @ Bit @
|
||||||
| VInteger !(SInteger sym) -- ^ @ Integer @ or @ Z n @
|
| VInteger !(SInteger sym) -- ^ @ Integer @ or @ Z n @
|
||||||
| VRational !(SRational sym) -- ^ @ Rational @
|
| VRational !(SRational sym) -- ^ @ Rational @
|
||||||
|
| VFloat !(SFloat sym)
|
||||||
| VSeq !Integer !(SeqMap sym) -- ^ @ [n]a @
|
| VSeq !Integer !(SeqMap sym) -- ^ @ [n]a @
|
||||||
-- Invariant: VSeq is never a sequence of bits
|
-- Invariant: VSeq is never a sequence of bits
|
||||||
| VWord !Integer !(SEval sym (WordValue sym)) -- ^ @ [n]Bit @
|
| VWord !Integer !(SEval sym (WordValue sym)) -- ^ @ [n]Bit @
|
||||||
@ -322,6 +327,7 @@ forceValue v = case v of
|
|||||||
VBit b -> seq b (return ())
|
VBit b -> seq b (return ())
|
||||||
VInteger i -> seq i (return ())
|
VInteger i -> seq i (return ())
|
||||||
VRational q -> seq q (return ())
|
VRational q -> seq q (return ())
|
||||||
|
VFloat f -> seq f (return ())
|
||||||
VWord _ wv -> forceWordValue =<< wv
|
VWord _ wv -> forceWordValue =<< wv
|
||||||
VStream _ -> return ()
|
VStream _ -> return ()
|
||||||
VFun _ -> return ()
|
VFun _ -> return ()
|
||||||
@ -336,6 +342,7 @@ instance Backend sym => Show (GenValue sym) where
|
|||||||
VBit _ -> "bit"
|
VBit _ -> "bit"
|
||||||
VInteger _ -> "integer"
|
VInteger _ -> "integer"
|
||||||
VRational _ -> "rational"
|
VRational _ -> "rational"
|
||||||
|
VFloat _ -> "float"
|
||||||
VSeq n _ -> "seq:" ++ show n
|
VSeq n _ -> "seq:" ++ show n
|
||||||
VWord n _ -> "word:" ++ show n
|
VWord n _ -> "word:" ++ show n
|
||||||
VStream _ -> "stream"
|
VStream _ -> "stream"
|
||||||
@ -365,6 +372,7 @@ ppValue x opts = loop
|
|||||||
VBit b -> return $ ppBit x b
|
VBit b -> return $ ppBit x b
|
||||||
VInteger i -> return $ ppInteger x opts i
|
VInteger i -> return $ ppInteger x opts i
|
||||||
VRational q -> return $ ppRational x opts q
|
VRational q -> return $ ppRational x opts q
|
||||||
|
VFloat i -> return $ ppFloat x opts i
|
||||||
VSeq sz vals -> ppWordSeq sz vals
|
VSeq sz vals -> ppWordSeq sz vals
|
||||||
VWord _ wv -> ppWordVal =<< wv
|
VWord _ wv -> ppWordVal =<< wv
|
||||||
VStream vals -> do vals' <- traverse (>>=loop) $ enumerateSeqMap (useInfLength opts) vals
|
VStream vals -> do vals' <- traverse (>>=loop) $ enumerateSeqMap (useInfLength opts) vals
|
||||||
@ -413,6 +421,13 @@ lam = VFun
|
|||||||
wlam :: Backend sym => sym -> (SWord sym -> SEval sym (GenValue sym)) -> GenValue sym
|
wlam :: Backend sym => sym -> (SWord sym -> SEval sym (GenValue sym)) -> GenValue sym
|
||||||
wlam sym f = VFun (\arg -> arg >>= fromVWord sym "wlam" >>= f)
|
wlam sym f = VFun (\arg -> arg >>= fromVWord sym "wlam" >>= f)
|
||||||
|
|
||||||
|
-- | 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'.
|
-- | A type lambda that expects a 'Type'.
|
||||||
tlam :: Backend sym => (TValue -> GenValue sym) -> GenValue sym
|
tlam :: Backend sym => (TValue -> GenValue sym) -> GenValue sym
|
||||||
tlam f = VPoly (return . f)
|
tlam f = VPoly (return . f)
|
||||||
@ -421,6 +436,12 @@ tlam f = VPoly (return . f)
|
|||||||
nlam :: Backend sym => (Nat' -> GenValue sym) -> GenValue sym
|
nlam :: Backend sym => (Nat' -> GenValue sym) -> GenValue sym
|
||||||
nlam f = VNumPoly (return . f)
|
nlam f = VNumPoly (return . f)
|
||||||
|
|
||||||
|
-- | A type lambda that expects a funite 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.
|
-- | Generate a stream.
|
||||||
toStream :: Backend sym => [GenValue sym] -> SEval sym (GenValue sym)
|
toStream :: Backend sym => [GenValue sym] -> SEval sym (GenValue sym)
|
||||||
toStream vs =
|
toStream vs =
|
||||||
@ -546,6 +567,12 @@ fromVRecord val = case val of
|
|||||||
VRecord fs -> fs
|
VRecord fs -> fs
|
||||||
_ -> evalPanic "fromVRecord" ["not a record"]
|
_ -> evalPanic "fromVRecord" ["not a record"]
|
||||||
|
|
||||||
|
fromVFloat :: GenValue sym -> SFloat sym
|
||||||
|
fromVFloat val =
|
||||||
|
case val of
|
||||||
|
VFloat x -> x
|
||||||
|
_ -> evalPanic "fromVFloat" ["not a Float"]
|
||||||
|
|
||||||
-- | Lookup a field in a record.
|
-- | Lookup a field in a record.
|
||||||
lookupRecord :: Ident -> GenValue sym -> SEval sym (GenValue sym)
|
lookupRecord :: Ident -> GenValue sym -> SEval sym (GenValue sym)
|
||||||
lookupRecord f val =
|
lookupRecord f val =
|
||||||
|
@ -4,17 +4,8 @@
|
|||||||
-- License : BSD3
|
-- License : BSD3
|
||||||
-- Maintainer : cryptol@galois.com
|
-- Maintainer : cryptol@galois.com
|
||||||
|
|
||||||
{-# LANGUAGE DataKinds #-}
|
|
||||||
{-# LANGUAGE DeriveFunctor #-}
|
|
||||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
|
||||||
{-# LANGUAGE LambdaCase #-}
|
|
||||||
{-# LANGUAGE RankNTypes #-}
|
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
|
||||||
{-# LANGUAGE StandaloneDeriving #-}
|
|
||||||
{-# LANGUAGE TypeApplications #-}
|
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
|
||||||
{-# LANGUAGE ViewPatterns #-}
|
{-# LANGUAGE ViewPatterns #-}
|
||||||
{-# LANGUAGE TypeOperators #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
module Cryptol.Eval.What4
|
module Cryptol.Eval.What4
|
||||||
( What4(..)
|
( What4(..)
|
||||||
, W4Result(..)
|
, W4Result(..)
|
||||||
@ -24,383 +15,36 @@ module Cryptol.Eval.What4
|
|||||||
) where
|
) where
|
||||||
|
|
||||||
|
|
||||||
import qualified Control.Exception as X
|
import Control.Monad (join)
|
||||||
import Control.Monad (foldM, join)
|
|
||||||
import Control.Monad.IO.Class
|
|
||||||
import Data.Bits (bit, shiftR, shiftL, testBit)
|
|
||||||
import qualified Data.BitVector.Sized as BV
|
|
||||||
import Data.List
|
|
||||||
import qualified Data.Map as Map
|
import qualified Data.Map as Map
|
||||||
import Data.Parameterized.NatRepr
|
|
||||||
import Data.Parameterized.Some
|
|
||||||
import qualified Data.Text as T
|
|
||||||
|
|
||||||
import qualified What4.Interface as W4
|
import qualified What4.Interface as W4
|
||||||
import qualified What4.SWord as SW
|
|
||||||
import qualified What4.Utils.AbstractDomains as W4
|
|
||||||
|
|
||||||
import Cryptol.Eval.Backend
|
import Cryptol.Eval.Backend
|
||||||
import Cryptol.Eval.Concrete.Value( BV(..), ppBV )
|
|
||||||
import Cryptol.Eval.Generic
|
import Cryptol.Eval.Generic
|
||||||
import Cryptol.Eval.Monad (Eval(..), EvalError(..), Unsupported(..), io, delayFill, blackhole)
|
import Cryptol.Eval.Type (finNat')
|
||||||
import Cryptol.Eval.Type (TValue(..), finNat')
|
|
||||||
import Cryptol.Eval.Value
|
import Cryptol.Eval.Value
|
||||||
|
import Cryptol.Eval.What4.Value
|
||||||
|
import Cryptol.Eval.What4.Float(floatPrims)
|
||||||
import Cryptol.Testing.Random( randomV )
|
import Cryptol.Testing.Random( randomV )
|
||||||
import Cryptol.TypeCheck.Solver.InfNat (Nat'(..), widthInteger)
|
|
||||||
import Cryptol.Utils.Ident
|
import Cryptol.Utils.Ident
|
||||||
import Cryptol.Utils.Panic
|
|
||||||
import Cryptol.Utils.PP
|
|
||||||
|
|
||||||
|
|
||||||
data What4 sym = What4 sym
|
evalPrim :: W4.IsExprBuilder sym => sym -> PrimIdent -> Maybe (Value sym)
|
||||||
|
|
||||||
type Value sym = GenValue (What4 sym)
|
|
||||||
|
|
||||||
data W4Result sym a
|
|
||||||
= W4Error !EvalError
|
|
||||||
| W4Result !(W4.Pred sym) !a -- safety predicate and result
|
|
||||||
|
|
||||||
instance Functor (W4Result sym) where
|
|
||||||
fmap _ (W4Error err) = W4Error err
|
|
||||||
fmap f (W4Result p x) = W4Result p (f x)
|
|
||||||
|
|
||||||
total :: W4.IsExprBuilder sym => sym -> a -> W4Result sym a
|
|
||||||
total sym = W4Result (W4.backendPred sym True)
|
|
||||||
|
|
||||||
-- TODO? Reorganize this to use PartialT ?
|
|
||||||
newtype W4Eval sym a = W4Eval{ w4Eval :: sym -> Eval (W4Result sym a) }
|
|
||||||
deriving (Functor)
|
|
||||||
|
|
||||||
instance W4.IsExprBuilder sym => Applicative (W4Eval sym) where
|
|
||||||
pure x = W4Eval $ \sym -> pure (total sym x)
|
|
||||||
mf <*> mx = mf >>= \f -> mx >>= \x -> pure (f x)
|
|
||||||
|
|
||||||
instance W4.IsExprBuilder sym => Monad (W4Eval sym) where
|
|
||||||
return = pure
|
|
||||||
x >>= f = W4Eval $ \sym ->
|
|
||||||
w4Eval x sym >>= \case
|
|
||||||
W4Error err -> pure (W4Error err)
|
|
||||||
W4Result px x' ->
|
|
||||||
w4Eval (f x') sym >>= \case
|
|
||||||
W4Error err -> pure (W4Error err)
|
|
||||||
W4Result pz z ->
|
|
||||||
do p <- io (W4.andPred sym px pz)
|
|
||||||
pure (W4Result p z)
|
|
||||||
|
|
||||||
instance W4.IsExprBuilder sym => MonadIO (W4Eval sym) where
|
|
||||||
liftIO m = W4Eval $ \sym -> fmap (total sym) (liftIO m)
|
|
||||||
|
|
||||||
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 SEval (What4 sym) = W4Eval sym
|
|
||||||
|
|
||||||
raiseError _ err = W4Eval (\_ -> pure (W4Error err))
|
|
||||||
|
|
||||||
assertSideCondition _ cond err
|
|
||||||
| Just False <- W4.asConstantPred cond = W4Eval (\_ -> pure (W4Error err))
|
|
||||||
| otherwise = W4Eval (\_ -> pure (W4Result cond ()))
|
|
||||||
|
|
||||||
isReady (What4 sym) m =
|
|
||||||
case w4Eval m sym of
|
|
||||||
Ready _ -> True
|
|
||||||
_ -> False
|
|
||||||
|
|
||||||
sDelayFill _ m retry = W4Eval $ \sym ->
|
|
||||||
do m' <- delayFill (w4Eval m sym) (w4Eval retry sym)
|
|
||||||
pure (total sym (W4Eval (const m')))
|
|
||||||
|
|
||||||
sDeclareHole _ msg = W4Eval $ \sym ->
|
|
||||||
do (hole, fill) <- blackhole msg
|
|
||||||
pure (total sym ( W4Eval (const hole), \m -> W4Eval (\sym' -> fmap (total sym') (fill (w4Eval m sym'))) ))
|
|
||||||
|
|
||||||
mergeEval _sym f c mx my = W4Eval $ \sym ->
|
|
||||||
do rx <- w4Eval mx sym
|
|
||||||
ry <- w4Eval my sym
|
|
||||||
case (rx, ry) of
|
|
||||||
(W4Error err, W4Error _) ->
|
|
||||||
pure $ W4Error err -- arbitrarily choose left error to report
|
|
||||||
(W4Error _, W4Result p y) ->
|
|
||||||
do p' <- io (W4.andPred sym p =<< W4.notPred sym c)
|
|
||||||
pure $ W4Result p' y
|
|
||||||
(W4Result p x, W4Error _) ->
|
|
||||||
do p' <- io (W4.andPred sym p c)
|
|
||||||
pure $ W4Result p' x
|
|
||||||
(W4Result px x, W4Result py y) ->
|
|
||||||
do zr <- w4Eval (f c x y) sym
|
|
||||||
case zr of
|
|
||||||
W4Error err -> pure $ W4Error err
|
|
||||||
W4Result pz z ->
|
|
||||||
do p' <- io (W4.andPred sym pz =<< W4.itePred sym 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 "[?]"
|
|
||||||
|
|
||||||
|
|
||||||
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
|
|
||||||
|
|
||||||
|
|
||||||
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)
|
|
||||||
|
|
||||||
-- Primitives ------------------------------------------------------------------
|
|
||||||
|
|
||||||
evalPrim :: W4.IsExprBuilder sym => sym -> Ident -> Maybe (Value sym)
|
|
||||||
evalPrim sym prim = Map.lookup prim (primTable sym)
|
evalPrim sym prim = Map.lookup prim (primTable sym)
|
||||||
|
|
||||||
-- See also Cryptol.Prims.Eval.primTable
|
-- See also Cryptol.Prims.Eval.primTable
|
||||||
primTable :: W4.IsExprBuilder sym => sym -> Map.Map Ident (Value sym)
|
primTable :: W4.IsExprBuilder sym => sym -> Map.Map PrimIdent (Value sym)
|
||||||
primTable w4sym = let sym = What4 w4sym in
|
primTable w4sym = let sym = What4 w4sym in
|
||||||
Map.fromList $ map (\(n, v) -> (mkIdent (T.pack n), v))
|
Map.union (floatPrims sym) $
|
||||||
|
Map.fromList $ map (\(n, v) -> (prelPrim n, v))
|
||||||
|
|
||||||
[ -- Literals
|
[ -- Literals
|
||||||
("True" , VBit (bitLit sym True))
|
("True" , VBit (bitLit sym True))
|
||||||
, ("False" , VBit (bitLit sym False))
|
, ("False" , VBit (bitLit sym False))
|
||||||
, ("number" , ecNumberV sym) -- Converts a numeric type into its corresponding value.
|
, ("number" , ecNumberV sym) -- Converts a numeric type into its corresponding value.
|
||||||
-- { val, rep } (Literal val rep) => rep
|
-- { val, rep } (Literal val rep) => rep
|
||||||
|
, ("fraction" , ecFractionV sym)
|
||||||
, ("ratio" , ratioV sym)
|
, ("ratio" , ratioV sym)
|
||||||
|
|
||||||
-- Zero
|
-- Zero
|
||||||
@ -547,372 +191,3 @@ primTable w4sym = let sym = What4 w4sym in
|
|||||||
|
|
||||||
|
|
||||||
|
|
||||||
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
|
|
||||||
|
54
src/Cryptol/Eval/What4/Float.hs
Normal file
54
src/Cryptol/Eval/What4/Float.hs
Normal file
@ -0,0 +1,54 @@
|
|||||||
|
{-# 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.IsExprBuilder 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)
|
||||||
|
|
||||||
|
, "fpAdd" ~> fpBinArithV sym4 fpPlus
|
||||||
|
, "fpSub" ~> fpBinArithV sym4 fpMinus
|
||||||
|
, "fpMul" ~> fpBinArithV sym4 fpMult
|
||||||
|
, "fpDiv" ~> fpBinArithV sym4 fpDiv
|
||||||
|
]
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
-- | 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)
|
||||||
|
|
||||||
|
|
328
src/Cryptol/Eval/What4/SFloat.hs
Normal file
328
src/Cryptol/Eval/What4/SFloat.hs
Normal file
@ -0,0 +1,328 @@
|
|||||||
|
{-# 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
|
||||||
|
, fpFromRational
|
||||||
|
|
||||||
|
-- * Interchange formats
|
||||||
|
, fpFromBinary
|
||||||
|
, fpToBinary
|
||||||
|
|
||||||
|
-- * Relations
|
||||||
|
, SFloatRel
|
||||||
|
, fpEq
|
||||||
|
, fpEqIEEE
|
||||||
|
, fpLtIEEE
|
||||||
|
, fpGtIEEE
|
||||||
|
|
||||||
|
-- * Arithmetic
|
||||||
|
, SFloatBinArith
|
||||||
|
, fpNeg
|
||||||
|
, fpAdd
|
||||||
|
, fpSub
|
||||||
|
, fpMul
|
||||||
|
, fpDiv
|
||||||
|
|
||||||
|
-- * Conversions
|
||||||
|
, fpRound
|
||||||
|
, fpToReal
|
||||||
|
, fpFromReal
|
||||||
|
, 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.
|
||||||
|
fpFromRational ::
|
||||||
|
IsExprBuilder sym =>
|
||||||
|
sym ->
|
||||||
|
Integer {- ^ Exponent width -} ->
|
||||||
|
Integer {- ^ Precision width -} ->
|
||||||
|
Rational ->
|
||||||
|
IO (SFloat sym)
|
||||||
|
fpFromRational 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
|
||||||
|
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
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
|
||||||
|
|
||||||
|
|
||||||
|
|
820
src/Cryptol/Eval/What4/Value.hs
Normal file
820
src/Cryptol/Eval/What4/Value.hs
Normal file
@ -0,0 +1,820 @@
|
|||||||
|
-- |
|
||||||
|
-- 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)
|
||||||
|
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(..), io, delayFill, blackhole)
|
||||||
|
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)
|
||||||
|
|
||||||
|
data W4Result sym a
|
||||||
|
= W4Error !EvalError
|
||||||
|
| W4Result !(W4.Pred sym) !a -- safety predicate and result
|
||||||
|
|
||||||
|
instance Functor (W4Result sym) where
|
||||||
|
fmap _ (W4Error err) = W4Error err
|
||||||
|
fmap f (W4Result p x) = W4Result p (f x)
|
||||||
|
|
||||||
|
total :: W4.IsExprBuilder sym => sym -> a -> W4Result sym a
|
||||||
|
total sym = W4Result (W4.backendPred sym True)
|
||||||
|
|
||||||
|
-- TODO? Reorganize this to use PartialT ?
|
||||||
|
newtype W4Eval sym a = W4Eval{ w4Eval :: sym -> Eval (W4Result sym a) }
|
||||||
|
deriving (Functor)
|
||||||
|
|
||||||
|
instance W4.IsExprBuilder sym => Applicative (W4Eval sym) where
|
||||||
|
pure x = W4Eval $ \sym -> pure (total sym x)
|
||||||
|
mf <*> mx = mf >>= \f -> mx >>= \x -> pure (f x)
|
||||||
|
|
||||||
|
instance W4.IsExprBuilder sym => Monad (W4Eval sym) where
|
||||||
|
return = pure
|
||||||
|
x >>= f = W4Eval $ \sym ->
|
||||||
|
w4Eval x sym >>= \case
|
||||||
|
W4Error err -> pure (W4Error err)
|
||||||
|
W4Result px x' ->
|
||||||
|
w4Eval (f x') sym >>= \case
|
||||||
|
W4Error err -> pure (W4Error err)
|
||||||
|
W4Result pz z ->
|
||||||
|
do p <- io (W4.andPred sym px pz)
|
||||||
|
pure (W4Result p z)
|
||||||
|
|
||||||
|
instance W4.IsExprBuilder sym => MonadIO (W4Eval sym) where
|
||||||
|
liftIO m = W4Eval $ \sym -> fmap (total sym) (liftIO m)
|
||||||
|
|
||||||
|
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 _ err = W4Eval (\_ -> pure (W4Error err))
|
||||||
|
|
||||||
|
assertSideCondition _ cond err
|
||||||
|
| Just False <- W4.asConstantPred cond = W4Eval (\_ -> pure (W4Error err))
|
||||||
|
| otherwise = W4Eval (\_ -> pure (W4Result cond ()))
|
||||||
|
|
||||||
|
isReady (What4 sym) m =
|
||||||
|
case w4Eval m sym of
|
||||||
|
Ready _ -> True
|
||||||
|
_ -> False
|
||||||
|
|
||||||
|
sDelayFill _ m retry = W4Eval $ \sym ->
|
||||||
|
do m' <- delayFill (w4Eval m sym) (w4Eval retry sym)
|
||||||
|
pure (total sym (W4Eval (const m')))
|
||||||
|
|
||||||
|
sDeclareHole _ msg = W4Eval $ \sym ->
|
||||||
|
do (hole, fill) <- blackhole msg
|
||||||
|
pure (total sym ( W4Eval (const hole), \m -> W4Eval (\sym' -> fmap (total sym') (fill (w4Eval m sym'))) ))
|
||||||
|
|
||||||
|
mergeEval _sym f c mx my = W4Eval $ \sym ->
|
||||||
|
do rx <- w4Eval mx sym
|
||||||
|
ry <- w4Eval my sym
|
||||||
|
case (rx, ry) of
|
||||||
|
(W4Error err, W4Error _) ->
|
||||||
|
pure $ W4Error err -- arbitrarily choose left error to report
|
||||||
|
(W4Error _, W4Result p y) ->
|
||||||
|
do p' <- io (W4.andPred sym p =<< W4.notPred sym c)
|
||||||
|
pure $ W4Result p' y
|
||||||
|
(W4Result p x, W4Error _) ->
|
||||||
|
do p' <- io (W4.andPred sym p c)
|
||||||
|
pure $ W4Result p' x
|
||||||
|
(W4Result px x, W4Result py y) ->
|
||||||
|
do zr <- w4Eval (f c x y) sym
|
||||||
|
case zr of
|
||||||
|
W4Error err -> pure $ W4Error err
|
||||||
|
W4Result pz z ->
|
||||||
|
do p' <- io (W4.andPred sym pz =<< W4.itePred sym 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.fpFromRational 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 -> undefined -- XXX
|
||||||
|
W4.RNA -> W4.realRound sy y
|
||||||
|
W4.RTP -> W4.realCeil sy y
|
||||||
|
W4.RTN -> W4.realFloor sy y
|
||||||
|
W4.RTZ -> undefined -- XXX
|
||||||
|
|
||||||
|
|
||||||
|
|
@ -42,14 +42,14 @@ import qualified Cryptol.TypeCheck.AST as T
|
|||||||
import qualified Cryptol.TypeCheck.PP as T
|
import qualified Cryptol.TypeCheck.PP as T
|
||||||
import qualified Cryptol.TypeCheck.Sanity as TcSanity
|
import qualified Cryptol.TypeCheck.Sanity as TcSanity
|
||||||
import Cryptol.Transform.AddModParams (addModParams)
|
import Cryptol.Transform.AddModParams (addModParams)
|
||||||
import Cryptol.Utils.Ident (preludeName, arrayName, interactiveName
|
import Cryptol.Utils.Ident (preludeName, floatName, arrayName, interactiveName
|
||||||
, modNameChunks, notParamInstModName
|
, modNameChunks, notParamInstModName
|
||||||
, isParamInstModName )
|
, isParamInstModName )
|
||||||
import Cryptol.Utils.PP (pretty)
|
import Cryptol.Utils.PP (pretty)
|
||||||
import Cryptol.Utils.Panic (panic)
|
import Cryptol.Utils.Panic (panic)
|
||||||
import Cryptol.Utils.Logger(logPutStrLn, logPrint)
|
import Cryptol.Utils.Logger(logPutStrLn, logPrint)
|
||||||
|
|
||||||
import Cryptol.Prelude (preludeContents, arrayContents)
|
import Cryptol.Prelude (preludeContents, floatContents, arrayContents)
|
||||||
|
|
||||||
import Cryptol.Transform.MonoValues (rewModule)
|
import Cryptol.Transform.MonoValues (rewModule)
|
||||||
|
|
||||||
@ -259,6 +259,7 @@ findModule n = do
|
|||||||
handleNotFound =
|
handleNotFound =
|
||||||
case n of
|
case n of
|
||||||
m | m == preludeName -> pure (InMem "Cryptol" preludeContents)
|
m | m == preludeName -> pure (InMem "Cryptol" preludeContents)
|
||||||
|
| m == floatName -> pure (InMem "Float" floatContents)
|
||||||
| m == arrayName -> pure (InMem "Array" arrayContents)
|
| m == arrayName -> pure (InMem "Array" arrayContents)
|
||||||
_ -> moduleNotFound n =<< getSearchPath
|
_ -> moduleNotFound n =<< getSearchPath
|
||||||
|
|
||||||
@ -369,8 +370,15 @@ checkDecls ds = do
|
|||||||
getPrimMap :: ModuleM PrimMap
|
getPrimMap :: ModuleM PrimMap
|
||||||
getPrimMap =
|
getPrimMap =
|
||||||
do env <- getModuleEnv
|
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
|
case lookupModule preludeName env of
|
||||||
Just lm -> return (ifacePrimMap (lmInterface lm))
|
Just prel -> return $ mkPrims prel
|
||||||
|
`alsoPrimFrom` floatName
|
||||||
Nothing -> panic "Cryptol.ModuleSystem.Base.getPrimMap"
|
Nothing -> panic "Cryptol.ModuleSystem.Base.getPrimMap"
|
||||||
[ "Unable to find the prelude" ]
|
[ "Unable to find the prelude" ]
|
||||||
|
|
||||||
|
@ -27,6 +27,7 @@ module Cryptol.ModuleSystem.Interface (
|
|||||||
import Cryptol.ModuleSystem.Name
|
import Cryptol.ModuleSystem.Name
|
||||||
import Cryptol.TypeCheck.AST
|
import Cryptol.TypeCheck.AST
|
||||||
import Cryptol.Utils.Ident (ModName)
|
import Cryptol.Utils.Ident (ModName)
|
||||||
|
import Cryptol.Utils.Panic(panic)
|
||||||
import Cryptol.Parser.Position(Located)
|
import Cryptol.Parser.Position(Located)
|
||||||
|
|
||||||
import qualified Data.Map as Map
|
import qualified Data.Map as Map
|
||||||
@ -177,6 +178,13 @@ ifaceDeclsPrimMap IfaceDecls { .. } =
|
|||||||
, primTypes = Map.fromList (newtypes ++ types)
|
, primTypes = Map.fromList (newtypes ++ types)
|
||||||
}
|
}
|
||||||
where
|
where
|
||||||
exprs = [ (nameIdent n, n) | n <- Map.keys ifDecls ]
|
entry n = case asPrim n of
|
||||||
newtypes = [ (nameIdent n, n) | n <- Map.keys ifNewtypes ]
|
Just pid -> (pid,n)
|
||||||
types = [ (nameIdent n, n) | n <- Map.keys ifTySyns ]
|
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)
|
||||||
|
@ -13,7 +13,6 @@
|
|||||||
{-# LANGUAGE FlexibleInstances #-}
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
{-# LANGUAGE RecordWildCards #-}
|
{-# LANGUAGE RecordWildCards #-}
|
||||||
-- for the instances of RunM and BaseM
|
-- for the instances of RunM and BaseM
|
||||||
{-# LANGUAGE UndecidableInstances #-}
|
{-# LANGUAGE UndecidableInstances #-}
|
||||||
@ -219,14 +218,11 @@ nameFixity :: Name -> Maybe Fixity
|
|||||||
nameFixity = nFixity
|
nameFixity = nFixity
|
||||||
|
|
||||||
|
|
||||||
asPrim :: Name -> Maybe Ident
|
asPrim :: Name -> Maybe PrimIdent
|
||||||
asPrim Name { .. } =
|
asPrim Name { .. } =
|
||||||
case nInfo of
|
case nInfo of
|
||||||
Declared p _
|
Declared p _ -> Just $ PrimIdent p $ identText nIdent
|
||||||
| p == preludeName -> Just nIdent
|
_ -> Nothing
|
||||||
| p == arrayName ->
|
|
||||||
Just $ mkIdent $ modNameToText p <> "::" <> identText nIdent
|
|
||||||
_ -> Nothing
|
|
||||||
|
|
||||||
toParamInstName :: Name -> Name
|
toParamInstName :: Name -> Name
|
||||||
toParamInstName n =
|
toParamInstName n =
|
||||||
@ -351,11 +347,16 @@ paramModRecParam = Name { nInfo = Parameter
|
|||||||
-- Prim Maps -------------------------------------------------------------------
|
-- Prim Maps -------------------------------------------------------------------
|
||||||
|
|
||||||
-- | A mapping from an identifier defined in some module to its real name.
|
-- | A mapping from an identifier defined in some module to its real name.
|
||||||
data PrimMap = PrimMap { primDecls :: Map.Map Ident Name
|
data PrimMap = PrimMap { primDecls :: Map.Map PrimIdent Name
|
||||||
, primTypes :: Map.Map Ident Name
|
, primTypes :: Map.Map PrimIdent Name
|
||||||
} deriving (Show, Generic, NFData)
|
} 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
|
-- | 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.
|
-- this will panic if it doesn't find the name.
|
||||||
|
@ -87,14 +87,19 @@ merge :: [Name] -> [Name] -> [Name]
|
|||||||
merge xs ys | xs == ys = xs
|
merge xs ys | xs == ys = xs
|
||||||
| otherwise = nub (xs ++ ys)
|
| 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
|
||||||
toPrimMap NamingEnv { .. } = PrimMap { .. }
|
toPrimMap NamingEnv { .. } = PrimMap { .. }
|
||||||
where
|
where
|
||||||
primDecls = Map.fromList [ (nameIdent n,n) | ns <- Map.elems neExprs
|
entry n = case asPrim n of
|
||||||
, n <- ns ]
|
Just p -> (p,n)
|
||||||
primTypes = Map.fromList [ (nameIdent n,n) | ns <- Map.elems neTypes
|
Nothing -> panic "toPrimMap" [ "Not a declared name?"
|
||||||
, n <- ns ]
|
, 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.
|
-- | Generate a display format based on a naming environment.
|
||||||
toNameDisp :: NamingEnv -> NameDisp
|
toNameDisp :: NamingEnv -> NameDisp
|
||||||
|
@ -52,6 +52,7 @@ import Paths_cryptol
|
|||||||
|
|
||||||
%token
|
%token
|
||||||
NUM { $$@(Located _ (Token (Num {}) _))}
|
NUM { $$@(Located _ (Token (Num {}) _))}
|
||||||
|
FRAC { $$@(Located _ (Token (Frac {}) _))}
|
||||||
STRLIT { $$@(Located _ (Token (StrLit {}) _))}
|
STRLIT { $$@(Located _ (Token (StrLit {}) _))}
|
||||||
CHARLIT { $$@(Located _ (Token (ChrLit {}) _))}
|
CHARLIT { $$@(Located _ (Token (ChrLit {}) _))}
|
||||||
|
|
||||||
@ -483,6 +484,7 @@ no_sel_aexpr :: { Expr PName }
|
|||||||
: qname { at $1 $ EVar (thing $1) }
|
: qname { at $1 $ EVar (thing $1) }
|
||||||
|
|
||||||
| NUM { at $1 $ numLit (tokenType (thing $1)) }
|
| NUM { at $1 $ numLit (tokenType (thing $1)) }
|
||||||
|
| FRAC { at $1 $ fracLit (tokenType (thing $1)) }
|
||||||
| STRLIT { at $1 $ ELit $ ECString $ getStr $1 }
|
| STRLIT { at $1 $ ELit $ ECString $ getStr $1 }
|
||||||
| CHARLIT { at $1 $ ELit $ ECChar $ getChr $1 }
|
| CHARLIT { at $1 $ ELit $ ECChar $ getChr $1 }
|
||||||
| '_' { at $1 $ EVar $ mkUnqual $ mkIdent "_" }
|
| '_' { at $1 $ EVar $ mkUnqual $ mkIdent "_" }
|
||||||
|
@ -61,7 +61,7 @@ module Cryptol.Parser.AST
|
|||||||
|
|
||||||
-- * Expressions
|
-- * Expressions
|
||||||
, Expr(..)
|
, Expr(..)
|
||||||
, Literal(..), NumInfo(..)
|
, Literal(..), NumInfo(..), FracInfo(..)
|
||||||
, Match(..)
|
, Match(..)
|
||||||
, Pattern(..)
|
, Pattern(..)
|
||||||
, Selector(..)
|
, Selector(..)
|
||||||
@ -88,7 +88,8 @@ import Cryptol.Utils.PP
|
|||||||
import Data.List(intersperse)
|
import Data.List(intersperse)
|
||||||
import Data.Bits(shiftR)
|
import Data.Bits(shiftR)
|
||||||
import Data.Maybe (catMaybes)
|
import Data.Maybe (catMaybes)
|
||||||
import Numeric(showIntAtBase)
|
import Data.Ratio(numerator,denominator)
|
||||||
|
import Numeric(showIntAtBase,showFloat,showHFloat)
|
||||||
|
|
||||||
import GHC.Generics (Generic)
|
import GHC.Generics (Generic)
|
||||||
import Control.DeepSeq
|
import Control.DeepSeq
|
||||||
@ -280,9 +281,15 @@ data NumInfo = BinLit Int -- ^ n-digit binary literal
|
|||||||
| PolyLit Int -- ^ polynomial literal
|
| PolyLit Int -- ^ polynomial literal
|
||||||
deriving (Eq, Show, Generic, NFData)
|
deriving (Eq, Show, Generic, NFData)
|
||||||
|
|
||||||
|
-- | Information about fractional literals.
|
||||||
|
data FracInfo = DecFrac
|
||||||
|
| HexFrac
|
||||||
|
deriving (Eq,Show,Generic,NFData)
|
||||||
|
|
||||||
-- | Literals.
|
-- | Literals.
|
||||||
data Literal = ECNum Integer NumInfo -- ^ @0x10@ (HexLit 2)
|
data Literal = ECNum Integer NumInfo -- ^ @0x10@ (HexLit 2)
|
||||||
| ECChar Char -- ^ @'a'@
|
| ECChar Char -- ^ @'a'@
|
||||||
|
| ECFrac Rational FracInfo -- ^ @1.2e3@
|
||||||
| ECString String -- ^ @\"hello\"@
|
| ECString String -- ^ @\"hello\"@
|
||||||
deriving (Eq, Show, Generic, NFData)
|
deriving (Eq, Show, Generic, NFData)
|
||||||
|
|
||||||
@ -624,8 +631,21 @@ instance PP Literal where
|
|||||||
case lit of
|
case lit of
|
||||||
ECNum n i -> ppNumLit n i
|
ECNum n i -> ppNumLit n i
|
||||||
ECChar c -> text (show c)
|
ECChar c -> text (show c)
|
||||||
|
ECFrac n i -> ppFracLit n i
|
||||||
ECString s -> text (show s)
|
ECString s -> text (show s)
|
||||||
|
|
||||||
|
ppFracLit :: Rational -> FracInfo -> Doc
|
||||||
|
ppFracLit x i
|
||||||
|
| toRational dbl == x =
|
||||||
|
case i of
|
||||||
|
DecFrac -> text (showFloat dbl "")
|
||||||
|
HexFrac -> text (showHFloat dbl "")
|
||||||
|
| otherwise =
|
||||||
|
"fraction`" <.> braces
|
||||||
|
(commaSep (map integer [ numerator x, denominator x ]))
|
||||||
|
where
|
||||||
|
dbl = fromRational x :: Double
|
||||||
|
|
||||||
|
|
||||||
ppNumLit :: Integer -> NumInfo -> Doc
|
ppNumLit :: Integer -> NumInfo -> Doc
|
||||||
ppNumLit n info =
|
ppNumLit n info =
|
||||||
|
@ -48,7 +48,10 @@ $unitick = \x7
|
|||||||
@num2 = "0b" (_*[0-1])+
|
@num2 = "0b" (_*[0-1])+
|
||||||
@num8 = "0o" (_*[0-7])+
|
@num8 = "0o" (_*[0-7])+
|
||||||
@num10 = [0-9](_*[0-9])*
|
@num10 = [0-9](_*[0-9])*
|
||||||
@num16 = "0x" (_*[0-9A-Fa-f])+
|
@digits16 = (_*[0-9A-Fa-f])+
|
||||||
|
@num16 = "0x" @digits16
|
||||||
|
@fnum10 = @num10 "." @num10 ([eE] [\+\-]? @num10)?
|
||||||
|
@fnum16 = @num16 "." @digits16 ([pP] [\+\-]? @num10)?
|
||||||
|
|
||||||
@strPart = [^\\\"]+
|
@strPart = [^\\\"]+
|
||||||
@chrPart = [^\\\']+
|
@chrPart = [^\\\']+
|
||||||
@ -127,6 +130,10 @@ $white+ { emit $ White Space }
|
|||||||
@num8 { emitS (numToken 8 . Text.drop 2) }
|
@num8 { emitS (numToken 8 . Text.drop 2) }
|
||||||
@num10 { emitS (numToken 10 . Text.drop 0) }
|
@num10 { emitS (numToken 10 . Text.drop 0) }
|
||||||
@num16 { emitS (numToken 16 . Text.drop 2) }
|
@num16 { emitS (numToken 16 . Text.drop 2) }
|
||||||
|
@fnum10 { emitS (fnumToken 10 . Text.drop 0) }
|
||||||
|
@fnum16 { emitS (fnumToken 16 . Text.drop 2) }
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
"_" { emit $ Sym Underscore }
|
"_" { emit $ Sym Underscore }
|
||||||
@id { mkIdent }
|
@id { mkIdent }
|
||||||
|
@ -225,6 +225,40 @@ fromDigit x'
|
|||||||
| otherwise = toInteger (fromEnum x - fromEnum '0')
|
| otherwise = toInteger (fromEnum x - fromEnum '0')
|
||||||
where x = toLower x'
|
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
|
data AlexInput = Inp { alexPos :: !Position
|
||||||
@ -431,6 +465,7 @@ data TokenErr = UnterminatedComment
|
|||||||
deriving (Eq, Show, Generic, NFData)
|
deriving (Eq, Show, Generic, NFData)
|
||||||
|
|
||||||
data TokenT = Num !Integer !Int !Int -- ^ value, base, number of digits
|
data TokenT = Num !Integer !Int !Int -- ^ value, base, number of digits
|
||||||
|
| Frac !Rational !Int -- ^ value, base.
|
||||||
| ChrLit !Char -- ^ character literal
|
| ChrLit !Char -- ^ character literal
|
||||||
| Ident ![T.Text] !T.Text -- ^ (qualified) identifier
|
| Ident ![T.Text] !T.Text -- ^ (qualified) identifier
|
||||||
| StrLit !String -- ^ string literal
|
| StrLit !String -- ^ string literal
|
||||||
|
@ -209,6 +209,15 @@ numLit (Num x base digs)
|
|||||||
|
|
||||||
numLit x = panic "[Parser] numLit" ["invalid numeric literal", show x]
|
numLit x = panic "[Parser] numLit" ["invalid numeric literal", show x]
|
||||||
|
|
||||||
|
fracLit :: TokenT -> Expr PName
|
||||||
|
fracLit tok =
|
||||||
|
case tok of
|
||||||
|
Frac x base
|
||||||
|
| 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 :: Located Token -> ParseM Integer
|
||||||
intVal tok =
|
intVal tok =
|
||||||
case tokenType (thing tok) of
|
case tokenType (thing tok) of
|
||||||
|
@ -55,4 +55,5 @@ translateExprToNumT expr =
|
|||||||
|
|
||||||
cvtLit (ECNum n _) = return (TNum n)
|
cvtLit (ECNum n _) = return (TNum n)
|
||||||
cvtLit (ECChar c) = return (TChar c)
|
cvtLit (ECChar c) = return (TChar c)
|
||||||
|
cvtLit (ECFrac {}) = Nothing
|
||||||
cvtLit (ECString _) = Nothing
|
cvtLit (ECString _) = Nothing
|
||||||
|
@ -15,6 +15,7 @@
|
|||||||
|
|
||||||
module Cryptol.Prelude
|
module Cryptol.Prelude
|
||||||
( preludeContents
|
( preludeContents
|
||||||
|
, floatContents
|
||||||
, arrayContents
|
, arrayContents
|
||||||
, cryptolTcContents
|
, cryptolTcContents
|
||||||
) where
|
) where
|
||||||
@ -27,6 +28,9 @@ import Text.Heredoc (there)
|
|||||||
preludeContents :: ByteString
|
preludeContents :: ByteString
|
||||||
preludeContents = B.pack [there|lib/Cryptol.cry|]
|
preludeContents = B.pack [there|lib/Cryptol.cry|]
|
||||||
|
|
||||||
|
floatContents :: ByteString
|
||||||
|
floatContents = B.pack [there|lib/Float.cry|]
|
||||||
|
|
||||||
arrayContents :: ByteString
|
arrayContents :: ByteString
|
||||||
arrayContents = B.pack [there|lib/Array.cry|]
|
arrayContents = B.pack [there|lib/Array.cry|]
|
||||||
|
|
||||||
|
@ -277,9 +277,19 @@ getPPValOpts =
|
|||||||
do base <- getKnownUser "base"
|
do base <- getKnownUser "base"
|
||||||
ascii <- getKnownUser "ascii"
|
ascii <- getKnownUser "ascii"
|
||||||
infLength <- getKnownUser "infLength"
|
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
|
return E.PPOpts { E.useBase = base
|
||||||
, E.useAscii = ascii
|
, E.useAscii = ascii
|
||||||
, E.useInfLength = infLength
|
, E.useInfLength = infLength
|
||||||
|
, E.useFPBase = fpBase
|
||||||
|
, E.useFPFormat = fpFmt
|
||||||
}
|
}
|
||||||
|
|
||||||
getEvalOpts :: REPL E.EvalOpts
|
getEvalOpts :: REPL E.EvalOpts
|
||||||
@ -788,8 +798,8 @@ mkSolverResult thing result earg =
|
|||||||
Left ts -> mkArgs (map addError ts)
|
Left ts -> mkArgs (map addError ts)
|
||||||
Right tes -> mkArgs tes
|
Right tes -> mkArgs tes
|
||||||
|
|
||||||
eTrue = T.ePrim prims (M.packIdent "True")
|
eTrue = T.ePrim prims (M.prelPrim "True")
|
||||||
eFalse = T.ePrim prims (M.packIdent "False")
|
eFalse = T.ePrim prims (M.prelPrim "False")
|
||||||
resultE = if result then eTrue else eFalse
|
resultE = if result then eTrue else eFalse
|
||||||
|
|
||||||
rty = T.TRec $ [(rIdent, T.tBit )] ++ map fst argF
|
rty = T.TRec $ [(rIdent, T.tBit )] ++ map fst argF
|
||||||
@ -857,8 +867,8 @@ readFileCmd fp = do
|
|||||||
do pm <- getPrimMap
|
do pm <- getPrimMap
|
||||||
let val = byteStringToInteger bs
|
let val = byteStringToInteger bs
|
||||||
let len = BS.length bs
|
let len = BS.length bs
|
||||||
let split = T.ePrim pm (M.packIdent "split")
|
let split = T.ePrim pm (M.prelPrim "split")
|
||||||
let number = T.ePrim pm (M.packIdent "number")
|
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 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 t = T.tWord (T.tNum (toInteger len * 8))
|
||||||
let x = T.EProofApp (T.ETApp (T.ETApp number (T.tNum val)) t)
|
let x = T.EProofApp (T.ETApp (T.ETApp number (T.tNum val)) t)
|
||||||
|
@ -63,6 +63,7 @@ module Cryptol.REPL.Monad (
|
|||||||
, getUserSatNum
|
, getUserSatNum
|
||||||
, getUserShowProverStats
|
, getUserShowProverStats
|
||||||
, getUserProverValidate
|
, getUserProverValidate
|
||||||
|
, parsePPFloatFormat
|
||||||
|
|
||||||
-- ** Configurable Output
|
-- ** Configurable Output
|
||||||
, getPutStr
|
, getPutStr
|
||||||
@ -97,6 +98,7 @@ import qualified Cryptol.Parser.AST as P
|
|||||||
import Cryptol.Symbolic (SatNum(..))
|
import Cryptol.Symbolic (SatNum(..))
|
||||||
import qualified Cryptol.Symbolic.SBV as SBV (proverNames, checkProverInstallation)
|
import qualified Cryptol.Symbolic.SBV as SBV (proverNames, checkProverInstallation)
|
||||||
import qualified Cryptol.Symbolic.What4 as W4 (proverNames)
|
import qualified Cryptol.Symbolic.What4 as W4 (proverNames)
|
||||||
|
import Cryptol.Eval.Monad(PPFloatFormat(..),PPFloatExp(..))
|
||||||
|
|
||||||
import Control.Monad (ap,unless,when)
|
import Control.Monad (ap,unless,when)
|
||||||
import Control.Monad.Base
|
import Control.Monad.Base
|
||||||
@ -797,11 +799,47 @@ userOptions = mkOptionMap
|
|||||||
, simpleOpt "show-examples" (EnvBool True) noCheck
|
, simpleOpt "show-examples" (EnvBool True) noCheck
|
||||||
"Print the (counter) example after :sat or :prove"
|
"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
|
, simpleOpt "ignore-safety" (EnvBool False) noCheck
|
||||||
"Ignore safety predicates when performing :sat or :prove checks"
|
"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.
|
-- | Check the value to the `base` option.
|
||||||
checkBase :: Checker
|
checkBase :: Checker
|
||||||
checkBase val = case val of
|
checkBase val = case val of
|
||||||
|
@ -120,6 +120,7 @@ data FinType
|
|||||||
| FTInteger
|
| FTInteger
|
||||||
| FTIntMod Integer
|
| FTIntMod Integer
|
||||||
| FTRational
|
| FTRational
|
||||||
|
| FTFloat Integer Integer
|
||||||
| FTSeq Int FinType
|
| FTSeq Int FinType
|
||||||
| FTTuple [FinType]
|
| FTTuple [FinType]
|
||||||
| FTRecord (Map.Map Ident FinType)
|
| FTRecord (Map.Map Ident FinType)
|
||||||
@ -139,6 +140,7 @@ finType ty =
|
|||||||
TVInteger -> Just FTInteger
|
TVInteger -> Just FTInteger
|
||||||
TVIntMod n -> Just (FTIntMod n)
|
TVIntMod n -> Just (FTIntMod n)
|
||||||
TVRational -> Just FTRational
|
TVRational -> Just FTRational
|
||||||
|
TVFloat e p -> Just (FTFloat e p)
|
||||||
TVSeq n t -> FTSeq <$> numType n <*> finType t
|
TVSeq n t -> FTSeq <$> numType n <*> finType t
|
||||||
TVTuple ts -> FTTuple <$> traverse finType ts
|
TVTuple ts -> FTTuple <$> traverse finType ts
|
||||||
TVRec fields -> FTRecord . Map.fromList <$> traverse (traverseSnd finType) fields
|
TVRec fields -> FTRecord . Map.fromList <$> traverse (traverseSnd finType) fields
|
||||||
@ -152,6 +154,7 @@ unFinType fty =
|
|||||||
FTInteger -> tInteger
|
FTInteger -> tInteger
|
||||||
FTIntMod n -> tIntMod (tNum n)
|
FTIntMod n -> tIntMod (tNum n)
|
||||||
FTRational -> tRational
|
FTRational -> tRational
|
||||||
|
FTFloat e p -> tFloat (tNum e) (tNum p)
|
||||||
FTSeq l ety -> tSeq (tNum l) (unFinType ety)
|
FTSeq l ety -> tSeq (tNum l) (unFinType ety)
|
||||||
FTTuple ftys -> tTuple (unFinType <$> ftys)
|
FTTuple ftys -> tTuple (unFinType <$> ftys)
|
||||||
FTRecord fs -> tRec (Map.toList (fmap unFinType fs))
|
FTRecord fs -> tRec (Map.toList (fmap unFinType fs))
|
||||||
|
@ -32,6 +32,8 @@ import Data.Maybe (fromMaybe)
|
|||||||
import qualified Data.Map as Map
|
import qualified Data.Map as Map
|
||||||
import qualified Control.Exception as X
|
import qualified Control.Exception as X
|
||||||
|
|
||||||
|
import LibBF(bfNaN)
|
||||||
|
|
||||||
import qualified Data.SBV as SBV (sObserve)
|
import qualified Data.SBV as SBV (sObserve)
|
||||||
import qualified Data.SBV.Internals as SBV (SBV(..))
|
import qualified Data.SBV.Internals as SBV (SBV(..))
|
||||||
import qualified Data.SBV.Dynamic as SBV
|
import qualified Data.SBV.Dynamic as SBV
|
||||||
@ -48,6 +50,7 @@ import qualified Cryptol.Eval.Backend as Eval
|
|||||||
import qualified Cryptol.Eval as Eval
|
import qualified Cryptol.Eval as Eval
|
||||||
import qualified Cryptol.Eval.Concrete as Concrete
|
import qualified Cryptol.Eval.Concrete as Concrete
|
||||||
import Cryptol.Eval.Concrete (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.Monad as Eval
|
||||||
|
|
||||||
import qualified Cryptol.Eval.Value as Eval
|
import qualified Cryptol.Eval.Value as Eval
|
||||||
@ -429,6 +432,14 @@ parseValue (FTTuple ts) cvs = (Eval.VTuple (map Eval.ready vs), cvs')
|
|||||||
parseValue (FTRecord fs) cvs = (Eval.VRecord (Map.fromList (zip ns (map Eval.ready vs))), cvs')
|
parseValue (FTRecord fs) cvs = (Eval.VRecord (Map.fromList (zip ns (map Eval.ready vs))), cvs')
|
||||||
where (ns, ts) = unzip (Map.toList fs)
|
where (ns, ts) = unzip (Map.toList fs)
|
||||||
(vs, cvs') = parseValues ts cvs
|
(vs, cvs') = parseValues ts cvs
|
||||||
|
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 :: Integer -> Eval.SInteger SBV -> Eval.SBit SBV
|
||||||
inBoundsIntMod n x =
|
inBoundsIntMod n x =
|
||||||
@ -447,6 +458,7 @@ forallFinType ty =
|
|||||||
let z = SBV.svInteger SBV.KUnbounded 0
|
let z = SBV.svInteger SBV.KUnbounded 0
|
||||||
tell [SBV.svLessThan z d]
|
tell [SBV.svLessThan z d]
|
||||||
return (Eval.VRational (Eval.SRational n d))
|
return (Eval.VRational (Eval.SRational n d))
|
||||||
|
FTFloat {} -> pure (Eval.VFloat ()) -- XXX: NOT IMPLEMENTED
|
||||||
FTIntMod n -> do x <- lift forallSInteger_
|
FTIntMod n -> do x <- lift forallSInteger_
|
||||||
tell [inBoundsIntMod n x]
|
tell [inBoundsIntMod n x]
|
||||||
return (Eval.VInteger x)
|
return (Eval.VInteger x)
|
||||||
@ -468,6 +480,7 @@ existsFinType ty =
|
|||||||
let z = SBV.svInteger SBV.KUnbounded 0
|
let z = SBV.svInteger SBV.KUnbounded 0
|
||||||
tell [SBV.svLessThan z d]
|
tell [SBV.svLessThan z d]
|
||||||
return (Eval.VRational (Eval.SRational n d))
|
return (Eval.VRational (Eval.SRational n d))
|
||||||
|
FTFloat {} -> pure $ Eval.VFloat () -- XXX: NOT IMPLEMENTED
|
||||||
FTIntMod n -> do x <- lift existsSInteger_
|
FTIntMod n -> do x <- lift existsSInteger_
|
||||||
tell [inBoundsIntMod n x]
|
tell [inBoundsIntMod n x]
|
||||||
return (Eval.VInteger x)
|
return (Eval.VInteger x)
|
||||||
|
@ -39,10 +39,12 @@ import qualified Cryptol.ModuleSystem.Monad as M
|
|||||||
|
|
||||||
import qualified Cryptol.Eval as Eval
|
import qualified Cryptol.Eval as Eval
|
||||||
import qualified Cryptol.Eval.Concrete as Concrete
|
import qualified Cryptol.Eval.Concrete as Concrete
|
||||||
|
import qualified Cryptol.Eval.Concrete.Float as Concrete
|
||||||
|
|
||||||
import qualified Cryptol.Eval.Backend as Eval
|
import qualified Cryptol.Eval.Backend as Eval
|
||||||
import qualified Cryptol.Eval.Value as Eval
|
import qualified Cryptol.Eval.Value as Eval
|
||||||
import Cryptol.Eval.What4
|
import Cryptol.Eval.What4
|
||||||
|
import qualified Cryptol.Eval.What4.SFloat as W4
|
||||||
import Cryptol.Symbolic
|
import Cryptol.Symbolic
|
||||||
import Cryptol.TypeCheck.AST
|
import Cryptol.TypeCheck.AST
|
||||||
import Cryptol.Utils.Ident (Ident)
|
import Cryptol.Utils.Ident (Ident)
|
||||||
@ -358,6 +360,18 @@ varBlockingPred sym evalFn v =
|
|||||||
VarWord (SW.DBV w) ->
|
VarWord (SW.DBV w) ->
|
||||||
do wlit <- W4.groundEval evalFn w
|
do wlit <- W4.groundEval evalFn w
|
||||||
W4.notPred sym =<< W4.bvEq sym w =<< W4.bvLit sym (W4.bvWidth w) wlit
|
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
|
VarFinSeq _n vs -> computeBlockingPred sym evalFn vs
|
||||||
VarTuple vs -> computeBlockingPred sym evalFn vs
|
VarTuple vs -> computeBlockingPred sym evalFn vs
|
||||||
VarRecord fs -> computeBlockingPred sym evalFn (map snd (Map.toList fs))
|
VarRecord fs -> computeBlockingPred sym evalFn (map snd (Map.toList fs))
|
||||||
@ -385,6 +399,7 @@ data VarShape sym
|
|||||||
= VarBit (W4.Pred sym)
|
= VarBit (W4.Pred sym)
|
||||||
| VarInteger (W4.SymInteger sym)
|
| VarInteger (W4.SymInteger sym)
|
||||||
| VarRational (W4.SymInteger sym) (W4.SymInteger sym)
|
| VarRational (W4.SymInteger sym) (W4.SymInteger sym)
|
||||||
|
| VarFloat (W4.SFloat sym)
|
||||||
| VarWord (SW.SWord sym)
|
| VarWord (SW.SWord sym)
|
||||||
| VarFinSeq Int [VarShape sym]
|
| VarFinSeq Int [VarShape sym]
|
||||||
| VarTuple [VarShape sym]
|
| VarTuple [VarShape sym]
|
||||||
@ -400,6 +415,7 @@ freshVariable sym ty =
|
|||||||
<*> W4.freshBoundedInt sym W4.emptySymbol (Just 1) Nothing
|
<*> W4.freshBoundedInt sym W4.emptySymbol (Just 1) Nothing
|
||||||
FTIntMod 0 -> panic "freshVariable" ["0 modulus not allowed"]
|
FTIntMod 0 -> panic "freshVariable" ["0 modulus not allowed"]
|
||||||
FTIntMod n -> VarInteger <$> W4.freshBoundedInt sym W4.emptySymbol (Just 0) (Just (n-1))
|
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 FTBit -> VarWord <$> SW.freshBV sym W4.emptySymbol (toInteger n)
|
||||||
FTSeq n t -> VarFinSeq n <$> sequence (replicate n (freshVariable sym t))
|
FTSeq n t -> VarFinSeq n <$> sequence (replicate n (freshVariable sym t))
|
||||||
FTTuple ts -> VarTuple <$> mapM (freshVariable sym) ts
|
FTTuple ts -> VarTuple <$> mapM (freshVariable sym) ts
|
||||||
@ -412,6 +428,7 @@ varToSymValue sym var =
|
|||||||
VarInteger i -> Eval.VInteger i
|
VarInteger i -> Eval.VInteger i
|
||||||
VarRational n d -> Eval.VRational (Eval.SRational n d)
|
VarRational n d -> Eval.VRational (Eval.SRational n d)
|
||||||
VarWord w -> Eval.VWord (SW.bvWidth w) (return (Eval.WordVal w))
|
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))
|
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)
|
VarTuple vs -> Eval.VTuple (map (pure . varToSymValue sym) vs)
|
||||||
VarRecord fs -> Eval.VRecord (fmap (pure . varToSymValue sym) fs)
|
VarRecord fs -> Eval.VRecord (fmap (pure . varToSymValue sym) fs)
|
||||||
@ -431,6 +448,11 @@ varToConcreteValue evalFn v =
|
|||||||
VarWord (SW.DBV x) ->
|
VarWord (SW.DBV x) ->
|
||||||
do let w = W4.intValue (W4.bvWidth x)
|
do let w = W4.intValue (W4.bvWidth x)
|
||||||
Eval.VWord w . pure . Eval.WordVal . Concrete.mkBv w . BV.asUnsigned <$> W4.groundEval evalFn 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 ->
|
VarFinSeq n vs ->
|
||||||
do vs' <- mapM (varToConcreteValue evalFn) vs
|
do vs' <- mapM (varToConcreteValue evalFn) vs
|
||||||
pure (Eval.VSeq (toInteger n) (Eval.finiteSeqMap Concrete.Concrete (map pure vs')))
|
pure (Eval.VSeq (toInteger n) (Eval.finiteSeqMap Concrete.Concrete (map pure vs')))
|
||||||
|
@ -17,6 +17,7 @@ module Cryptol.Testing.Random where
|
|||||||
|
|
||||||
import qualified Control.Exception as X
|
import qualified Control.Exception as X
|
||||||
import Control.Monad (join, liftM2)
|
import Control.Monad (join, liftM2)
|
||||||
|
import Data.Ratio ((%))
|
||||||
import Data.Bits ( (.&.), shiftR )
|
import Data.Bits ( (.&.), shiftR )
|
||||||
import Data.List (unfoldr, genericTake, genericIndex, genericReplicate)
|
import Data.List (unfoldr, genericTake, genericIndex, genericReplicate)
|
||||||
import Data.Map (Map)
|
import Data.Map (Map)
|
||||||
@ -33,7 +34,8 @@ import Cryptol.Eval.Type (TValue(..), tValTy)
|
|||||||
import Cryptol.Eval.Value (GenValue(..),SeqMap(..), WordValue(..),
|
import Cryptol.Eval.Value (GenValue(..),SeqMap(..), WordValue(..),
|
||||||
ppValue, defaultPPOpts, finiteSeqMap)
|
ppValue, defaultPPOpts, finiteSeqMap)
|
||||||
import Cryptol.Eval.Generic (zeroV)
|
import Cryptol.Eval.Generic (zeroV)
|
||||||
import Cryptol.TypeCheck.AST (Type(..), TCon(..), TC(..), tNoUser, tIsFun)
|
import Cryptol.TypeCheck.AST (Type(..), TCon(..), TC(..), tNoUser, tIsFun
|
||||||
|
, tIsNum )
|
||||||
import Cryptol.TypeCheck.SimpType(tRebuild')
|
import Cryptol.TypeCheck.SimpType(tRebuild')
|
||||||
|
|
||||||
import Cryptol.Utils.Ident (Ident)
|
import Cryptol.Utils.Ident (Ident)
|
||||||
@ -149,6 +151,9 @@ randomValue sym ty =
|
|||||||
(TC TCIntMod, [TCon (TC (TCNum n)) []]) ->
|
(TC TCIntMod, [TCon (TC (TCNum n)) []]) ->
|
||||||
do return (randomIntMod sym 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]) ->
|
(TC TCSeq, [TCon (TC TCInf) [], el]) ->
|
||||||
do mk <- randomValue sym el
|
do mk <- randomValue sym el
|
||||||
return (randomStream mk)
|
return (randomStream mk)
|
||||||
@ -269,6 +274,26 @@ randomRecord gens sz g0 =
|
|||||||
let (v, g') = gen sz g
|
let (v, g') = gen sz g
|
||||||
in seq v (g', v)
|
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 ---------------------------------------------------------------
|
-- Random Values ---------------------------------------------------------------
|
||||||
|
|
||||||
@ -363,6 +388,7 @@ typeSize ty =
|
|||||||
TCon (TC (TCNum n)) _ -> Just n
|
TCon (TC (TCNum n)) _ -> Just n
|
||||||
_ -> Nothing
|
_ -> Nothing
|
||||||
(TCIntMod, _) -> Nothing
|
(TCIntMod, _) -> Nothing
|
||||||
|
(TCFloat {}, _) -> Nothing
|
||||||
(TCArray, _) -> Nothing
|
(TCArray, _) -> Nothing
|
||||||
(TCSeq, [sz,el]) -> case tNoUser sz of
|
(TCSeq, [sz,el]) -> case tNoUser sz of
|
||||||
TCon (TC (TCNum n)) _ -> (^ n) <$> typeSize el
|
TCon (TC (TCNum n)) _ -> (^ n) <$> typeSize el
|
||||||
@ -398,6 +424,7 @@ typeValues ty =
|
|||||||
[ TCon (TC (TCNum n)) _ ] | 0 < n ->
|
[ TCon (TC (TCNum n)) _ ] | 0 < n ->
|
||||||
[ VInteger x | x <- [ 0 .. n - 1 ] ]
|
[ VInteger x | x <- [ 0 .. n - 1 ] ]
|
||||||
_ -> []
|
_ -> []
|
||||||
|
TCFloat {} -> []
|
||||||
TCArray -> []
|
TCArray -> []
|
||||||
TCSeq ->
|
TCSeq ->
|
||||||
case map tNoUser ts of
|
case map tNoUser ts of
|
||||||
|
@ -36,7 +36,7 @@ import Cryptol.ModuleSystem.Exports(ExportSpec(..)
|
|||||||
import Cryptol.Parser.AST ( Selector(..),Pragma(..)
|
import Cryptol.Parser.AST ( Selector(..),Pragma(..)
|
||||||
, Import(..), ImportSpec(..), ExportType(..)
|
, Import(..), ImportSpec(..), ExportType(..)
|
||||||
, Fixity(..))
|
, Fixity(..))
|
||||||
import Cryptol.Utils.Ident (Ident,isInfixIdent,ModName,packIdent)
|
import Cryptol.Utils.Ident (Ident,isInfixIdent,ModName,PrimIdent,prelPrim)
|
||||||
import Cryptol.TypeCheck.PP
|
import Cryptol.TypeCheck.PP
|
||||||
import Cryptol.TypeCheck.Type
|
import Cryptol.TypeCheck.Type
|
||||||
|
|
||||||
@ -176,22 +176,21 @@ data DeclDef = DPrim
|
|||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
-- | Construct a primitive, given a map to the unique names of the Cryptol
|
-- | Construct a primitive, given a map to the unique primitive name.
|
||||||
-- module.
|
ePrim :: PrimMap -> PrimIdent -> Expr
|
||||||
ePrim :: PrimMap -> Ident -> Expr
|
|
||||||
ePrim pm n = EVar (lookupPrimDecl n pm)
|
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 :: PrimMap -> Type -> String -> Expr
|
||||||
eError prims t str =
|
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)
|
(tNum (length str))) (eString prims str)
|
||||||
|
|
||||||
eString :: PrimMap -> String -> Expr
|
eString :: PrimMap -> String -> Expr
|
||||||
eString prims str = EList (map (eChar prims) str) tChar
|
eString prims str = EList (map (eChar prims) str) tChar
|
||||||
|
|
||||||
eChar :: PrimMap -> Char -> Expr
|
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
|
where v = fromEnum c
|
||||||
w = 8 :: Int
|
w = 8 :: Int
|
||||||
|
|
||||||
|
@ -23,6 +23,9 @@ module Cryptol.TypeCheck.Infer
|
|||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
|
import qualified Data.Text as Text
|
||||||
|
|
||||||
|
|
||||||
import Cryptol.ModuleSystem.Name (asPrim,lookupPrimDecl,nameLoc)
|
import Cryptol.ModuleSystem.Name (asPrim,lookupPrimDecl,nameLoc)
|
||||||
import Cryptol.Parser.Position
|
import Cryptol.Parser.Position
|
||||||
import qualified Cryptol.Parser.AST as P
|
import qualified Cryptol.Parser.AST as P
|
||||||
@ -53,6 +56,7 @@ import Data.Either(partitionEithers)
|
|||||||
import Data.Maybe(mapMaybe,isJust, fromMaybe)
|
import Data.Maybe(mapMaybe,isJust, fromMaybe)
|
||||||
import Data.List(partition,find)
|
import Data.List(partition,find)
|
||||||
import Data.Graph(SCC(..))
|
import Data.Graph(SCC(..))
|
||||||
|
import Data.Ratio(numerator,denominator)
|
||||||
import Data.Traversable(forM)
|
import Data.Traversable(forM)
|
||||||
import Control.Monad(zipWithM,unless,foldM)
|
import Control.Monad(zipWithM,unless,foldM)
|
||||||
|
|
||||||
@ -85,17 +89,17 @@ inferModule m =
|
|||||||
|
|
||||||
|
|
||||||
|
|
||||||
-- | Construct a primitive in the parsed AST.
|
-- | Construct a Prelude primitive in the parsed AST.
|
||||||
mkPrim :: String -> InferM (P.Expr Name)
|
mkPrim :: String -> InferM (P.Expr Name)
|
||||||
mkPrim str =
|
mkPrim str =
|
||||||
do nm <- mkPrim' str
|
do nm <- mkPrim' str
|
||||||
return (P.EVar nm)
|
return (P.EVar nm)
|
||||||
|
|
||||||
-- | Construct a primitive in the parsed AST.
|
-- | Construct a Prelude primitive in the parsed AST.
|
||||||
mkPrim' :: String -> InferM Name
|
mkPrim' :: String -> InferM Name
|
||||||
mkPrim' str =
|
mkPrim' str =
|
||||||
do prims <- getPrimMap
|
do prims <- getPrimMap
|
||||||
return (lookupPrimDecl (packIdent str) prims)
|
return (lookupPrimDecl (prelPrim (Text.pack str)) prims)
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
@ -103,6 +107,7 @@ desugarLiteral :: Bool -> P.Literal -> InferM (P.Expr Name)
|
|||||||
desugarLiteral fixDec lit =
|
desugarLiteral fixDec lit =
|
||||||
do l <- curRange
|
do l <- curRange
|
||||||
numberPrim <- mkPrim "number"
|
numberPrim <- mkPrim "number"
|
||||||
|
fracPrim <- mkPrim "fraction"
|
||||||
let named (x,y) = P.NamedInst
|
let named (x,y) = P.NamedInst
|
||||||
P.Named { name = Located l (packIdent x), value = y }
|
P.Named { name = Located l (packIdent x), value = y }
|
||||||
number fs = P.EAppT numberPrim (map named fs)
|
number fs = P.EAppT numberPrim (map named fs)
|
||||||
@ -124,6 +129,13 @@ desugarLiteral fixDec lit =
|
|||||||
| otherwise -> [ ]
|
| otherwise -> [ ]
|
||||||
P.PolyLit _n -> [ ("rep", P.TSeq P.TWild P.TBit) ]
|
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.HexFrac -> 1))
|
||||||
|
in P.EAppT fracPrim [ arg numerator, arg denominator, rnd ]
|
||||||
|
|
||||||
P.ECChar c ->
|
P.ECChar c ->
|
||||||
number [ ("val", P.TNum (toInteger (fromEnum c)))
|
number [ ("val", P.TNum (toInteger (fromEnum c)))
|
||||||
, ("rep", tBits (8 :: Integer)) ]
|
, ("rep", tBits (8 :: Integer)) ]
|
||||||
@ -325,7 +337,7 @@ checkE expr tGoal =
|
|||||||
P.EApp fun@(dropLoc -> P.EApp (dropLoc -> P.EVar c) _)
|
P.EApp fun@(dropLoc -> P.EApp (dropLoc -> P.EVar c) _)
|
||||||
arg@(dropLoc -> P.ELit l)
|
arg@(dropLoc -> P.ELit l)
|
||||||
| Just n <- asPrim c
|
| Just n <- asPrim c
|
||||||
, n `elem` map packIdent [ "<<", ">>", "<<<", ">>>" , "@", "!" ] ->
|
, n `elem` map prelPrim [ "<<", ">>", "<<<", ">>>" , "@", "!" ] ->
|
||||||
do newArg <- do l1 <- desugarLiteral True l
|
do newArg <- do l1 <- desugarLiteral True l
|
||||||
return $ case arg of
|
return $ case arg of
|
||||||
P.ELocated _ pos -> P.ELocated l1 pos
|
P.ELocated _ pos -> P.ELocated l1 pos
|
||||||
|
@ -18,6 +18,8 @@
|
|||||||
{-# LANGUAGE ViewPatterns #-}
|
{-# LANGUAGE ViewPatterns #-}
|
||||||
module Cryptol.TypeCheck.InferTypes where
|
module Cryptol.TypeCheck.InferTypes where
|
||||||
|
|
||||||
|
import Control.Monad(guard)
|
||||||
|
|
||||||
import Cryptol.Parser.Position
|
import Cryptol.Parser.Position
|
||||||
import Cryptol.ModuleSystem.Name (asPrim,nameLoc)
|
import Cryptol.ModuleSystem.Name (asPrim,nameLoc)
|
||||||
import Cryptol.TypeCheck.AST
|
import Cryptol.TypeCheck.AST
|
||||||
@ -25,7 +27,7 @@ import Cryptol.TypeCheck.PP
|
|||||||
import Cryptol.TypeCheck.Subst
|
import Cryptol.TypeCheck.Subst
|
||||||
import Cryptol.TypeCheck.TypePat
|
import Cryptol.TypeCheck.TypePat
|
||||||
import Cryptol.TypeCheck.SimpType(tMax)
|
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.Panic(panic)
|
||||||
import Cryptol.Utils.Misc(anyJust)
|
import Cryptol.Utils.Misc(anyJust)
|
||||||
|
|
||||||
@ -302,13 +304,17 @@ instance PP ConstraintSource where
|
|||||||
ppUse :: Expr -> Doc
|
ppUse :: Expr -> Doc
|
||||||
ppUse expr =
|
ppUse expr =
|
||||||
case expr of
|
case expr of
|
||||||
EVar (asPrim -> Just prim)
|
EVar (isPrelPrim -> Just prim)
|
||||||
| identText prim == "number" -> "literal or demoted expression"
|
| prim == "number" -> "literal or demoted expression"
|
||||||
| identText prim == "infFrom" -> "infinite enumeration"
|
| prim == "infFrom" -> "infinite enumeration"
|
||||||
| identText prim == "infFromThen" -> "infinite enumeration (with step)"
|
| prim == "infFromThen" -> "infinite enumeration (with step)"
|
||||||
| identText prim == "fromTo" -> "finite enumeration"
|
| prim == "fromTo" -> "finite enumeration"
|
||||||
| identText prim == "fromThenTo" -> "finite enumeration"
|
| prim == "fromThenTo" -> "finite enumeration"
|
||||||
_ -> "expression" <+> pp expr
|
_ -> "expression" <+> pp expr
|
||||||
|
where
|
||||||
|
isPrelPrim x = do PrimIdent p i <- asPrim x
|
||||||
|
guard (p == preludeName)
|
||||||
|
pure i
|
||||||
|
|
||||||
instance PP (WithNames Goal) where
|
instance PP (WithNames Goal) where
|
||||||
ppPrec _ (WithNames g names) =
|
ppPrec _ (WithNames g names) =
|
||||||
|
@ -10,7 +10,9 @@ import Cryptol.TypeCheck.Solver.Class
|
|||||||
( solveZeroInst, solveLogicInst, solveRingInst
|
( solveZeroInst, solveLogicInst, solveRingInst
|
||||||
, solveIntegralInst, solveFieldInst, solveRoundInst
|
, solveIntegralInst, solveFieldInst, solveRoundInst
|
||||||
, solveEqInst, solveCmpInst, solveSignedCmpInst
|
, solveEqInst, solveCmpInst, solveSignedCmpInst
|
||||||
, solveLiteralInst )
|
, solveLiteralInst
|
||||||
|
, solveValidFloat, solveFLiteralInst
|
||||||
|
)
|
||||||
|
|
||||||
import Cryptol.Utils.Debug(ppTrace)
|
import Cryptol.Utils.Debug(ppTrace)
|
||||||
import Cryptol.TypeCheck.PP
|
import Cryptol.TypeCheck.PP
|
||||||
@ -51,8 +53,9 @@ simplifyStep ctxt prop =
|
|||||||
TCon (PC PCmp) [ty] -> solveCmpInst ty
|
TCon (PC PCmp) [ty] -> solveCmpInst ty
|
||||||
TCon (PC PSignedCmp) [ty] -> solveSignedCmpInst ty
|
TCon (PC PSignedCmp) [ty] -> solveSignedCmpInst ty
|
||||||
TCon (PC PLiteral) [t1,t2] -> solveLiteralInst t1 t2
|
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 PFin) [ty] -> cryIsFinType ctxt ty
|
||||||
|
|
||||||
TCon (PC PEqual) [t1,t2] -> cryIsEqual ctxt t1 t2
|
TCon (PC PEqual) [t1,t2] -> cryIsEqual ctxt t1 t2
|
||||||
|
@ -20,14 +20,50 @@ module Cryptol.TypeCheck.Solver.Class
|
|||||||
, solveCmpInst
|
, solveCmpInst
|
||||||
, solveSignedCmpInst
|
, solveSignedCmpInst
|
||||||
, solveLiteralInst
|
, solveLiteralInst
|
||||||
|
, solveFLiteralInst
|
||||||
|
, solveValidFloat
|
||||||
) where
|
) where
|
||||||
|
|
||||||
|
import qualified LibBF as FP
|
||||||
|
|
||||||
import Cryptol.TypeCheck.Type
|
import Cryptol.TypeCheck.Type
|
||||||
import Cryptol.TypeCheck.SimpType (tAdd,tWidth)
|
import Cryptol.TypeCheck.SimpType (tAdd,tWidth)
|
||||||
import Cryptol.TypeCheck.Solver.Types
|
import Cryptol.TypeCheck.Solver.Types
|
||||||
import Cryptol.TypeCheck.PP
|
import Cryptol.TypeCheck.PP
|
||||||
|
|
||||||
|
|
||||||
|
{- | 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.
|
-- | Solve a Zero constraint by instance, if possible.
|
||||||
solveZeroInst :: Type -> Solved
|
solveZeroInst :: Type -> Solved
|
||||||
solveZeroInst ty = case tNoUser ty of
|
solveZeroInst ty = case tNoUser ty of
|
||||||
@ -45,11 +81,13 @@ solveZeroInst ty = case tNoUser ty of
|
|||||||
TCon (TC TCIntMod) [n] -> SolvedIf [ pFin n, n >== tOne ]
|
TCon (TC TCIntMod) [n] -> SolvedIf [ pFin n, n >== tOne ]
|
||||||
|
|
||||||
-- Zero Real
|
-- Zero Real
|
||||||
-- Zero Float
|
|
||||||
|
|
||||||
-- Zero Rational
|
-- Zero Rational
|
||||||
TCon (TC TCRational) [] -> SolvedIf []
|
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
|
-- Zero a => Zero [n]a
|
||||||
TCon (TC TCSeq) [_, a] -> SolvedIf [ pZero a ]
|
TCon (TC TCSeq) [_, a] -> SolvedIf [ pZero a ]
|
||||||
|
|
||||||
@ -117,6 +155,9 @@ solveRingInst ty = case tNoUser ty of
|
|||||||
-- Ring Rational
|
-- Ring Rational
|
||||||
TCon (TC TCRational) [] -> SolvedIf []
|
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 }
|
-- (Ring a, Ring b) => Ring { x1 : a, x2 : b }
|
||||||
TRec fs -> SolvedIf [ pRing ety | (_,ety) <- fs ]
|
TRec fs -> SolvedIf [ pRing ety | (_,ety) <- fs ]
|
||||||
|
|
||||||
@ -181,8 +222,10 @@ solveFieldInst ty = case tNoUser ty of
|
|||||||
-- Field Rational
|
-- Field Rational
|
||||||
TCon (TC TCRational) [] -> SolvedIf []
|
TCon (TC TCRational) [] -> SolvedIf []
|
||||||
|
|
||||||
|
-- ValidFloat e p => Field (Float e p)
|
||||||
|
TCon (TC TCFloat) [e,p] -> SolvedIf [ pValidFloat e p ]
|
||||||
|
|
||||||
-- Field Real
|
-- Field Real
|
||||||
-- Field Float
|
|
||||||
-- Field (Z n)
|
-- Field (Z n)
|
||||||
-- TCon (TC TCIntMod) [n] -> SolvedIf [ pFin n, n >== tOne, pPrime n ]
|
-- TCon (TC TCIntMod) [n] -> SolvedIf [ pFin n, n >== tOne, pPrime n ]
|
||||||
|
|
||||||
@ -199,8 +242,10 @@ solveRoundInst ty = case tNoUser ty of
|
|||||||
-- Round Rational
|
-- Round Rational
|
||||||
TCon (TC TCRational) [] -> SolvedIf []
|
TCon (TC TCRational) [] -> SolvedIf []
|
||||||
|
|
||||||
|
-- ValidFloat e p => Round (Float e p)
|
||||||
|
TCon (TC TCFloat) [e,p] -> SolvedIf [ pValidFloat e p ]
|
||||||
|
|
||||||
-- Round Real
|
-- Round Real
|
||||||
-- Round Float
|
|
||||||
|
|
||||||
_ -> Unsolved
|
_ -> Unsolved
|
||||||
|
|
||||||
@ -222,6 +267,9 @@ solveEqInst ty = case tNoUser ty of
|
|||||||
-- Eq Rational
|
-- Eq Rational
|
||||||
TCon (TC TCRational) [] -> SolvedIf []
|
TCon (TC TCRational) [] -> SolvedIf []
|
||||||
|
|
||||||
|
-- ValidFloat e p => Eq (Float e p)
|
||||||
|
TCon (TC TCFloat) [e,p] -> SolvedIf [ pValidFloat e p ]
|
||||||
|
|
||||||
-- Eq (Z n)
|
-- Eq (Z n)
|
||||||
TCon (TC TCIntMod) [n] -> SolvedIf [ pFin n, n >== tOne ]
|
TCon (TC TCIntMod) [n] -> SolvedIf [ pFin n, n >== tOne ]
|
||||||
|
|
||||||
@ -261,6 +309,9 @@ solveCmpInst ty = case tNoUser ty of
|
|||||||
TCon (TC TCIntMod) [_] ->
|
TCon (TC TCIntMod) [_] ->
|
||||||
Unsolvable $ TCErrorMessage "Values of Z_n type cannot be compared for order"
|
Unsolvable $ TCErrorMessage "Values of Z_n type cannot be compared for order"
|
||||||
|
|
||||||
|
-- ValidFloat e p => Cmp (Float e p)
|
||||||
|
TCon (TC TCFloat) [e,p] -> SolvedIf [ pValidFloat e p ]
|
||||||
|
|
||||||
-- (fin n, Cmp a) => Cmp [n]a
|
-- (fin n, Cmp a) => Cmp [n]a
|
||||||
TCon (TC TCSeq) [n,a] -> SolvedIf [ pFin n, pCmp a ]
|
TCon (TC TCSeq) [n,a] -> SolvedIf [ pFin n, pCmp a ]
|
||||||
|
|
||||||
@ -318,6 +369,42 @@ solveSignedCmpInst ty = case tNoUser ty of
|
|||||||
_ -> Unsolved
|
_ -> 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 []
|
||||||
|
|
||||||
|
TCon (TC TCFloat) [e,p]
|
||||||
|
| Just 0 <- tIsNum rndT -> SolvedIf [ pValidFloat e p ]
|
||||||
|
| 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.
|
-- | Solve Literal constraints.
|
||||||
solveLiteralInst :: Type -> Type -> Solved
|
solveLiteralInst :: Type -> Type -> Solved
|
||||||
solveLiteralInst val ty
|
solveLiteralInst val ty
|
||||||
@ -348,5 +435,6 @@ solveLiteralInst val ty
|
|||||||
TVar _ -> Unsolved
|
TVar _ -> Unsolved
|
||||||
|
|
||||||
_ -> Unsolvable $ TCErrorMessage $ show
|
_ -> Unsolvable $ TCErrorMessage $ show
|
||||||
$ "Type" <+> quotes (pp ty) <+> "does not support literals."
|
$ "Type" <+> quotes (pp ty) <+> "does not support integer literals."
|
||||||
|
|
||||||
|
|
||||||
|
@ -138,6 +138,14 @@ propInterval varInts prop = catMaybes
|
|||||||
|
|
||||||
return (x, Interval { iLower = Nat 0, iUpper = ub })
|
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)
|
||||||
|
|
||||||
]
|
]
|
||||||
|
|
||||||
|
|
||||||
|
@ -42,12 +42,20 @@ builtInType nm =
|
|||||||
case M.nameInfo nm of
|
case M.nameInfo nm of
|
||||||
M.Declared m _
|
M.Declared m _
|
||||||
| m == preludeName -> Map.lookup (M.nameIdent nm) builtInTypes
|
| m == preludeName -> Map.lookup (M.nameIdent nm) builtInTypes
|
||||||
|
| m == floatName -> Map.lookup (M.nameIdent nm) builtInFloat
|
||||||
| m == arrayName -> Map.lookup (M.nameIdent nm) builtInArray
|
| m == arrayName -> Map.lookup (M.nameIdent nm) builtInArray
|
||||||
_ -> Nothing
|
_ -> Nothing
|
||||||
|
|
||||||
where
|
where
|
||||||
x ~> y = (packIdent x, y)
|
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
|
builtInTypes = Map.fromList
|
||||||
[ -- Types
|
[ -- Types
|
||||||
"inf" ~> TC TCInf
|
"inf" ~> TC TCInf
|
||||||
@ -71,6 +79,7 @@ builtInType nm =
|
|||||||
, "Cmp" ~> PC PCmp
|
, "Cmp" ~> PC PCmp
|
||||||
, "SignedCmp" ~> PC PSignedCmp
|
, "SignedCmp" ~> PC PSignedCmp
|
||||||
, "Literal" ~> PC PLiteral
|
, "Literal" ~> PC PLiteral
|
||||||
|
, "FLiteral" ~> PC PFLiteral
|
||||||
|
|
||||||
-- Type functions
|
-- Type functions
|
||||||
, "+" ~> TF TCAdd
|
, "+" ~> TF TCAdd
|
||||||
@ -126,6 +135,7 @@ instance HasKind TC where
|
|||||||
TCBit -> KType
|
TCBit -> KType
|
||||||
TCInteger -> KType
|
TCInteger -> KType
|
||||||
TCRational -> KType
|
TCRational -> KType
|
||||||
|
TCFloat -> KNum :-> KNum :-> KType
|
||||||
TCIntMod -> KNum :-> KType
|
TCIntMod -> KNum :-> KType
|
||||||
TCArray -> KType :-> KType :-> KType
|
TCArray -> KType :-> KType :-> KType
|
||||||
TCSeq -> KNum :-> KType :-> KType
|
TCSeq -> KNum :-> KType :-> KType
|
||||||
@ -152,6 +162,8 @@ instance HasKind PC where
|
|||||||
PCmp -> KType :-> KProp
|
PCmp -> KType :-> KProp
|
||||||
PSignedCmp -> KType :-> KProp
|
PSignedCmp -> KType :-> KProp
|
||||||
PLiteral -> KNum :-> KType :-> KProp
|
PLiteral -> KNum :-> KType :-> KProp
|
||||||
|
PFLiteral -> KNum :-> KNum :-> KNum :-> KType :-> KProp
|
||||||
|
PValidFloat -> KNum :-> KNum :-> KProp
|
||||||
PAnd -> KProp :-> KProp :-> KProp
|
PAnd -> KProp :-> KProp :-> KProp
|
||||||
PTrue -> KProp
|
PTrue -> KProp
|
||||||
|
|
||||||
@ -199,6 +211,10 @@ data PC = PEqual -- ^ @_ == _@
|
|||||||
| PCmp -- ^ @Cmp _@
|
| PCmp -- ^ @Cmp _@
|
||||||
| PSignedCmp -- ^ @SignedCmp _@
|
| PSignedCmp -- ^ @SignedCmp _@
|
||||||
| PLiteral -- ^ @Literal _ _@
|
| PLiteral -- ^ @Literal _ _@
|
||||||
|
| PFLiteral -- ^ @FLiteral _ _ _@
|
||||||
|
|
||||||
|
| PValidFloat -- ^ @ValidFloat _ _@ constraints on supported
|
||||||
|
-- floating point representaitons
|
||||||
|
|
||||||
| PAnd -- ^ This is useful when simplifying things in place
|
| PAnd -- ^ This is useful when simplifying things in place
|
||||||
| PTrue -- ^ Ditto
|
| PTrue -- ^ Ditto
|
||||||
@ -210,6 +226,7 @@ data TC = TCNum Integer -- ^ Numbers
|
|||||||
| TCInf -- ^ Inf
|
| TCInf -- ^ Inf
|
||||||
| TCBit -- ^ Bit
|
| TCBit -- ^ Bit
|
||||||
| TCInteger -- ^ Integer
|
| TCInteger -- ^ Integer
|
||||||
|
| TCFloat -- ^ Float
|
||||||
| TCIntMod -- ^ @Z _@
|
| TCIntMod -- ^ @Z _@
|
||||||
| TCRational -- ^ @Rational@
|
| TCRational -- ^ @Rational@
|
||||||
| TCArray -- ^ @Array _ _@
|
| TCArray -- ^ @Array _ _@
|
||||||
@ -302,6 +319,8 @@ instance PP PC where
|
|||||||
PCmp -> text "Cmp"
|
PCmp -> text "Cmp"
|
||||||
PSignedCmp -> text "SignedCmp"
|
PSignedCmp -> text "SignedCmp"
|
||||||
PLiteral -> text "Literal"
|
PLiteral -> text "Literal"
|
||||||
|
PFLiteral -> text "FLiteral"
|
||||||
|
PValidFloat -> text "ValidFloat"
|
||||||
PTrue -> text "True"
|
PTrue -> text "True"
|
||||||
PAnd -> text "(&&)"
|
PAnd -> text "(&&)"
|
||||||
|
|
||||||
@ -315,6 +334,7 @@ instance PP TC where
|
|||||||
TCIntMod -> text "Z"
|
TCIntMod -> text "Z"
|
||||||
TCRational -> text "Rational"
|
TCRational -> text "Rational"
|
||||||
TCArray -> text "Array"
|
TCArray -> text "Array"
|
||||||
|
TCFloat -> text "Float"
|
||||||
TCSeq -> text "[]"
|
TCSeq -> text "[]"
|
||||||
TCFun -> text "(->)"
|
TCFun -> text "(->)"
|
||||||
TCTuple 0 -> text "()"
|
TCTuple 0 -> text "()"
|
||||||
|
@ -495,6 +495,11 @@ pIsWidth ty = case tNoUser ty of
|
|||||||
TCon (TF TCWidth) [t1] -> Just t1
|
TCon (TF TCWidth) [t1] -> Just t1
|
||||||
_ -> Nothing
|
_ -> Nothing
|
||||||
|
|
||||||
|
pIsValidFloat :: Prop -> Maybe (Type,Type)
|
||||||
|
pIsValidFloat ty = case tNoUser ty of
|
||||||
|
TCon (PC PValidFloat) [a,b] -> Just (a,b)
|
||||||
|
_ -> Nothing
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
|
|
||||||
@ -530,6 +535,9 @@ tInteger = TCon (TC TCInteger) []
|
|||||||
tRational :: Type
|
tRational :: Type
|
||||||
tRational = TCon (TC TCRational) []
|
tRational = TCon (TC TCRational) []
|
||||||
|
|
||||||
|
tFloat :: Type -> Type -> Type
|
||||||
|
tFloat e p = TCon (TC TCFloat) [ e, p ]
|
||||||
|
|
||||||
tIntMod :: Type -> Type
|
tIntMod :: Type -> Type
|
||||||
tIntMod n = TCon (TC TCIntMod) [n]
|
tIntMod n = TCon (TC TCIntMod) [n]
|
||||||
|
|
||||||
@ -700,6 +708,9 @@ pFin ty =
|
|||||||
TCon (TC TCInf) _ -> pError (TCErrorMessage "`inf` is not finite.")
|
TCon (TC TCInf) _ -> pError (TCErrorMessage "`inf` is not finite.")
|
||||||
_ -> TCon (PC PFin) [ty]
|
_ -> TCon (PC PFin) [ty]
|
||||||
|
|
||||||
|
pValidFloat :: Type -> Type -> Type
|
||||||
|
pValidFloat e p = TCon (PC PValidFloat) [e,p]
|
||||||
|
|
||||||
-- | Make a malformed property.
|
-- | Make a malformed property.
|
||||||
pError :: TCErrorMessage -> Prop
|
pError :: TCErrorMessage -> Prop
|
||||||
pError msg = TCon (TError KProp msg) []
|
pError msg = TCon (TError KProp msg) []
|
||||||
@ -858,7 +869,7 @@ instance PP (WithNames Type) where
|
|||||||
|
|
||||||
(TCTuple _, fs) -> parens $ fsep $ punctuate comma $ map (go 0) fs
|
(TCTuple _, fs) -> parens $ fsep $ punctuate comma $ map (go 0) fs
|
||||||
|
|
||||||
(_, _) -> pp tc <+> fsep (map (go 4) ts)
|
(_, _) -> pp tc <+> fsep (map (go 5) ts)
|
||||||
|
|
||||||
TCon (PC pc) ts ->
|
TCon (PC pc) ts ->
|
||||||
case (pc,ts) of
|
case (pc,ts) of
|
||||||
|
@ -16,6 +16,7 @@ module Cryptol.Utils.Ident
|
|||||||
, modNameChunks
|
, modNameChunks
|
||||||
, packModName
|
, packModName
|
||||||
, preludeName
|
, preludeName
|
||||||
|
, floatName
|
||||||
, arrayName
|
, arrayName
|
||||||
, interactiveName
|
, interactiveName
|
||||||
, noModuleName
|
, noModuleName
|
||||||
@ -37,6 +38,11 @@ module Cryptol.Utils.Ident
|
|||||||
, identText
|
, identText
|
||||||
, modParamIdent
|
, modParamIdent
|
||||||
|
|
||||||
|
-- * Identifiers for primitived
|
||||||
|
, PrimIdent(..)
|
||||||
|
, prelPrim
|
||||||
|
, floatPrim
|
||||||
|
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Control.DeepSeq (NFData)
|
import Control.DeepSeq (NFData)
|
||||||
@ -101,6 +107,9 @@ modInstPref = "`"
|
|||||||
preludeName :: ModName
|
preludeName :: ModName
|
||||||
preludeName = packModName ["Cryptol"]
|
preludeName = packModName ["Cryptol"]
|
||||||
|
|
||||||
|
floatName :: ModName
|
||||||
|
floatName = packModName ["Float"]
|
||||||
|
|
||||||
arrayName :: ModName
|
arrayName :: ModName
|
||||||
arrayName = packModName ["Array"]
|
arrayName = packModName ["Array"]
|
||||||
|
|
||||||
@ -162,4 +171,23 @@ modParamIdent :: Ident -> Ident
|
|||||||
modParamIdent (Ident x t) = Ident x (T.append (T.pack "module parameter ") t)
|
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 speicif
|
||||||
|
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
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
instance NFData PrimIdent
|
||||||
|
@ -3,14 +3,14 @@ Loading module Cryptol
|
|||||||
Loading module Main
|
Loading module Main
|
||||||
|
|
||||||
[error] at T146.cry:1:18--6:10:
|
[error] at T146.cry:1:18--6:10:
|
||||||
The type ?fv`951 is not sufficiently polymorphic.
|
The type ?fv`955 is not sufficiently polymorphic.
|
||||||
It cannot depend on quantified variables: fv`935
|
It cannot depend on quantified variables: fv`939
|
||||||
where
|
where
|
||||||
?fv`951 is type argument 'fv' of 'Main::ec_v1' at T146.cry:4:19--4:24
|
?fv`955 is type argument 'fv' of 'Main::ec_v1' at T146.cry:4:19--4:24
|
||||||
fv`935 is signature variable 'fv' at T146.cry:11:10--11:12
|
fv`939 is signature variable 'fv' at T146.cry:11:10--11:12
|
||||||
[error] at T146.cry:5:19--5:24:
|
[error] at T146.cry:5:19--5:24:
|
||||||
The type ?fv`953 is not sufficiently polymorphic.
|
The type ?fv`957 is not sufficiently polymorphic.
|
||||||
It cannot depend on quantified variables: fv`935
|
It cannot depend on quantified variables: fv`939
|
||||||
where
|
where
|
||||||
?fv`953 is type argument 'fv' of 'Main::ec_v2' at T146.cry:5:19--5:24
|
?fv`957 is type argument 'fv' of 'Main::ec_v2' at T146.cry:5:19--5:24
|
||||||
fv`935 is signature variable 'fv' at T146.cry:11:10--11:12
|
fv`939 is signature variable 'fv' at T146.cry:11:10--11:12
|
||||||
|
@ -44,6 +44,7 @@ Primitive Types
|
|||||||
Bit : *
|
Bit : *
|
||||||
Cmp : * -> Prop
|
Cmp : * -> Prop
|
||||||
Eq : * -> Prop
|
Eq : * -> Prop
|
||||||
|
FLiteral : # -> # -> # -> * -> Prop
|
||||||
Field : * -> Prop
|
Field : * -> Prop
|
||||||
fin : # -> Prop
|
fin : # -> Prop
|
||||||
Integer : *
|
Integer : *
|
||||||
@ -129,6 +130,7 @@ Symbols
|
|||||||
floor : {a} (Round a) => a -> Integer
|
floor : {a} (Round a) => a -> Integer
|
||||||
foldl : {n, a, b} (fin n) => (a -> b -> a) -> a -> [n]b -> a
|
foldl : {n, a, b} (fin n) => (a -> b -> a) -> a -> [n]b -> a
|
||||||
foldr : {n, a, b} (fin n) => (a -> b -> b) -> b -> [n]a -> b
|
foldr : {n, a, b} (fin n) => (a -> b -> b) -> b -> [n]a -> b
|
||||||
|
fraction : {m, n, r, a} (FLiteral m n r a) => a
|
||||||
fromInteger : {a} (Ring a) => Integer -> a
|
fromInteger : {a} (Ring a) => Integer -> a
|
||||||
fromThenTo :
|
fromThenTo :
|
||||||
{first, next, last, a, len} (fin first, fin next, fin last,
|
{first, next, last, a, len} (fin first, fin next, fin last,
|
||||||
|
@ -4,9 +4,9 @@ Loading module Main
|
|||||||
|
|
||||||
[error] at issue290v2.cry:2:1--2:19:
|
[error] at issue290v2.cry:2:1--2:19:
|
||||||
Unsolved constraints:
|
Unsolved constraints:
|
||||||
• n`932 == 1
|
• n`936 == 1
|
||||||
arising from
|
arising from
|
||||||
checking a pattern: type of 1st argument of Main::minMax
|
checking a pattern: type of 1st argument of Main::minMax
|
||||||
at issue290v2.cry:2:8--2:11
|
at issue290v2.cry:2:8--2:11
|
||||||
where
|
where
|
||||||
n`932 is signature variable 'n' at issue290v2.cry:1:11--1:12
|
n`936 is signature variable 'n' at issue290v2.cry:1:11--1:12
|
||||||
|
@ -12,9 +12,9 @@ Loading module Main
|
|||||||
assuming
|
assuming
|
||||||
• fin k
|
• fin k
|
||||||
the following constraints hold:
|
the following constraints hold:
|
||||||
• k >= n`932
|
• k >= n`936
|
||||||
arising from
|
arising from
|
||||||
matching types
|
matching types
|
||||||
at issue723.cry:7:17--7:19
|
at issue723.cry:7:17--7:19
|
||||||
where
|
where
|
||||||
n`932 is signature variable 'n' at issue723.cry:1:6--1:7
|
n`936 is signature variable 'n' at issue723.cry:1:6--1:7
|
||||||
|
@ -18,4 +18,4 @@ Loading module Cryptol
|
|||||||
Loading module test04
|
Loading module test04
|
||||||
|
|
||||||
[error] at test04.cry:1:1--5:14:
|
[error] at test04.cry:1:1--5:14:
|
||||||
Type '()' does not support literals.
|
Type '()' does not support integer literals.
|
||||||
|
29
tests/regression/FloatTests.cry
Normal file
29
tests/regression/FloatTests.cry
Normal file
@ -0,0 +1,29 @@
|
|||||||
|
module FloatTests where
|
||||||
|
|
||||||
|
import Float
|
||||||
|
|
||||||
|
section : {n} fin n => [n][8] -> [78][8]
|
||||||
|
section x = "-- " # take`{min 60 n} x # repeat '-'
|
||||||
|
|
||||||
|
type Small = Float 3 2
|
||||||
|
type Medium = Float64
|
||||||
|
type Large = Float 60 5000
|
||||||
|
|
||||||
|
property roundTrip x = fpFromBits (fpToBits x) =.= x
|
||||||
|
|
||||||
|
roundTrip2 : {e : #, p : #} (fin e, fin p, ValidFloat e p) => [e + p] -> Bool
|
||||||
|
property roundTrip2 x = fpToBits num == x \/ num =.= fpNaN
|
||||||
|
where num = fpFromBits x : Float e p
|
||||||
|
property eqRefl1 x = x =.= x
|
||||||
|
property eqRefl2 x = x == x \/ x =.= fpNaN
|
||||||
|
property eqProp x y = ~(x == y) \/
|
||||||
|
(x =.= y \/ x =.= fpNaN
|
||||||
|
\/ y =.= fpNaN
|
||||||
|
\/ (x =.= 0.0 /\ y =.= -0.0)
|
||||||
|
\/ (x =.= -0.0 /\ y =.= 0.0)
|
||||||
|
)
|
||||||
|
property leqRefl x = x <= x \/ x =.= fpNaN
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
134
tests/regression/float.icry
Normal file
134
tests/regression/float.icry
Normal file
@ -0,0 +1,134 @@
|
|||||||
|
:module FloatTests
|
||||||
|
:set ascii=on
|
||||||
|
|
||||||
|
section "Float Formatting"
|
||||||
|
:help :set fp-base
|
||||||
|
:help :set fp-format
|
||||||
|
|
||||||
|
:set fp-base=2
|
||||||
|
10.25 : Medium
|
||||||
|
|
||||||
|
:set fp-base=8
|
||||||
|
10.25 : Medium
|
||||||
|
|
||||||
|
:set fp-base=10
|
||||||
|
10.25 : Medium
|
||||||
|
1.0 /. 3.0 : Small
|
||||||
|
0.4 : Small
|
||||||
|
|
||||||
|
:set fp-base=16
|
||||||
|
10.25 : Medium
|
||||||
|
1.0 /. 3.0 : Small
|
||||||
|
|
||||||
|
:set fp-base=16
|
||||||
|
:set fp-format=free+exp
|
||||||
|
0x12.34 : Medium
|
||||||
|
:set fp-format=.1
|
||||||
|
0x12.34 : Medium
|
||||||
|
:set fp-format=2
|
||||||
|
0x12.34 : Medium
|
||||||
|
:set fp-format=2+exp
|
||||||
|
0x12.34 : Medium
|
||||||
|
|
||||||
|
|
||||||
|
section "Float Type"
|
||||||
|
:help Float
|
||||||
|
zero : Float 0 0 // Too small
|
||||||
|
zero : Float 80 1000 // Too large
|
||||||
|
zero : Small
|
||||||
|
zero : Medium
|
||||||
|
zero : Large
|
||||||
|
|
||||||
|
section "Literals"
|
||||||
|
:set fp-base=10
|
||||||
|
1.0 : Medium
|
||||||
|
1.25 : Medium
|
||||||
|
1.25e2 : Medium
|
||||||
|
:set fp-base=16
|
||||||
|
0x1.25 : Medium
|
||||||
|
0xFF.FFp3 : Medium
|
||||||
|
0xFF.FFp-4 : Medium
|
||||||
|
0xFF.FFe3 : Medium // This is NOT AN EXPONENT
|
||||||
|
5.0 : Small // Not checked
|
||||||
|
0x5.0 : Small // Checked
|
||||||
|
1.2 : Medium
|
||||||
|
0x0.2 : Small // Subnormal
|
||||||
|
fpFromBits 1 : Small // Subnormal
|
||||||
|
|
||||||
|
section "NaN"
|
||||||
|
:help fpNaN
|
||||||
|
fpNaN : Medium
|
||||||
|
:set base=2
|
||||||
|
fpToBits (fpNaN : Small)
|
||||||
|
fpToBits (fpNaN : Medium)
|
||||||
|
roundTrip (fpNaN : Large)
|
||||||
|
eqRefl1 (fpNaN : Medium)
|
||||||
|
eqRefl2 (fpNaN : Medium)
|
||||||
|
leqRefl (fpNaN : Medium)
|
||||||
|
|
||||||
|
section "Arithmetic"
|
||||||
|
|
||||||
|
:set fp-base=10
|
||||||
|
1.0 + 1.0 : Medium
|
||||||
|
1.0 - 1.0 : Medium
|
||||||
|
3.0 * 2.0 : Medium
|
||||||
|
3.0 /. 2.0 : Medium
|
||||||
|
|
||||||
|
1.0 /. 0.0 : Medium
|
||||||
|
-1.0 /. 0.0 : Medium
|
||||||
|
-0.0 /. 0.0 : Medium
|
||||||
|
1.0 /. -0.0 : Medium
|
||||||
|
-1.0 /. -0.0 : Medium
|
||||||
|
-0.0 /. -0.0 : Medium
|
||||||
|
|
||||||
|
2.0 + 3.0 : Small
|
||||||
|
2.0 + 8.0 : Small
|
||||||
|
|
||||||
|
fpAdd rne 2.0 3.0 : Small
|
||||||
|
fpAdd rne 2.0 8.0 : Small
|
||||||
|
fpAdd rne (-2.0) (-3.0) : Small
|
||||||
|
fpAdd rne (-2.0) (-8.0) : Small
|
||||||
|
fpAdd rna 2.0 3.0 : Small
|
||||||
|
fpAdd rna 2.0 8.0 : Small
|
||||||
|
fpAdd rna (-2.0) (-3.0) : Small
|
||||||
|
fpAdd rna (-2.0) (-8.0) : Small
|
||||||
|
fpAdd rtp 2.0 3.0 : Small
|
||||||
|
fpAdd rtp 2.0 8.0 : Small
|
||||||
|
fpAdd rtp (-2.0) (-3.0) : Small
|
||||||
|
fpAdd rtp (-2.0) (-8.0) : Small
|
||||||
|
fpAdd rtn 2.0 3.0 : Small
|
||||||
|
fpAdd rtn 2.0 8.0 : Small
|
||||||
|
fpAdd rtn (-2.0) (-3.0) : Small
|
||||||
|
fpAdd rtn (-2.0) (-8.0) : Small
|
||||||
|
fpAdd rtz 2.0 3.0 : Small
|
||||||
|
fpAdd rtz 2.0 8.0 : Small
|
||||||
|
fpAdd rtz (-2.0) (-3.0) : Small
|
||||||
|
fpAdd rtz (-2.0) (-8.0) : Small
|
||||||
|
|
||||||
|
|
||||||
|
section "Proofs"
|
||||||
|
:set prover=w4-z3
|
||||||
|
:set show-examples = off
|
||||||
|
:prove \(x : Medium) -> x == 0.0 \/ x =.= fpNaN // False
|
||||||
|
:set show-examples = on
|
||||||
|
:prove \(x : Medium) -> x == x // False
|
||||||
|
:prove \(x : Medium) -> eqRefl1 x
|
||||||
|
:prove \(x : Medium) -> eqRefl2 x
|
||||||
|
:prove \(x : Medium) -> roundTrip x
|
||||||
|
:prove roundTrip2`{3,2}
|
||||||
|
:prove roundTrip2`{11,53}
|
||||||
|
:prove \(x : Medium) -> leqRefl x
|
||||||
|
:prove \(x : Medium) y -> eqProp x y
|
||||||
|
|
||||||
|
section "Random Testing"
|
||||||
|
:check \(x : Medium) -> eqRefl1 x
|
||||||
|
:check \(x : Medium) -> eqRefl2 x
|
||||||
|
:check \(x : Medium) -> roundTrip x
|
||||||
|
:prove roundTrip2`{3,2}
|
||||||
|
:prove roundTrip2`{11,53}
|
||||||
|
:check \(x : Medium) -> leqRefl x
|
||||||
|
:check \(x : Medium) y -> eqProp x y
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
146
tests/regression/float.icry.stdout
Normal file
146
tests/regression/float.icry.stdout
Normal file
@ -0,0 +1,146 @@
|
|||||||
|
Loading module Cryptol
|
||||||
|
Loading module Float
|
||||||
|
Loading module FloatTests
|
||||||
|
"-- Float Formatting-----------------------------------------------------------"
|
||||||
|
|
||||||
|
fp-base = 16
|
||||||
|
|
||||||
|
Default value: 16
|
||||||
|
|
||||||
|
The base to display floating point numbers at (2, 8, 10, or 16).
|
||||||
|
|
||||||
|
|
||||||
|
fp-format = free
|
||||||
|
|
||||||
|
Default value: free
|
||||||
|
|
||||||
|
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
|
||||||
|
|
||||||
|
|
||||||
|
0b1010.01
|
||||||
|
0o12.2
|
||||||
|
10.25
|
||||||
|
0.4
|
||||||
|
0.4
|
||||||
|
0xa.4
|
||||||
|
0x0.6
|
||||||
|
0x1.234p4
|
||||||
|
0x12.3
|
||||||
|
0x12
|
||||||
|
0x1.2p4
|
||||||
|
"-- Float Type-----------------------------------------------------------------"
|
||||||
|
|
||||||
|
primitive type Float : # -> # -> *
|
||||||
|
|
||||||
|
`Float exponent precision` requires:
|
||||||
|
• ValidFloat exponent precision
|
||||||
|
|
||||||
|
IEEE-754 floating point numbers.
|
||||||
|
|
||||||
|
|
||||||
|
[error] at <interactive>:1:1--1:17:
|
||||||
|
Unsolved constraints:
|
||||||
|
• ValidFloat 0 0
|
||||||
|
arising from
|
||||||
|
use of partial type function Float
|
||||||
|
at <interactive>:1:1--1:17
|
||||||
|
|
||||||
|
[error] at <interactive>:1:1--1:21:
|
||||||
|
Unsolved constraints:
|
||||||
|
• ValidFloat 80 1000
|
||||||
|
arising from
|
||||||
|
use of partial type function Float
|
||||||
|
at <interactive>:1:1--1:21
|
||||||
|
0x0.0p0
|
||||||
|
0x0.0p0
|
||||||
|
0x0.0p0
|
||||||
|
"-- Literals-------------------------------------------------------------------"
|
||||||
|
1.0e0
|
||||||
|
1.2e0
|
||||||
|
1.2e2
|
||||||
|
0x1.2p0
|
||||||
|
0x8.0p8
|
||||||
|
0x1.0p4
|
||||||
|
0x1.0p8
|
||||||
|
0x4.0p0
|
||||||
|
|
||||||
|
[error] at <interactive>:1:1--1:20:
|
||||||
|
5/1 cannot be represented in FloatTests::Small
|
||||||
|
0x1.3p0
|
||||||
|
0x2.0p-4
|
||||||
|
0x2.0p-4
|
||||||
|
"-- NaN------------------------------------------------------------------------"
|
||||||
|
|
||||||
|
fpNaN : {e, p} (ValidFloat e p) => Float e p
|
||||||
|
|
||||||
|
Not a number.
|
||||||
|
|
||||||
|
NaN
|
||||||
|
0b01111
|
||||||
|
0b0111111111111000000000000000000000000000000000000000000000000000
|
||||||
|
True
|
||||||
|
True
|
||||||
|
True
|
||||||
|
True
|
||||||
|
"-- Arithmetic-----------------------------------------------------------------"
|
||||||
|
2.0e0
|
||||||
|
0.0e0
|
||||||
|
6.0e0
|
||||||
|
1.5e0
|
||||||
|
Inf
|
||||||
|
-Inf
|
||||||
|
NaN
|
||||||
|
-Inf
|
||||||
|
Inf
|
||||||
|
NaN
|
||||||
|
4.0e0
|
||||||
|
8.0e0
|
||||||
|
4.0e0
|
||||||
|
8.0e0
|
||||||
|
-4.0e0
|
||||||
|
-8.0e0
|
||||||
|
6.0e0
|
||||||
|
1.2e1
|
||||||
|
-6.0e0
|
||||||
|
-1.2e1
|
||||||
|
6.0e0
|
||||||
|
1.2e1
|
||||||
|
-4.0e0
|
||||||
|
-8.0e0
|
||||||
|
4.0e0
|
||||||
|
8.0e0
|
||||||
|
-6.0e0
|
||||||
|
-1.2e1
|
||||||
|
4.0e0
|
||||||
|
8.0e0
|
||||||
|
-4.0e0
|
||||||
|
-8.0e0
|
||||||
|
"-- Proofs---------------------------------------------------------------------"
|
||||||
|
Counterexample
|
||||||
|
Counterexample
|
||||||
|
(\(x : Medium) -> x == x) NaN = False
|
||||||
|
Q.E.D.
|
||||||
|
Q.E.D.
|
||||||
|
Q.E.D.
|
||||||
|
Q.E.D.
|
||||||
|
Q.E.D.
|
||||||
|
Q.E.D.
|
||||||
|
Q.E.D.
|
||||||
|
"-- Random Testing-------------------------------------------------------------"
|
||||||
|
Using random testing.
|
||||||
|
Testing... Passed 100 tests.
|
||||||
|
Using random testing.
|
||||||
|
Testing... Passed 100 tests.
|
||||||
|
Using random testing.
|
||||||
|
Testing... Passed 100 tests.
|
||||||
|
Q.E.D.
|
||||||
|
Q.E.D.
|
||||||
|
Using random testing.
|
||||||
|
Testing... Passed 100 tests.
|
||||||
|
Using random testing.
|
||||||
|
Testing... Passed 100 tests.
|
@ -52,6 +52,7 @@ cl :: TokenT -> AttributeValue
|
|||||||
cl tok =
|
cl tok =
|
||||||
case tok of
|
case tok of
|
||||||
Num {} -> "number"
|
Num {} -> "number"
|
||||||
|
Frac {} -> "number"
|
||||||
Ident {} -> "identifier"
|
Ident {} -> "identifier"
|
||||||
KW {} -> "keyword"
|
KW {} -> "keyword"
|
||||||
Op {} -> "operator"
|
Op {} -> "operator"
|
||||||
|
Loading…
Reference in New Issue
Block a user