From d40d6b4af7ae8e32f236b1ec37c271b84f15192a Mon Sep 17 00:00:00 2001 From: Rob Dockins Date: Mon, 23 Nov 2020 14:33:37 -0800 Subject: [PATCH 01/27] Retain source position annotations from the parsed AST into the typechecked AST. This should eventually allow us to emit more useful error messages for runtime errors. --- src/Cryptol/Eval.hs | 2 ++ src/Cryptol/Eval/Reference.lhs | 2 ++ src/Cryptol/IR/FreeVars.hs | 1 + src/Cryptol/ModuleSystem/Base.hs | 6 +++-- src/Cryptol/ModuleSystem/InstantiateModule.hs | 1 + src/Cryptol/Transform/AddModParams.hs | 1 + src/Cryptol/Transform/MonoValues.hs | 1 + src/Cryptol/Transform/Specialize.hs | 1 + src/Cryptol/TypeCheck.hs | 4 ++- src/Cryptol/TypeCheck/AST.hs | 10 ++++++-- src/Cryptol/TypeCheck/Infer.hs | 4 +-- src/Cryptol/TypeCheck/Parseable.hs | 1 + src/Cryptol/TypeCheck/Sanity.hs | 25 +++++++++++++------ src/Cryptol/TypeCheck/Subst.hs | 1 + src/Cryptol/TypeCheck/TypeOf.hs | 3 +++ 15 files changed, 49 insertions(+), 14 deletions(-) diff --git a/src/Cryptol/Eval.hs b/src/Cryptol/Eval.hs index f6cf0ab5f..107096c64 100644 --- a/src/Cryptol/Eval.hs +++ b/src/Cryptol/Eval.hs @@ -106,6 +106,8 @@ evalExpr :: SEval sym (GenValue sym) evalExpr sym env expr = case expr of + ELocated _ t -> evalExpr sym env t -- TODO, track source locations + -- Try to detect when the user has directly written a finite sequence of -- literal bit values and pack these into a word. EList es ty diff --git a/src/Cryptol/Eval/Reference.lhs b/src/Cryptol/Eval/Reference.lhs index 85781705c..62d070838 100644 --- a/src/Cryptol/Eval/Reference.lhs +++ b/src/Cryptol/Eval/Reference.lhs @@ -284,6 +284,8 @@ assigns values to those variables. > evalExpr env expr = > case expr of > +> ELocated _ e -> evalExpr env e +> > EList es _ty -> > pure $ VList (Nat (genericLength es)) [ evalExpr env e | e <- es ] > diff --git a/src/Cryptol/IR/FreeVars.hs b/src/Cryptol/IR/FreeVars.hs index 5ea8705e5..712b3068e 100644 --- a/src/Cryptol/IR/FreeVars.hs +++ b/src/Cryptol/IR/FreeVars.hs @@ -99,6 +99,7 @@ instance FreeVars DeclDef where instance FreeVars Expr where freeVars expr = case expr of + ELocated _r t -> freeVars t EList es t -> freeVars es <> freeVars t ETuple es -> freeVars es ERec fs -> freeVars (recordElements fs) diff --git a/src/Cryptol/ModuleSystem/Base.hs b/src/Cryptol/ModuleSystem/Base.hs index 28e5d8a5e..dd7dff02d 100644 --- a/src/Cryptol/ModuleSystem/Base.hs +++ b/src/Cryptol/ModuleSystem/Base.hs @@ -453,7 +453,7 @@ checkSingleModule how isrc path m = do data TCLinter o = TCLinter { lintCheck :: - o -> T.InferInput -> Either TcSanity.Error [TcSanity.ProofObligation] + o -> T.InferInput -> Either (Range, TcSanity.Error) [TcSanity.ProofObligation] , lintModule :: Maybe P.ModName } @@ -465,7 +465,9 @@ exprLinter = TCLinter Left err -> Left err Right (s1,os) | TcSanity.same s s1 -> Right os - | otherwise -> Left (TcSanity.TypeMismatch "exprLinter" s s1) + | otherwise -> Left ( fromMaybe emptyRange (getLoc e') + , TcSanity.TypeMismatch "exprLinter" s s1 + ) , lintModule = Nothing } diff --git a/src/Cryptol/ModuleSystem/InstantiateModule.hs b/src/Cryptol/ModuleSystem/InstantiateModule.hs index 8544c898a..e4b3cd4a2 100644 --- a/src/Cryptol/ModuleSystem/InstantiateModule.hs +++ b/src/Cryptol/ModuleSystem/InstantiateModule.hs @@ -183,6 +183,7 @@ instance Inst Expr where Just y -> EVar y _ -> expr + ELocated r e -> ELocated r (inst env e) EList xs t -> EList (inst env xs) (inst env t) ETuple es -> ETuple (inst env es) ERec xs -> ERec (fmap go xs) diff --git a/src/Cryptol/Transform/AddModParams.hs b/src/Cryptol/Transform/AddModParams.hs index 21edbbdcd..67a222699 100644 --- a/src/Cryptol/Transform/AddModParams.hs +++ b/src/Cryptol/Transform/AddModParams.hs @@ -230,6 +230,7 @@ instance Inst Expr where in ESel (EVar paramModRecParam) (RecordSel (nameIdent x) (Just sh)) | otherwise -> EVar x + ELocated r t -> ELocated r (inst ps t) EList es t -> EList (inst ps es) (inst ps t) ETuple es -> ETuple (inst ps es) ERec fs -> ERec (fmap (inst ps) fs) diff --git a/src/Cryptol/Transform/MonoValues.hs b/src/Cryptol/Transform/MonoValues.hs index bbc7a0cfe..d31238087 100644 --- a/src/Cryptol/Transform/MonoValues.hs +++ b/src/Cryptol/Transform/MonoValues.hs @@ -179,6 +179,7 @@ rewE rews = go Nothing -> EProofApp <$> go e Just yes -> return yes + ELocated r t -> ELocated r <$> go t EList es t -> EList <$> mapM go es <*> return t ETuple es -> ETuple <$> mapM go es ERec fs -> ERec <$> traverse go fs diff --git a/src/Cryptol/Transform/Specialize.hs b/src/Cryptol/Transform/Specialize.hs index 825fdb35b..76b89fe56 100644 --- a/src/Cryptol/Transform/Specialize.hs +++ b/src/Cryptol/Transform/Specialize.hs @@ -70,6 +70,7 @@ specialize expr (ev, byteReader, modEnv) = run $ do specializeExpr :: Expr -> SpecM Expr specializeExpr expr = case expr of + ELocated r e -> ELocated r <$> specializeExpr e EList es t -> EList <$> traverse specializeExpr es <*> pure t ETuple es -> ETuple <$> traverse specializeExpr es ERec fs -> ERec <$> traverse specializeExpr fs diff --git a/src/Cryptol/TypeCheck.hs b/src/Cryptol/TypeCheck.hs index 25d4ee9b6..88b943544 100644 --- a/src/Cryptol/TypeCheck.hs +++ b/src/Cryptol/TypeCheck.hs @@ -78,7 +78,9 @@ tcExpr e0 inp = runInferM inp where go loc expr = case expr of - P.ELocated e loc' -> go loc' e + P.ELocated e loc' -> + do (te, sch) <- go loc' e + pure (ELocated loc' te, sch) P.EVar x -> do res <- lookupVar x case res of diff --git a/src/Cryptol/TypeCheck/AST.hs b/src/Cryptol/TypeCheck/AST.hs index 90b51ad84..46c4cdd00 100644 --- a/src/Cryptol/TypeCheck/AST.hs +++ b/src/Cryptol/TypeCheck/AST.hs @@ -28,7 +28,7 @@ module Cryptol.TypeCheck.AST , module Cryptol.TypeCheck.Type ) where -import Cryptol.Parser.Position(Located) +import Cryptol.Parser.Position(Located,Range,HasLoc(..)) import Cryptol.ModuleSystem.Name import Cryptol.ModuleSystem.Exports(ExportSpec(..) , isExportedBind, isExportedType) @@ -124,6 +124,8 @@ data Expr = EList [Expr] Type -- ^ List value (with type of elements) | EAbs Name Type Expr -- ^ Function value + | ELocated Range Expr -- ^ Source location information + {- | Proof abstraction. Because we don't keep proofs around we don't need to name the assumption, but we still need to record the assumption. The assumption is the 'Type' term, @@ -200,6 +202,8 @@ eChar prims c = ETApp (ETApp (ePrim prims (prelPrim "number")) (tNum v)) (tWord instance PP (WithNames Expr) where ppPrec prec (WithNames expr nm) = case expr of + ELocated _ t -> ppWP prec t + EList [] t -> optParens (prec > 0) $ text "[]" <+> colon <+> ppWP prec t @@ -319,7 +323,9 @@ splitExprInst e = (e2, reverse ts, length ps) (ts,e2) = splitWhile splitTApp e1 - +instance HasLoc Expr where + getLoc (ELocated r _) = Just r + getLoc _ = Nothing instance PP Expr where ppPrec n t = ppWithNamesPrec IntMap.empty n t diff --git a/src/Cryptol/TypeCheck/Infer.hs b/src/Cryptol/TypeCheck/Infer.hs index 5f8b5416e..67bca1cee 100644 --- a/src/Cryptol/TypeCheck/Infer.hs +++ b/src/Cryptol/TypeCheck/Infer.hs @@ -169,7 +169,7 @@ appTys expr ts tGoal = -- XXX: Is there a scoping issue here? I think not, but check. P.ELocated e r -> - inRange r (appTys e ts tGoal) + inRange r (ELocated r <$> appTys e ts tGoal) P.ENeg {} -> mono P.EComplement {} -> mono @@ -368,7 +368,7 @@ checkE expr tGoal = P.EFun ps e -> checkFun Nothing ps e tGoal - P.ELocated e r -> inRange r (checkE e tGoal) + P.ELocated e r -> inRange r (ELocated r <$> checkE e tGoal) P.ESplit e -> do prim <- mkPrim "splitAt" diff --git a/src/Cryptol/TypeCheck/Parseable.hs b/src/Cryptol/TypeCheck/Parseable.hs index 5f92c9224..333aea413 100644 --- a/src/Cryptol/TypeCheck/Parseable.hs +++ b/src/Cryptol/TypeCheck/Parseable.hs @@ -31,6 +31,7 @@ class ShowParseable t where showParseable :: t -> Doc instance ShowParseable Expr where + showParseable (ELocated _ e) = showParseable e -- TODO? emit range information showParseable (EList es _) = parens (text "EList" <+> showParseable es) showParseable (ETuple es) = parens (text "ETuple" <+> showParseable es) showParseable (ERec ides) = parens (text "ERec" <+> showParseable (canonicalFields ides)) diff --git a/src/Cryptol/TypeCheck/Sanity.hs b/src/Cryptol/TypeCheck/Sanity.hs index 7aebc45bb..9a5d28109 100644 --- a/src/Cryptol/TypeCheck/Sanity.hs +++ b/src/Cryptol/TypeCheck/Sanity.hs @@ -15,7 +15,7 @@ module Cryptol.TypeCheck.Sanity ) where -import Cryptol.Parser.Position(thing) +import Cryptol.Parser.Position(thing,Range,emptyRange) import Cryptol.TypeCheck.AST import Cryptol.TypeCheck.Subst (apSubst, singleTParamSubst) import Cryptol.TypeCheck.Monad(InferInput(..)) @@ -31,15 +31,15 @@ import Data.Map ( Map ) import qualified Data.Map as Map -tcExpr :: InferInput -> Expr -> Either Error (Schema, [ ProofObligation ]) +tcExpr :: InferInput -> Expr -> Either (Range, Error) (Schema, [ ProofObligation ]) tcExpr env e = runTcM env (exprSchema e) -tcDecls :: InferInput -> [DeclGroup] -> Either Error [ ProofObligation ] +tcDecls :: InferInput -> [DeclGroup] -> Either (Range, Error) [ ProofObligation ] tcDecls env ds0 = case runTcM env (checkDecls ds0) of Left err -> Left err Right (_,ps) -> Right ps -tcModule :: InferInput -> Module -> Either Error [ ProofObligation ] +tcModule :: InferInput -> Module -> Either (Range, Error) [ ProofObligation ] tcModule env m = case runTcM env check of Left err -> Left err Right (_,ps) -> Right ps @@ -143,6 +143,8 @@ exprSchema :: Expr -> TcM Schema exprSchema expr = case expr of + ELocated rng t -> withRange rng (exprSchema t) + EList es t -> do checkTypeIs KType t forM_ es $ \e -> @@ -444,6 +446,7 @@ checkArm (m : ms) = data RO = RO { roTVars :: Map Int TParam , roAsmps :: [Prop] + , roRange :: Range , roVars :: Map Name Schema } @@ -453,7 +456,7 @@ data RW = RW { woProofObligations :: [ProofObligation] } -newtype TcM a = TcM (ReaderT RO (ExceptionT Error (StateT RW Id)) a) +newtype TcM a = TcM (ReaderT RO (ExceptionT (Range, Error) (StateT RW Id)) a) instance Functor TcM where fmap = liftM @@ -468,7 +471,7 @@ instance Monad TcM where let TcM m1 = f a m1) -runTcM :: InferInput -> TcM a -> Either Error (a, [ProofObligation]) +runTcM :: InferInput -> TcM a -> Either (Range, Error) (a, [ProofObligation]) runTcM env (TcM m) = case runM m ro rw of (Left err, _) -> Left err @@ -478,6 +481,7 @@ runTcM env (TcM m) = | tp <- Map.elems (inpParamTypes env) , let x = mtpParam tp ] , roAsmps = map thing (inpParamConstraints env) + , roRange = emptyRange , roVars = Map.union (fmap mvpType (inpParamFuns env)) (inpVars env) @@ -511,13 +515,20 @@ data Error = deriving Show reportError :: Error -> TcM a -reportError e = TcM (raise e) +reportError e = TcM $ + do ro <- ask + raise (roRange ro, e) withTVar :: TParam -> TcM a -> TcM a withTVar a (TcM m) = TcM $ do ro <- ask local ro { roTVars = Map.insert (tpUnique a) a (roTVars ro) } m +withRange :: Range -> TcM a -> TcM a +withRange rng (TcM m) = TcM $ + do ro <- ask + local ro { roRange = rng } m + withAsmp :: Prop -> TcM a -> TcM a withAsmp p (TcM m) = TcM $ do ro <- ask diff --git a/src/Cryptol/TypeCheck/Subst.hs b/src/Cryptol/TypeCheck/Subst.hs index 39ab1506b..52976355f 100644 --- a/src/Cryptol/TypeCheck/Subst.hs +++ b/src/Cryptol/TypeCheck/Subst.hs @@ -348,6 +348,7 @@ instance TVars Expr where where go expr = case expr of + ELocated r e -> ELocated r !$ (go e) EApp e1 e2 -> EApp !$ (go e1) !$ (go e2) EAbs x t e1 -> EAbs x !$ (apSubst su t) !$ (go e1) ETAbs a e -> ETAbs a !$ (go e) diff --git a/src/Cryptol/TypeCheck/TypeOf.hs b/src/Cryptol/TypeCheck/TypeOf.hs index e587e1720..22f40025b 100644 --- a/src/Cryptol/TypeCheck/TypeOf.hs +++ b/src/Cryptol/TypeCheck/TypeOf.hs @@ -30,6 +30,7 @@ fastTypeOf :: Map Name Schema -> Expr -> Type fastTypeOf tyenv expr = case expr of -- Monomorphic fragment + ELocated _ t -> fastTypeOf tyenv t EList es t -> tSeq (tNum (length es)) t ETuple es -> tTuple (map (fastTypeOf tyenv) es) ERec fields -> tRec (fmap (fastTypeOf tyenv) fields) @@ -59,6 +60,8 @@ fastTypeOf tyenv expr = fastSchemaOf :: Map Name Schema -> Expr -> Schema fastSchemaOf tyenv expr = case expr of + ELocated _ e -> fastSchemaOf tyenv e + -- Polymorphic fragment EVar x -> case Map.lookup x tyenv of Just ty -> ty From 4454a1e3e343ea5aed96f8fd4e7ea0e136c0596d Mon Sep 17 00:00:00 2001 From: Rob Dockins Date: Wed, 25 Nov 2020 22:24:42 -0800 Subject: [PATCH 02/27] Remove instances of immediately-nested location information annotations. --- src/Cryptol/Parser.y | 4 ++-- src/Cryptol/Parser/AST.hs | 3 ++- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/src/Cryptol/Parser.y b/src/Cryptol/Parser.y index 7137ed5ce..15f828d26 100644 --- a/src/Cryptol/Parser.y +++ b/src/Cryptol/Parser.y @@ -424,7 +424,7 @@ expr :: { Expr PName } -- | An expression without a `where` clause exprNoWhere :: { Expr PName } - : simpleExpr qop longRHS { at ($1,$3) (binOp $1 $2 $3) } + : simpleExpr qop longRHS { binOp $1 $2 $3 } | longRHS { $1 } | typedExpr { $1 } @@ -441,7 +441,7 @@ typedExpr :: { Expr PName } -- A possibly infix expression (no where, no long application, no type annot) simpleExpr :: { Expr PName } - : simpleExpr qop simpleRHS { at ($1,$3) (binOp $1 $2 $3) } + : simpleExpr qop simpleRHS { binOp $1 $2 $3 } | simpleRHS { $1 } -- An expression without an obvious end marker diff --git a/src/Cryptol/Parser/AST.hs b/src/Cryptol/Parser/AST.hs index bfe032205..00af9ee4d 100644 --- a/src/Cryptol/Parser/AST.hs +++ b/src/Cryptol/Parser/AST.hs @@ -394,7 +394,8 @@ newtype Prop n = CType (Type n) instance AddLoc (Expr n) where - addLoc = ELocated + addLoc (ELocated x _) r = addLoc x r + addLoc x r = ELocated x r dropLoc (ELocated e _) = dropLoc e dropLoc e = e From 744fcfd8610dd29897b530c5f12b04d80f49f95e Mon Sep 17 00:00:00 2001 From: Rob Dockins Date: Tue, 24 Nov 2020 09:51:42 -0800 Subject: [PATCH 03/27] Get better output from `displayException` when throwing EvalError. --- src/Cryptol/Backend/Monad.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/Cryptol/Backend/Monad.hs b/src/Cryptol/Backend/Monad.hs index f40480146..d94aa41ec 100644 --- a/src/Cryptol/Backend/Monad.hs +++ b/src/Cryptol/Backend/Monad.hs @@ -351,7 +351,7 @@ data EvalError | 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 instance PP EvalError where ppPrec _ e = case e of @@ -369,6 +369,9 @@ instance PP EvalError where BadValue x -> "invalid input for" <+> backticks (text x) NoPrim x -> text "unimplemented primitive:" <+> pp x +instance Show EvalError where + show = show . pp + instance X.Exception EvalError From ef442be2960e4dfc668ab84891aa4ff40b5fed76 Mon Sep 17 00:00:00 2001 From: Rob Dockins Date: Tue, 24 Nov 2020 10:02:59 -0800 Subject: [PATCH 04/27] Refactor how primitives are represented. We invent a lightweight syntax for primitives that is evaluated to values when a primitive is looked up at evaluation time. Currently, this does not add any additional capabilities, but gives us the ability to modify the representation of values without touching all the primitive definitions, and gives us a place to hook in additional capabilies to the primitives. As part of this refactoring, the primitives that are defined totally generically are moved to the `Cryptol.Eval.Generic` module and used uniformly in all the backends. --- cryptol.cabal | 1 + src/Cryptol/Eval.hs | 7 +- src/Cryptol/Eval/Concrete.hs | 410 +++++++++----------------- src/Cryptol/Eval/Generic.hs | 553 ++++++++++++++++++++++++----------- src/Cryptol/Eval/Prims.hs | 33 +++ src/Cryptol/Eval/SBV.hs | 170 ++--------- src/Cryptol/Eval/What4.hs | 289 ++++++------------ 7 files changed, 668 insertions(+), 795 deletions(-) create mode 100644 src/Cryptol/Eval/Prims.hs diff --git a/cryptol.cabal b/cryptol.cabal index e65d3ed76..a737c0d32 100644 --- a/cryptol.cabal +++ b/cryptol.cabal @@ -171,6 +171,7 @@ library Cryptol.Eval.Concrete, Cryptol.Eval.Env, Cryptol.Eval.Generic, + Cryptol.Eval.Prims, Cryptol.Eval.Reference, Cryptol.Eval.SBV, Cryptol.Eval.Type, diff --git a/src/Cryptol/Eval.hs b/src/Cryptol/Eval.hs index 107096c64..7d9ae33f4 100644 --- a/src/Cryptol/Eval.hs +++ b/src/Cryptol/Eval.hs @@ -39,6 +39,7 @@ import Cryptol.Backend.Concrete( Concrete(..) ) import Cryptol.Backend.Monad import Cryptol.Eval.Generic ( iteValue ) import Cryptol.Eval.Env +import Cryptol.Eval.Prims import Cryptol.Eval.Type import Cryptol.Eval.Value import Cryptol.ModuleSystem.Name @@ -63,9 +64,9 @@ import Prelude.Compat type EvalEnv = GenEvalEnv Concrete type EvalPrims sym = - ( Backend sym, ?evalPrim :: PrimIdent -> Maybe (Either Expr (GenValue sym)) ) + ( Backend sym, ?evalPrim :: PrimIdent -> Maybe (Either Expr (Prim sym)) ) -type ConcPrims = ?evalPrim :: PrimIdent -> Maybe (Either Expr (GenValue Concrete)) +type ConcPrims = ?evalPrim :: PrimIdent -> Maybe (Either Expr (Prim Concrete)) -- Expression Evaluation ------------------------------------------------------- @@ -527,7 +528,7 @@ evalDecl sym renv env d = case dDefinition d of DPrim -> case ?evalPrim =<< asPrim (dName d) of - Just (Right v) -> pure (bindVarDirect (dName d) v env) + Just (Right p) -> bindVar sym (dName d) (evalPrim sym (dName d) p) env Just (Left ex) -> bindVar sym (dName d) (evalExpr sym renv ex) env Nothing -> bindVar sym (dName d) (cryNoPrimError sym (dName d)) env diff --git a/src/Cryptol/Eval/Concrete.hs b/src/Cryptol/Eval/Concrete.hs index 90bd6286b..ec683b650 100644 --- a/src/Cryptol/Eval/Concrete.hs +++ b/src/Cryptol/Eval/Concrete.hs @@ -25,7 +25,7 @@ module Cryptol.Eval.Concrete , toExpr ) where -import Control.Monad (join, guard, zipWithM, foldM) +import Control.Monad (guard, zipWithM, foldM) import Data.Bits (Bits(..)) import Data.Ratio((%),numerator,denominator) import Data.Word(Word32, Word64) @@ -44,6 +44,7 @@ import Cryptol.Backend.FloatHelpers import Cryptol.Backend.Monad import Cryptol.Eval.Generic hiding (logicShift) +import Cryptol.Eval.Prims import Cryptol.Eval.Type import Cryptol.Eval.Value import qualified Cryptol.SHA as SHA @@ -139,153 +140,18 @@ floatToExpr prims eT pT f = -- Primitives ------------------------------------------------------------------ -primTable :: EvalOpts -> Map PrimIdent Value +primTable :: EvalOpts -> Map PrimIdent (Prim Concrete) primTable eOpts = let sym = Concrete in + Map.union (genericPrimTable sym) $ Map.union (floatPrims sym) $ Map.union suiteBPrims $ Map.union primeECPrims $ Map.fromList $ map (\(n, v) -> (prelPrim n, v)) - [ -- Literals - ("True" , VBit (bitLit sym True)) - , ("False" , VBit (bitLit sym False)) - , ("number" , {-# SCC "Prelude::number" #-} - ecNumberV sym) - , ("ratio" , {-# SCC "Prelude::ratio" #-} - ratioV sym) - , ("fraction" , ecFractionV sym) - - - -- Zero - , ("zero" , {-# SCC "Prelude::zero" #-} - VPoly (zeroV sym)) - - -- Logic - , ("&&" , {-# SCC "Prelude::(&&)" #-} - binary (andV sym)) - , ("||" , {-# SCC "Prelude::(||)" #-} - binary (orV sym)) - , ("^" , {-# SCC "Prelude::(^)" #-} - binary (xorV sym)) - , ("complement" , {-# SCC "Prelude::complement" #-} - unary (complementV sym)) - - -- Ring - , ("fromInteger", {-# SCC "Prelude::fromInteger" #-} - fromIntegerV sym) - , ("+" , {-# SCC "Prelude::(+)" #-} - binary (addV sym)) - , ("-" , {-# SCC "Prelude::(-)" #-} - binary (subV sym)) - , ("*" , {-# SCC "Prelude::(*)" #-} - binary (mulV sym)) - , ("negate" , {-# SCC "Prelude::negate" #-} - unary (negateV sym)) - - -- Integral - , ("toInteger" , {-# SCC "Prelude::toInteger" #-} - toIntegerV sym) - , ("/" , {-# SCC "Prelude::(/)" #-} - binary (divV sym)) - , ("%" , {-# SCC "Prelude::(%)" #-} - binary (modV sym)) - , ("^^" , {-# SCC "Prelude::(^^)" #-} - expV sym) - , ("infFrom" , {-# SCC "Prelude::infFrom" #-} - infFromV sym) - , ("infFromThen", {-# SCC "Prelude::infFromThen" #-} - infFromThenV sym) - - -- Field - , ("recip" , {-# SCC "Prelude::recip" #-} - recipV sym) - , ("/." , {-# SCC "Prelude::(/.)" #-} - fieldDivideV sym) - - -- Round - , ("floor" , {-# SCC "Prelude::floor" #-} - unary (floorV sym)) - , ("ceiling" , {-# SCC "Prelude::ceiling" #-} - unary (ceilingV sym)) - , ("trunc" , {-# SCC "Prelude::trunc" #-} - unary (truncV sym)) - , ("roundAway" , {-# SCC "Prelude::roundAway" #-} - unary (roundAwayV sym)) - , ("roundToEven", {-# SCC "Prelude::roundToEven" #-} - unary (roundToEvenV sym)) - - -- Bitvector specific operations - , ("/$" , {-# SCC "Prelude::(/$)" #-} - sdivV sym) - , ("%$" , {-# SCC "Prelude::(%$)" #-} - smodV sym) - , ("lg2" , {-# SCC "Prelude::lg2" #-} - lg2V sym) - , (">>$" , {-# SCC "Prelude::(>>$)" #-} + [ (">>$" , {-# SCC "Prelude::(>>$)" #-} sshrV) - -- Cmp - , ("<" , {-# SCC "Prelude::(<)" #-} - binary (lessThanV sym)) - , (">" , {-# SCC "Prelude::(>)" #-} - binary (greaterThanV sym)) - , ("<=" , {-# SCC "Prelude::(<=)" #-} - binary (lessThanEqV sym)) - , (">=" , {-# SCC "Prelude::(>=)" #-} - binary (greaterThanEqV sym)) - , ("==" , {-# SCC "Prelude::(==)" #-} - binary (eqV sym)) - , ("!=" , {-# SCC "Prelude::(!=)" #-} - binary (distinctV sym)) - - -- SignedCmp - , ("<$" , {-# SCC "Prelude::(<$)" #-} - binary (signedLessThanV sym)) - - -- Finite enumerations - , ("fromTo" , {-# SCC "Prelude::fromTo" #-} - fromToV sym) - , ("fromThenTo" , {-# SCC "Prelude::fromThenTo" #-} - fromThenToV sym) - - -- Sequence manipulations - , ("#" , {-# SCC "Prelude::(#)" #-} - nlam $ \ front -> - nlam $ \ back -> - tlam $ \ elty -> - lam $ \ l -> return $ - lam $ \ r -> join (ccatV sym front back elty <$> l <*> r)) - - - , ("join" , {-# SCC "Prelude::join" #-} - nlam $ \ parts -> - nlam $ \ (finNat' -> each) -> - tlam $ \ a -> - lam $ \ x -> - joinV sym parts each a =<< x) - - , ("split" , {-# SCC "Prelude::split" #-} - ecSplitV sym) - - , ("splitAt" , {-# SCC "Prelude::splitAt" #-} - nlam $ \ front -> - nlam $ \ back -> - tlam $ \ a -> - lam $ \ x -> - splitAtV sym front back a =<< x) - - , ("reverse" , {-# SCC "Prelude::reverse" #-} - nlam $ \_a -> - tlam $ \_b -> - lam $ \xs -> reverseV sym =<< xs) - - , ("transpose" , {-# SCC "Prelude::transpose" #-} - nlam $ \a -> - nlam $ \b -> - tlam $ \c -> - lam $ \xs -> transposeV sym a b c =<< xs) - -- Shifts and rotates , ("<<" , {-# SCC "Prelude::(<<)" #-} logicShift shiftLW shiftLS) @@ -308,44 +174,15 @@ primTable eOpts = let sym = Concrete in , ("updateEnd" , {-# SCC "Prelude::updateEnd" #-} updatePrim sym updateBack_word updateBack) - -- Misc - , ("foldl" , {-# SCC "Prelude::foldl" #-} - foldlV sym) - - , ("foldl'" , {-# SCC "Prelude::foldl'" #-} - foldl'V sym) - - , ("deepseq" , {-# SCC "Prelude::deepseq" #-} - tlam $ \_a -> - tlam $ \_b -> - lam $ \x -> pure $ - lam $ \y -> - do _ <- forceValue =<< x - y) - - , ("parmap" , {-# SCC "Prelude::parmap" #-} - parmapV sym) - - , ("fromZ" , {-# SCC "Prelude::fromZ" #-} - fromZV sym) - - , ("error" , {-# SCC "Prelude::error" #-} - tlam $ \a -> - nlam $ \_ -> - lam $ \s -> errorV sym a =<< (valueToString sym =<< s)) - - , ("random" , {-# SCC "Prelude::random" #-} - tlam $ \a -> - wlam sym $ \(bvVal -> x) -> randomV sym a x) - , ("trace" , {-# SCC "Prelude::trace" #-} - nlam $ \_n -> - tlam $ \_a -> - tlam $ \_b -> - lam $ \s -> return $ - lam $ \x -> return $ - lam $ \y -> do - msg <- valueToString sym =<< s + PNumPoly \_n -> + PTyPoly \_a -> + PTyPoly \_b -> + PFun \s -> + PFun \x -> + PFun \y -> + PPrim + do msg <- valueToString sym =<< s let EvalOpts { evalPPOpts, evalLogger } = eOpts doc <- ppValue sym evalPPOpts =<< x yv <- y @@ -354,10 +191,11 @@ primTable eOpts = let sym = Concrete in return yv) , ("pmult", - ilam $ \u -> - ilam $ \v -> - wlam Concrete $ \(BV _ x) -> return $ - wlam Concrete $ \(BV _ y) -> + PFinPoly \u -> + PFinPoly \v -> + PWordFun \(BV _ x) -> + PWordFun \(BV _ y) -> + PPrim let z = if u <= v then F2.pmult (fromInteger (u+1)) x y else @@ -365,56 +203,62 @@ primTable eOpts = let sym = Concrete in in return . VWord (1+u+v) . pure . WordVal . mkBv (1+u+v) $! z) , ("pmod", - ilam $ \_u -> - ilam $ \v -> - wlam Concrete $ \(BV w x) -> return $ - wlam Concrete $ \(BV _ m) -> + PFinPoly \_u -> + PFinPoly \v -> + PWordFun \(BV w x) -> + PWordFun \(BV _ m) -> + PPrim do assertSideCondition sym (m /= 0) DivideByZero return . VWord v . pure . WordVal . mkBv v $! F2.pmod (fromInteger w) x m) , ("pdiv", - ilam $ \_u -> - ilam $ \_v -> - wlam Concrete $ \(BV w x) -> return $ - wlam Concrete $ \(BV _ m) -> + PFinPoly \_u -> + PFinPoly \_v -> + PWordFun \(BV w x) -> + PWordFun \(BV _ m) -> + PPrim do assertSideCondition sym (m /= 0) DivideByZero return . VWord w . pure . WordVal . mkBv w $! F2.pdiv (fromInteger w) x m) ] -primeECPrims :: Map.Map PrimIdent Value +primeECPrims :: Map.Map PrimIdent (Prim Concrete) primeECPrims = Map.fromList $ map (\(n,v) -> (primeECPrim n, v)) [ ("ec_double", {-# SCC "PrimeEC::ec_double" #-} - ilam $ \p -> - lam $ \s -> + PFinPoly \p -> + PFun \s -> + PPrim do s' <- toProjectivePoint =<< s let r = PrimeEC.ec_double (PrimeEC.primeModulus p) s' fromProjectivePoint $! r) , ("ec_add_nonzero", {-# SCC "PrimeEC::ec_add_nonzero" #-} - ilam $ \p -> - lam $ \s -> pure $ - lam $ \t -> + PFinPoly \p -> + PFun \s -> + PFun \t -> + PPrim do s' <- toProjectivePoint =<< s t' <- toProjectivePoint =<< t let r = PrimeEC.ec_add_nonzero (PrimeEC.primeModulus p) s' t' fromProjectivePoint $! r) , ("ec_mult", {-# SCC "PrimeEC::ec_mult" #-} - ilam $ \p -> - lam $ \d -> pure $ - lam $ \s -> + PFinPoly \p -> + PFun \d -> + PFun \s -> + PPrim do d' <- fromVInteger <$> d s' <- toProjectivePoint =<< s let r = PrimeEC.ec_mult (PrimeEC.primeModulus p) d' s' fromProjectivePoint $! r) , ("ec_twin_mult", {-# SCC "PrimeEC::ec_twin_mult" #-} - ilam $ \p -> - lam $ \d0 -> pure $ - lam $ \s -> pure $ - lam $ \d1 -> pure $ - lam $ \t -> + PFinPoly \p -> + PFun \d0 -> + PFun \s -> + PFun \d1 -> + PFun \t -> + PPrim do d0' <- fromVInteger <$> d0 s' <- toProjectivePoint =<< s d1' <- fromVInteger <$> d1 @@ -436,59 +280,64 @@ fromProjectivePoint (PrimeEC.ProjectivePoint x y z) = -suiteBPrims :: Map.Map PrimIdent Value +suiteBPrims :: Map.Map PrimIdent (Prim Concrete) suiteBPrims = Map.fromList $ map (\(n, v) -> (suiteBPrim n, v)) [ ("processSHA2_224", {-# SCC "SuiteB::processSHA2_224" #-} - ilam $ \n -> - lam $ \xs -> - do blks <- enumerateSeqMap n . fromVSeq <$> xs - (SHA.SHA256S w0 w1 w2 w3 w4 w5 w6 _) <- - foldM (\st blk -> seq st (SHA.processSHA256Block st <$> (toSHA256Block =<< blk))) - SHA.initialSHA224State blks - let f :: Word32 -> Eval Value - f = pure . VWord 32 . pure . WordVal . BV 32 . toInteger - zs = finiteSeqMap Concrete (map f [w0,w1,w2,w3,w4,w5,w6]) - seq zs (pure (VSeq 7 zs))) + PFinPoly \n -> + PFun \xs -> + PPrim + do blks <- enumerateSeqMap n . fromVSeq <$> xs + (SHA.SHA256S w0 w1 w2 w3 w4 w5 w6 _) <- + foldM (\st blk -> seq st (SHA.processSHA256Block st <$> (toSHA256Block =<< blk))) + SHA.initialSHA224State blks + let f :: Word32 -> Eval Value + f = pure . VWord 32 . pure . WordVal . BV 32 . toInteger + zs = finiteSeqMap Concrete (map f [w0,w1,w2,w3,w4,w5,w6]) + seq zs (pure (VSeq 7 zs))) , ("processSHA2_256", {-# SCC "SuiteB::processSHA2_256" #-} - ilam $ \n -> - lam $ \xs -> - do blks <- enumerateSeqMap n . fromVSeq <$> xs - (SHA.SHA256S w0 w1 w2 w3 w4 w5 w6 w7) <- - foldM (\st blk -> seq st (SHA.processSHA256Block st <$> (toSHA256Block =<< blk))) - SHA.initialSHA256State blks - let f :: Word32 -> Eval Value - f = pure . VWord 32 . pure . WordVal . BV 32 . toInteger - zs = finiteSeqMap Concrete (map f [w0,w1,w2,w3,w4,w5,w6,w7]) - seq zs (pure (VSeq 8 zs))) + PFinPoly \n -> + PFun \xs -> + PPrim + do blks <- enumerateSeqMap n . fromVSeq <$> xs + (SHA.SHA256S w0 w1 w2 w3 w4 w5 w6 w7) <- + foldM (\st blk -> seq st (SHA.processSHA256Block st <$> (toSHA256Block =<< blk))) + SHA.initialSHA256State blks + let f :: Word32 -> Eval Value + f = pure . VWord 32 . pure . WordVal . BV 32 . toInteger + zs = finiteSeqMap Concrete (map f [w0,w1,w2,w3,w4,w5,w6,w7]) + seq zs (pure (VSeq 8 zs))) , ("processSHA2_384", {-# SCC "SuiteB::processSHA2_384" #-} - ilam $ \n -> - lam $ \xs -> - do blks <- enumerateSeqMap n . fromVSeq <$> xs - (SHA.SHA512S w0 w1 w2 w3 w4 w5 _ _) <- - foldM (\st blk -> seq st (SHA.processSHA512Block st <$> (toSHA512Block =<< blk))) - SHA.initialSHA384State blks - let f :: Word64 -> Eval Value - f = pure . VWord 64 . pure . WordVal . BV 64 . toInteger - zs = finiteSeqMap Concrete (map f [w0,w1,w2,w3,w4,w5]) - seq zs (pure (VSeq 6 zs))) + PFinPoly \n -> + PFun \xs -> + PPrim + do blks <- enumerateSeqMap n . fromVSeq <$> xs + (SHA.SHA512S w0 w1 w2 w3 w4 w5 _ _) <- + foldM (\st blk -> seq st (SHA.processSHA512Block st <$> (toSHA512Block =<< blk))) + SHA.initialSHA384State blks + let f :: Word64 -> Eval Value + f = pure . VWord 64 . pure . WordVal . BV 64 . toInteger + zs = finiteSeqMap Concrete (map f [w0,w1,w2,w3,w4,w5]) + seq zs (pure (VSeq 6 zs))) , ("processSHA2_512", {-# SCC "SuiteB::processSHA2_512" #-} - ilam $ \n -> - lam $ \xs -> - do blks <- enumerateSeqMap n . fromVSeq <$> xs - (SHA.SHA512S w0 w1 w2 w3 w4 w5 w6 w7) <- - foldM (\st blk -> seq st (SHA.processSHA512Block st <$> (toSHA512Block =<< blk))) - SHA.initialSHA512State blks - let f :: Word64 -> Eval Value - f = pure . VWord 64 . pure . WordVal . BV 64 . toInteger - zs = finiteSeqMap Concrete (map f [w0,w1,w2,w3,w4,w5,w6,w7]) - seq zs (pure (VSeq 8 zs))) + PFinPoly \n -> + PFun \xs -> + PPrim + do blks <- enumerateSeqMap n . fromVSeq <$> xs + (SHA.SHA512S w0 w1 w2 w3 w4 w5 w6 w7) <- + foldM (\st blk -> seq st (SHA.processSHA512Block st <$> (toSHA512Block =<< blk))) + SHA.initialSHA512State blks + let f :: Word64 -> Eval Value + f = pure . VWord 64 . pure . WordVal . BV 64 . toInteger + zs = finiteSeqMap Concrete (map f [w0,w1,w2,w3,w4,w5,w6,w7]) + seq zs (pure (VSeq 8 zs))) , ("AESKeyExpand", {-# SCC "SuiteB::AESKeyExpand" #-} - ilam $ \k -> - lam $ \seed -> + PFinPoly \k -> + PFun \seed -> + PPrim do ss <- fromVSeq <$> seed let toWord :: Integer -> Eval Word32 toWord i = fromInteger. bvVal <$> (fromVWord Concrete "AESInfKeyExpand" =<< lookupSeqMap ss i) @@ -500,7 +349,8 @@ suiteBPrims = Map.fromList $ map (\(n, v) -> (suiteBPrim n, v)) pure (VSeq len (finiteSeqMap Concrete (map fromWord ws)))) , ("AESInvMixColumns", {-# SCC "SuiteB::AESInvMixColumns" #-} - lam $ \st -> + PFun \st -> + PPrim do ss <- fromVSeq <$> st let toWord :: Integer -> Eval Word32 toWord i = fromInteger. bvVal <$> (fromVWord Concrete "AESInvMixColumns" =<< lookupSeqMap ss i) @@ -511,7 +361,8 @@ suiteBPrims = Map.fromList $ map (\(n, v) -> (suiteBPrim n, v)) pure . VSeq 4 . finiteSeqMap Concrete . map fromWord $ ws') , ("AESEncRound", {-# SCC "SuiteB::AESEncRound" #-} - lam $ \st -> + PFun \st -> + PPrim do ss <- fromVSeq <$> st let toWord :: Integer -> Eval Word32 toWord i = fromInteger. bvVal <$> (fromVWord Concrete "AESEncRound" =<< lookupSeqMap ss i) @@ -522,7 +373,8 @@ suiteBPrims = Map.fromList $ map (\(n, v) -> (suiteBPrim n, v)) pure . VSeq 4 . finiteSeqMap Concrete . map fromWord $ ws') , ("AESEncFinalRound", {-# SCC "SuiteB::AESEncFinalRound" #-} - lam $ \st -> + PFun \st -> + PPrim do ss <- fromVSeq <$> st let toWord :: Integer -> Eval Word32 toWord i = fromInteger. bvVal <$> (fromVWord Concrete "AESEncFinalRound" =<< lookupSeqMap ss i) @@ -533,7 +385,8 @@ suiteBPrims = Map.fromList $ map (\(n, v) -> (suiteBPrim n, v)) pure . VSeq 4 . finiteSeqMap Concrete . map fromWord $ ws') , ("AESDecRound", {-# SCC "SuiteB::AESDecRound" #-} - lam $ \st -> + PFun \st -> + PPrim do ss <- fromVSeq <$> st let toWord :: Integer -> Eval Word32 toWord i = fromInteger. bvVal <$> (fromVWord Concrete "AESDecRound" =<< lookupSeqMap ss i) @@ -544,7 +397,8 @@ suiteBPrims = Map.fromList $ map (\(n, v) -> (suiteBPrim n, v)) pure . VSeq 4 . finiteSeqMap Concrete . map fromWord $ ws') , ("AESDecFinalRound", {-# SCC "SuiteB::AESDecFinalRound" #-} - lam $ \st -> + PFun \st -> + PPrim do ss <- fromVSeq <$> st let toWord :: Integer -> Eval Word32 toWord i = fromInteger. bvVal <$> (fromVWord Concrete "AESDecFinalRound" =<< lookupSeqMap ss i) @@ -603,12 +457,13 @@ toSHA512Block blk = -------------------------------------------------------------------------------- -sshrV :: Value +sshrV :: Prim Concrete sshrV = - nlam $ \_n -> - tlam $ \ix -> - wlam Concrete $ \(BV w x) -> return $ - lam $ \y -> + PNumPoly \_n -> + PTyPoly \ix -> + PWordFun \(BV w x) -> + PFun \y -> + PPrim do idx <- y >>= asIndex Concrete ">>$" ix >>= \case Left idx -> pure idx Right wv -> bvVal <$> asWordVal Concrete wv @@ -618,14 +473,15 @@ logicShift :: (Integer -> Integer -> Integer -> Integer) -- ^ The function may assume its arguments are masked. -- It is responsible for masking its result if needed. -> (Nat' -> TValue -> SeqMap Concrete -> Integer -> SeqMap Concrete) - -> Value -logicShift opW opS - = nlam $ \ a -> - tlam $ \ _ix -> - tlam $ \ c -> - lam $ \ l -> return $ - lam $ \ r -> do - i <- r >>= \case + -> Prim Concrete +logicShift opW opS = + PNumPoly \a -> + PTyPoly \_ix -> + PTyPoly \c -> + PFun \l -> + PFun \r -> + PPrim + do i <- r >>= \case VInteger i -> pure i VWord _ wval -> bvVal <$> (asWordVal Concrete =<< wval) _ -> evalPanic "logicShift" ["not an index"] @@ -797,33 +653,33 @@ updateBack_word (Nat n) _eltTy bs (Right w) val = do updateWordValue Concrete bs (n - idx - 1) (fromVBit <$> val) -floatPrims :: Concrete -> Map PrimIdent Value +floatPrims :: Concrete -> Map PrimIdent (Prim Concrete) floatPrims sym = Map.fromList [ (floatPrim i,v) | (i,v) <- nonInfixTable ] where (~>) = (,) nonInfixTable = - [ "fpNaN" ~> ilam \e -> ilam \p -> + [ "fpNaN" ~> PFinPoly \e -> PFinPoly \p -> PVal $ VFloat BF { bfValue = FP.bfNaN , bfExpWidth = e, bfPrecWidth = p } - , "fpPosInf" ~> ilam \e -> ilam \p -> + , "fpPosInf" ~> PFinPoly \e -> PFinPoly \p -> PVal $ VFloat BF { bfValue = FP.bfPosInf , bfExpWidth = e, bfPrecWidth = p } - , "fpFromBits" ~> ilam \e -> ilam \p -> wlam sym \bv -> - pure $ VFloat $ floatFromBits e p $ bvVal bv + , "fpFromBits" ~> PFinPoly \e -> PFinPoly \p -> PWordFun \bv -> PVal $ + VFloat $ floatFromBits e p $ bvVal bv - , "fpToBits" ~> ilam \e -> ilam \p -> flam \x -> - pure $ word sym (e + p) + , "fpToBits" ~> PFinPoly \e -> PFinPoly \p -> PFloatFun \x -> PVal + $ word sym (e + p) $ floatToBits e p $ bfValue x - , "=.=" ~> ilam \_ -> ilam \_ -> flam \x -> pure $ flam \y -> - pure $ VBit + , "=.=" ~> PFinPoly \_ -> PFinPoly \_ -> PFloatFun \x -> PFloatFun \y -> PVal + $ VBit $ bitLit sym $ FP.bfCompare (bfValue x) (bfValue y) == EQ - , "fpIsFinite" ~> ilam \_ -> ilam \_ -> flam \x -> - pure $ VBit $ bitLit sym $ FP.bfIsFinite $ bfValue x + , "fpIsFinite" ~> PFinPoly \_ -> PFinPoly \_ -> PFloatFun \x -> PVal + $ VBit $ bitLit sym $ FP.bfIsFinite $ bfValue x -- From Backend class , "fpAdd" ~> fpBinArithV sym fpPlus @@ -832,18 +688,16 @@ floatPrims sym = Map.fromList [ (floatPrim i,v) | (i,v) <- nonInfixTable ] , "fpDiv" ~> fpBinArithV sym fpDiv , "fpFromRational" ~> - ilam \e -> ilam \p -> wlam sym \r -> pure $ lam \x -> + PFinPoly \e -> PFinPoly \p -> PWordFun \r -> PFun \x -> PPrim do rat <- fromVRational <$> x VFloat <$> do mode <- fpRoundMode sym r pure $ floatFromRational e p mode $ sNum rat % sDenom rat , "fpToRational" ~> - ilam \_e -> ilam \_p -> flam \fp -> + PFinPoly \_e -> PFinPoly \_p -> PFloatFun \fp -> PPrim case floatToRational "fpToRational" fp of Left err -> raiseError sym err Right r -> pure $ VRational SRational { sNum = numerator r, sDenom = denominator r } ] - - diff --git a/src/Cryptol/Eval/Generic.hs b/src/Cryptol/Eval/Generic.hs index f2f34856d..eca73ec62 100644 --- a/src/Cryptol/Eval/Generic.hs +++ b/src/Cryptol/Eval/Generic.hs @@ -11,6 +11,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE Rank2Types #-} @@ -27,8 +28,9 @@ import Control.Monad (join, unless) import System.Random.TF.Gen (seedTFGen) import Data.Bits (testBit, (.&.), shiftR) - import Data.Maybe (fromMaybe) +import qualified Data.Map.Strict as Map +import Data.Map(Map) import Data.Ratio ((%)) import Cryptol.TypeCheck.AST @@ -38,8 +40,10 @@ import Cryptol.Backend.Concrete (Concrete(..)) import Cryptol.Backend.Monad ( Eval, evalPanic, EvalError(..), Unsupported(..) ) import Cryptol.Testing.Random( randomValue ) +import Cryptol.Eval.Prims import Cryptol.Eval.Type import Cryptol.Eval.Value +import Cryptol.Utils.Ident (PrimIdent, prelPrim) import Cryptol.Utils.Panic (panic) import Cryptol.Utils.RecordMap @@ -63,14 +67,15 @@ mkLit sym ty i = _ -> evalPanic "Cryptol.Eval.Prim.evalConst" [ "Invalid type for number" ] -{-# SPECIALIZE ecNumberV :: Concrete -> GenValue Concrete +{-# SPECIALIZE ecNumberV :: Concrete -> Prim Concrete #-} -- | Make a numeric constant. -ecNumberV :: Backend sym => sym -> GenValue sym +ecNumberV :: Backend sym => sym -> Prim sym ecNumberV sym = - nlam $ \valT -> - VPoly $ \ty -> + PNumPoly \valT -> + PTyPoly \ty -> + PPrim case valT of Nat v -> mkLit sym ty v _ -> evalPanic "Cryptol.Eval.Prim.evalConst" @@ -80,32 +85,38 @@ ecNumberV sym = ] - {-# SPECIALIZE intV :: Concrete -> Integer -> TValue -> Eval (GenValue Concrete) #-} intV :: Backend sym => sym -> SInteger sym -> TValue -> SEval sym (GenValue sym) -intV sym i = ringNullary sym (\w -> wordFromInt sym w i) (pure i) (\m -> intToZn sym m i) (intToRational sym i) - (\e p -> fpRndMode sym >>= \r -> fpFromInteger sym e p r i) - -{-# SPECIALIZE ratioV :: Concrete -> GenValue Concrete #-} -ratioV :: Backend sym => sym -> GenValue sym +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 -> Prim Concrete #-} +ratioV :: Backend sym => sym -> Prim sym ratioV sym = - lam $ \x -> return $ - lam $ \y -> + PFun \x -> + PFun \y -> + PPrim do x' <- fromVInteger <$> x y' <- fromVInteger <$> y VRational <$> ratio sym x' y' -{-# SPECIALIZE ecFractionV :: Concrete -> GenValue Concrete +{-# SPECIALIZE ecFractionV :: Concrete -> Prim Concrete #-} -ecFractionV :: Backend sym => sym -> GenValue sym +ecFractionV :: Backend sym => sym -> Prim sym ecFractionV sym = - ilam \n -> - ilam \d -> - ilam \_r -> - VPoly \ty -> + PFinPoly \n -> + PFinPoly \d -> + PFinPoly \_r -> + PTyPoly \ty -> + PPrim case ty of - TVFloat e p -> VFloat <$> fpLit sym e p (n % d) + TVFloat e p -> VFloat <$> fpLit sym e p (n % d) TVRational -> do x <- integerLit sym n y <- integerLit sym d @@ -116,34 +127,35 @@ ecFractionV sym = -{-# SPECIALIZE fromZV :: Concrete -> GenValue Concrete #-} -fromZV :: Backend sym => sym -> GenValue sym +{-# SPECIALIZE fromZV :: Concrete -> Prim Concrete #-} +fromZV :: Backend sym => sym -> Prim sym fromZV sym = - nlam $ \(finNat' -> n) -> - lam $ \v -> VInteger <$> (znToInt sym n . fromVInteger =<< v) + PFinPoly \n -> + PFun \v -> + PPrim + (VInteger <$> (znToInt sym n . fromVInteger =<< v)) -- Operation Lifting ----------------------------------------------------------- type Binary sym = TValue -> GenValue sym -> GenValue sym -> SEval sym (GenValue sym) -{-# SPECIALIZE binary :: Binary Concrete -> GenValue Concrete +{-# SPECIALIZE binary :: Binary Concrete -> Prim Concrete #-} -binary :: Backend sym => Binary sym -> GenValue sym -binary f = tlam $ \ ty -> - lam $ \ a -> return $ - lam $ \ b -> do - --io $ putStrLn "Entering a binary function" - join (f ty <$> a <*> b) +binary :: Backend sym => Binary sym -> Prim sym +binary f = PTyPoly \ty -> + PFun \a -> + PFun \b -> + PPrim $ join (f ty <$> a <*> b) type Unary sym = TValue -> GenValue sym -> SEval sym (GenValue sym) -{-# SPECIALIZE unary :: Unary Concrete -> GenValue Concrete +{-# SPECIALIZE unary :: Unary Concrete -> Prim Concrete #-} -unary :: Backend sym => Unary sym -> GenValue sym -unary f = tlam $ \ ty -> - lam $ \ a -> f ty =<< a - +unary :: Backend sym => Unary sym -> Prim sym +unary f = PTyPoly \ty -> + PFun \a -> + PPrim (f ty =<< a) type BinWord sym = Integer -> SWord sym -> SWord sym -> SEval sym (SWord sym) @@ -398,15 +410,16 @@ integralBinary sym opw opi ty l r = case ty of --------------------------------------------------------------------------- -- Ring -{-# SPECIALIZE fromIntegerV :: Concrete -> GenValue Concrete +{-# SPECIALIZE fromIntegerV :: Concrete -> Prim Concrete #-} -- | Convert an unbounded integer to a value in Ring -fromIntegerV :: Backend sym => sym -> GenValue sym +fromIntegerV :: Backend sym => sym -> Prim sym fromIntegerV sym = - tlam $ \ a -> - lam $ \ v -> - do i <- fromVInteger <$> v - intV sym i a + PTyPoly \ a -> + PFun \ v -> + PPrim + do i <- fromVInteger <$> v + intV sym i a {-# INLINE addV #-} addV :: Backend sym => sym -> Binary sym @@ -458,13 +471,14 @@ divV sym = integralBinary sym opw opi opw _w x y = wordDiv sym x y opi x y = intDiv sym x y -{-# SPECIALIZE expV :: Concrete -> GenValue Concrete #-} -expV :: Backend sym => sym -> GenValue sym +{-# SPECIALIZE expV :: Concrete -> Prim Concrete #-} +expV :: Backend sym => sym -> Prim sym expV sym = - tlam $ \aty -> - tlam $ \ety -> - lam $ \am -> return $ - lam $ \em -> + PTyPoly \aty -> + PTyPoly \ety -> + PFun \am -> + PFun \em -> + PPrim do a <- am e <- em case ety of @@ -522,12 +536,13 @@ modV sym = integralBinary sym opw opi opw _w x y = wordMod sym x y opi x y = intMod sym x y -{-# SPECIALIZE toIntegerV :: Concrete -> GenValue Concrete #-} +{-# SPECIALIZE toIntegerV :: Concrete -> Prim Concrete #-} -- | Convert a word to a non-negative integer. -toIntegerV :: Backend sym => sym -> GenValue sym +toIntegerV :: Backend sym => sym -> Prim sym toIntegerV sym = - tlam $ \a -> - lam $ \v -> + PTyPoly \a -> + PFun \v -> + PPrim case a of TVSeq _w el | isTBit el -> VInteger <$> (wordToInt sym =<< (fromVWord sym "toInteger" =<< v)) @@ -537,11 +552,12 @@ toIntegerV sym = ----------------------------------------------------------------------------- -- Field -{-# SPECIALIZE recipV :: Concrete -> GenValue Concrete #-} -recipV :: Backend sym => sym -> GenValue sym +{-# SPECIALIZE recipV :: Concrete -> Prim Concrete #-} +recipV :: Backend sym => sym -> Prim sym recipV sym = - tlam $ \a -> - lam $ \x -> + PTyPoly \a -> + PFun \x -> + PPrim case a of TVRational -> VRational <$> (rationalRecip sym . fromVRational =<< x) TVFloat e p -> @@ -552,12 +568,13 @@ recipV sym = TVIntMod m -> VInteger <$> (znRecip sym m . fromVInteger =<< x) _ -> evalPanic "recip" [show a ++ "is not a Field"] -{-# SPECIALIZE fieldDivideV :: Concrete -> GenValue Concrete #-} -fieldDivideV :: Backend sym => sym -> GenValue sym +{-# SPECIALIZE fieldDivideV :: Concrete -> Prim Concrete #-} +fieldDivideV :: Backend sym => sym -> Prim sym fieldDivideV sym = - tlam $ \a -> - lam $ \x -> return $ - lam $ \y -> + PTyPoly \a -> + PFun \x -> + PFun \y -> + PPrim case a of TVRational -> do x' <- fromVRational <$> x @@ -656,27 +673,27 @@ complementV sym = logicUnary sym (bitComplement sym) (wordComplement sym) -- Bitvector signed div and modulus {-# INLINE lg2V #-} -lg2V :: Backend sym => sym -> GenValue sym +lg2V :: Backend sym => sym -> Prim sym lg2V sym = - nlam $ \(finNat' -> w) -> - wlam sym $ \x -> return $ - VWord w (WordVal <$> wordLg2 sym x) + PFinPoly \w -> + PWordFun \x -> + PVal (VWord w (WordVal <$> wordLg2 sym x)) -{-# SPECIALIZE sdivV :: Concrete -> GenValue Concrete #-} -sdivV :: Backend sym => sym -> GenValue sym +{-# SPECIALIZE sdivV :: Concrete -> Prim Concrete #-} +sdivV :: Backend sym => sym -> Prim sym sdivV sym = - nlam $ \(finNat' -> w) -> - wlam sym $ \x -> return $ - wlam sym $ \y -> return $ - VWord w (WordVal <$> wordSignedDiv sym x y) + PFinPoly \w -> + PWordFun \x -> + PWordFun \y -> + PVal (VWord w (WordVal <$> wordSignedDiv sym x y)) -{-# SPECIALIZE smodV :: Concrete -> GenValue Concrete #-} -smodV :: Backend sym => sym -> GenValue sym +{-# SPECIALIZE smodV :: Concrete -> Prim Concrete #-} +smodV :: Backend sym => sym -> Prim sym smodV sym = - nlam $ \(finNat' -> w) -> - wlam sym $ \x -> return $ - wlam sym $ \y -> return $ - VWord w (WordVal <$> wordSignedMod sym x y) + PFinPoly \w -> + PWordFun \x -> + PWordFun \y -> + PVal (VWord w (WordVal <$> wordSignedMod sym x y)) -- Cmp ------------------------------------------------------------------------- @@ -1093,12 +1110,13 @@ extractWordVal _ len start (LargeBitsVal n xs) = {-# INLINE ecSplitV #-} -- | Split implementation. -ecSplitV :: Backend sym => sym -> GenValue sym +ecSplitV :: Backend sym => sym -> Prim sym ecSplitV sym = - nlam $ \ parts -> - nlam $ \ each -> - tlam $ \ a -> - lam $ \ val -> + PNumPoly \parts -> + PNumPoly \each -> + PTyPoly \a -> + PFun \val -> + PPrim case (parts, each) of (Nat p, Nat e) | isTBit a -> do ~(VWord _ val') <- val @@ -1471,14 +1489,15 @@ indexPrim :: (Nat' -> TValue -> SeqMap sym -> TValue -> SInteger sym -> SEval sym (GenValue sym)) -> (Nat' -> TValue -> SeqMap sym -> TValue -> [SBit sym] -> SEval sym (GenValue sym)) -> (Nat' -> TValue -> SeqMap sym -> TValue -> SWord sym -> SEval sym (GenValue sym)) -> - GenValue sym + Prim sym indexPrim sym int_op bits_op word_op = - nlam $ \ len -> - tlam $ \ eltTy -> - tlam $ \ ix -> - lam $ \ xs -> return $ - lam $ \ idx -> do - vs <- xs >>= \case + PNumPoly \len -> + PTyPoly \eltTy -> + PTyPoly \ix -> + PFun \xs -> + PFun \idx -> + PPrim + do vs <- xs >>= \case VWord _ w -> w >>= \w' -> return $ IndexSeqMap (\i -> VBit <$> indexWordValue sym w' i) VSeq _ vs -> return vs VStream vs -> return vs @@ -1497,31 +1516,33 @@ updatePrim :: sym -> (Nat' -> TValue -> WordValue sym -> Either (SInteger sym) (WordValue sym) -> SEval sym (GenValue sym) -> SEval sym (WordValue sym)) -> (Nat' -> TValue -> SeqMap sym -> Either (SInteger sym) (WordValue sym) -> SEval sym (GenValue sym) -> SEval sym (SeqMap sym)) -> - GenValue sym + Prim sym updatePrim sym updateWord updateSeq = - nlam $ \len -> - tlam $ \eltTy -> - tlam $ \ix -> - lam $ \xs -> return $ - lam $ \idx -> return $ - lam $ \val -> do - idx' <- asIndex sym "update" ix =<< idx - assertIndexInBounds sym len idx' - xs >>= \case - VWord l w -> do w' <- sDelay sym Nothing w - return $ VWord l (w' >>= \w'' -> updateWord len eltTy w'' idx' val) - VSeq l vs -> VSeq l <$> updateSeq len eltTy vs idx' val - VStream vs -> VStream <$> updateSeq len eltTy vs idx' val - _ -> evalPanic "Expected sequence value" ["updatePrim"] + PNumPoly \len -> + PTyPoly \eltTy -> + PTyPoly \ix -> + PFun \xs -> + PFun \idx -> + PFun \val -> + PPrim + do idx' <- asIndex sym "update" ix =<< idx + assertIndexInBounds sym len idx' + xs >>= \case + VWord l w -> do w' <- sDelay sym Nothing w + return $ VWord l (w' >>= \w'' -> updateWord len eltTy w'' idx' val) + VSeq l vs -> VSeq l <$> updateSeq len eltTy vs idx' val + VStream vs -> VStream <$> updateSeq len eltTy vs idx' val + _ -> evalPanic "Expected sequence value" ["updatePrim"] {-# INLINE fromToV #-} -- @[ 0 .. 10 ]@ -fromToV :: Backend sym => sym -> GenValue sym +fromToV :: Backend sym => sym -> Prim sym fromToV sym = - nlam $ \ first -> - nlam $ \ lst -> - tlam $ \ ty -> + PNumPoly \first -> + PNumPoly \lst -> + PTyPoly \ty -> + PVal let !f = mkLit sym ty in case (first, lst) of (Nat first', Nat lst') -> @@ -1532,13 +1553,14 @@ fromToV sym = {-# INLINE fromThenToV #-} -- @[ 0, 1 .. 10 ]@ -fromThenToV :: Backend sym => sym -> GenValue sym +fromThenToV :: Backend sym => sym -> Prim sym fromThenToV sym = - nlam $ \ first -> - nlam $ \ next -> - nlam $ \ lst -> - tlam $ \ ty -> - nlam $ \ len -> + PNumPoly \first -> + PNumPoly \next -> + PNumPoly \lst -> + PTyPoly \ty -> + PNumPoly \len -> + PVal let !f = mkLit sym ty in case (first, next, lst, len) of (Nat first', Nat next', Nat _lst', Nat len') -> @@ -1547,31 +1569,33 @@ fromThenToV sym = _ -> evalPanic "fromThenToV" ["invalid arguments"] {-# INLINE infFromV #-} -infFromV :: Backend sym => sym -> GenValue sym +infFromV :: Backend sym => sym -> Prim sym infFromV sym = - tlam $ \ ty -> - lam $ \ x -> - do mx <- sDelay sym Nothing x - return $ VStream $ IndexSeqMap $ \i -> - do x' <- mx - i' <- integerLit sym i - addV sym ty x' =<< intV sym i' ty + PTyPoly \ty -> + PFun \x -> + PPrim + do mx <- sDelay sym Nothing x + return $ VStream $ IndexSeqMap $ \i -> + do x' <- mx + i' <- integerLit sym i + addV sym ty x' =<< intV sym i' ty {-# INLINE infFromThenV #-} -infFromThenV :: Backend sym => sym -> GenValue sym +infFromThenV :: Backend sym => sym -> Prim sym infFromThenV sym = - tlam $ \ ty -> - lam $ \ first -> return $ - lam $ \ next -> - do mxd <- sDelay sym Nothing - (do x <- first - y <- next - d <- subV sym ty y x - pure (x,d)) - return $ VStream $ IndexSeqMap $ \i -> do - (x,d) <- mxd - i' <- integerLit sym i - addV sym ty x =<< mulV sym ty d =<< intV sym i' ty + PTyPoly \ty -> + PFun \first -> + PFun \next -> + PPrim + do mxd <- sDelay sym Nothing + (do x <- first + y <- next + d <- subV sym ty y x + pure (x,d)) + return $ VStream $ IndexSeqMap $ \i -> do + (x,d) <- mxd + i' <- integerLit sym i + addV sym ty x =<< mulV sym ty d =<< intV sym i' ty -- Shifting --------------------------------------------------- @@ -1670,13 +1694,14 @@ logicShift :: Backend sym => {- ^ reindexing operation for positive indices (sequence size, starting index, shift amount -} -> (Nat' -> Integer -> Integer -> Maybe Integer) {- ^ reindexing operation for negative indices (sequence size, starting index, shift amount -} -> - GenValue sym + Prim sym logicShift sym nm shrinkRange wopPos wopNeg reindexPos reindexNeg = - nlam $ \m -> - tlam $ \ix -> - tlam $ \a -> - VFun $ \xs -> return $ - VFun $ \y -> + PNumPoly \m -> + PTyPoly \ix -> + PTyPoly \a -> + PFun \xs -> + PFun \y -> + PPrim do xs' <- xs y' <- asIndex sym "shift" ix =<< y case y' of @@ -1921,15 +1946,16 @@ mergeSeqMap sym c x y = -foldlV :: Backend sym => sym -> GenValue sym +foldlV :: Backend sym => sym -> Prim sym foldlV sym = - ilam $ \_n -> - tlam $ \_a -> - tlam $ \_b -> - lam $ \f -> pure $ - lam $ \z -> pure $ - lam $ \v -> - v >>= \case + PNumPoly \_n -> + PTyPoly \_a -> + PTyPoly \_b -> + PFun \f -> + PFun \z -> + PStrictFun \v -> + PPrim + case v of VSeq n m -> go0 f z (enumerateSeqMap n m) VWord _n wv -> go0 f z . map (pure . VBit) =<< (enumerateWordValue sym =<< wv) _ -> panic "Cryptol.Eval.Generic.foldlV" ["Expected finite sequence"] @@ -1944,15 +1970,16 @@ foldlV sym = do f' <- fromVFun <$> (f a) go1 f (f' b) bs -foldl'V :: Backend sym => sym -> GenValue sym +foldl'V :: Backend sym => sym -> Prim sym foldl'V sym = - ilam $ \_n -> - tlam $ \_a -> - tlam $ \_b -> - lam $ \f -> pure $ - lam $ \z -> pure $ - lam $ \v -> - v >>= \case + PNumPoly \_n -> + PTyPoly \_a -> + PTyPoly \_b -> + PFun \f -> + PFun \z -> + PStrictFun \v -> + PPrim + case v of VSeq n m -> go0 f z (enumerateSeqMap n m) VWord _n wv -> go0 f z . map (pure . VBit) =<< (enumerateWordValue sym =<< wv) _ -> panic "Cryptol.Eval.Generic.foldlV" ["Expected finite sequence"] @@ -1994,13 +2021,14 @@ randomV sym ty seed = -------------------------------------------------------------------------------- -- Experimental parallel primitives -parmapV :: Backend sym => sym -> GenValue sym +parmapV :: Backend sym => sym -> Prim sym parmapV sym = - tlam $ \_a -> - tlam $ \_b -> - ilam $ \_n -> - lam $ \f -> pure $ - lam $ \xs -> + PTyPoly \_a -> + PTyPoly \_b -> + PFinPoly \_n -> + PFun \f -> + PFun \xs -> + PPrim do f' <- fromVFun <$> f xs' <- xs case xs' of @@ -2033,14 +2061,14 @@ sparkParMap sym f n m = -- Floating Point Operations -- | Make a Cryptol value for a binary arithmetic function. -fpBinArithV :: Backend sym => sym -> FPArith2 sym -> GenValue sym +fpBinArithV :: Backend sym => sym -> FPArith2 sym -> Prim sym fpBinArithV sym fun = - ilam \_ -> - ilam \_ -> - wlam sym \r -> - pure $ flam \x -> - pure $ flam \y -> - VFloat <$> fun sym r x y + PFinPoly \_e -> + PFinPoly \_p -> + PWordFun \r -> + PFloatFun \x -> + PFloatFun \y -> + PPrim (VFloat <$> fun sym r x y) -- | Rounding mode used in FP operations that do not specify it explicitly. fpRndMode, fpRndRNE, fpRndRNA, fpRndRTP, fpRndRTN, fpRndRTZ :: @@ -2051,3 +2079,188 @@ 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 -} + + + +{-# SPECIALIZE genericPrimTable :: Concrete -> Map PrimIdent (Prim Concrete) #-} + +genericPrimTable :: Backend sym => sym -> Map PrimIdent (Prim sym) +genericPrimTable sym = + Map.fromList $ map (\(n, v) -> (prelPrim n, v)) + + [ -- Literals + ("True" , PVal $ VBit (bitLit sym True)) + , ("False" , PVal $ VBit (bitLit sym False)) + , ("number" , {-# SCC "Prelude::number" #-} + ecNumberV sym) + , ("ratio" , {-# SCC "Prelude::ratio" #-} + ratioV sym) + , ("fraction" , ecFractionV sym) + + -- Zero + , ("zero" , {-# SCC "Prelude::zero" #-} + PTyPoly (PPrim . zeroV sym)) + + -- Logic + , ("&&" , {-# SCC "Prelude::(&&)" #-} + binary (andV sym)) + , ("||" , {-# SCC "Prelude::(||)" #-} + binary (orV sym)) + , ("^" , {-# SCC "Prelude::(^)" #-} + binary (xorV sym)) + , ("complement" , {-# SCC "Prelude::complement" #-} + unary (complementV sym)) + + -- Ring + , ("fromInteger", {-# SCC "Prelude::fromInteger" #-} + fromIntegerV sym) + , ("+" , {-# SCC "Prelude::(+)" #-} + binary (addV sym)) + , ("-" , {-# SCC "Prelude::(-)" #-} + binary (subV sym)) + , ("*" , {-# SCC "Prelude::(*)" #-} + binary (mulV sym)) + , ("negate" , {-# SCC "Prelude::negate" #-} + unary (negateV sym)) + + -- Integral + , ("toInteger" , {-# SCC "Prelude::toInteger" #-} + toIntegerV sym) + , ("/" , {-# SCC "Prelude::(/)" #-} + binary (divV sym)) + , ("%" , {-# SCC "Prelude::(%)" #-} + binary (modV sym)) + , ("^^" , {-# SCC "Prelude::(^^)" #-} + expV sym) + , ("infFrom" , {-# SCC "Prelude::infFrom" #-} + infFromV sym) + , ("infFromThen", {-# SCC "Prelude::infFromThen" #-} + infFromThenV sym) + + -- Field + , ("recip" , {-# SCC "Prelude::recip" #-} + recipV sym) + , ("/." , {-# SCC "Prelude::(/.)" #-} + fieldDivideV sym) + + -- Round + , ("floor" , {-# SCC "Prelude::floor" #-} + unary (floorV sym)) + , ("ceiling" , {-# SCC "Prelude::ceiling" #-} + unary (ceilingV sym)) + , ("trunc" , {-# SCC "Prelude::trunc" #-} + unary (truncV sym)) + , ("roundAway" , {-# SCC "Prelude::roundAway" #-} + unary (roundAwayV sym)) + , ("roundToEven", {-# SCC "Prelude::roundToEven" #-} + unary (roundToEvenV sym)) + + -- Bitvector specific operations + , ("/$" , {-# SCC "Prelude::(/$)" #-} + sdivV sym) + , ("%$" , {-# SCC "Prelude::(%$)" #-} + smodV sym) + , ("lg2" , {-# SCC "Prelude::lg2" #-} + lg2V sym) + + -- Cmp + , ("<" , {-# SCC "Prelude::(<)" #-} + binary (lessThanV sym)) + , (">" , {-# SCC "Prelude::(>)" #-} + binary (greaterThanV sym)) + , ("<=" , {-# SCC "Prelude::(<=)" #-} + binary (lessThanEqV sym)) + , (">=" , {-# SCC "Prelude::(>=)" #-} + binary (greaterThanEqV sym)) + , ("==" , {-# SCC "Prelude::(==)" #-} + binary (eqV sym)) + , ("!=" , {-# SCC "Prelude::(!=)" #-} + binary (distinctV sym)) + + -- SignedCmp + , ("<$" , {-# SCC "Prelude::(<$)" #-} + binary (signedLessThanV sym)) + + -- Finite enumerations + , ("fromTo" , {-# SCC "Prelude::fromTo" #-} + fromToV sym) + , ("fromThenTo" , {-# SCC "Prelude::fromThenTo" #-} + fromThenToV sym) + + -- Sequence manipulations + , ("#" , {-# SCC "Prelude::(#)" #-} + PFinPoly \front -> + PNumPoly \back -> + PTyPoly \elty -> + PFun \l -> + PFun \r -> + PPrim (join (ccatV sym (Nat front) back elty <$> l <*> r))) + + , ("join" , {-# SCC "Prelude::join" #-} + PNumPoly \parts -> + PFinPoly \each -> + PTyPoly \a -> + PStrictFun \x -> + PPrim $ joinV sym parts each a x) + + , ("split" , {-# SCC "Prelude::split" #-} + ecSplitV sym) + + , ("splitAt" , {-# SCC "Prelude::splitAt" #-} + PNumPoly \front -> + PNumPoly \back -> + PTyPoly \a -> + PStrictFun \x -> + PPrim $ splitAtV sym front back a x) + + , ("reverse" , {-# SCC "Prelude::reverse" #-} + PFinPoly \_a -> + PTyPoly \_b -> + PStrictFun \xs -> + PPrim $ reverseV sym xs) + + , ("transpose" , {-# SCC "Prelude::transpose" #-} + PNumPoly \a -> + PNumPoly \b -> + PTyPoly \c -> + PStrictFun \xs -> + PPrim $ transposeV sym a b c xs) + + -- Misc + + -- {at,len} (fin len) => [len][8] -> at + , ("error" , {-# SCC "Prelude::error" #-} + PTyPoly \a -> + PFinPoly \_ -> + PStrictFun \s -> + PPrim (errorV sym a =<< valueToString sym s)) + + , ("random" , {-# SCC "Prelude::random" #-} + PTyPoly \a -> + PWordFun \x -> + PPrim + case wordAsLit sym x of + Just (_,i) -> randomV sym a i + Nothing -> liftIO (X.throw (UnsupportedSymbolicOp "random"))) + + , ("foldl" , {-# SCC "Prelude::foldl" #-} + foldlV sym) + + , ("foldl'" , {-# SCC "Prelude::foldl'" #-} + foldl'V sym) + + , ("deepseq" , {-# SCC "Prelude::deepseq" #-} + PTyPoly \_a -> + PTyPoly \_b -> + PFun \x -> + PFun \y -> + PPrim do _ <- forceValue =<< x + y) + + , ("parmap" , {-# SCC "Prelude::parmap" #-} + parmapV sym) + + , ("fromZ" , {-# SCC "Prelude::fromZ" #-} + fromZV sym) + + ] diff --git a/src/Cryptol/Eval/Prims.hs b/src/Cryptol/Eval/Prims.hs new file mode 100644 index 000000000..561b3ea25 --- /dev/null +++ b/src/Cryptol/Eval/Prims.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE LambdaCase #-} +module Cryptol.Eval.Prims where + +import Cryptol.Backend +import Cryptol.TypeCheck.Solver.InfNat(Nat'(..)) +import Cryptol.Eval.Type +import Cryptol.Eval.Value +import Cryptol.ModuleSystem.Name +import Cryptol.Utils.Panic + +data Prim sym + = PFun (SEval sym (GenValue sym) -> Prim sym) + | PStrictFun (GenValue sym -> Prim sym) + | PWordFun (SWord sym -> Prim sym) + | PFloatFun (SFloat sym -> Prim sym) + | PTyPoly (TValue -> Prim sym) + | PNumPoly (Nat' -> Prim sym) + | PFinPoly (Integer -> Prim sym) + | PPrim (SEval sym (GenValue sym)) + | PVal (GenValue sym) + +evalPrim :: Backend sym => sym -> Name -> Prim sym -> SEval sym (GenValue sym) +evalPrim sym nm p = case p of + PFun f -> pure (lam (evalPrim sym nm . f)) + PStrictFun f -> pure (lam (\x -> evalPrim sym nm . f =<< x)) + PWordFun f -> pure (lam (\x -> evalPrim sym nm . f =<< (fromVWord sym (show nm) =<< x))) + PFloatFun f -> pure (flam (evalPrim sym nm . f)) + PTyPoly f -> pure (VPoly (evalPrim sym nm . f)) + PNumPoly f -> pure (VNumPoly (evalPrim sym nm . f)) + PFinPoly f -> pure (VNumPoly (\case Inf -> panic "PFin" ["Unexpected `inf`", show nm]; + Nat n -> evalPrim sym nm (f n))) + PPrim m -> m + PVal v -> pure v diff --git a/src/Cryptol/Eval/SBV.hs b/src/Cryptol/Eval/SBV.hs index 3b32f8b98..eb73001c2 100644 --- a/src/Cryptol/Eval/SBV.hs +++ b/src/Cryptol/Eval/SBV.hs @@ -6,6 +6,7 @@ -- Stability : provisional -- Portability : portable +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -21,7 +22,6 @@ module Cryptol.Eval.SBV ) where import qualified Control.Exception as X -import Control.Monad (join) import Control.Monad.IO.Class (MonadIO(..)) import Data.Bits (bit, shiftL) import qualified Data.Map as Map @@ -33,8 +33,9 @@ import Cryptol.Backend import Cryptol.Backend.Monad ( EvalError(..), Unsupported(..) ) import Cryptol.Backend.SBV -import Cryptol.Eval.Type (TValue(..), finNat') +import Cryptol.Eval.Type (TValue(..)) import Cryptol.Eval.Generic +import Cryptol.Eval.Prims import Cryptol.Eval.Value import Cryptol.TypeCheck.Solver.InfNat (Nat'(..), widthInteger) import Cryptol.Utils.Ident @@ -46,106 +47,12 @@ type Value = GenValue SBV -- Primitives ------------------------------------------------------------------ -- See also Cryptol.Eval.Concrete.primTable -primTable :: SBV -> Map.Map PrimIdent Value -primTable sym = +primTable :: SBV -> Map.Map PrimIdent (Prim SBV) +primTable sym = + Map.union (genericPrimTable sym) $ Map.fromList $ map (\(n, v) -> (prelPrim (T.pack n), v)) - [ -- Literals - ("True" , VBit (bitLit sym True)) - , ("False" , VBit (bitLit sym False)) - , ("number" , ecNumberV sym) -- Converts a numeric type into its corresponding value. - -- { val, rep } (Literal val rep) => rep - , ("fraction" , ecFractionV sym) - , ("ratio" , ratioV sym) - - -- Zero - , ("zero" , VPoly (zeroV sym)) - - -- Logic - , ("&&" , binary (andV sym)) - , ("||" , binary (orV sym)) - , ("^" , binary (xorV sym)) - , ("complement" , unary (complementV sym)) - - -- Ring - , ("fromInteger" , fromIntegerV sym) - , ("+" , binary (addV sym)) - , ("-" , binary (subV sym)) - , ("negate" , unary (negateV sym)) - , ("*" , binary (mulV sym)) - - -- Integral - , ("toInteger" , toIntegerV sym) - , ("/" , binary (divV sym)) - , ("%" , binary (modV sym)) - , ("^^" , expV sym) - , ("infFrom" , infFromV sym) - , ("infFromThen" , infFromThenV sym) - - -- Field - , ("recip" , recipV sym) - , ("/." , fieldDivideV sym) - - -- Round - , ("floor" , unary (floorV sym)) - , ("ceiling" , unary (ceilingV sym)) - , ("trunc" , unary (truncV sym)) - , ("roundAway" , unary (roundAwayV sym)) - , ("roundToEven" , unary (roundToEvenV sym)) - - -- Word operations - , ("/$" , sdivV sym) - , ("%$" , smodV sym) - , ("lg2" , lg2V sym) - , (">>$" , sshrV sym) - - -- Cmp - , ("<" , binary (lessThanV sym)) - , (">" , binary (greaterThanV sym)) - , ("<=" , binary (lessThanEqV sym)) - , (">=" , binary (greaterThanEqV sym)) - , ("==" , binary (eqV sym)) - , ("!=" , binary (distinctV sym)) - - -- SignedCmp - , ("<$" , binary (signedLessThanV sym)) - - -- Finite enumerations - , ("fromTo" , fromToV sym) - , ("fromThenTo" , fromThenToV sym) - - -- Sequence manipulations - , ("#" , -- {a,b,d} (fin a) => [a] d -> [b] d -> [a + b] d - nlam $ \ front -> - nlam $ \ back -> - tlam $ \ elty -> - lam $ \ l -> return $ - lam $ \ r -> join (ccatV sym front back elty <$> l <*> r)) - - , ("join" , - nlam $ \ parts -> - nlam $ \ (finNat' -> each) -> - tlam $ \ a -> - lam $ \ x -> - joinV sym parts each a =<< x) - - , ("split" , ecSplitV sym) - - , ("splitAt" , - nlam $ \ front -> - nlam $ \ back -> - tlam $ \ a -> - lam $ \ x -> - splitAtV sym front back a =<< x) - - , ("reverse" , nlam $ \_a -> - tlam $ \_b -> - lam $ \xs -> reverseV sym =<< xs) - - , ("transpose" , nlam $ \a -> - nlam $ \b -> - tlam $ \c -> - lam $ \xs -> transposeV sym a b c =<< xs) + [ (">>$" , sshrV sym) -- Shifts and rotates , ("<<" , logicShift sym "<<" @@ -179,52 +86,22 @@ primTable sym = , ("update" , updatePrim sym (updateFrontSym_word sym) (updateFrontSym sym)) , ("updateEnd" , updatePrim sym (updateBackSym_word sym) (updateBackSym sym)) - -- Misc - - , ("fromZ" , fromZV sym) - - , ("foldl" , foldlV sym) - , ("foldl'" , foldl'V sym) - - , ("deepseq" , - tlam $ \_a -> - tlam $ \_b -> - lam $ \x -> pure $ - lam $ \y -> - do _ <- forceValue =<< x - y) - - , ("parmap" , parmapV sym) - - -- {at,len} (fin len) => [len][8] -> at - , ("error" , - tlam $ \a -> - nlam $ \_ -> - VFun $ \s -> errorV sym a =<< (valueToString sym =<< s)) - - , ("random" , - tlam $ \a -> - wlam sym $ \x -> - case integerAsLit sym x of - Just i -> randomV sym a i - Nothing -> cryUserError sym "cannot evaluate 'random' with symbolic inputs") - -- The trace function simply forces its first two -- values before returing the third in the symbolic -- evaluator. , ("trace", - nlam $ \_n -> - tlam $ \_a -> - tlam $ \_b -> - lam $ \s -> return $ - lam $ \x -> return $ - lam $ \y -> do - _ <- s - _ <- x - y) + PNumPoly \_n -> + PTyPoly \_a -> + PTyPoly \_b -> + PFun \s -> + PFun \x -> + PFun \y -> + PPrim + do _ <- s + _ <- x + y) ] - indexFront :: SBV -> Nat' -> @@ -468,13 +345,14 @@ asWordList = go id go f (WordVal x :vs) = go (f . (x:)) vs go _f (LargeBitsVal _ _ : _) = Nothing -sshrV :: SBV -> Value +sshrV :: SBV -> Prim SBV sshrV sym = - nlam $ \n -> - tlam $ \ix -> - wlam sym $ \x -> return $ - lam $ \y -> - y >>= asIndex sym ">>$" ix >>= \case + PNumPoly \n -> + PTyPoly \ix -> + PWordFun \x -> + PStrictFun \y -> + PPrim $ + asIndex sym ">>$" ix y >>= \case Left idx -> do let w = toInteger (SBV.intSizeOf x) let pneg = svLessThan idx (svInteger KUnbounded 0) diff --git a/src/Cryptol/Eval/What4.hs b/src/Cryptol/Eval/What4.hs index fef8940ed..a04fa0023 100644 --- a/src/Cryptol/Eval/What4.hs +++ b/src/Cryptol/Eval/What4.hs @@ -23,7 +23,7 @@ module Cryptol.Eval.What4 import qualified Control.Exception as X import Control.Concurrent.MVar -import Control.Monad (join,foldM) +import Control.Monad (foldM) import Control.Monad.IO.Class import Data.Bits import qualified Data.Map as Map @@ -32,8 +32,8 @@ import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as Text import Data.Parameterized.Context -import Data.Parameterized.Some import Data.Parameterized.TraversableFC +import Data.Parameterized.Some import qualified Data.BitVector.Sized as BV import qualified What4.Interface as W4 @@ -46,7 +46,8 @@ import Cryptol.Backend.What4 import qualified Cryptol.Backend.What4.SFloat as W4 import Cryptol.Eval.Generic -import Cryptol.Eval.Type (finNat', TValue(..)) +import Cryptol.Eval.Prims +import Cryptol.Eval.Type (TValue(..)) import Cryptol.Eval.Value import qualified Cryptol.SHA as SHA @@ -60,111 +61,17 @@ import Cryptol.Utils.RecordMap type Value sym = GenValue (What4 sym) -- See also Cryptol.Prims.Eval.primTable -primTable :: W4.IsSymExprBuilder sym => What4 sym -> Map.Map PrimIdent (Value sym) +primTable :: W4.IsSymExprBuilder sym => What4 sym -> Map.Map PrimIdent (Prim (What4 sym)) primTable sym = let w4sym = w4 sym in Map.union (floatPrims sym) $ Map.union (suiteBPrims sym) $ Map.union (primeECPrims sym) $ + Map.union (genericPrimTable sym) $ Map.fromList $ map (\(n, v) -> (prelPrim n, v)) - [ -- Literals - ("True" , VBit (bitLit sym True)) - , ("False" , VBit (bitLit sym False)) - , ("number" , ecNumberV sym) -- Converts a numeric type into its corresponding value. - -- { val, rep } (Literal val rep) => rep - , ("fraction" , ecFractionV sym) - , ("ratio" , ratioV sym) - - -- Zero - , ("zero" , VPoly (zeroV sym)) - - -- Logic - , ("&&" , binary (andV sym)) - , ("||" , binary (orV sym)) - , ("^" , binary (xorV sym)) - , ("complement" , unary (complementV sym)) - - -- Ring - , ("fromInteger" , fromIntegerV sym) - , ("+" , binary (addV sym)) - , ("-" , binary (subV sym)) - , ("negate" , unary (negateV sym)) - , ("*" , binary (mulV sym)) - - -- Integral - , ("toInteger" , toIntegerV sym) - , ("/" , binary (divV sym)) - , ("%" , binary (modV sym)) - , ("^^" , expV sym) - , ("infFrom" , infFromV sym) - , ("infFromThen" , infFromThenV sym) - - -- Field - , ("recip" , recipV sym) - , ("/." , fieldDivideV sym) - - -- Round - , ("floor" , unary (floorV sym)) - , ("ceiling" , unary (ceilingV sym)) - , ("trunc" , unary (truncV sym)) - , ("roundAway" , unary (roundAwayV sym)) - , ("roundToEven" , unary (roundToEvenV sym)) - - -- Word operations - , ("/$" , sdivV sym) - , ("%$" , smodV sym) - , ("lg2" , lg2V sym) - , (">>$" , sshrV sym) - - -- Cmp - , ("<" , binary (lessThanV sym)) - , (">" , binary (greaterThanV sym)) - , ("<=" , binary (lessThanEqV sym)) - , (">=" , binary (greaterThanEqV sym)) - , ("==" , binary (eqV sym)) - , ("!=" , binary (distinctV sym)) - - -- SignedCmp - , ("<$" , binary (signedLessThanV sym)) - - -- Finite enumerations - , ("fromTo" , fromToV sym) - , ("fromThenTo" , fromThenToV sym) - - -- Sequence manipulations - , ("#" , -- {a,b,d} (fin a) => [a] d -> [b] d -> [a + b] d - nlam $ \ front -> - nlam $ \ back -> - tlam $ \ elty -> - lam $ \ l -> return $ - lam $ \ r -> join (ccatV sym front back elty <$> l <*> r)) - - , ("join" , - nlam $ \ parts -> - nlam $ \ (finNat' -> each) -> - tlam $ \ a -> - lam $ \ x -> - joinV sym parts each a =<< x) - - , ("split" , ecSplitV sym) - - , ("splitAt" , - nlam $ \ front -> - nlam $ \ back -> - tlam $ \ a -> - lam $ \ x -> - splitAtV sym front back a =<< x) - - , ("reverse" , nlam $ \_a -> - tlam $ \_b -> - lam $ \xs -> reverseV sym =<< xs) - - , ("transpose" , nlam $ \a -> - nlam $ \b -> - tlam $ \c -> - lam $ \xs -> transposeV sym a b c =<< xs) + [ (">>$" , sshrV sym) -- Shifts and rotates , ("<<" , logicShift sym "<<" shiftShrink @@ -189,50 +96,23 @@ primTable sym = -- Misc - , ("foldl" , foldlV sym) - , ("foldl'" , foldl'V sym) - - , ("deepseq" , - tlam $ \_a -> - tlam $ \_b -> - lam $ \x -> pure $ - lam $ \y -> - do _ <- forceValue =<< x - y) - - , ("parmap" , parmapV sym) - - , ("fromZ" , fromZV sym) - - -- {at,len} (fin len) => [len][8] -> at - , ("error" , - tlam $ \a -> - nlam $ \_ -> - VFun $ \s -> errorV sym a =<< (valueToString sym =<< s)) - - , ("random" , - tlam $ \a -> - wlam sym $ \x -> - case wordAsLit sym x of - Just (_,i) -> randomV sym a i - Nothing -> cryUserError sym "cannot evaluate 'random' with symbolic inputs") - -- The trace function simply forces its first two -- values before returing the third in the symbolic -- evaluator. , ("trace", - nlam $ \_n -> - tlam $ \_a -> - tlam $ \_b -> - lam $ \s -> return $ - lam $ \x -> return $ - lam $ \y -> do - _ <- s - _ <- x - y) + PNumPoly \_n -> + PTyPoly \_a -> + PTyPoly \_b -> + PFun \s -> + PFun \x -> + PFun \y -> + PPrim + do _ <- s + _ <- x + y) ] -primeECPrims :: W4.IsSymExprBuilder sym => What4 sym -> Map.Map PrimIdent (Value sym) +primeECPrims :: W4.IsSymExprBuilder sym => What4 sym -> Map.Map PrimIdent (Prim (What4 sym)) primeECPrims sym = Map.fromList $ [ (primeECPrim n, v) | (n,v) <- prims ] where (~>) = (,) @@ -240,8 +120,9 @@ primeECPrims sym = Map.fromList $ [ (primeECPrim n, v) | (n,v) <- prims ] prims = [ -- {p} (prime p, p > 3) => ProjectivePoint p -> ProjectivePoint p "ec_double" ~> - ilam \p -> - lam \s -> + PFinPoly \p -> + PFun \s -> + PPrim do p' <- integerLit sym p s' <- toProjectivePoint sym =<< s addUninterpWarning sym "Prime ECC" @@ -252,9 +133,10 @@ primeECPrims sym = Map.fromList $ [ (primeECPrim n, v) | (n,v) <- prims ] -- {p} (prime p, p > 3) => ProjectivePoint p -> ProjectivePoint p -> ProjectivePoint p , "ec_add_nonzero" ~> - ilam \p -> - lam \s -> pure $ - lam \t -> + PFinPoly \p -> + PFun \s -> + PFun \t -> + PPrim do p' <- integerLit sym p s' <- toProjectivePoint sym =<< s t' <- toProjectivePoint sym =<< t @@ -266,9 +148,10 @@ primeECPrims sym = Map.fromList $ [ (primeECPrim n, v) | (n,v) <- prims ] -- {p} (prime p, p > 3) => Z p -> ProjectivePoint p -> ProjectivePoint p , "ec_mult" ~> - ilam \p -> - lam \k -> pure $ - lam \s -> + PFinPoly \p -> + PFun \k -> + PFun \s -> + PPrim do p' <- integerLit sym p k' <- fromVInteger <$> k s' <- toProjectivePoint sym =<< s @@ -280,11 +163,12 @@ primeECPrims sym = Map.fromList $ [ (primeECPrim n, v) | (n,v) <- prims ] -- {p} (prime p, p > 3) => Z p -> ProjectivePoint p -> Z p -> ProjectivePoint p -> ProjectivePoint p , "ec_twin_mult" ~> - ilam \p -> - lam \j -> pure $ - lam \s -> pure $ - lam \k -> pure $ - lam \t -> + PFinPoly \p -> + PFun \j -> + PFun \s -> + PFun \k -> + PFun \t -> + PPrim do p' <- integerLit sym p j' <- fromVInteger <$> j s' <- toProjectivePoint sym =<< s @@ -299,7 +183,6 @@ primeECPrims sym = Map.fromList $ [ (primeECPrim n, v) | (n,v) <- prims ] fromProjectivePoint sym z ] - type ProjectivePoint = W4.BaseStructType (EmptyCtx ::> W4.BaseIntegerType ::> W4.BaseIntegerType ::> W4.BaseIntegerType) projectivePointRepr :: W4.BaseTypeRepr ProjectivePoint @@ -321,37 +204,44 @@ fromProjectivePoint sym p = liftIO $ z <- VInteger <$> W4.structField (w4 sym) p (natIndex @2) pure $ VRecord $ recordFromFields [ (packIdent "x",pure x), (packIdent "y",pure y),(packIdent "z",pure z) ] -suiteBPrims :: W4.IsSymExprBuilder sym => What4 sym -> Map.Map PrimIdent (Value sym) + +suiteBPrims :: W4.IsSymExprBuilder sym => What4 sym -> Map.Map PrimIdent (Prim (What4 sym)) suiteBPrims sym = Map.fromList $ [ (suiteBPrim n, v) | (n,v) <- prims ] where (~>) = (,) prims = [ "AESEncRound" ~> - lam \st -> + PFun \st -> + PPrim do addUninterpWarning sym "AES encryption" applyAESStateFunc sym "AESEncRound" =<< st , "AESEncFinalRound" ~> - lam \st -> + PFun \st -> + PPrim do addUninterpWarning sym "AES encryption" applyAESStateFunc sym "AESEncFinalRound" =<< st , "AESDecRound" ~> - lam \st -> + PFun \st -> + PPrim do addUninterpWarning sym "AES decryption" applyAESStateFunc sym "AESDecRound" =<< st , "AESDecFinalRound" ~> - lam \st -> + PFun \st -> + PPrim do addUninterpWarning sym "AES decryption" applyAESStateFunc sym "AESDecFinalRound" =<< st , "AESInvMixColumns" ~> - lam \st -> + PFun \st -> + PPrim do addUninterpWarning sym "AES key expansion" applyAESStateFunc sym "AESInvMixColumns" =<< st -- {k} (fin k, k >= 4, 8 >= k) => [k][32] -> [4*(k+7)][32] , "AESKeyExpand" ~> - ilam \k -> - lam \st -> + PFinPoly \k -> + PFun \st -> + PPrim do ss <- fromVSeq <$> st -- pack the arguments into a k-tuple of 32-bit values Some ws <- generateSomeM (fromInteger k) (\i -> Some <$> toWord32 sym "AESKeyExpand" ss (toInteger i)) @@ -372,8 +262,9 @@ suiteBPrims sym = Map.fromList $ [ (suiteBPrim n, v) | (n,v) <- prims ] -- {n} (fin n) => [n][16][32] -> [7][32] , "processSHA2_224" ~> - ilam \n -> - lam \xs -> + PFinPoly \n -> + PFun \xs -> + PPrim do blks <- enumerateSeqMap n . fromVSeq <$> xs addUninterpWarning sym "SHA-224" initSt <- liftIO (mkSHA256InitialState sym SHA.initialSHA224State) @@ -389,8 +280,9 @@ suiteBPrims sym = Map.fromList $ [ (suiteBPrim n, v) | (n,v) <- prims ] -- {n} (fin n) => [n][16][32] -> [8][32] , "processSHA2_256" ~> - ilam \n -> - lam \xs -> + PFinPoly \n -> + PFun \xs -> + PPrim do blks <- enumerateSeqMap n . fromVSeq <$> xs addUninterpWarning sym "SHA-256" initSt <- liftIO (mkSHA256InitialState sym SHA.initialSHA256State) @@ -406,8 +298,9 @@ suiteBPrims sym = Map.fromList $ [ (suiteBPrim n, v) | (n,v) <- prims ] -- {n} (fin n) => [n][16][64] -> [6][64] , "processSHA2_384" ~> - ilam \n -> - lam \xs -> + PFinPoly \n -> + PFun \xs -> + PPrim do blks <- enumerateSeqMap n . fromVSeq <$> xs addUninterpWarning sym "SHA-384" initSt <- liftIO (mkSHA512InitialState sym SHA.initialSHA384State) @@ -423,8 +316,9 @@ suiteBPrims sym = Map.fromList $ [ (suiteBPrim n, v) | (n,v) <- prims ] -- {n} (fin n) => [n][16][64] -> [8][64] , "processSHA2_512" ~> - ilam \n -> - lam \xs -> + PFinPoly \n -> + PFun \xs -> + PPrim do blks <- enumerateSeqMap n . fromVSeq <$> xs addUninterpWarning sym "SHA-512" initSt <- liftIO (mkSHA512InitialState sym SHA.initialSHA512State) @@ -636,13 +530,14 @@ applyAESStateFunc sym funNm x = argCtx = W4.knownRepr -sshrV :: W4.IsSymExprBuilder sym => What4 sym -> Value sym +sshrV :: W4.IsSymExprBuilder sym => What4 sym -> Prim (What4 sym) sshrV sym = - nlam $ \(Nat n) -> - tlam $ \ix -> - wlam sym $ \x -> return $ - lam $ \y -> - y >>= asIndex sym ">>$" ix >>= \case + PFinPoly \n -> + PTyPoly \ix -> + PWordFun \x -> + PStrictFun \y -> + PPrim $ + asIndex sym ">>$" ix y >>= \case Left i -> do pneg <- intLessThan sym i =<< integerLit sym 0 zneg <- do i' <- shiftShrink sym (Nat n) ix =<< intNegate sym i @@ -983,9 +878,8 @@ updateBackSym_word sym (Nat n) eltTy bv (Right wv) val = - -- | Table of floating point primitives -floatPrims :: W4.IsSymExprBuilder sym => What4 sym -> Map PrimIdent (Value sym) +floatPrims :: W4.IsSymExprBuilder sym => What4 sym -> Map PrimIdent (Prim (What4 sym)) floatPrims sym = Map.fromList [ (floatPrim i,v) | (i,v) <- nonInfixTable ] where @@ -995,18 +889,19 @@ floatPrims sym = nonInfixTable = [ "fpNaN" ~> fpConst (W4.fpNaN w4sym) , "fpPosInf" ~> fpConst (W4.fpPosInf w4sym) - , "fpFromBits" ~> ilam \e -> ilam \p -> wlam sym \w -> - VFloat <$> liftIO (W4.fpFromBinary w4sym e p w) - , "fpToBits" ~> ilam \e -> ilam \p -> flam \x -> - pure $ VWord (e+p) + , "fpFromBits" ~> PFinPoly \e -> PFinPoly \p -> PWordFun \w -> + PPrim (VFloat <$> liftIO (W4.fpFromBinary w4sym e p w)) + , "fpToBits" ~> PFinPoly \e -> PFinPoly \p -> PFloatFun \x -> PVal + $ VWord (e+p) $ WordVal <$> liftIO (W4.fpToBinary w4sym x) - , "=.=" ~> ilam \_ -> ilam \_ -> flam \x -> pure $ flam \y -> - VBit <$> liftIO (W4.fpEq w4sym x y) - , "fpIsFinite" ~> ilam \_ -> ilam \_ -> flam \x -> - VBit <$> liftIO do inf <- W4.fpIsInf w4sym x - nan <- W4.fpIsNaN w4sym x - weird <- W4.orPred w4sym inf nan - W4.notPred w4sym weird + , "=.=" ~> PFinPoly \_ -> PFinPoly \_ -> PFloatFun \x -> PFloatFun \y -> + PPrim (VBit <$> liftIO (W4.fpEq w4sym x y)) + , "fpIsFinite" ~> PFinPoly \_ -> PFinPoly \_ -> PFloatFun \x -> + PPrim + (VBit <$> liftIO do inf <- W4.fpIsInf w4sym x + nan <- W4.fpIsNaN w4sym x + weird <- W4.orPred w4sym inf nan + W4.notPred w4sym weird) , "fpAdd" ~> fpBinArithV sym fpPlus , "fpSub" ~> fpBinArithV sym fpMinus @@ -1014,23 +909,21 @@ floatPrims sym = , "fpDiv" ~> fpBinArithV sym fpDiv , "fpFromRational" ~> - ilam \e -> ilam \p -> wlam sym \r -> pure $ lam \x -> - do rat <- fromVRational <$> x - VFloat <$> fpCvtFromRational sym e p r rat + PFinPoly \e -> PFinPoly \p -> PWordFun \r -> PFun \x -> PPrim + do rat <- fromVRational <$> x + VFloat <$> fpCvtFromRational sym e p r rat , "fpToRational" ~> - ilam \_e -> ilam \_p -> flam \fp -> - VRational <$> fpCvtToRational sym fp + PFinPoly \_e -> PFinPoly \_p -> PFloatFun \fp -> + PPrim (VRational <$> fpCvtToRational sym fp) ] - - -- | A helper for definitng floating point constants. fpConst :: W4.IsSymExprBuilder sym => (Integer -> Integer -> IO (W4.SFloat sym)) -> - Value sym + Prim (What4 sym) fpConst mk = - ilam \ e -> - VNumPoly \ ~(Nat p) -> - VFloat <$> liftIO (mk e p) + PFinPoly \e -> + PNumPoly \ ~(Nat p) -> + PPrim (VFloat <$> liftIO (mk e p)) From 369805146f78027307374a6a53e5093ed024813d Mon Sep 17 00:00:00 2001 From: Rob Dockins Date: Tue, 24 Nov 2020 14:36:59 -0800 Subject: [PATCH 05/27] Add source-location tracking when calling primitives. This turns out to be surprisingly involved! Every evaluation helper and primitive that can raise a runtime error requires knowledge of it's current source location, and we need to rearrange slightly how variable lookups work so we can track the source location of the calling context for primitives, rather than just the location where the primitive was declared. --- .../src/CryptolServer/Data/Expression.hs | 1 + src/Cryptol/Backend.hs | 60 +- src/Cryptol/Backend/Concrete.hs | 53 +- src/Cryptol/Backend/Monad.hs | 60 +- src/Cryptol/Backend/SBV.hs | 74 +-- src/Cryptol/Backend/What4.hs | 99 ++-- src/Cryptol/Eval.hs | 98 ++-- src/Cryptol/Eval/Concrete.hs | 132 +++-- src/Cryptol/Eval/Env.hs | 20 +- src/Cryptol/Eval/Generic.hs | 516 ++++++++++-------- src/Cryptol/Eval/Prims.hs | 28 +- src/Cryptol/Eval/SBV.hs | 73 +-- src/Cryptol/Eval/Type.hs | 4 +- src/Cryptol/Eval/Value.hs | 32 +- src/Cryptol/Eval/What4.hs | 112 ++-- src/Cryptol/ModuleSystem/Base.hs | 1 + src/Cryptol/Parser/Position.hs | 5 + src/Cryptol/REPL/Monad.hs | 6 +- src/Cryptol/Symbolic.hs | 2 +- src/Cryptol/Symbolic/SBV.hs | 3 + src/Cryptol/Symbolic/What4.hs | 2 + src/Cryptol/Testing/Random.hs | 9 +- 22 files changed, 778 insertions(+), 612 deletions(-) diff --git a/cryptol-remote-api/src/CryptolServer/Data/Expression.hs b/cryptol-remote-api/src/CryptolServer/Data/Expression.hs index 56b21ecea..bf5d0c4b6 100644 --- a/cryptol-remote-api/src/CryptolServer/Data/Expression.hs +++ b/cryptol-remote-api/src/CryptolServer/Data/Expression.hs @@ -318,6 +318,7 @@ readBack :: PrimMap -> TC.Type -> Value -> Eval Expression readBack prims ty val = let tbl = primTable theEvalOpts in let ?evalPrim = \i -> Right <$> Map.lookup i tbl in + let ?range = emptyRange in -- TODO? case TC.tNoUser ty of TC.TRec tfs -> Record . HM.fromList <$> diff --git a/src/Cryptol/Backend.hs b/src/Cryptol/Backend.hs index 797c539f1..916029ff9 100644 --- a/src/Cryptol/Backend.hs +++ b/src/Cryptol/Backend.hs @@ -35,29 +35,30 @@ import Data.Kind (Type) import Data.Ratio ( (%), numerator, denominator ) import Cryptol.Backend.FloatHelpers (BF) -import Cryptol.Backend.Monad ( PPOpts(..), EvalError(..) ) -import Cryptol.TypeCheck.AST(Name) +import Cryptol.Backend.Monad ( PPOpts(..), EvalError(..), EvalErrorEx(..) ) +import Cryptol.ModuleSystem.Name(Name,nameLoc) +import Cryptol.Parser.Position import Cryptol.Utils.PP -invalidIndex :: Backend sym => sym -> Integer -> SEval sym a -invalidIndex sym = raiseError sym . InvalidIndex . Just +invalidIndex :: Backend sym => sym -> Range -> Integer -> SEval sym a +invalidIndex sym rng = raiseError sym . EvalErrorEx rng . InvalidIndex . Just -cryUserError :: Backend sym => sym -> String -> SEval sym a -cryUserError sym = raiseError sym . UserError +cryUserError :: Backend sym => sym -> Range -> String -> SEval sym a +cryUserError sym rng = raiseError sym . EvalErrorEx rng . UserError cryNoPrimError :: Backend sym => sym -> Name -> SEval sym a -cryNoPrimError sym = raiseError sym . NoPrim +cryNoPrimError sym nm = raiseError sym (EvalErrorEx (nameLoc nm) (NoPrim nm)) {-# INLINE sDelay #-} -- | Delay the given evaluation computation, returning a thunk -- which will run the computation when forced. Raise a loop -- error if the resulting thunk is forced during its own evaluation. -sDelay :: Backend sym => sym -> Maybe String -> SEval sym a -> SEval sym (SEval sym a) -sDelay sym msg m = +sDelay :: Backend sym => sym -> Range -> Maybe String -> SEval sym a -> SEval sym (SEval sym a) +sDelay sym rng msg m = let msg' = maybe "" ("while evaluating "++) msg - retry = raiseError sym (LoopError msg') + retry = raiseError sym (EvalErrorEx rng (LoopError msg')) in sDelayFill sym m retry @@ -72,21 +73,21 @@ data SRational sym = intToRational :: Backend sym => sym -> SInteger sym -> SEval sym (SRational sym) intToRational sym x = SRational x <$> (integerLit sym 1) -ratio :: Backend sym => sym -> SInteger sym -> SInteger sym -> SEval sym (SRational sym) -ratio sym n d = +ratio :: Backend sym => sym -> Range -> SInteger sym -> SInteger sym -> SEval sym (SRational sym) +ratio sym rng n d = do pz <- bitComplement sym =<< intEq sym d =<< integerLit sym 0 - assertSideCondition sym pz DivideByZero + assertSideCondition sym pz (EvalErrorEx rng DivideByZero) pure (SRational n d) -rationalRecip :: Backend sym => sym -> SRational sym -> SEval sym (SRational sym) -rationalRecip sym (SRational a b) = ratio sym b a +rationalRecip :: Backend sym => sym -> Range -> SRational sym -> SEval sym (SRational sym) +rationalRecip sym rng (SRational a b) = ratio sym rng b a -rationalDivide :: Backend sym => sym -> SRational sym -> SRational sym -> SEval sym (SRational sym) -rationalDivide sym x y = rationalMul sym x =<< rationalRecip sym y +rationalDivide :: Backend sym => sym -> Range -> SRational sym -> SRational sym -> SEval sym (SRational sym) +rationalDivide sym rng x y = rationalMul sym x =<< rationalRecip sym rng y rationalFloor :: Backend sym => sym -> SRational sym -> SEval sym (SInteger sym) -- NB, relies on integer division being round-to-negative-inf division -rationalFloor sym (SRational n d) = intDiv sym n d +rationalFloor sym (SRational n d) = intDiv sym emptyRange n d rationalCeiling :: Backend sym => sym -> SRational sym -> SEval sym (SInteger sym) rationalCeiling sym r = intNegate sym =<< rationalFloor sym =<< rationalNegate sym r @@ -120,7 +121,7 @@ rationalRoundToEven sym r = where isEven x = - do parity <- intMod sym x =<< integerLit sym 2 + do parity <- intMod sym emptyRange x =<< integerLit sym 2 intEq sym parity =<< integerLit sym 0 ite x t e = @@ -228,7 +229,7 @@ class MonadIO (SEval sym) => Backend sym where -- after the fact. A preallocated thunk is returned, along with an operation to -- fill the thunk with the associated computation. -- This is used to implement recursive declaration groups. - sDeclareHole :: sym -> String -> SEval sym (SEval sym a, SEval sym a -> SEval sym ()) + sDeclareHole :: sym -> String -> Range -> SEval sym (SEval sym a, SEval sym a -> SEval sym ()) -- | Delay the given evaluation computation, returning a thunk -- which will run the computation when forced. Run the 'retry' @@ -239,7 +240,7 @@ class MonadIO (SEval sym) => Backend sym where -- | Begin evaluating the given computation eagerly in a separate thread -- and return a thunk which will await the completion of the given computation -- when forced. - sSpark :: sym -> SEval sym a -> SEval sym (SEval sym a) + sSpark :: sym -> Range -> SEval sym a -> SEval sym (SEval sym a) -- | Merge the two given computations according to the predicate. mergeEval :: @@ -252,10 +253,10 @@ class MonadIO (SEval sym) => Backend sym where -- | Assert that a condition must hold, and indicate what sort of -- error is indicated if the condition fails. - assertSideCondition :: sym -> SBit sym -> EvalError -> SEval sym () + assertSideCondition :: sym -> SBit sym -> EvalErrorEx -> SEval sym () -- | Indiciate that an error condition exists - raiseError :: sym -> EvalError -> SEval sym a + raiseError :: sym -> EvalErrorEx -> SEval sym a -- ==== Pretty printing ==== @@ -336,6 +337,9 @@ class MonadIO (SEval sym) => Backend sym where -- ==== Word operations ==== + -- TODO, add error handling to wordBit and wordUpdate + + -- | Extract the numbered bit from the word. -- -- NOTE: this assumes that the sequence of bits is big-endian and finite, so the @@ -472,6 +476,7 @@ class MonadIO (SEval sym) => Backend sym where -- call with a second argument concretely equal to 0. wordDiv :: sym -> + Range -> SWord sym -> SWord sym -> SEval sym (SWord sym) @@ -481,6 +486,7 @@ class MonadIO (SEval sym) => Backend sym where -- call with a second argument concretely equal to 0. wordMod :: sym -> + Range -> SWord sym -> SWord sym -> SEval sym (SWord sym) @@ -490,6 +496,7 @@ class MonadIO (SEval sym) => Backend sym where -- call with a second argument concretely equal to 0. wordSignedDiv :: sym -> + Range -> SWord sym -> SWord sym -> SEval sym (SWord sym) @@ -499,6 +506,7 @@ class MonadIO (SEval sym) => Backend sym where -- call with a second argument concretely equal to 0. wordSignedMod :: sym -> + Range -> SWord sym -> SWord sym -> SEval sym (SWord sym) @@ -583,6 +591,7 @@ class MonadIO (SEval sym) => Backend sym where -- Same semantics as Haskell's @div@ operation. intDiv :: sym -> + Range -> SInteger sym -> SInteger sym -> SEval sym (SInteger sym) @@ -592,6 +601,7 @@ class MonadIO (SEval sym) => Backend sym where -- Same semantics as Haskell's @mod@ operation. intMod :: sym -> + Range -> SInteger sym -> SInteger sym -> SEval sym (SInteger sym) @@ -678,6 +688,7 @@ class MonadIO (SEval sym) => Backend sym where -- PRECONDITION: the modulus is a prime znRecip :: sym -> + Range -> Integer {- ^ modulus -} -> SInteger sym -> SEval sym (SInteger sym) @@ -695,11 +706,13 @@ class MonadIO (SEval sym) => Backend sym where fpToInteger :: sym -> String {- ^ Name of the function for error reporting -} -> + Range -> SWord sym {-^ Rounding mode -} -> SFloat sym -> SEval sym (SInteger sym) fpFromInteger :: sym -> + Range -> Integer {- exp width -} -> Integer {- prec width -} -> SWord sym {- ^ rounding mode -} -> @@ -708,6 +721,7 @@ class MonadIO (SEval sym) => Backend sym where type FPArith2 sym = sym -> + Range -> SWord sym -> SFloat sym -> SFloat sym -> diff --git a/src/Cryptol/Backend/Concrete.hs b/src/Cryptol/Backend/Concrete.hs index 5e8d89033..7f54db9c7 100644 --- a/src/Cryptol/Backend/Concrete.hs +++ b/src/Cryptol/Backend/Concrete.hs @@ -45,6 +45,7 @@ import qualified Cryptol.Backend.Arch as Arch import qualified Cryptol.Backend.FloatHelpers as FP import Cryptol.Backend import Cryptol.Backend.Monad +import Cryptol.Parser.Position import Cryptol.TypeCheck.Solver.InfNat (genLog) import Cryptol.Utils.Panic (panic) import Cryptol.Utils.PP @@ -157,7 +158,7 @@ instance Backend Concrete where y <- my f c x y - sDeclareHole _ = blackhole + sDeclareHole _ rng = blackhole rng sDelayFill _ = delayFill sSpark _ = evalSpark @@ -256,33 +257,33 @@ instance Backend Concrete where | i == j = pure $! mkBv i (x*y) | otherwise = panic "Attempt to multiply words of different sizes: wordMult" [show i, show j] - wordDiv sym (BV i x) (BV j y) + wordDiv sym rng (BV i x) (BV j y) | i == 0 && j == 0 = pure $! mkBv 0 0 | i == j = - do assertSideCondition sym (y /= 0) DivideByZero + do assertSideCondition sym (y /= 0) (EvalErrorEx rng DivideByZero) pure $! mkBv i (x `div` y) | otherwise = panic "Attempt to divide words of different sizes: wordDiv" [show i, show j] - wordMod sym (BV i x) (BV j y) + wordMod sym rng (BV i x) (BV j y) | i == 0 && j == 0 = pure $! mkBv 0 0 | i == j = - do assertSideCondition sym (y /= 0) DivideByZero + do assertSideCondition sym (y /= 0) (EvalErrorEx rng DivideByZero) pure $! mkBv i (x `mod` y) | otherwise = panic "Attempt to mod words of different sizes: wordMod" [show i, show j] - wordSignedDiv sym (BV i x) (BV j y) + wordSignedDiv sym rng (BV i x) (BV j y) | i == 0 && j == 0 = pure $! mkBv 0 0 | i == j = - do assertSideCondition sym (y /= 0) DivideByZero + do assertSideCondition sym (y /= 0) (EvalErrorEx rng DivideByZero) let sx = signedValue i x sy = signedValue i y pure $! mkBv i (sx `quot` sy) | otherwise = panic "Attempt to divide words of different sizes: wordSignedDiv" [show i, show j] - wordSignedMod sym (BV i x) (BV j y) + wordSignedMod sym rng (BV i x) (BV j y) | i == 0 && j == 0 = pure $! mkBv 0 0 | i == j = - do assertSideCondition sym (y /= 0) DivideByZero + do assertSideCondition sym (y /= 0) (EvalErrorEx rng DivideByZero) let sx = signedValue i x sy = signedValue i y pure $! mkBv i (sx `rem` sy) @@ -298,11 +299,11 @@ instance Backend Concrete where intMinus _ x y = pure $! x - y intNegate _ x = pure $! negate x intMult _ x y = pure $! x * y - intDiv sym x y = - do assertSideCondition sym (y /= 0) DivideByZero + intDiv sym rng x y = + do assertSideCondition sym (y /= 0) (EvalErrorEx rng DivideByZero) pure $! x `div` y - intMod sym x y = - do assertSideCondition sym (y /= 0) DivideByZero + intMod sym rng x y = + do assertSideCondition sym (y /= 0) (EvalErrorEx rng DivideByZero) pure $! x `mod` y intToZn _ 0 _ = evalPanic "intToZn" ["0 modulus not allowed"] @@ -316,8 +317,8 @@ instance Backend Concrete where -- NB: under the precondition that `m` is prime, -- the only values for which no inverse exists are -- congruent to 0 modulo m. - znRecip sym m x - | r == 0 = raiseError sym DivideByZero + znRecip sym rng m x + | r == 0 = raiseError sym (EvalErrorEx rng DivideByZero) | otherwise = pure r where r = Integer.recipModInteger x m @@ -341,8 +342,8 @@ instance Backend Concrete where fpMult = fpBinArith FP.bfMul fpDiv = fpBinArith FP.bfDiv fpNeg _ x = pure x { FP.bfValue = FP.bfNeg (FP.bfValue x) } - fpFromInteger sym e p r x = - do opts <- FP.fpOpts e p <$> fpRoundMode sym r + fpFromInteger sym rng e p r x = + do opts <- FP.fpOpts e p <$> fpRoundMode sym rng r pure FP.BF { FP.bfExpWidth = e , FP.bfPrecWidth = p , FP.bfValue = FP.fpCheckStatus $ @@ -364,32 +365,34 @@ liftBinIntMod op m x y fpBinArith :: (FP.BFOpts -> FP.BigFloat -> FP.BigFloat -> (FP.BigFloat, FP.Status)) -> Concrete -> + Range -> SWord Concrete {- ^ Rouding mode -} -> SFloat Concrete -> SFloat Concrete -> SEval Concrete (SFloat Concrete) -fpBinArith fun = \sym r x y -> +fpBinArith fun = \sym rng r x y -> do opts <- FP.fpOpts (FP.bfExpWidth x) (FP.bfPrecWidth x) - <$> fpRoundMode sym r + <$> fpRoundMode sym rng r pure x { FP.bfValue = FP.fpCheckStatus (fun opts (FP.bfValue x) (FP.bfValue y)) } fpCvtToInteger :: Concrete -> String -> + Range -> SWord Concrete {- ^ Rounding mode -} -> SFloat Concrete -> SEval Concrete (SInteger Concrete) -fpCvtToInteger sym fun rnd flt = - do mode <- fpRoundMode sym rnd +fpCvtToInteger sym fun rng rnd flt = + do mode <- fpRoundMode sym rng rnd case FP.floatToInteger fun mode flt of Right i -> pure i - Left err -> raiseError sym err + Left err -> raiseError sym (EvalErrorEx rng err) -fpRoundMode :: Concrete -> SWord Concrete -> SEval Concrete FP.RoundMode -fpRoundMode sym w = +fpRoundMode :: Concrete -> Range -> SWord Concrete -> SEval Concrete FP.RoundMode +fpRoundMode sym rng w = case FP.fpRound (bvVal w) of - Left err -> raiseError sym err + Left err -> raiseError sym (EvalErrorEx rng err) Right a -> pure a diff --git a/src/Cryptol/Backend/Monad.hs b/src/Cryptol/Backend/Monad.hs index d94aa41ec..45d1d40ab 100644 --- a/src/Cryptol/Backend/Monad.hs +++ b/src/Cryptol/Backend/Monad.hs @@ -31,9 +31,10 @@ module Cryptol.Backend.Monad -- * Error reporting , Unsupported(..) , EvalError(..) +, EvalErrorEx(..) , evalPanic , wordTooWide -, typeCannotBeDemoted +, WordTooWide(..) ) where import Control.Concurrent @@ -47,10 +48,11 @@ import Data.Typeable (Typeable) import qualified Control.Exception as X +import Cryptol.Parser.Position import Cryptol.Utils.Panic import Cryptol.Utils.PP import Cryptol.Utils.Logger(Logger) -import Cryptol.TypeCheck.AST(Type,Name) +import Cryptol.TypeCheck.AST(Name) -- | A computation that returns an already-evaluated value. ready :: a -> Eval a @@ -138,7 +140,7 @@ data ThunkState a -- thread ID. We track the "backup" computation to run if we detect -- a tight loop evaluating this thunk. If the thunk is being evaluated -- by some other thread, the current thread will await its completion. - | ForcedErr !EvalError + | ForcedErr !EvalErrorEx -- ^ This thunk has been forced, and its evaluation results in an exception | Forced !a -- ^ This thunk has been forced to the given value @@ -173,17 +175,18 @@ delayFill (Eval x) backup = Eval (Thunk <$> newTVarIO (Unforced x (runEval backu -- returning a thunk which will await the completion of -- the computation when forced. evalSpark :: + Range -> Eval a -> Eval (Eval a) -- Ready computations need no additional evaluation. -evalSpark e@(Ready _) = return e +evalSpark _ e@(Ready _) = return e -- A thunked computation might already have -- been forced. If so, return the result. Otherwise, -- fork a thread to force this computation and return -- the thunk. -evalSpark (Thunk tv) = Eval $ +evalSpark _ (Thunk tv) = Eval $ readTVarIO tv >>= \case Forced x -> return (Ready x) ForcedErr ex -> return (Eval (X.throwIO ex)) @@ -193,8 +196,8 @@ evalSpark (Thunk tv) = Eval $ -- If the computation is nontrivial but not already a thunk, -- create a thunk and fork a thread to force it. -evalSpark (Eval x) = Eval $ - do tv <- newTVarIO (Unforced x (X.throwIO (LoopError ""))) +evalSpark rng (Eval x) = Eval $ + do tv <- newTVarIO (Unforced x (X.throwIO (EvalErrorEx rng (LoopError "")))) _ <- forkIO (sparkThunk tv) return (Thunk tv) @@ -231,11 +234,13 @@ sparkThunk tv = -- This is used to implement recursive declaration groups. blackhole :: String {- ^ A name to associate with this thunk. -} -> + Range -> Eval (Eval a, Eval a -> Eval ()) -blackhole msg = Eval $ +blackhole msg rng = Eval $ do tv <- newTVarIO (Void msg) + let ex = EvalErrorEx rng (LoopError msg) let set (Ready x) = io $ atomically (writeTVar tv (Forced x)) - set m = io $ atomically (writeTVar tv (Unforced (runEval m) (X.throwIO (LoopError msg)))) + set m = io $ atomically (writeTVar tv (Unforced (runEval m) (X.throwIO ex))) return (Thunk tv, set) -- | Force a thunk to get the result. @@ -262,7 +267,7 @@ unDelay tv = -- a loop error. If some other thread is evaluating, reset the -- transaction to await completion of the thunk. UnderEvaluation t _ - | tid == t -> writeTVar tv (UnderEvaluation tid (X.throwIO (LoopError ""))) + | tid == t -> writeTVar tv (UnderEvaluation tid (X.throwIO (EvalErrorEx emptyRange (LoopError "")))) -- TODO? better range info | otherwise -> retry -- wait, if some other thread is evaualting _ -> return () @@ -341,11 +346,9 @@ evalPanic cxt = panic ("[Eval] " ++ cxt) -- | Data type describing errors that can occur during evaluation. data EvalError = InvalidIndex (Maybe Integer) -- ^ Out-of-bounds index - | TypeCannotBeDemoted Type -- ^ Non-numeric type passed to @number@ function | DivideByZero -- ^ Division or modulus by 0 | NegativeExponent -- ^ Exponentiation by negative integer | LogNegative -- ^ Logarithm of a negative integer - | WordTooWide Integer -- ^ Bitvector too large | UserError String -- ^ Call to the Cryptol @error@ primitive | LoopError String -- ^ Detectable nontermination | NoPrim Name -- ^ Primitive with no implementation @@ -357,12 +360,10 @@ instance PP EvalError where ppPrec _ e = case e of InvalidIndex (Just i) -> text "invalid sequence index:" <+> integer i InvalidIndex Nothing -> text "invalid sequence index" - TypeCannotBeDemoted t -> text "type cannot be demoted:" <+> pp t +-- TypeCannotBeDemoted t -> text "type cannot be demoted:" <+> pp t DivideByZero -> text "division by 0" NegativeExponent -> text "negative exponent" LogNegative -> text "logarithm of negative" - WordTooWide w -> - text "word too wide for memory:" <+> integer w <+> text "bits" UserError x -> text "Run-time error:" <+> text x LoopError x -> text "<>" <+> text x BadRoundingMode r -> "invalid rounding mode" <+> integer r @@ -372,8 +373,19 @@ instance PP EvalError where instance Show EvalError where show = show . pp -instance X.Exception EvalError +data EvalErrorEx = + EvalErrorEx Range EvalError + deriving Typeable + +instance PP EvalErrorEx where + ppPrec _ (EvalErrorEx rng ex) + | rng == emptyRange = pp ex + | otherwise = vcat [ pp ex, text "at" <+> pp rng ] + +instance Show EvalErrorEx where + show = show . pp +instance X.Exception EvalErrorEx data Unsupported = UnsupportedSymbolicOp String -- ^ Operation cannot be supported in the symbolic simulator @@ -387,11 +399,23 @@ instance X.Exception Unsupported -- | For things like @`(inf)@ or @`(0-1)@. -typeCannotBeDemoted :: Type -> a -typeCannotBeDemoted t = X.throw (TypeCannotBeDemoted t) +--typeCannotBeDemoted :: Type -> a +--typeCannotBeDemoted t = X.throw (TypeCannotBeDemoted t) -- | For when we know that a word is too wide and will exceed gmp's -- limits (though words approaching this size will probably cause the -- system to crash anyway due to lack of memory). wordTooWide :: Integer -> a wordTooWide w = X.throw (WordTooWide w) + +data WordTooWide = WordTooWide Integer -- ^ Bitvector too large + deriving Typeable + +instance PP WordTooWide where + ppPrec _ (WordTooWide w) = + text "word too wide for memory:" <+> integer w <+> text "bits" + +instance Show WordTooWide where + show = show . pp + +instance X.Exception WordTooWide diff --git a/src/Cryptol/Backend/SBV.hs b/src/Cryptol/Backend/SBV.hs index 615a7a8f2..79276c7ed 100644 --- a/src/Cryptol/Backend/SBV.hs +++ b/src/Cryptol/Backend/SBV.hs @@ -47,9 +47,10 @@ import Cryptol.Backend import Cryptol.Backend.Concrete ( integerToChar, ppBV, BV(..) ) import Cryptol.Backend.Monad ( Eval(..), blackhole, delayFill, evalSpark - , EvalError(..), Unsupported(..) + , EvalError(..), EvalErrorEx(..), Unsupported(..) ) +import Cryptol.Parser.Position (Range) import Cryptol.Utils.Panic (panic) import Cryptol.Utils.PP @@ -97,7 +98,7 @@ freshSInteger_ (SBV stateVar _) = -- SBV Evaluation monad ------------------------------------------------------- data SBVResult a - = SBVError !EvalError + = SBVError !EvalErrorEx | SBVResult !SVal !a -- safety predicate and result instance Functor SBVResult where @@ -167,12 +168,12 @@ instance Backend SBV where do m' <- delayFill (sbvEval m) (sbvEval retry) pure (pure (SBVEval m')) - sSpark _ m = SBVEval $ - do m' <- evalSpark (sbvEval m) + sSpark _ rng m = SBVEval $ + do m' <- evalSpark rng (sbvEval m) pure (pure (SBVEval m')) - sDeclareHole _ msg = SBVEval $ - do (hole, fill) <- blackhole msg + sDeclareHole _ msg rng = SBVEval $ + do (hole, fill) <- blackhole msg rng pure (pure (SBVEval hole, \m -> SBVEval (fmap pure $ fill (sbvEval m)))) mergeEval _sym f c mx my = SBVEval $ @@ -265,24 +266,24 @@ instance Backend SBV where wordMult _ a b = pure $! svTimes a b wordNegate _ a = pure $! svUNeg a - wordDiv sym a b = + wordDiv sym rng a b = do let z = literalSWord (intSizeOf b) 0 - assertSideCondition sym (svNot (svEqual b z)) DivideByZero + assertSideCondition sym (svNot (svEqual b z)) (EvalErrorEx rng DivideByZero) pure $! svQuot a b - wordMod sym a b = + wordMod sym rng a b = do let z = literalSWord (intSizeOf b) 0 - assertSideCondition sym (svNot (svEqual b z)) DivideByZero + assertSideCondition sym (svNot (svEqual b z)) (EvalErrorEx rng DivideByZero) pure $! svRem a b - wordSignedDiv sym a b = + wordSignedDiv sym rng a b = do let z = literalSWord (intSizeOf b) 0 - assertSideCondition sym (svNot (svEqual b z)) DivideByZero + assertSideCondition sym (svNot (svEqual b z)) (EvalErrorEx rng DivideByZero) pure $! signedQuot a b - wordSignedMod sym a b = + wordSignedMod sym rng a b = do let z = literalSWord (intSizeOf b) 0 - assertSideCondition sym (svNot (svEqual b z)) DivideByZero + assertSideCondition sym (svNot (svEqual b z)) (EvalErrorEx rng DivideByZero) pure $! signedRem a b wordLg2 _ a = sLg2 a @@ -299,14 +300,14 @@ instance Backend SBV where intMult _ a b = pure $! svTimes a b intNegate _ a = pure $! SBV.svUNeg a - intDiv sym a b = + intDiv sym rng a b = do let z = svInteger KUnbounded 0 - assertSideCondition sym (svNot (svEqual b z)) DivideByZero + assertSideCondition sym (svNot (svEqual b z)) (EvalErrorEx rng DivideByZero) let p = svLessThan z b pure $! svSymbolicMerge KUnbounded True p (svQuot a b) (svQuot (svUNeg a) (svUNeg b)) - intMod sym a b = + intMod sym rng a b = do let z = svInteger KUnbounded 0 - assertSideCondition sym (svNot (svEqual b z)) DivideByZero + assertSideCondition sym (svNot (svEqual b z)) (EvalErrorEx rng DivideByZero) let p = svLessThan z b pure $! svSymbolicMerge KUnbounded True p (svRem a b) (svUNeg (svRem (svUNeg a) (svUNeg b))) @@ -327,20 +328,20 @@ instance Backend SBV where znNegate sym m a = sModNegate sym m a znRecip = sModRecip - ppFloat _ _ _ = text "[?]" - fpExactLit _ _ = unsupported "fpExactLit" - fpLit _ _ _ _ = unsupported "fpLit" - fpLogicalEq _ _ _ = unsupported "fpLogicalEq" - fpEq _ _ _ = unsupported "fpEq" - fpLessThan _ _ _ = unsupported "fpLessThan" - fpGreaterThan _ _ _ = unsupported "fpGreaterThan" - fpPlus _ _ _ _ = unsupported "fpPlus" - fpMinus _ _ _ _ = unsupported "fpMinus" - fpMult _ _ _ _ = unsupported "fpMult" - fpDiv _ _ _ _ = unsupported "fpDiv" - fpNeg _ _ = unsupported "fpNeg" - fpFromInteger _ _ _ _ _ = unsupported "fpFromInteger" - fpToInteger _ _ _ _ = unsupported "fpToInteger" + ppFloat _ _ _ = text "[?]" + fpExactLit _ _ = unsupported "fpExactLit" + fpLit _ _ _ _ = unsupported "fpLit" + fpLogicalEq _ _ _ = unsupported "fpLogicalEq" + fpEq _ _ _ = unsupported "fpEq" + fpLessThan _ _ _ = unsupported "fpLessThan" + fpGreaterThan _ _ _ = unsupported "fpGreaterThan" + fpPlus _ _ _ _ _ = unsupported "fpPlus" + fpMinus _ _ _ _ _ = unsupported "fpMinus" + fpMult _ _ _ _ _ = unsupported "fpMult" + fpDiv _ _ _ _ _ = unsupported "fpDiv" + fpNeg _ _ = unsupported "fpNeg" + fpFromInteger _ _ _ _ _ _ = unsupported "fpFromInteger" + fpToInteger _ _ _ _ _ = unsupported "fpToInteger" unsupported :: String -> SEval SBV a unsupported x = liftIO (X.throw (UnsupportedSymbolicOp x)) @@ -399,15 +400,16 @@ sModMult sym modulus x y = -- that the modulus is prime and the input is nonzero. sModRecip :: SBV -> + Range -> Integer {- ^ modulus: must be prime -} -> SInteger SBV -> SEval SBV (SInteger SBV) -sModRecip _sym 0 _ = panic "sModRecip" ["0 modulus not allowed"] -sModRecip sym m x +sModRecip _sym _ 0 _ = panic "sModRecip" ["0 modulus not allowed"] +sModRecip sym rng m x -- If the input is concrete, evaluate the answer | Just xi <- svAsInteger x = let r = Integer.recipModInteger xi m - in if r == 0 then raiseError sym DivideByZero else integerLit sym r + in if r == 0 then raiseError sym (EvalErrorEx rng DivideByZero) else integerLit sym r -- If the input is symbolic, create a new symbolic constant -- and assert that it is the desired multiplicitive inverse. @@ -415,7 +417,7 @@ sModRecip sym m x -- the modulus is prime, and as long as the input is nonzero. | otherwise = do divZero <- svDivisible sym m x - assertSideCondition sym (svNot divZero) DivideByZero + assertSideCondition sym (svNot divZero) (EvalErrorEx rng DivideByZero) z <- liftIO (freshSInteger_ sym) let xz = svTimes x z diff --git a/src/Cryptol/Backend/What4.hs b/src/Cryptol/Backend/What4.hs index 8fe8de308..81562c321 100644 --- a/src/Cryptol/Backend/What4.hs +++ b/src/Cryptol/Backend/What4.hs @@ -39,9 +39,10 @@ import Cryptol.Backend import Cryptol.Backend.Concrete( BV(..), ppBV ) import Cryptol.Backend.FloatHelpers import Cryptol.Backend.Monad - ( Eval(..), EvalError(..), Unsupported(..) - , delayFill, blackhole, evalSpark + ( Eval(..), EvalError(..), EvalErrorEx(..) + , Unsupported(..), delayFill, blackhole, evalSpark ) +import Cryptol.Parser.Position import Cryptol.Utils.Panic import Cryptol.Utils.PP @@ -72,7 +73,7 @@ newtype W4Conn sym a = W4Conn { evalConn :: sym -> Eval a } -- | The symbolic value we computed. data W4Result sym a - = W4Error !EvalError + = W4Error !EvalErrorEx -- ^ A malformed value | W4Result !(W4.Pred sym) !a @@ -185,22 +186,22 @@ addSafety :: W4.IsSymExprBuilder sym => W4.Pred sym -> W4Eval sym () addSafety p = W4Eval (pure (W4Result p ())) -- | A fully undefined symbolic value -evalError :: W4.IsSymExprBuilder sym => EvalError -> W4Eval sym a +evalError :: W4.IsSymExprBuilder sym => EvalErrorEx -> W4Eval sym a evalError err = W4Eval (pure (W4Error err)) -------------------------------------------------------------------------------- -assertBVDivisor :: W4.IsSymExprBuilder sym => What4 sym -> SW.SWord sym -> W4Eval sym () -assertBVDivisor sym x = +assertBVDivisor :: W4.IsSymExprBuilder sym => What4 sym -> Range -> SW.SWord sym -> W4Eval sym () +assertBVDivisor sym rng x = do p <- liftIO (SW.bvIsNonzero (w4 sym) x) - assertSideCondition sym p DivideByZero + assertSideCondition sym p (EvalErrorEx rng DivideByZero) assertIntDivisor :: - W4.IsSymExprBuilder sym => What4 sym -> W4.SymInteger sym -> W4Eval sym () -assertIntDivisor sym x = + W4.IsSymExprBuilder sym => What4 sym -> Range -> W4.SymInteger sym -> W4Eval sym () +assertIntDivisor sym rng x = do p <- liftIO (W4.notPred (w4 sym) =<< W4.intEq (w4 sym) x =<< W4.intLit (w4 sym) 0) - assertSideCondition sym p DivideByZero + assertSideCondition sym p (EvalErrorEx rng DivideByZero) instance W4.IsSymExprBuilder sym => Backend (What4 sym) where type SBit (What4 sym) = W4.Pred sym @@ -225,15 +226,15 @@ instance W4.IsSymExprBuilder sym => Backend (What4 sym) where do sym <- getSym doEval (w4Thunk <$> delayFill (w4Eval m sym) (w4Eval retry sym)) - sSpark _ m = + sSpark _ rng m = total do sym <- getSym - doEval (w4Thunk <$> evalSpark (w4Eval m sym)) + doEval (w4Thunk <$> evalSpark rng (w4Eval m sym)) - sDeclareHole _ msg = + sDeclareHole _ msg rng = total - do (hole, fill) <- doEval (blackhole msg) + do (hole, fill) <- doEval (blackhole msg rng) pure ( w4Thunk hole , \m -> total do sym <- getSym @@ -353,17 +354,17 @@ instance W4.IsSymExprBuilder sym => Backend (What4 sym) where wordNegate sym x = liftIO (SW.bvNeg (w4 sym) x) wordLg2 sym x = sLg2 (w4 sym) x - wordDiv sym x y = - do assertBVDivisor sym y + wordDiv sym rng x y = + do assertBVDivisor sym rng y liftIO (SW.bvUDiv (w4 sym) x y) - wordMod sym x y = - do assertBVDivisor sym y + wordMod sym rng x y = + do assertBVDivisor sym rng y liftIO (SW.bvURem (w4 sym) x y) - wordSignedDiv sym x y = - do assertBVDivisor sym y + wordSignedDiv sym rng x y = + do assertBVDivisor sym rng y liftIO (SW.bvSDiv (w4 sym) x y) - wordSignedMod sym x y = - do assertBVDivisor sym y + wordSignedMod sym rng x y = + do assertBVDivisor sym rng y liftIO (SW.bvSRem (w4 sym) x y) wordToInt sym x = liftIO (SW.bvToInteger (w4 sym) x) @@ -377,8 +378,8 @@ instance W4.IsSymExprBuilder sym => Backend (What4 sym) where -- NB: What4's division operation provides SMTLib's euclidean division, -- which doesn't match the round-to-neg-infinity semantics of Cryptol, -- so we have to do some work to get the desired semantics. - intDiv sym x y = - do assertIntDivisor sym y + intDiv sym rng x y = + do assertIntDivisor sym rng y liftIO $ do neg <- liftIO (W4.intLt (w4 sym) y =<< W4.intLit (w4 sym) 0) case W4.asConstantPred neg of @@ -397,8 +398,8 @@ instance W4.IsSymExprBuilder sym => Backend (What4 sym) where -- NB: What4's division operation provides SMTLib's euclidean division, -- which doesn't match the round-to-neg-infinity semantics of Cryptol, -- so we have to do some work to get the desired semantics. - intMod sym x y = - do assertIntDivisor sym y + intMod sym rng x y = + do assertIntDivisor sym rng y liftIO $ do neg <- liftIO (W4.intLt (w4 sym) y =<< W4.intLit (w4 sym) 0) case W4.asConstantPred neg of @@ -459,8 +460,8 @@ instance W4.IsSymExprBuilder sym => Backend (What4 sym) where fpNeg sym x = liftIO $ FP.fpNeg (w4 sym) x - fpFromInteger sym e p r x = - do rm <- fpRoundingMode sym r + fpFromInteger sym rng e p r x = + do rm <- fpRoundingMode sym rng r liftIO $ FP.fpFromInteger (w4 sym) e p rm x fpToInteger = fpCvtToInteger @@ -565,8 +566,8 @@ w4bvRor sym x y = liftIO $ SW.bvRor sym x y fpRoundingMode :: W4.IsSymExprBuilder sym => - What4 sym -> SWord (What4 sym) -> SEval (What4 sym) W4.RoundingMode -fpRoundingMode sym v = + What4 sym -> Range -> SWord (What4 sym) -> SEval (What4 sym) W4.RoundingMode +fpRoundingMode sym rng v = case wordAsLit sym v of Just (_w,i) -> case i of @@ -575,32 +576,33 @@ fpRoundingMode sym v = 2 -> pure W4.RTP 3 -> pure W4.RTN 4 -> pure W4.RTZ - x -> raiseError sym (BadRoundingMode x) + x -> raiseError sym (EvalErrorEx rng (BadRoundingMode x)) _ -> liftIO $ X.throwIO $ UnsupportedSymbolicOp "rounding mode" fpBinArith :: W4.IsSymExprBuilder sym => FP.SFloatBinArith sym -> What4 sym -> + Range -> SWord (What4 sym) -> SFloat (What4 sym) -> SFloat (What4 sym) -> SEval (What4 sym) (SFloat (What4 sym)) -fpBinArith fun = \sym r x y -> - do m <- fpRoundingMode sym r +fpBinArith fun = \sym rng r x y -> + do m <- fpRoundingMode sym rng r liftIO (fun (w4 sym) m x y) fpCvtToInteger :: (W4.IsSymExprBuilder sy, sym ~ What4 sy) => - sym -> String -> SWord sym -> SFloat sym -> SEval sym (SInteger sym) -fpCvtToInteger sym fun r x = + sym -> String -> Range -> SWord sym -> SFloat sym -> SEval sym (SInteger sym) +fpCvtToInteger sym fun rng r x = do grd <- liftIO do bad1 <- FP.fpIsInf (w4 sym) x bad2 <- FP.fpIsNaN (w4 sym) x W4.notPred (w4 sym) =<< W4.orPred (w4 sym) bad1 bad2 - assertSideCondition sym grd (BadValue fun) - rnd <- fpRoundingMode sym r + assertSideCondition sym grd (EvalErrorEx rng (BadValue fun)) + rnd <- fpRoundingMode sym rng r liftIO do y <- FP.fpToReal (w4 sym) x case rnd of @@ -613,23 +615,23 @@ fpCvtToInteger sym fun r x = fpCvtToRational :: (W4.IsSymExprBuilder sy, sym ~ What4 sy) => - sym -> SFloat sym -> SEval sym (SRational sym) -fpCvtToRational sym fp = + sym -> Range -> SFloat sym -> SEval sym (SRational sym) +fpCvtToRational sym rng fp = do grd <- liftIO do bad1 <- FP.fpIsInf (w4 sym) fp bad2 <- FP.fpIsNaN (w4 sym) fp W4.notPred (w4 sym) =<< W4.orPred (w4 sym) bad1 bad2 - assertSideCondition sym grd (BadValue "fpToRational") + assertSideCondition sym grd (EvalErrorEx rng (BadValue "fpToRational")) (rel,x,y) <- liftIO (FP.fpToRational (w4 sym) fp) addDefEqn sym =<< liftIO (W4.impliesPred (w4 sym) grd rel) - ratio sym x y + ratio sym rng x y fpCvtFromRational :: (W4.IsSymExprBuilder sy, sym ~ What4 sy) => - sym -> Integer -> Integer -> SWord sym -> + sym -> Range -> Integer -> Integer -> SWord sym -> SRational sym -> SEval sym (SFloat sym) -fpCvtFromRational sym e p r rat = - do rnd <- fpRoundingMode sym r +fpCvtFromRational sym rng e p r rat = + do rnd <- fpRoundingMode sym rng r liftIO (FP.fpFromRational (w4 sym) e p rnd (sNum rat) (sDenom rat)) -- Create a fresh constant and assert that it is the @@ -639,15 +641,16 @@ fpCvtFromRational sym e p r rat = sModRecip :: W4.IsSymExprBuilder sym => What4 sym -> + Range -> Integer -> W4.SymInteger sym -> W4Eval sym (W4.SymInteger sym) -sModRecip _sym 0 _ = panic "sModRecip" ["0 modulus not allowed"] -sModRecip sym m x +sModRecip _sym _ 0 _ = panic "sModRecip" ["0 modulus not allowed"] +sModRecip sym rng m x -- If the input is concrete, evaluate the answer | Just xi <- W4.asInteger x = let r = Integer.recipModInteger xi m - in if r == 0 then raiseError sym DivideByZero else integerLit sym r + in if r == 0 then raiseError sym (EvalErrorEx rng DivideByZero) else integerLit sym r -- If the input is symbolic, create a new symbolic constant -- and assert that it is the desired multiplicitive inverse. @@ -656,7 +659,7 @@ sModRecip sym m x | otherwise = do divZero <- liftIO (W4.intDivisible (w4 sym) x (fromInteger m)) ok <- liftIO (W4.notPred (w4 sym) divZero) - assertSideCondition sym ok DivideByZero + assertSideCondition sym ok (EvalErrorEx rng DivideByZero) z <- liftIO (W4.freshBoundedInt (w4 sym) W4.emptySymbol (Just 1) (Just (m-1))) xz <- liftIO (W4.intMul (w4 sym) x z) diff --git a/src/Cryptol/Eval.hs b/src/Cryptol/Eval.hs index 7d9ae33f4..78fefe842 100644 --- a/src/Cryptol/Eval.hs +++ b/src/Cryptol/Eval.hs @@ -30,6 +30,7 @@ module Cryptol.Eval ( , evalSel , evalSetSel , EvalError(..) + , EvalErrorEx(..) , Unsupported(..) , forceValue ) where @@ -43,6 +44,7 @@ import Cryptol.Eval.Prims import Cryptol.Eval.Type import Cryptol.Eval.Value import Cryptol.ModuleSystem.Name +import Cryptol.Parser.Position import Cryptol.Parser.Selector(ppSelector) import Cryptol.TypeCheck.AST import Cryptol.TypeCheck.Solver.InfNat(Nat'(..)) @@ -89,7 +91,7 @@ moduleEnv :: moduleEnv sym m env = evalDecls sym (mDecls m) =<< evalNewtypes sym (mNewtypes m) env {-# SPECIALIZE evalExpr :: - ConcPrims => + (?range :: Range, ConcPrims) => Concrete -> GenEvalEnv Concrete -> Expr -> @@ -100,14 +102,16 @@ moduleEnv sym m env = evalDecls sym (mDecls m) =<< evalNewtypes sym (mNewtypes m -- by the `EvalPrims` class, which defines the behavior of bits and words, in -- addition to providing implementations for all the primitives. evalExpr :: - EvalPrims sym => + (?range :: Range, EvalPrims sym) => sym -> GenEvalEnv sym {- ^ Evaluation environment -} -> Expr {- ^ Expression to evaluate -} -> SEval sym (GenValue sym) evalExpr sym env expr = case expr of - ELocated _ t -> evalExpr sym env t -- TODO, track source locations + ELocated r e -> + let ?range = r in + evalExpr sym env e -- Try to detect when the user has directly written a finite sequence of -- literal bit values and pack these into a word. @@ -118,22 +122,22 @@ evalExpr sym env expr = case expr of return $ VWord len $ case tryFromBits sym vs of Just w -> WordVal <$> w - Nothing -> do xs <- mapM (sDelay sym Nothing) vs - return $ LargeBitsVal len $ finiteSeqMap sym xs + Nothing -> do xs <- mapM (sDelay sym ?range Nothing) vs + return $ LargeBitsVal len $ finiteSeqMap xs | otherwise -> {-# SCC "evalExpr->EList" #-} do - xs <- mapM (sDelay sym Nothing) vs - return $ VSeq len $ finiteSeqMap sym xs + xs <- mapM (sDelay sym ?range Nothing) vs + return $ VSeq len $ finiteSeqMap xs where tyv = evalValType (envTypes env) ty vs = map eval es len = genericLength es ETuple es -> {-# SCC "evalExpr->ETuple" #-} do - xs <- mapM (sDelay sym Nothing . eval) es + xs <- mapM (sDelay sym ?range Nothing . eval) es return $ VTuple xs ERec fields -> {-# SCC "evalExpr->ERec" #-} do - xs <- traverse (sDelay sym Nothing . eval) fields + xs <- traverse (sDelay sym ?range Nothing . eval) fields return $ VRecord xs ESel e sel -> {-# SCC "evalExpr->ESel" #-} do @@ -156,7 +160,8 @@ evalExpr sym env expr = case expr of EVar n -> {-# SCC "evalExpr->EVar" #-} do case lookupVar n env of - Just val -> val + Just (Left p) -> evalPrim sym n p + Just (Right val) -> val Nothing -> do envdoc <- ppEnv sym defaultPPOpts env panic "[Eval] evalExpr" @@ -277,7 +282,7 @@ evalDeclGroup sym env dg = do -- declare a "hole" for each declaration -- and extend the evaluation environment holes <- mapM (declHole sym) ds - let holeEnv = IntMap.fromList $ [ (nameUnique nm, h) | (nm,_,h,_) <- holes ] + let holeEnv = IntMap.fromList $ [ (nameUnique nm, Right h) | (nm,_,h,_) <- holes ] let env' = env `mappend` emptyEnv{ envVars = holeEnv } -- evaluate the declaration bodies, building a new evaluation environment @@ -321,11 +326,11 @@ fillHole :: SEval sym () fillHole sym env (nm, sch, _, fill) = do case lookupVar nm env of - Nothing -> evalPanic "fillHole" ["Recursive definition not completed", show (ppLocName nm)] - Just v - | isValueType env sch -> fill =<< sDelayFill sym v (etaDelay sym (show (ppLocName nm)) env sch v) - | otherwise -> fill (etaDelay sym (show (ppLocName nm)) env sch v) + Just (Right v) + | isValueType env sch -> fill =<< sDelayFill sym v (etaDelay sym (nameLoc nm) (show (ppLocName nm)) env sch v) + | otherwise -> fill (etaDelay sym (nameLoc nm) (show (ppLocName nm)) env sch v) + _ -> evalPanic "fillHole" ["Recursive definition not completed", show (ppLocName nm)] -- | 'Value' types are non-polymorphic types recursive constructed from -- bits, finite sequences, tuples and records. Types of this form can @@ -347,6 +352,7 @@ isValueType _ _ = False {-# SPECIALIZE etaWord :: Concrete -> + Range -> Integer -> SEval Concrete (GenValue Concrete) -> SEval Concrete (WordValue Concrete) @@ -356,17 +362,19 @@ isValueType _ _ = False etaWord :: Backend sym => sym -> + Range -> Integer -> SEval sym (GenValue sym) -> SEval sym (WordValue sym) -etaWord sym n val = do - w <- sDelay sym Nothing (fromWordVal "during eta-expansion" =<< val) +etaWord sym rng n val = do + w <- sDelay sym rng Nothing (fromWordVal "during eta-expansion" =<< val) xs <- memoMap $ IndexSeqMap $ \i -> - do w' <- w; VBit <$> indexWordValue sym w' i + do w' <- w; VBit <$> indexWordValue sym rng w' i pure $ LargeBitsVal n xs {-# SPECIALIZE etaDelay :: Concrete -> + Range -> String -> GenEvalEnv Concrete -> Schema -> @@ -383,12 +391,13 @@ etaWord sym n val = do etaDelay :: Backend sym => sym -> + Range -> String -> GenEvalEnv sym -> Schema -> SEval sym (GenValue sym) -> SEval sym (GenValue sym) -etaDelay sym msg env0 Forall{ sVars = vs0, sType = tp0 } = goTpVars env0 vs0 +etaDelay sym rng msg env0 Forall{ sVars = vs0, sType = tp0 } = goTpVars env0 vs0 where goTpVars env [] val = go (evalValType (envTypes env) tp0) val goTpVars env (v:vs) val = @@ -452,26 +461,26 @@ etaDelay sym msg env0 Forall{ sVars = vs0, sType = tp0 } = goTpVars env0 vs0 TVArray{} -> v TVSeq n TVBit -> - do w <- sDelayFill sym (fromWordVal "during eta-expansion" =<< v) (etaWord sym n v) + do w <- sDelayFill sym (fromWordVal "during eta-expansion" =<< v) (etaWord sym rng n v) return $ VWord n w TVSeq n el -> - do x' <- sDelay sym (Just msg) (fromSeq "during eta-expansion" =<< v) + do x' <- sDelay sym rng (Just msg) (fromSeq "during eta-expansion" =<< v) return $ VSeq n $ IndexSeqMap $ \i -> do go el (flip lookupSeqMap i =<< x') TVStream el -> - do x' <- sDelay sym (Just msg) (fromSeq "during eta-expansion" =<< v) + do x' <- sDelay sym rng (Just msg) (fromSeq "during eta-expansion" =<< v) return $ VStream $ IndexSeqMap $ \i -> go el (flip lookupSeqMap i =<< x') TVFun _t1 t2 -> - do v' <- sDelay sym (Just msg) (fromVFun <$> v) + do v' <- sDelay sym rng (Just msg) (fromVFun <$> v) return $ VFun $ \a -> go t2 ( ($a) =<< v' ) TVTuple ts -> do let n = length ts - v' <- sDelay sym (Just msg) (fromVTuple <$> v) + v' <- sDelay sym rng (Just msg) (fromVTuple <$> v) return $ VTuple $ [ go t =<< (flip genericIndex i <$> v') | i <- [0..(n-1)] @@ -479,7 +488,7 @@ etaDelay sym msg env0 Forall{ sVars = vs0, sType = tp0 } = goTpVars env0 vs0 ] TVRec fs -> - do v' <- sDelay sym (Just msg) (fromVRecord <$> v) + do v' <- sDelay sym rng (Just msg) (fromVRecord <$> v) let err f = evalPanic "expected record value with field" [show f] let eta f t = go t =<< (fromMaybe (err f) . lookupField f <$> v') return $ VRecord (mapWithFieldName eta fs) @@ -502,7 +511,7 @@ declHole sym d = DPrim -> evalPanic "Unexpected primitive declaration in recursive group" [show (ppLocName nm)] DExpr _ -> do - (hole, fill) <- sDeclareHole sym msg + (hole, fill) <- sDeclareHole sym msg (nameLoc nm) return (nm, sch, hole, fill) where nm = dName d @@ -525,10 +534,11 @@ evalDecl :: Decl {- ^ The declaration to evaluate -} -> SEval sym (GenEvalEnv sym) evalDecl sym renv env d = + let ?range = nameLoc (dName d) in case dDefinition d of DPrim -> case ?evalPrim =<< asPrim (dName d) of - Just (Right p) -> bindVar sym (dName d) (evalPrim sym (dName d) p) env + Just (Right p) -> pure $ bindVarDirect (dName d) p env Just (Left ex) -> bindVar sym (dName d) (evalExpr sym renv ex) env Nothing -> bindVar sym (dName d) (cryNoPrimError sym (dName d)) env @@ -538,7 +548,7 @@ evalDecl sym renv env d = -- Selectors ------------------------------------------------------------------- {-# SPECIALIZE evalSel :: - ConcPrims => + (?range :: Range, ConcPrims) => Concrete -> GenValue Concrete -> Selector -> @@ -549,7 +559,7 @@ evalDecl sym renv env d = -- tuple and record selections pointwise down into other value constructs -- (e.g., streams and functions). evalSel :: - EvalPrims sym => + (?range :: Range, EvalPrims sym) => sym -> GenValue sym -> Selector -> @@ -581,18 +591,18 @@ evalSel sym val sel = case sel of case v of VSeq _ vs -> lookupSeqMap vs (toInteger n) VStream vs -> lookupSeqMap vs (toInteger n) - VWord _ wv -> VBit <$> (flip (indexWordValue sym) (toInteger n) =<< wv) + VWord _ wv -> VBit <$> (flip (indexWordValue sym ?range) (toInteger n) =<< wv) _ -> do vdoc <- ppValue sym defaultPPOpts val evalPanic "Cryptol.Eval.evalSel" [ "Unexpected value in list selection" , show vdoc ] {-# SPECIALIZE evalSetSel :: - ConcPrims => + (?range :: Range, ConcPrims) => Concrete -> TValue -> GenValue Concrete -> Selector -> SEval Concrete (GenValue Concrete) -> SEval Concrete (GenValue Concrete) #-} evalSetSel :: forall sym. - EvalPrims sym => + (?range :: Range, EvalPrims sym) => sym -> TValue -> GenValue sym -> Selector -> SEval sym (GenValue sym) -> SEval sym (GenValue sym) @@ -632,7 +642,7 @@ evalSetSel sym _tyv e sel v = VSeq i mp -> pure $ VSeq i $ updateSeqMap mp n v VStream mp -> pure $ VStream $ updateSeqMap mp n v VWord i m -> pure $ VWord i $ do m1 <- m - updateWordValue sym m1 n asBit + updateWordValue sym ?range m1 n asBit _ -> bad "Sequence update on a non-sequence." asBit = do res <- v @@ -648,7 +658,7 @@ evalSetSel sym _tyv e sel v = data ListEnv sym = ListEnv { leVars :: !(IntMap.IntMap (Integer -> SEval sym (GenValue sym))) -- ^ Bindings whose values vary by position - , leStatic :: !(IntMap.IntMap (SEval sym (GenValue sym))) + , leStatic :: !(IntMap.IntMap (Either (Prim sym) (SEval sym (GenValue sym)))) -- ^ Bindings whose values are constant , leTypes :: !TypeEnv } @@ -683,7 +693,7 @@ toListEnv e = -- locations. evalListEnv :: ListEnv sym -> Integer -> GenEvalEnv sym evalListEnv (ListEnv vm st tm) i = - let v = fmap ($i) vm + let v = fmap (Right . ($i)) vm in EvalEnv{ envVars = IntMap.union v st , envTypes = tm } @@ -701,7 +711,7 @@ bindVarList n vs lenv = lenv { leVars = IntMap.insert (nameUnique n) vs (leVars -- List Comprehensions --------------------------------------------------------- {-# SPECIALIZE evalComp :: - ConcPrims => + (?range :: Range, ConcPrims) => Concrete -> GenEvalEnv Concrete -> Nat' -> @@ -712,7 +722,7 @@ bindVarList n vs lenv = lenv { leVars = IntMap.insert (nameUnique n) vs (leVars #-} -- | Evaluate a comprehension. evalComp :: - EvalPrims sym => + (?range :: Range, EvalPrims sym) => sym -> GenEvalEnv sym {- ^ Starting evaluation environment -} -> Nat' {- ^ Length of the comprehension -} -> @@ -726,7 +736,7 @@ evalComp sym env len elty body ms = evalExpr sym (evalListEnv lenv i) body) {-# SPECIALIZE branchEnvs :: - ConcPrims => + (?range :: Range, ConcPrims) => Concrete -> ListEnv Concrete -> [Match] -> @@ -735,7 +745,7 @@ evalComp sym env len elty body ms = -- | Turn a list of matches into the final environments for each iteration of -- the branch. branchEnvs :: - EvalPrims sym => + (?range :: Range, EvalPrims sym) => sym -> ListEnv sym -> [Match] -> @@ -743,7 +753,7 @@ branchEnvs :: branchEnvs sym env matches = foldM (evalMatch sym) env matches {-# SPECIALIZE evalMatch :: - ConcPrims => + (?range :: Range, ConcPrims) => Concrete -> ListEnv Concrete -> Match -> @@ -752,7 +762,7 @@ branchEnvs sym env matches = foldM (evalMatch sym) env matches -- | Turn a match into the list of environments it represents. evalMatch :: - EvalPrims sym => + (?range :: Range, EvalPrims sym) => sym -> ListEnv sym -> Match -> @@ -770,7 +780,7 @@ evalMatch sym lenv m = case m of let lenv' = lenv { leVars = fmap stutter (leVars lenv) } let vs i = do let (q, r) = i `divMod` nLen lookupSeqMap vss q >>= \case - VWord _ w -> VBit <$> (flip (indexWordValue sym) r =<< w) + VWord _ w -> VBit <$> (flip (indexWordValue sym ?range) r =<< w) VSeq _ xs' -> lookupSeqMap xs' r VStream xs' -> lookupSeqMap xs' r _ -> evalPanic "evalMatch" ["Not a list value"] @@ -781,14 +791,14 @@ evalMatch sym lenv m = case m of -- `leVars` elements of the comprehension environment into `leStatic` elements -- by selecting out the 0th element. Inf -> do - let allvars = IntMap.union (fmap ($0) (leVars lenv)) (leStatic lenv) + let allvars = IntMap.union (fmap (Right . ($0)) (leVars lenv)) (leStatic lenv) let lenv' = lenv { leVars = IntMap.empty , leStatic = allvars } let env = EvalEnv allvars (leTypes lenv) xs <- evalExpr sym env expr let vs i = case xs of - VWord _ w -> VBit <$> (flip (indexWordValue sym) i =<< w) + VWord _ w -> VBit <$> (flip (indexWordValue sym ?range) i =<< w) VSeq _ xs' -> lookupSeqMap xs' i VStream xs' -> lookupSeqMap xs' i _ -> evalPanic "evalMatch" ["Not a list value"] diff --git a/src/Cryptol/Eval/Concrete.hs b/src/Cryptol/Eval/Concrete.hs index ec683b650..33adf7a3c 100644 --- a/src/Cryptol/Eval/Concrete.hs +++ b/src/Cryptol/Eval/Concrete.hs @@ -50,6 +50,7 @@ import Cryptol.Eval.Value import qualified Cryptol.SHA as SHA import qualified Cryptol.AES as AES import qualified Cryptol.PrimeEC as PrimeEC +import Cryptol.Parser.Position (Range) import Cryptol.ModuleSystem.Name import Cryptol.TypeCheck.AST as AST import Cryptol.Utils.Panic (panic) @@ -207,8 +208,9 @@ primTable eOpts = let sym = Concrete in PFinPoly \v -> PWordFun \(BV w x) -> PWordFun \(BV _ m) -> + PRange \rng -> PPrim - do assertSideCondition sym (m /= 0) DivideByZero + do assertSideCondition sym (m /= 0) (EvalErrorEx rng DivideByZero) return . VWord v . pure . WordVal . mkBv v $! F2.pmod (fromInteger w) x m) , ("pdiv", @@ -216,8 +218,9 @@ primTable eOpts = let sym = Concrete in PFinPoly \_v -> PWordFun \(BV w x) -> PWordFun \(BV _ m) -> + PRange \rng -> PPrim - do assertSideCondition sym (m /= 0) DivideByZero + do assertSideCondition sym (m /= 0) (EvalErrorEx rng DivideByZero) return . VWord w . pure . WordVal . mkBv w $! F2.pdiv (fromInteger w) x m) ] @@ -292,7 +295,7 @@ suiteBPrims = Map.fromList $ map (\(n, v) -> (suiteBPrim n, v)) SHA.initialSHA224State blks let f :: Word32 -> Eval Value f = pure . VWord 32 . pure . WordVal . BV 32 . toInteger - zs = finiteSeqMap Concrete (map f [w0,w1,w2,w3,w4,w5,w6]) + zs = finiteSeqMap (map f [w0,w1,w2,w3,w4,w5,w6]) seq zs (pure (VSeq 7 zs))) , ("processSHA2_256", {-# SCC "SuiteB::processSHA2_256" #-} @@ -305,7 +308,7 @@ suiteBPrims = Map.fromList $ map (\(n, v) -> (suiteBPrim n, v)) SHA.initialSHA256State blks let f :: Word32 -> Eval Value f = pure . VWord 32 . pure . WordVal . BV 32 . toInteger - zs = finiteSeqMap Concrete (map f [w0,w1,w2,w3,w4,w5,w6,w7]) + zs = finiteSeqMap (map f [w0,w1,w2,w3,w4,w5,w6,w7]) seq zs (pure (VSeq 8 zs))) , ("processSHA2_384", {-# SCC "SuiteB::processSHA2_384" #-} @@ -318,7 +321,7 @@ suiteBPrims = Map.fromList $ map (\(n, v) -> (suiteBPrim n, v)) SHA.initialSHA384State blks let f :: Word64 -> Eval Value f = pure . VWord 64 . pure . WordVal . BV 64 . toInteger - zs = finiteSeqMap Concrete (map f [w0,w1,w2,w3,w4,w5]) + zs = finiteSeqMap (map f [w0,w1,w2,w3,w4,w5]) seq zs (pure (VSeq 6 zs))) , ("processSHA2_512", {-# SCC "SuiteB::processSHA2_512" #-} @@ -331,7 +334,7 @@ suiteBPrims = Map.fromList $ map (\(n, v) -> (suiteBPrim n, v)) SHA.initialSHA512State blks let f :: Word64 -> Eval Value f = pure . VWord 64 . pure . WordVal . BV 64 . toInteger - zs = finiteSeqMap Concrete (map f [w0,w1,w2,w3,w4,w5,w6,w7]) + zs = finiteSeqMap (map f [w0,w1,w2,w3,w4,w5,w6,w7]) seq zs (pure (VSeq 8 zs))) , ("AESKeyExpand", {-# SCC "SuiteB::AESKeyExpand" #-} @@ -346,7 +349,7 @@ suiteBPrims = Map.fromList $ map (\(n, v) -> (suiteBPrim n, v)) kws <- mapM toWord [0 .. k-1] let ws = AES.keyExpansionWords k kws let len = 4*(k+7) - pure (VSeq len (finiteSeqMap Concrete (map fromWord ws)))) + pure (VSeq len (finiteSeqMap (map fromWord ws)))) , ("AESInvMixColumns", {-# SCC "SuiteB::AESInvMixColumns" #-} PFun \st -> @@ -358,7 +361,7 @@ suiteBPrims = Map.fromList $ map (\(n, v) -> (suiteBPrim n, v)) fromWord = pure . VWord 32 . pure . WordVal . BV 32 . toInteger ws <- mapM toWord [0,1,2,3] let ws' = AES.invMixColumns ws - pure . VSeq 4 . finiteSeqMap Concrete . map fromWord $ ws') + pure . VSeq 4 . finiteSeqMap . map fromWord $ ws') , ("AESEncRound", {-# SCC "SuiteB::AESEncRound" #-} PFun \st -> @@ -370,7 +373,7 @@ suiteBPrims = Map.fromList $ map (\(n, v) -> (suiteBPrim n, v)) fromWord = pure . VWord 32 . pure . WordVal . BV 32 . toInteger ws <- mapM toWord [0,1,2,3] let ws' = AES.aesRound ws - pure . VSeq 4 . finiteSeqMap Concrete . map fromWord $ ws') + pure . VSeq 4 . finiteSeqMap . map fromWord $ ws') , ("AESEncFinalRound", {-# SCC "SuiteB::AESEncFinalRound" #-} PFun \st -> @@ -382,7 +385,7 @@ suiteBPrims = Map.fromList $ map (\(n, v) -> (suiteBPrim n, v)) fromWord = pure . VWord 32 . pure . WordVal . BV 32 . toInteger ws <- mapM toWord [0,1,2,3] let ws' = AES.aesFinalRound ws - pure . VSeq 4 . finiteSeqMap Concrete . map fromWord $ ws') + pure . VSeq 4 . finiteSeqMap . map fromWord $ ws') , ("AESDecRound", {-# SCC "SuiteB::AESDecRound" #-} PFun \st -> @@ -394,7 +397,7 @@ suiteBPrims = Map.fromList $ map (\(n, v) -> (suiteBPrim n, v)) fromWord = pure . VWord 32 . pure . WordVal . BV 32 . toInteger ws <- mapM toWord [0,1,2,3] let ws' = AES.aesInvRound ws - pure . VSeq 4 . finiteSeqMap Concrete . map fromWord $ ws') + pure . VSeq 4 . finiteSeqMap . map fromWord $ ws') , ("AESDecFinalRound", {-# SCC "SuiteB::AESDecFinalRound" #-} PFun \st -> @@ -406,7 +409,7 @@ suiteBPrims = Map.fromList $ map (\(n, v) -> (suiteBPrim n, v)) fromWord = pure . VWord 32 . pure . WordVal . BV 32 . toInteger ws <- mapM toWord [0,1,2,3] let ws' = AES.aesInvFinalRound ws - pure . VSeq 4 . finiteSeqMap Concrete . map fromWord $ ws') + pure . VSeq 4 . finiteSeqMap . map fromWord $ ws') ] @@ -472,7 +475,7 @@ sshrV = logicShift :: (Integer -> Integer -> Integer -> Integer) -- ^ The function may assume its arguments are masked. -- It is responsible for masking its result if needed. - -> (Nat' -> TValue -> SeqMap Concrete -> Integer -> SeqMap Concrete) + -> (Range -> Nat' -> TValue -> SeqMap Concrete -> Integer -> SeqMap Concrete) -> Prim Concrete logicShift opW opS = PNumPoly \a -> @@ -480,6 +483,7 @@ logicShift opW opS = PTyPoly \c -> PFun \l -> PFun \r -> + PRange \rng -> PPrim do i <- r >>= \case VInteger i -> pure i @@ -488,9 +492,9 @@ logicShift opW opS = l >>= \case VWord w wv -> return $ VWord w $ wv >>= \case WordVal (BV _ x) -> return $ WordVal (BV w (opW w x i)) - LargeBitsVal n xs -> return $ LargeBitsVal n $ opS (Nat n) c xs i + LargeBitsVal n xs -> return $ LargeBitsVal n $ opS rng (Nat n) c xs i - _ -> mkSeq a c <$> (opS a c <$> (fromSeq "logicShift" =<< l) <*> return i) + _ -> mkSeq a c <$> (opS rng a c <$> (fromSeq "logicShift" =<< l) <*> return i) -- Left shift for words. shiftLW :: Integer -> Integer -> Integer -> Integer @@ -519,31 +523,31 @@ signedShiftRW w ival by else shiftR (signedValue w ival) (fromInteger by') -shiftLS :: Nat' -> TValue -> SeqMap Concrete -> Integer -> SeqMap Concrete -shiftLS w ety vs by - | by < 0 = shiftRS w ety vs (negate by) +shiftLS :: Range -> Nat' -> TValue -> SeqMap Concrete -> Integer -> SeqMap Concrete +shiftLS rng w ety vs by + | by < 0 = shiftRS rng w ety vs (negate by) -shiftLS w ety vs by = IndexSeqMap $ \i -> +shiftLS rng w ety vs by = IndexSeqMap $ \i -> case w of Nat len | i+by < len -> lookupSeqMap vs (i+by) - | i < len -> zeroV Concrete ety + | i < len -> zeroV Concrete rng ety | otherwise -> evalPanic "shiftLS" ["Index out of bounds"] Inf -> lookupSeqMap vs (i+by) -shiftRS :: Nat' -> TValue -> SeqMap Concrete -> Integer -> SeqMap Concrete -shiftRS w ety vs by - | by < 0 = shiftLS w ety vs (negate by) +shiftRS :: Range -> Nat' -> TValue -> SeqMap Concrete -> Integer -> SeqMap Concrete +shiftRS rng w ety vs by + | by < 0 = shiftLS rng w ety vs (negate by) -shiftRS w ety vs by = IndexSeqMap $ \i -> +shiftRS rng w ety vs by = IndexSeqMap $ \i -> case w of Nat len | i >= by -> lookupSeqMap vs (i-by) - | i < len -> zeroV Concrete ety + | i < len -> zeroV Concrete rng ety | otherwise -> evalPanic "shiftLS" ["Index out of bounds"] Inf | i >= by -> lookupSeqMap vs (i-by) - | otherwise -> zeroV Concrete ety + | otherwise -> zeroV Concrete rng ety -- XXX integer doesn't implement rotateL, as there's no bit bound @@ -552,8 +556,8 @@ rotateLW 0 i _ = i rotateLW w i by = mask w $ (i `shiftL` b) .|. (i `shiftR` (fromInteger w - b)) where b = fromInteger (by `mod` w) -rotateLS :: Nat' -> TValue -> SeqMap Concrete -> Integer -> SeqMap Concrete -rotateLS w _ vs by = IndexSeqMap $ \i -> +rotateLS :: Range -> Nat' -> TValue -> SeqMap Concrete -> Integer -> SeqMap Concrete +rotateLS _ w _ vs by = IndexSeqMap $ \i -> case w of Nat len -> lookupSeqMap vs ((by + i) `mod` len) _ -> panic "Cryptol.Eval.Prim.rotateLS" [ "unexpected infinite sequence" ] @@ -564,8 +568,8 @@ rotateRW 0 i _ = i rotateRW w i by = mask w $ (i `shiftR` b) .|. (i `shiftL` (fromInteger w - b)) where b = fromInteger (by `mod` w) -rotateRS :: Nat' -> TValue -> SeqMap Concrete -> Integer -> SeqMap Concrete -rotateRS w _ vs by = IndexSeqMap $ \i -> +rotateRS :: Range -> Nat' -> TValue -> SeqMap Concrete -> Integer -> SeqMap Concrete +rotateRS _ w _ vs by = IndexSeqMap $ \i -> case w of Nat len -> lookupSeqMap vs ((len - by + i) `mod` len) _ -> panic "Cryptol.Eval.Prim.rotateRS" [ "unexpected infinite sequence" ] @@ -573,84 +577,88 @@ rotateRS w _ vs by = IndexSeqMap $ \i -> -- Sequence Primitives --------------------------------------------------------- -indexFront :: Nat' -> TValue -> SeqMap Concrete -> TValue -> BV -> Eval Value -indexFront _mblen _a vs _ix (bvVal -> ix) = lookupSeqMap vs ix +indexFront :: Range -> Nat' -> TValue -> SeqMap Concrete -> TValue -> BV -> Eval Value +indexFront _rng _mblen _a vs _ix (bvVal -> ix) = lookupSeqMap vs ix -indexFront_bits :: Nat' -> TValue -> SeqMap Concrete -> TValue -> [Bool] -> Eval Value -indexFront_bits mblen a vs ix bs = indexFront mblen a vs ix =<< packWord Concrete bs +indexFront_bits :: Range -> Nat' -> TValue -> SeqMap Concrete -> TValue -> [Bool] -> Eval Value +indexFront_bits rng mblen a vs ix bs = indexFront rng mblen a vs ix =<< packWord Concrete bs -indexFront_int :: Nat' -> TValue -> SeqMap Concrete -> TValue -> Integer -> Eval Value -indexFront_int _mblen _a vs _ix idx = lookupSeqMap vs idx +indexFront_int :: Range -> Nat' -> TValue -> SeqMap Concrete -> TValue -> Integer -> Eval Value +indexFront_int _rng _mblen _a vs _ix idx = lookupSeqMap vs idx -indexBack :: Nat' -> TValue -> SeqMap Concrete -> TValue -> BV -> Eval Value -indexBack mblen a vs ix (bvVal -> idx) = indexBack_int mblen a vs ix idx +indexBack :: Range -> Nat' -> TValue -> SeqMap Concrete -> TValue -> BV -> Eval Value +indexBack rng mblen a vs ix (bvVal -> idx) = indexBack_int rng mblen a vs ix idx -indexBack_bits :: Nat' -> TValue -> SeqMap Concrete -> TValue -> [Bool] -> Eval Value -indexBack_bits mblen a vs ix bs = indexBack mblen a vs ix =<< packWord Concrete bs +indexBack_bits :: Range -> Nat' -> TValue -> SeqMap Concrete -> TValue -> [Bool] -> Eval Value +indexBack_bits rng mblen a vs ix bs = indexBack rng mblen a vs ix =<< packWord Concrete bs -indexBack_int :: Nat' -> TValue -> SeqMap Concrete -> TValue -> Integer -> Eval Value -indexBack_int mblen _a vs _ix idx = +indexBack_int :: Range -> Nat' -> TValue -> SeqMap Concrete -> TValue -> Integer -> Eval Value +indexBack_int _rng mblen _a vs _ix idx = case mblen of Nat len -> lookupSeqMap vs (len - idx - 1) Inf -> evalPanic "indexBack" ["unexpected infinite sequence"] updateFront :: + Range -> Nat' {- ^ length of the sequence -} -> TValue {- ^ type of values in the sequence -} -> SeqMap Concrete {- ^ sequence to update -} -> Either Integer (WordValue Concrete) {- ^ index -} -> Eval Value {- ^ new value at index -} -> Eval (SeqMap Concrete) -updateFront _len _eltTy vs (Left idx) val = do +updateFront _rng _len _eltTy vs (Left idx) val = do return $ updateSeqMap vs idx val -updateFront _len _eltTy vs (Right w) val = do +updateFront _rng _len _eltTy vs (Right w) val = do idx <- bvVal <$> asWordVal Concrete w return $ updateSeqMap vs idx val updateFront_word :: + Range -> Nat' {- ^ length of the sequence -} -> TValue {- ^ type of values in the sequence -} -> WordValue Concrete {- ^ bit sequence to update -} -> Either Integer (WordValue Concrete) {- ^ index -} -> Eval Value {- ^ new value at index -} -> Eval (WordValue Concrete) -updateFront_word _len _eltTy bs (Left idx) val = do - updateWordValue Concrete bs idx (fromVBit <$> val) +updateFront_word rng _len _eltTy bs (Left idx) val = do + updateWordValue Concrete rng bs idx (fromVBit <$> val) -updateFront_word _len _eltTy bs (Right w) val = do +updateFront_word rng _len _eltTy bs (Right w) val = do idx <- bvVal <$> asWordVal Concrete w - updateWordValue Concrete bs idx (fromVBit <$> val) + updateWordValue Concrete rng bs idx (fromVBit <$> val) updateBack :: + Range -> Nat' {- ^ length of the sequence -} -> TValue {- ^ type of values in the sequence -} -> SeqMap Concrete {- ^ sequence to update -} -> Either Integer (WordValue Concrete) {- ^ index -} -> Eval Value {- ^ new value at index -} -> Eval (SeqMap Concrete) -updateBack Inf _eltTy _vs _w _val = +updateBack _ Inf _eltTy _vs _w _val = evalPanic "Unexpected infinite sequence in updateEnd" [] -updateBack (Nat n) _eltTy vs (Left idx) val = do +updateBack _ (Nat n) _eltTy vs (Left idx) val = do return $ updateSeqMap vs (n - idx - 1) val -updateBack (Nat n) _eltTy vs (Right w) val = do +updateBack _ (Nat n) _eltTy vs (Right w) val = do idx <- bvVal <$> asWordVal Concrete w return $ updateSeqMap vs (n - idx - 1) val updateBack_word :: + Range -> Nat' {- ^ length of the sequence -} -> TValue {- ^ type of values in the sequence -} -> WordValue Concrete {- ^ bit sequence to update -} -> Either Integer (WordValue Concrete) {- ^ index -} -> Eval Value {- ^ new value at index -} -> Eval (WordValue Concrete) -updateBack_word Inf _eltTy _bs _w _val = +updateBack_word _ Inf _eltTy _bs _w _val = evalPanic "Unexpected infinite sequence in updateEnd" [] -updateBack_word (Nat n) _eltTy bs (Left idx) val = do - updateWordValue Concrete bs (n - idx - 1) (fromVBit <$> val) -updateBack_word (Nat n) _eltTy bs (Right w) val = do +updateBack_word rng (Nat n) _eltTy bs (Left idx) val = do + updateWordValue Concrete rng bs (n - idx - 1) (fromVBit <$> val) +updateBack_word rng (Nat n) _eltTy bs (Right w) val = do idx <- bvVal <$> asWordVal Concrete w - updateWordValue Concrete bs (n - idx - 1) (fromVBit <$> val) + updateWordValue Concrete rng bs (n - idx - 1) (fromVBit <$> val) floatPrims :: Concrete -> Map PrimIdent (Prim Concrete) @@ -688,15 +696,19 @@ floatPrims sym = Map.fromList [ (floatPrim i,v) | (i,v) <- nonInfixTable ] , "fpDiv" ~> fpBinArithV sym fpDiv , "fpFromRational" ~> - PFinPoly \e -> PFinPoly \p -> PWordFun \r -> PFun \x -> PPrim + PFinPoly \e -> PFinPoly \p -> PWordFun \r -> PFun \x -> + PRange \rng -> + PPrim do rat <- fromVRational <$> x - VFloat <$> do mode <- fpRoundMode sym r + VFloat <$> do mode <- fpRoundMode sym rng r pure $ floatFromRational e p mode $ sNum rat % sDenom rat , "fpToRational" ~> - PFinPoly \_e -> PFinPoly \_p -> PFloatFun \fp -> PPrim + PFinPoly \_e -> PFinPoly \_p -> PFloatFun \fp -> + PRange \rng -> + PPrim case floatToRational "fpToRational" fp of - Left err -> raiseError sym err + Left err -> raiseError sym (EvalErrorEx rng err) Right r -> pure $ VRational SRational { sNum = numerator r, sDenom = denominator r } diff --git a/src/Cryptol/Eval/Env.hs b/src/Cryptol/Eval/Env.hs index d4e1a2d77..633dc9fe2 100644 --- a/src/Cryptol/Eval/Env.hs +++ b/src/Cryptol/Eval/Env.hs @@ -18,6 +18,7 @@ import Cryptol.Backend import Cryptol.Backend.Monad( PPOpts ) +import Cryptol.Eval.Prims import Cryptol.Eval.Type import Cryptol.Eval.Value import Cryptol.ModuleSystem.Name @@ -37,7 +38,7 @@ import Prelude.Compat -- Evaluation Environment ------------------------------------------------------ data GenEvalEnv sym = EvalEnv - { envVars :: !(IntMap.IntMap (SEval sym (GenValue sym))) + { envVars :: !(IntMap.IntMap (Either (Prim sym) (SEval sym (GenValue sym)))) , envTypes :: !TypeEnv } deriving Generic @@ -58,8 +59,11 @@ instance Monoid (GenEvalEnv sym) where ppEnv :: Backend sym => sym -> PPOpts -> GenEvalEnv sym -> SEval sym Doc ppEnv sym opts env = brackets . fsep <$> mapM bind (IntMap.toList (envVars env)) where - bind (k,v) = do vdoc <- ppValue sym opts =<< v - return (int k <+> text "->" <+> vdoc) + bind (k,Left _) = + do return (int k <+> text "<>") + bind (k,Right v) = + do vdoc <- ppValue sym opts =<< v + return (int k <+> text "->" <+> vdoc) -- | Evaluation environment with no bindings emptyEnv :: GenEvalEnv sym @@ -75,23 +79,23 @@ bindVar :: SEval sym (GenEvalEnv sym) bindVar sym n val env = do let nm = show $ ppLocName n - val' <- sDelay sym (Just nm) val - return $ env{ envVars = IntMap.insert (nameUnique n) val' (envVars env) } + val' <- sDelay sym (nameLoc n) (Just nm) val + return $ env{ envVars = IntMap.insert (nameUnique n) (Right val') (envVars env) } -- | Bind a variable to a value in the evaluation environment, without -- creating a thunk. bindVarDirect :: Backend sym => Name -> - GenValue sym -> + Prim sym -> GenEvalEnv sym -> GenEvalEnv sym bindVarDirect n val env = do - env{ envVars = IntMap.insert (nameUnique n) (pure val) (envVars env) } + env{ envVars = IntMap.insert (nameUnique n) (Left val) (envVars env) } -- | Lookup a variable in the environment. {-# INLINE lookupVar #-} -lookupVar :: Name -> GenEvalEnv sym -> Maybe (SEval sym (GenValue sym)) +lookupVar :: Name -> GenEvalEnv sym -> Maybe (Either (Prim sym) (SEval sym (GenValue sym))) lookupVar n env = IntMap.lookup (nameUnique n) (envVars env) -- | Bind a type variable of kind *. diff --git a/src/Cryptol/Eval/Generic.hs b/src/Cryptol/Eval/Generic.hs index eca73ec62..19062f730 100644 --- a/src/Cryptol/Eval/Generic.hs +++ b/src/Cryptol/Eval/Generic.hs @@ -37,7 +37,8 @@ import Cryptol.TypeCheck.AST import Cryptol.TypeCheck.Solver.InfNat (Nat'(..),nMul,widthInteger) import Cryptol.Backend import Cryptol.Backend.Concrete (Concrete(..)) -import Cryptol.Backend.Monad ( Eval, evalPanic, EvalError(..), Unsupported(..) ) +import Cryptol.Backend.Monad ( Eval, evalPanic, EvalError(..), EvalErrorEx(..), Unsupported(..) ) +import Cryptol.Parser.Position (Range,emptyRange) import Cryptol.Testing.Random( randomValue ) import Cryptol.Eval.Prims @@ -85,26 +86,27 @@ ecNumberV sym = ] -{-# SPECIALIZE intV :: Concrete -> Integer -> TValue -> Eval (GenValue Concrete) +{-# SPECIALIZE intV :: Concrete -> Range -> Integer -> TValue -> Eval (GenValue Concrete) #-} -intV :: Backend sym => sym -> SInteger sym -> TValue -> SEval sym (GenValue sym) -intV sym i = - ringNullary sym +intV :: Backend sym => sym -> Range -> SInteger sym -> TValue -> SEval sym (GenValue sym) +intV sym rng i = + ringNullary sym rng (\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) + (\e p -> fpRndMode sym >>= \r -> fpFromInteger sym rng e p r i) {-# SPECIALIZE ratioV :: Concrete -> Prim Concrete #-} ratioV :: Backend sym => sym -> Prim sym ratioV sym = - PFun \x -> - PFun \y -> + PFun \x -> + PFun \y -> + PRange \rng -> PPrim do x' <- fromVInteger <$> x y' <- fromVInteger <$> y - VRational <$> ratio sym x' y' + VRational <$> ratio sym rng x' y' {-# SPECIALIZE ecFractionV :: Concrete -> Prim Concrete #-} @@ -114,13 +116,14 @@ ecFractionV sym = PFinPoly \d -> PFinPoly \_r -> PTyPoly \ty -> + PRange \rng -> PPrim 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 + VRational <$> ratio sym rng x y _ -> evalPanic "ecFractionV" [ "Unexpected `FLiteral` type: " ++ show ty ] @@ -138,7 +141,7 @@ fromZV sym = -- Operation Lifting ----------------------------------------------------------- -type Binary sym = TValue -> GenValue sym -> GenValue sym -> SEval sym (GenValue sym) +type Binary sym = Range -> TValue -> GenValue sym -> GenValue sym -> SEval sym (GenValue sym) {-# SPECIALIZE binary :: Binary Concrete -> Prim Concrete #-} @@ -146,16 +149,18 @@ binary :: Backend sym => Binary sym -> Prim sym binary f = PTyPoly \ty -> PFun \a -> PFun \b -> - PPrim $ join (f ty <$> a <*> b) + PRange \rng -> + PPrim $ join (f rng ty <$> a <*> b) -type Unary sym = TValue -> GenValue sym -> SEval sym (GenValue sym) +type Unary sym = Range -> TValue -> GenValue sym -> SEval sym (GenValue sym) {-# SPECIALIZE unary :: Unary Concrete -> Prim Concrete #-} unary :: Backend sym => Unary sym -> Prim sym unary f = PTyPoly \ty -> PFun \a -> - PPrim (f ty =<< a) + PRange \rng -> + PPrim (f rng ty =<< a) type BinWord sym = Integer -> SWord sym -> SWord sym -> SEval sym (SWord sym) @@ -176,7 +181,7 @@ ringBinary :: forall sym. (SRational sym -> SRational sym -> SEval sym (SRational sym)) -> (SFloat sym -> SFloat sym -> SEval sym (SFloat sym)) -> Binary sym -ringBinary sym opw opi opz opq opfp = loop +ringBinary sym opw opi opz opq opfp rng = loop where loop' :: TValue -> SEval sym (GenValue sym) @@ -229,15 +234,15 @@ ringBinary sym opw opi opz opq opfp = loop -- tuples TVTuple tys -> - do ls <- mapM (sDelay sym Nothing) (fromVTuple l) - rs <- mapM (sDelay sym Nothing) (fromVTuple r) + do ls <- mapM (sDelay sym rng Nothing) (fromVTuple l) + rs <- mapM (sDelay sym rng Nothing) (fromVTuple r) return $ VTuple (zipWith3 loop' tys ls rs) -- records TVRec fs -> do VRecord <$> traverseRecordMap - (\f fty -> sDelay sym Nothing (loop' fty (lookupRecord f l) (lookupRecord f r))) + (\f fty -> sDelay sym rng Nothing (loop' fty (lookupRecord f l) (lookupRecord f r))) fs TVAbstract {} -> @@ -264,7 +269,7 @@ ringUnary :: forall sym. (SRational sym -> SEval sym (SRational sym)) -> (SFloat sym -> SEval sym (SFloat sym)) -> Unary sym -ringUnary sym opw opi opz opq opfp = loop +ringUnary sym opw opi opz opq opfp rng = loop where loop' :: TValue -> SEval sym (GenValue sym) -> SEval sym (GenValue sym) loop' ty v = loop ty =<< v @@ -306,20 +311,21 @@ ringUnary sym opw opi opz opq opfp = loop -- tuples TVTuple tys -> - do as <- mapM (sDelay sym Nothing) (fromVTuple v) + do as <- mapM (sDelay sym rng Nothing) (fromVTuple v) return $ VTuple (zipWith loop' tys as) -- records TVRec fs -> VRecord <$> traverseRecordMap - (\f fty -> sDelay sym Nothing (loop' fty (lookupRecord f v))) + (\f fty -> sDelay sym rng Nothing (loop' fty (lookupRecord f v))) fs TVAbstract {} -> evalPanic "ringUnary" ["Abstract type not in `Ring`"] {-# SPECIALIZE ringNullary :: Concrete -> + Range -> (Integer -> SEval Concrete (SWord Concrete)) -> SEval Concrete (SInteger Concrete) -> (Integer -> SEval Concrete (SInteger Concrete)) -> @@ -332,6 +338,7 @@ ringUnary sym opw opi opz opq opfp = loop ringNullary :: forall sym. Backend sym => sym -> + Range -> (Integer -> SEval sym (SWord sym)) -> SEval sym (SInteger sym) -> (Integer -> SEval sym (SInteger sym)) -> @@ -339,7 +346,7 @@ ringNullary :: forall sym. (Integer -> Integer -> SEval sym (SFloat sym)) -> TValue -> SEval sym (GenValue sym) -ringNullary sym opw opi opz opq opfp = loop +ringNullary sym rng opw opi opz opq opfp = loop where loop :: TValue -> SEval sym (GenValue sym) loop ty = @@ -360,23 +367,23 @@ ringNullary sym opw opi opz opq opfp = loop -- words and finite sequences | isTBit a -> pure $ VWord w $ (WordVal <$> opw w) | otherwise -> - do v <- sDelay sym Nothing (loop a) - pure $ VSeq w $ IndexSeqMap $ const v + do v <- sDelay sym rng Nothing (loop a) + pure $ VSeq w $ IndexSeqMap \_i -> v TVStream a -> - do v <- sDelay sym Nothing (loop a) - pure $ VStream $ IndexSeqMap $ const v + do v <- sDelay sym rng Nothing (loop a) + pure $ VStream $ IndexSeqMap \_i -> v TVFun _ b -> - do v <- sDelay sym Nothing (loop b) + do v <- sDelay sym rng Nothing (loop b) pure $ lam $ const $ v TVTuple tys -> - do xs <- mapM (sDelay sym Nothing . loop) tys + do xs <- mapM (sDelay sym rng Nothing . loop) tys pure $ VTuple xs TVRec fs -> - do xs <- traverse (sDelay sym Nothing . loop) fs + do xs <- traverse (sDelay sym rng Nothing . loop) fs pure $ VRecord xs TVAbstract {} -> @@ -393,7 +400,7 @@ integralBinary :: forall sym. BinWord sym -> (SInteger sym -> SInteger sym -> SEval sym (SInteger sym)) -> Binary sym -integralBinary sym opw opi ty l r = case ty of +integralBinary sym opw opi _rng ty l r = case ty of TVInteger -> VInteger <$> opi (fromVInteger l) (fromVInteger r) @@ -415,31 +422,32 @@ integralBinary sym opw opi ty l r = case ty of -- | Convert an unbounded integer to a value in Ring fromIntegerV :: Backend sym => sym -> Prim sym fromIntegerV sym = - PTyPoly \ a -> - PFun \ v -> + PTyPoly \a -> + PFun \v -> + PRange \rng -> PPrim do i <- fromVInteger <$> v - intV sym i a + intV sym rng i a {-# INLINE addV #-} addV :: Backend sym => sym -> Binary sym -addV sym = ringBinary sym opw opi opz opq opfp +addV sym rng = ringBinary sym opw opi opz opq opfp rng where opw _w x y = wordPlus sym x y opi x y = intPlus sym x y opz m x y = znPlus sym m x y opq x y = rationalAdd sym x y - opfp x y = fpRndMode sym >>= \r -> fpPlus sym r x y + opfp x y = fpRndMode sym >>= \r -> fpPlus sym rng r x y {-# INLINE subV #-} subV :: Backend sym => sym -> Binary sym -subV sym = ringBinary sym opw opi opz opq opfp +subV sym rng = ringBinary sym opw opi opz opq opfp rng where opw _w x y = wordMinus sym x y opi x y = intMinus sym x y opz m x y = znMinus sym m x y opq x y = rationalSub sym x y - opfp x y = fpRndMode sym >>= \r -> fpMinus sym r x y + opfp x y = fpRndMode sym >>= \r -> fpMinus sym rng r x y {-# INLINE negateV #-} negateV :: Backend sym => sym -> Unary sym @@ -453,23 +461,23 @@ negateV sym = ringUnary sym opw opi opz opq opfp {-# INLINE mulV #-} mulV :: Backend sym => sym -> Binary sym -mulV sym = ringBinary sym opw opi opz opq opfp +mulV sym rng = ringBinary sym opw opi opz opq opfp rng where opw _w x y = wordMult sym x y opi x y = intMult sym x y opz m x y = znMult sym m x y opq x y = rationalMul sym x y - opfp x y = fpRndMode sym >>= \r -> fpMult sym r x y + opfp x y = fpRndMode sym >>= \r -> fpMult sym rng r x y -------------------------------------------------- -- Integral {-# INLINE divV #-} divV :: Backend sym => sym -> Binary sym -divV sym = integralBinary sym opw opi +divV sym rng = integralBinary sym opw opi rng where - opw _w x y = wordDiv sym x y - opi x y = intDiv sym x y + opw _w x y = wordDiv sym rng x y + opi x y = intDiv sym rng x y {-# SPECIALIZE expV :: Concrete -> Prim Concrete #-} expV :: Backend sym => sym -> Prim sym @@ -478,6 +486,7 @@ expV sym = PTyPoly \ety -> PFun \am -> PFun \em -> + PRange \rng -> PPrim do a <- am e <- em @@ -488,31 +497,31 @@ expV sym = Just n | n == 0 -> do onei <- integerLit sym 1 - intV sym onei aty + intV sym rng onei aty | n > 0 -> do ebits <- enumerateIntBits' sym n ei - computeExponent sym aty a ebits + computeExponent sym rng aty a ebits - | otherwise -> raiseError sym NegativeExponent + | otherwise -> raiseError sym (EvalErrorEx rng NegativeExponent) Nothing -> liftIO (X.throw (UnsupportedSymbolicOp "integer exponentiation")) TVSeq _w el | isTBit el -> do ebits <- enumerateWordValue sym =<< fromWordVal "(^^)" e - computeExponent sym aty a ebits + computeExponent sym rng aty a ebits _ -> evalPanic "expV" [show ety ++ " not int class `Integral`"] {-# SPECIALIZE computeExponent :: - Concrete -> TValue -> GenValue Concrete -> [SBit Concrete] -> SEval Concrete (GenValue Concrete) + Concrete -> Range -> TValue -> GenValue Concrete -> [SBit Concrete] -> SEval Concrete (GenValue Concrete) #-} computeExponent :: Backend sym => - sym -> TValue -> GenValue sym -> [SBit sym] -> SEval sym (GenValue sym) -computeExponent sym aty a bs0 = + sym -> Range -> TValue -> GenValue sym -> [SBit sym] -> SEval sym (GenValue sym) +computeExponent sym rng aty a bs0 = do onei <- integerLit sym 1 - one <- intV sym onei aty + one <- intV sym rng onei aty loop one (dropLeadingZeros bs0) where @@ -523,18 +532,18 @@ computeExponent sym aty a bs0 = loop acc [] = return acc loop acc (b:bs) = - do sq <- mulV sym aty acc acc + do sq <- mulV sym rng aty acc acc acc' <- iteValue sym b - (mulV sym aty a sq) + (mulV sym rng aty a sq) (pure sq) loop acc' bs {-# INLINE modV #-} modV :: Backend sym => sym -> Binary sym -modV sym = integralBinary sym opw opi +modV sym rng = integralBinary sym opw opi rng where - opw _w x y = wordMod sym x y - opi x y = intMod sym x y + opw _w x y = wordMod sym rng x y + opi x y = intMod sym rng x y {-# SPECIALIZE toIntegerV :: Concrete -> Prim Concrete #-} -- | Convert a word to a non-negative integer. @@ -557,15 +566,16 @@ recipV :: Backend sym => sym -> Prim sym recipV sym = PTyPoly \a -> PFun \x -> + PRange \rng -> PPrim case a of - TVRational -> VRational <$> (rationalRecip sym . fromVRational =<< x) + TVRational -> VRational <$> (rationalRecip sym rng . fromVRational =<< x) TVFloat e p -> do one <- fpLit sym e p 1 r <- fpRndMode sym xv <- fromVFloat <$> x - VFloat <$> fpDiv sym r one xv - TVIntMod m -> VInteger <$> (znRecip sym m . fromVInteger =<< x) + VFloat <$> fpDiv sym rng r one xv + TVIntMod m -> VInteger <$> (znRecip sym rng m . fromVInteger =<< x) _ -> evalPanic "recip" [show a ++ "is not a Field"] {-# SPECIALIZE fieldDivideV :: Concrete -> Prim Concrete #-} @@ -574,21 +584,22 @@ fieldDivideV sym = PTyPoly \a -> PFun \x -> PFun \y -> + PRange \rng -> PPrim case a of TVRational -> do x' <- fromVRational <$> x y' <- fromVRational <$> y - VRational <$> rationalDivide sym x' y' + VRational <$> rationalDivide sym rng x' y' TVFloat _e _p -> do xv <- fromVFloat <$> x yv <- fromVFloat <$> y r <- fpRndMode sym - VFloat <$> fpDiv sym r xv yv + VFloat <$> fpDiv sym rng r xv yv TVIntMod m -> do x' <- fromVInteger <$> x y' <- fromVInteger <$> y - yinv <- znRecip sym m y' + yinv <- znRecip sym rng m y' VInteger <$> znMult sym m x' yinv _ -> evalPanic "recip" [show a ++ "is not a Field"] @@ -610,7 +621,7 @@ roundOp :: (SRational sym -> SEval sym (SInteger sym)) -> (SFloat sym -> SEval sym (SInteger sym)) -> Unary sym -roundOp _sym nm qop opfp ty v = +roundOp _sym nm qop opfp _rng ty v = case ty of TVRational -> VInteger <$> (qop (fromVRational v)) TVFloat _ _ -> VInteger <$> opfp (fromVFloat v) @@ -618,38 +629,38 @@ roundOp _sym nm qop opfp ty v = {-# INLINE floorV #-} floorV :: Backend sym => sym -> Unary sym -floorV sym = roundOp sym "floor" opq opfp +floorV sym rng = roundOp sym "floor" opq opfp rng where opq = rationalFloor sym - opfp = \x -> fpRndRTN sym >>= \r -> fpToInteger sym "floor" r x + opfp = \x -> fpRndRTN sym >>= \r -> fpToInteger sym "floor" rng r x {-# INLINE ceilingV #-} ceilingV :: Backend sym => sym -> Unary sym -ceilingV sym = roundOp sym "ceiling" opq opfp +ceilingV sym rng = roundOp sym "ceiling" opq opfp rng where opq = rationalCeiling sym - opfp = \x -> fpRndRTP sym >>= \r -> fpToInteger sym "ceiling" r x + opfp = \x -> fpRndRTP sym >>= \r -> fpToInteger sym "ceiling" rng r x {-# INLINE truncV #-} truncV :: Backend sym => sym -> Unary sym -truncV sym = roundOp sym "trunc" opq opfp +truncV sym rng = roundOp sym "trunc" opq opfp rng where opq = rationalTrunc sym - opfp = \x -> fpRndRTZ sym >>= \r -> fpToInteger sym "trunc" r x + opfp = \x -> fpRndRTZ sym >>= \r -> fpToInteger sym "trunc" rng r x {-# INLINE roundAwayV #-} roundAwayV :: Backend sym => sym -> Unary sym -roundAwayV sym = roundOp sym "roundAway" opq opfp +roundAwayV sym rng = roundOp sym "roundAway" opq opfp rng where opq = rationalRoundAway sym - opfp = \x -> fpRndRNA sym >>= \r -> fpToInteger sym "roundAway" r x + opfp = \x -> fpRndRNA sym >>= \r -> fpToInteger sym "roundAway" rng r x {-# INLINE roundToEvenV #-} roundToEvenV :: Backend sym => sym -> Unary sym -roundToEvenV sym = roundOp sym "roundToEven" opq opfp +roundToEvenV sym rng = roundOp sym "roundToEven" opq opfp rng where opq = rationalRoundToEven sym - opfp = \x -> fpRndRNE sym >>= \r -> fpToInteger sym "roundToEven" r x + opfp = \x -> fpRndRNE sym >>= \r -> fpToInteger sym "roundToEven" rng r x -------------------------------------------------------------- -- Logic @@ -685,7 +696,8 @@ sdivV sym = PFinPoly \w -> PWordFun \x -> PWordFun \y -> - PVal (VWord w (WordVal <$> wordSignedDiv sym x y)) + PRange \rng -> + PVal (VWord w (WordVal <$> wordSignedDiv sym rng x y)) {-# SPECIALIZE smodV :: Concrete -> Prim Concrete #-} smodV :: Backend sym => sym -> Prim sym @@ -693,7 +705,8 @@ smodV sym = PFinPoly \w -> PWordFun \x -> PWordFun \y -> - PVal (VWord w (WordVal <$> wordSignedMod sym x y)) + PRange \rng -> + PVal (VWord w (WordVal <$> wordSignedMod sym rng x y)) -- Cmp ------------------------------------------------------------------------- @@ -824,31 +837,31 @@ lexCombine sym cmp eq k = {-# INLINE eqV #-} eqV :: Backend sym => sym -> Binary sym -eqV sym ty v1 v2 = VBit <$> valEq sym ty v1 v2 +eqV sym _rng ty v1 v2 = VBit <$> valEq sym ty v1 v2 {-# INLINE distinctV #-} distinctV :: Backend sym => sym -> Binary sym -distinctV sym ty v1 v2 = VBit <$> (bitComplement sym =<< valEq sym ty v1 v2) +distinctV sym _rng ty v1 v2 = VBit <$> (bitComplement sym =<< valEq sym ty v1 v2) {-# INLINE lessThanV #-} lessThanV :: Backend sym => sym -> Binary sym -lessThanV sym ty v1 v2 = VBit <$> valLt sym ty v1 v2 (bitLit sym False) +lessThanV sym _rng ty v1 v2 = VBit <$> valLt sym ty v1 v2 (bitLit sym False) {-# INLINE lessThanEqV #-} lessThanEqV :: Backend sym => sym -> Binary sym -lessThanEqV sym ty v1 v2 = VBit <$> valLt sym ty v1 v2 (bitLit sym True) +lessThanEqV sym _rng ty v1 v2 = VBit <$> valLt sym ty v1 v2 (bitLit sym True) {-# INLINE greaterThanV #-} greaterThanV :: Backend sym => sym -> Binary sym -greaterThanV sym ty v1 v2 = VBit <$> valGt sym ty v1 v2 (bitLit sym False) +greaterThanV sym _rng ty v1 v2 = VBit <$> valGt sym ty v1 v2 (bitLit sym False) {-# INLINE greaterThanEqV #-} greaterThanEqV :: Backend sym => sym -> Binary sym -greaterThanEqV sym ty v1 v2 = VBit <$> valGt sym ty v1 v2 (bitLit sym True) +greaterThanEqV sym _rng ty v1 v2 = VBit <$> valGt sym ty v1 v2 (bitLit sym True) {-# INLINE signedLessThanV #-} signedLessThanV :: Backend sym => sym -> Binary sym -signedLessThanV sym ty v1 v2 = VBit <$> cmpValue sym fb fw fi fz fq ff ty v1 v2 (pure $ bitLit sym False) +signedLessThanV sym _rng ty v1 v2 = VBit <$> cmpValue sym fb fw fi fz fq ff ty v1 v2 (pure $ bitLit sym False) where fb _ _ _ = panic "signedLessThan" ["Attempted to perform signed comparison on bit type"] fw x y k = lexCombine sym (wordSignedLessThan sym x y) (wordEq sym x y) k @@ -861,15 +874,17 @@ signedLessThanV sym ty v1 v2 = VBit <$> cmpValue sym fb fw fi fz fq ff ty v1 v2 {-# SPECIALIZE zeroV :: Concrete -> + Range -> TValue -> SEval Concrete (GenValue Concrete) #-} zeroV :: forall sym. Backend sym => sym -> + Range -> TValue -> SEval sym (GenValue sym) -zeroV sym ty = case ty of +zeroV sym rng ty = case ty of -- bits TVBit -> @@ -896,26 +911,26 @@ zeroV sym ty = case ty of TVSeq w ety | isTBit ety -> pure $ word sym w 0 | otherwise -> - do z <- sDelay sym Nothing (zeroV sym ety) - pure $ VSeq w (IndexSeqMap $ const z) + do z <- sDelay sym rng Nothing (zeroV sym rng ety) + pure $ VSeq w (IndexSeqMap \_i -> z) TVStream ety -> - do z <- sDelay sym Nothing (zeroV sym ety) - pure $ VStream (IndexSeqMap $ const z) + do z <- sDelay sym rng Nothing (zeroV sym rng ety) + pure $ VStream (IndexSeqMap \_i -> z) -- functions TVFun _ bty -> - do z <- sDelay sym Nothing (zeroV sym bty) + do z <- sDelay sym rng Nothing (zeroV sym rng bty) pure $ lam (const z) -- tuples TVTuple tys -> - do xs <- mapM (sDelay sym Nothing . zeroV sym) tys + do xs <- mapM (sDelay sym rng Nothing . zeroV sym rng) tys pure $ VTuple xs -- records TVRec fields -> - do xs <- traverse (sDelay sym Nothing . zeroV sym) fields + do xs <- traverse (sDelay sym rng Nothing . zeroV sym rng) fields pure $ VRecord xs TVAbstract {} -> evalPanic "zeroV" [ "Abstract type not in `Zero`" ] @@ -935,6 +950,7 @@ joinWordVal sym w1 w2 {-# SPECIALIZE joinWords :: Concrete -> + Range -> Integer -> Integer -> SeqMap Concrete -> @@ -943,17 +959,18 @@ joinWordVal sym w1 w2 joinWords :: forall sym. Backend sym => sym -> + Range -> Integer -> Integer -> SeqMap sym -> SEval sym (GenValue sym) -joinWords sym nParts nEach xs = +joinWords sym rng nParts nEach xs = loop (WordVal <$> wordLit sym 0 0) (enumerateSeqMap nParts xs) where loop :: SEval sym (WordValue sym) -> [SEval sym (GenValue sym)] -> SEval sym (GenValue sym) loop !wv [] = - VWord (nParts * nEach) <$> sDelay sym Nothing wv + VWord (nParts * nEach) <$> sDelay sym rng Nothing wv loop !wv (w : ws) = w >>= \case VWord _ w' -> @@ -962,6 +979,7 @@ joinWords sym nParts nEach xs = {-# SPECIALIZE joinSeq :: Concrete -> + Range -> Nat' -> Integer -> TValue -> @@ -971,6 +989,7 @@ joinWords sym nParts nEach xs = joinSeq :: Backend sym => sym -> + Range -> Nat' -> Integer -> TValue -> @@ -978,29 +997,29 @@ joinSeq :: SEval sym (GenValue sym) -- Special case for 0 length inner sequences. -joinSeq sym _parts 0 a _xs - = zeroV sym (TVSeq 0 a) +joinSeq sym rng _parts 0 a _xs + = zeroV sym rng (TVSeq 0 a) -- finite sequence of words -joinSeq sym (Nat parts) each TVBit xs +joinSeq sym rng (Nat parts) each TVBit xs | parts * each < largeBitSize - = joinWords sym parts each xs + = joinWords sym rng parts each xs | otherwise = do let zs = IndexSeqMap $ \i -> do let (q,r) = divMod i each ys <- fromWordVal "join seq" =<< lookupSeqMap xs q - VBit <$> indexWordValue sym ys r + VBit <$> indexWordValue sym rng ys r return $ VWord (parts * each) $ pure $ LargeBitsVal (parts * each) zs -- infinite sequence of words -joinSeq sym Inf each TVBit xs +joinSeq sym rng Inf each TVBit xs = return $ VStream $ IndexSeqMap $ \i -> do let (q,r) = divMod i each ys <- fromWordVal "join seq" =<< lookupSeqMap xs q - VBit <$> indexWordValue sym ys r + VBit <$> indexWordValue sym rng ys r -- finite or infinite sequence of non-words -joinSeq _sym parts each _a xs +joinSeq _sym _rng parts each _a xs = return $ vSeq $ IndexSeqMap $ \i -> do let (q,r) = divMod i each ys <- fromSeq "join seq" =<< lookupSeqMap xs q @@ -1018,12 +1037,13 @@ joinSeq _sym parts each _a xs joinV :: Backend sym => sym -> + Range -> Nat' -> Integer -> TValue -> GenValue sym -> SEval sym (GenValue sym) -joinV sym parts each a val = joinSeq sym parts each a =<< fromSeq "joinV" val +joinV sym rng parts each a val = joinSeq sym rng parts each a =<< fromSeq "joinV" val {-# INLINE splitWordVal #-} @@ -1046,33 +1066,34 @@ splitWordVal _ leftWidth rightWidth (LargeBitsVal _n xs) = splitAtV :: Backend sym => sym -> + Range -> Nat' -> Nat' -> TValue -> GenValue sym -> SEval sym (GenValue sym) -splitAtV sym front back a val = +splitAtV sym rng front back a val = case back of Nat rightWidth | aBit -> do - ws <- sDelay sym Nothing (splitWordVal sym leftWidth rightWidth =<< fromWordVal "splitAtV" val) + ws <- sDelay sym rng Nothing (splitWordVal sym leftWidth rightWidth =<< fromWordVal "splitAtV" val) return $ VTuple [ VWord leftWidth . pure . fst <$> ws , VWord rightWidth . pure . snd <$> ws ] Inf | aBit -> do - vs <- sDelay sym Nothing (fromSeq "splitAtV" val) - ls <- sDelay sym Nothing (fst . splitSeqMap leftWidth <$> vs) - rs <- sDelay sym Nothing (snd . splitSeqMap leftWidth <$> vs) + vs <- sDelay sym rng Nothing (fromSeq "splitAtV" val) + ls <- sDelay sym rng Nothing (fst . splitSeqMap leftWidth <$> vs) + rs <- sDelay sym rng Nothing (snd . splitSeqMap leftWidth <$> vs) return $ VTuple [ return $ VWord leftWidth (LargeBitsVal leftWidth <$> ls) , VStream <$> rs ] _ -> do - vs <- sDelay sym Nothing (fromSeq "splitAtV" val) - ls <- sDelay sym Nothing (fst . splitSeqMap leftWidth <$> vs) - rs <- sDelay sym Nothing (snd . splitSeqMap leftWidth <$> vs) + vs <- sDelay sym rng Nothing (fromSeq "splitAtV" val) + ls <- sDelay sym rng Nothing (fst . splitSeqMap leftWidth <$> vs) + rs <- sDelay sym rng Nothing (snd . splitSeqMap leftWidth <$> vs) return $ VTuple [ VSeq leftWidth <$> ls , mkSeq back a <$> rs ] @@ -1116,6 +1137,7 @@ ecSplitV sym = PNumPoly \each -> PTyPoly \a -> PFun \val -> + PRange \rng -> PPrim case (parts, each) of (Nat p, Nat e) | isTBit a -> do @@ -1123,7 +1145,7 @@ ecSplitV sym = return $ VSeq p $ IndexSeqMap $ \i -> pure $ VWord e (extractWordVal sym e ((p-i-1)*e) =<< val') (Inf, Nat e) | isTBit a -> do - val' <- sDelay sym Nothing (fromSeq "ecSplitV" =<< val) + val' <- sDelay sym rng Nothing (fromSeq "ecSplitV" =<< val) return $ VStream $ IndexSeqMap $ \i -> return $ VWord e $ return $ LargeBitsVal e $ IndexSeqMap $ \j -> let idx = i*e + toInteger j @@ -1131,13 +1153,13 @@ ecSplitV sym = xs <- val' lookupSeqMap xs idx (Nat p, Nat e) -> do - val' <- sDelay sym Nothing (fromSeq "ecSplitV" =<< val) + val' <- sDelay sym rng Nothing (fromSeq "ecSplitV" =<< val) return $ VSeq p $ IndexSeqMap $ \i -> return $ VSeq e $ IndexSeqMap $ \j -> do xs <- val' lookupSeqMap xs (e * i + j) (Inf , Nat e) -> do - val' <- sDelay sym Nothing (fromSeq "ecSplitV" =<< val) + val' <- sDelay sym rng Nothing (fromSeq "ecSplitV" =<< val) return $ VStream $ IndexSeqMap $ \i -> return $ VSeq e $ IndexSeqMap $ \j -> do xs <- val' @@ -1166,35 +1188,39 @@ reverseV _ _ = transposeV :: Backend sym => sym -> + Range -> Nat' -> Nat' -> TValue -> GenValue sym -> SEval sym (GenValue sym) -transposeV sym a b c xs +transposeV sym rng a b c xs | isTBit c, Nat na <- a = -- Fin a => [a][b]Bit -> [b][a]Bit return $ bseq $ IndexSeqMap $ \bi -> return $ VWord na $ return $ LargeBitsVal na $ IndexSeqMap $ \ai -> - do ys <- flip lookupSeqMap (toInteger ai) =<< fromSeq "transposeV" xs + do xs' <- fromSeq "transposeV" xs + ys <- lookupSeqMap xs' ai case ys of VStream ys' -> lookupSeqMap ys' bi - VWord _ wv -> VBit <$> (flip (indexWordValue sym) bi =<< wv) + VWord _ wv -> VBit <$> (flip (indexWordValue sym rng) bi =<< wv) _ -> evalPanic "transpose" ["expected sequence of bits"] | isTBit c, Inf <- a = -- [inf][b]Bit -> [b][inf]Bit return $ bseq $ IndexSeqMap $ \bi -> return $ VStream $ IndexSeqMap $ \ai -> - do ys <- flip lookupSeqMap ai =<< fromSeq "transposeV" xs + do xs' <- fromSeq "transposeV" xs + ys <- lookupSeqMap xs' ai case ys of VStream ys' -> lookupSeqMap ys' bi - VWord _ wv -> VBit <$> (flip (indexWordValue sym) bi =<< wv) + VWord _ wv -> VBit <$> (flip (indexWordValue sym rng) bi =<< wv) _ -> evalPanic "transpose" ["expected sequence of bits"] | otherwise = -- [a][b]c -> [b][a]c return $ bseq $ IndexSeqMap $ \bi -> return $ aseq $ IndexSeqMap $ \ai -> do - ys <- flip lookupSeqMap ai =<< fromSeq "transposeV 1" xs - z <- flip lookupSeqMap bi =<< fromSeq "transposeV 2" ys + xs' <- fromSeq "transposeV 1" xs + ys <- fromSeq "transposeV 2" =<< lookupSeqMap xs' ai + z <- lookupSeqMap ys bi return z where @@ -1213,6 +1239,7 @@ transposeV sym a b c xs ccatV :: Backend sym => sym -> + Range -> Nat' -> Nat' -> TValue -> @@ -1220,20 +1247,20 @@ ccatV :: (GenValue sym) -> SEval sym (GenValue sym) -ccatV sym _front _back _elty (VWord m l) (VWord n r) = +ccatV sym _rng _front _back _elty (VWord m l) (VWord n r) = return $ VWord (m+n) (join (joinWordVal sym <$> l <*> r)) -ccatV sym _front _back _elty (VWord m l) (VStream r) = do - l' <- sDelay sym Nothing l +ccatV sym rng _front _back _elty (VWord m l) (VStream r) = do + l' <- sDelay sym rng Nothing l return $ VStream $ IndexSeqMap $ \i -> if i < m then - VBit <$> (flip (indexWordValue sym) i =<< l') + VBit <$> (flip (indexWordValue sym rng) i =<< l') else lookupSeqMap r (i-m) -ccatV sym front back elty l r = do - l'' <- sDelay sym Nothing (fromSeq "ccatV left" l) - r'' <- sDelay sym Nothing (fromSeq "ccatV right" r) +ccatV sym rng front back elty l r = do + l'' <- sDelay sym rng Nothing (fromSeq "ccatV left" l) + r'' <- sDelay sym rng Nothing (fromSeq "ccatV right" r) let Nat n = front mkSeq (evalTF TCAdd [front,back]) elty <$> return (IndexSeqMap $ \i -> if i < n then do @@ -1275,7 +1302,7 @@ logicBinary :: forall sym. (SBit sym -> SBit sym -> SEval sym (SBit sym)) -> (SWord sym -> SWord sym -> SEval sym (SWord sym)) -> Binary sym -logicBinary sym opb opw = loop +logicBinary sym opb opw rng = loop where loop' :: TValue -> SEval sym (GenValue sym) @@ -1299,7 +1326,7 @@ logicBinary sym opb opw = loop TVSeq w aty -- words | isTBit aty - -> do v <- sDelay sym Nothing $ join + -> do v <- sDelay sym rng Nothing $ join (wordValLogicOp sym opb opw <$> fromWordVal "logicBinary l" l <*> fromWordVal "logicBinary r" r) @@ -1317,8 +1344,8 @@ logicBinary sym opb opw = loop (fromSeq "logicBinary right" r))) TVTuple etys -> do - ls <- mapM (sDelay sym Nothing) (fromVTuple l) - rs <- mapM (sDelay sym Nothing) (fromVTuple r) + ls <- mapM (sDelay sym rng Nothing) (fromVTuple l) + rs <- mapM (sDelay sym rng Nothing) (fromVTuple r) return $ VTuple $ zipWith3 loop' etys ls rs TVFun _ bty -> @@ -1327,7 +1354,7 @@ logicBinary sym opb opw = loop TVRec fields -> VRecord <$> traverseRecordMap - (\f fty -> sDelay sym Nothing (loop' fty (lookupRecord f l) (lookupRecord f r))) + (\f fty -> sDelay sym rng Nothing (loop' fty (lookupRecord f l) (lookupRecord f r))) fields TVAbstract {} -> evalPanic "logicBinary" @@ -1357,7 +1384,7 @@ logicUnary :: forall sym. (SBit sym -> SEval sym (SBit sym)) -> (SWord sym -> SEval sym (SWord sym)) -> Unary sym -logicUnary sym opb opw = loop +logicUnary sym opb opw rng = loop where loop' :: TValue -> SEval sym (GenValue sym) -> SEval sym (GenValue sym) loop' ty val = loop ty =<< val @@ -1375,7 +1402,7 @@ logicUnary sym opb opw = loop TVSeq w ety -- words | isTBit ety - -> do v <- sDelay sym Nothing (wordValUnaryOp opb opw =<< fromWordVal "logicUnary" val) + -> do v <- sDelay sym rng Nothing (wordValUnaryOp opb opw =<< fromWordVal "logicUnary" val) return $ VWord w v -- finite sequences @@ -1387,7 +1414,7 @@ logicUnary sym opb opw = loop VStream <$> (mapSeqMap (loop ety) =<< fromSeq "logicUnary" val) TVTuple etys -> - do as <- mapM (sDelay sym Nothing) (fromVTuple val) + do as <- mapM (sDelay sym rng Nothing) (fromVTuple val) return $ VTuple (zipWith loop' etys as) TVFun _ bty -> @@ -1396,7 +1423,7 @@ logicUnary sym opb opw = loop TVRec fields -> VRecord <$> traverseRecordMap - (\f fty -> sDelay sym Nothing (loop' fty (lookupRecord f val))) + (\f fty -> sDelay sym rng Nothing (loop' fty (lookupRecord f val))) fields TVAbstract {} -> evalPanic "logicUnary" [ "Abstract type not in `Logic`" ] @@ -1432,52 +1459,53 @@ bitsValueLessThan sym w (b:bs) n assertIndexInBounds :: Backend sym => sym -> + Range -> Nat' {- ^ Sequence size bounds -} -> Either (SInteger sym) (WordValue sym) {- ^ Index value -} -> SEval sym () -- All nonnegative integers are in bounds for an infinite sequence -assertIndexInBounds sym Inf (Left idx) = +assertIndexInBounds sym rng Inf (Left idx) = do ppos <- bitComplement sym =<< intLessThan sym idx =<< integerLit sym 0 - assertSideCondition sym ppos (InvalidIndex (integerAsLit sym idx)) + assertSideCondition sym ppos (EvalErrorEx rng (InvalidIndex (integerAsLit sym idx))) -- If the index is an integer, test that it -- is nonnegative and less than the concrete value of n. -assertIndexInBounds sym (Nat n) (Left idx) = +assertIndexInBounds sym rng (Nat n) (Left idx) = do n' <- integerLit sym n ppos <- bitComplement sym =<< intLessThan sym idx =<< integerLit sym 0 pn <- intLessThan sym idx n' p <- bitAnd sym ppos pn - assertSideCondition sym p (InvalidIndex (integerAsLit sym idx)) + assertSideCondition sym p (EvalErrorEx rng (InvalidIndex (integerAsLit sym idx))) -- Bitvectors can't index out of bounds for an infinite sequence -assertIndexInBounds _sym Inf (Right _) = return () +assertIndexInBounds _sym _rng Inf (Right _) = return () -- Can't index out of bounds for a sequence that is -- longer than the expressible index values -assertIndexInBounds sym (Nat n) (Right idx) +assertIndexInBounds sym _rng (Nat n) (Right idx) | n >= 2^(wordValueSize sym idx) = return () -- If the index is concrete, test it directly -assertIndexInBounds sym (Nat n) (Right (WordVal idx)) +assertIndexInBounds sym rng (Nat n) (Right (WordVal idx)) | Just (_w,i) <- wordAsLit sym idx - = unless (i < n) (raiseError sym (InvalidIndex (Just i))) + = unless (i < n) (raiseError sym (EvalErrorEx rng (InvalidIndex (Just i)))) -- If the index is a packed word, test that it -- is less than the concrete value of n, which -- fits into w bits because of the above test. -assertIndexInBounds sym (Nat n) (Right (WordVal idx)) = +assertIndexInBounds sym rng (Nat n) (Right (WordVal idx)) = do n' <- wordLit sym (wordLen sym idx) n p <- wordLessThan sym idx n' - assertSideCondition sym p (InvalidIndex Nothing) + assertSideCondition sym p (EvalErrorEx rng (InvalidIndex Nothing)) -- If the index is an unpacked word, force all the bits -- and compute the unsigned less-than test directly. -assertIndexInBounds sym (Nat n) (Right (LargeBitsVal w bits)) = +assertIndexInBounds sym rng (Nat n) (Right (LargeBitsVal w bits)) = do bitsList <- traverse (fromVBit <$>) (enumerateSeqMap w bits) p <- bitsValueLessThan sym w bitsList n - assertSideCondition sym p (InvalidIndex Nothing) + assertSideCondition sym p (EvalErrorEx rng (InvalidIndex Nothing)) -- | Indexing operations. @@ -1486,9 +1514,9 @@ assertIndexInBounds sym (Nat n) (Right (LargeBitsVal w bits)) = indexPrim :: Backend sym => sym -> - (Nat' -> TValue -> SeqMap sym -> TValue -> SInteger sym -> SEval sym (GenValue sym)) -> - (Nat' -> TValue -> SeqMap sym -> TValue -> [SBit sym] -> SEval sym (GenValue sym)) -> - (Nat' -> TValue -> SeqMap sym -> TValue -> SWord sym -> SEval sym (GenValue sym)) -> + (Range -> Nat' -> TValue -> SeqMap sym -> TValue -> SInteger sym -> SEval sym (GenValue sym)) -> + (Range -> Nat' -> TValue -> SeqMap sym -> TValue -> [SBit sym] -> SEval sym (GenValue sym)) -> + (Range -> Nat' -> TValue -> SeqMap sym -> TValue -> SWord sym -> SEval sym (GenValue sym)) -> Prim sym indexPrim sym int_op bits_op word_op = PNumPoly \len -> @@ -1496,26 +1524,27 @@ indexPrim sym int_op bits_op word_op = PTyPoly \ix -> PFun \xs -> PFun \idx -> + PRange \rng -> PPrim do vs <- xs >>= \case - VWord _ w -> w >>= \w' -> return $ IndexSeqMap (\i -> VBit <$> indexWordValue sym w' i) + VWord _ w -> w >>= \w' -> return $ IndexSeqMap (\i -> VBit <$> indexWordValue sym rng w' i) VSeq _ vs -> return vs VStream vs -> return vs _ -> evalPanic "Expected sequence value" ["indexPrim"] idx' <- asIndex sym "index" ix =<< idx - assertIndexInBounds sym len idx' + assertIndexInBounds sym rng len idx' case idx' of - Left i -> int_op len eltTy vs ix i - Right (WordVal w') -> word_op len eltTy vs ix w' - Right (LargeBitsVal m bs) -> bits_op len eltTy vs ix =<< traverse (fromVBit <$>) (enumerateSeqMap m bs) + Left i -> int_op rng len eltTy vs ix i + Right (WordVal w') -> word_op rng len eltTy vs ix w' + Right (LargeBitsVal m bs) -> bits_op rng len eltTy vs ix =<< traverse (fromVBit <$>) (enumerateSeqMap m bs) {-# INLINE updatePrim #-} updatePrim :: Backend sym => sym -> - (Nat' -> TValue -> WordValue sym -> Either (SInteger sym) (WordValue sym) -> SEval sym (GenValue sym) -> SEval sym (WordValue sym)) -> - (Nat' -> TValue -> SeqMap sym -> Either (SInteger sym) (WordValue sym) -> SEval sym (GenValue sym) -> SEval sym (SeqMap sym)) -> + (Range -> Nat' -> TValue -> WordValue sym -> Either (SInteger sym) (WordValue sym) -> SEval sym (GenValue sym) -> SEval sym (WordValue sym)) -> + (Range -> Nat' -> TValue -> SeqMap sym -> Either (SInteger sym) (WordValue sym) -> SEval sym (GenValue sym) -> SEval sym (SeqMap sym)) -> Prim sym updatePrim sym updateWord updateSeq = PNumPoly \len -> @@ -1524,14 +1553,15 @@ updatePrim sym updateWord updateSeq = PFun \xs -> PFun \idx -> PFun \val -> + PRange \rng -> PPrim do idx' <- asIndex sym "update" ix =<< idx - assertIndexInBounds sym len idx' + assertIndexInBounds sym rng len idx' xs >>= \case - VWord l w -> do w' <- sDelay sym Nothing w - return $ VWord l (w' >>= \w'' -> updateWord len eltTy w'' idx' val) - VSeq l vs -> VSeq l <$> updateSeq len eltTy vs idx' val - VStream vs -> VStream <$> updateSeq len eltTy vs idx' val + VWord l w -> do w' <- sDelay sym rng Nothing w + return $ VWord l (w' >>= \w'' -> updateWord rng len eltTy w'' idx' val) + VSeq l vs -> VSeq l <$> updateSeq rng len eltTy vs idx' val + VStream vs -> VStream <$> updateSeq rng len eltTy vs idx' val _ -> evalPanic "Expected sequence value" ["updatePrim"] {-# INLINE fromToV #-} @@ -1573,12 +1603,13 @@ infFromV :: Backend sym => sym -> Prim sym infFromV sym = PTyPoly \ty -> PFun \x -> + PRange \rng -> PPrim - do mx <- sDelay sym Nothing x + do mx <- sDelay sym rng Nothing x return $ VStream $ IndexSeqMap $ \i -> do x' <- mx i' <- integerLit sym i - addV sym ty x' =<< intV sym i' ty + addV sym rng ty x' =<< intV sym rng i' ty {-# INLINE infFromThenV #-} infFromThenV :: Backend sym => sym -> Prim sym @@ -1586,16 +1617,17 @@ infFromThenV sym = PTyPoly \ty -> PFun \first -> PFun \next -> + PRange \rng -> PPrim - do mxd <- sDelay sym Nothing + do mxd <- sDelay sym rng Nothing (do x <- first y <- next - d <- subV sym ty y x + d <- subV sym rng ty y x pure (x,d)) return $ VStream $ IndexSeqMap $ \i -> do (x,d) <- mxd i' <- integerLit sym i - addV sym ty x =<< mulV sym ty d =<< intV sym i' ty + addV sym rng ty x =<< mulV sym rng ty d =<< intV sym rng i' ty -- Shifting --------------------------------------------------- @@ -1701,6 +1733,7 @@ logicShift sym nm shrinkRange wopPos wopNeg reindexPos reindexNeg = PTyPoly \a -> PFun \xs -> PFun \y -> + PRange \rng -> PPrim do xs' <- xs y' <- asIndex sym "shift" ix =<< y @@ -1708,13 +1741,14 @@ logicShift sym nm shrinkRange wopPos wopNeg reindexPos reindexNeg = Left int_idx -> do pneg <- intLessThan sym int_idx =<< integerLit sym 0 iteValue sym pneg - (intShifter sym nm wopNeg reindexNeg m ix a xs' =<< shrinkRange sym m ix =<< intNegate sym int_idx) - (intShifter sym nm wopPos reindexPos m ix a xs' =<< shrinkRange sym m ix int_idx) + (intShifter sym rng nm wopNeg reindexNeg m ix a xs' =<< shrinkRange sym m ix =<< intNegate sym int_idx) + (intShifter sym rng nm wopPos reindexPos m ix a xs' =<< shrinkRange sym m ix int_idx) Right idx -> - wordShifter sym nm wopPos reindexPos m a xs' idx + wordShifter sym rng nm wopPos reindexPos m a xs' idx intShifter :: Backend sym => sym -> + Range -> String -> (SWord sym -> SWord sym -> SEval sym (SWord sym)) -> (Nat' -> Integer -> Integer -> Maybe Integer) -> @@ -1724,11 +1758,11 @@ intShifter :: Backend sym => GenValue sym -> SInteger sym -> SEval sym (GenValue sym) -intShifter sym nm wop reindex m ix a xs idx = +intShifter sym rng nm wop reindex m ix a xs idx = do let shiftOp vs shft = memoMap $ IndexSeqMap $ \i -> case reindex m i shft of - Nothing -> zeroV sym a + Nothing -> zeroV sym rng a Just i' -> lookupSeqMap vs i' case xs of VWord w x -> @@ -1752,6 +1786,7 @@ intShifter sym nm wop reindex m ix a xs idx = wordShifter :: Backend sym => sym -> + Range -> String -> (SWord sym -> SWord sym -> SEval sym (SWord sym)) -> (Nat' -> Integer -> Integer -> Maybe Integer) -> @@ -1760,11 +1795,11 @@ wordShifter :: Backend sym => GenValue sym -> WordValue sym -> SEval sym (GenValue sym) -wordShifter sym nm wop reindex m a xs idx = +wordShifter sym rng nm wop reindex m a xs idx = let shiftOp vs shft = memoMap $ IndexSeqMap $ \i -> case reindex m i shft of - Nothing -> zeroV sym a + Nothing -> zeroV sym rng a Just i' -> lookupSeqMap vs i' in case xs of VWord w x -> @@ -1798,12 +1833,13 @@ rotateShrink _sym Inf _ _ = panic "rotateShrink" ["expected finite sequence in r rotateShrink sym (Nat 0) _ _ = integerLit sym 0 rotateShrink sym (Nat w) _ x = do w' <- integerLit sym w - intMod sym x w' + intMod sym emptyRange x w' -- Miscellaneous --------------------------------------------------------------- {-# SPECIALIZE errorV :: Concrete -> + Range -> TValue -> String -> SEval Concrete (GenValue Concrete) @@ -1811,39 +1847,43 @@ rotateShrink sym (Nat w) _ x = errorV :: forall sym. Backend sym => sym -> + Range -> TValue -> String -> SEval sym (GenValue sym) -errorV sym ty msg = case ty of - -- bits - TVBit -> cryUserError sym msg - TVInteger -> cryUserError sym msg - TVIntMod _ -> cryUserError sym msg - TVRational -> cryUserError sym msg - TVArray{} -> cryUserError sym msg - TVFloat {} -> cryUserError sym msg +errorV sym rng ty msg = + let err = cryUserError sym rng msg in + case ty of + -- bits + TVBit -> err + TVInteger -> err + TVIntMod _ -> err + TVRational -> err + TVArray{} -> err + TVFloat {} -> err + + -- sequences + TVSeq w ety + | isTBit ety -> return $ VWord w $ return $ LargeBitsVal w $ IndexSeqMap $ \_ -> err + | otherwise -> return $ VSeq w (IndexSeqMap $ \_ -> errorV sym rng ety msg) - -- sequences - TVSeq w ety - | isTBit ety -> return $ VWord w $ return $ LargeBitsVal w $ IndexSeqMap $ \_ -> cryUserError sym msg - | otherwise -> return $ VSeq w (IndexSeqMap $ \_ -> errorV sym ety msg) + TVStream ety -> + return $ VStream (IndexSeqMap $ \_ -> errorV sym rng ety msg) - TVStream ety -> - return $ VStream (IndexSeqMap $ \_ -> errorV sym ety msg) + -- functions + TVFun _ bty -> + return $ lam (\ _ -> errorV sym rng bty msg) - -- functions - TVFun _ bty -> - return $ lam (\ _ -> errorV sym bty msg) + -- tuples + TVTuple tys -> + return $ VTuple (map (\t -> errorV sym rng t msg) tys) - -- tuples - TVTuple tys -> - return $ VTuple (map (\t -> errorV sym t msg) tys) + -- records + TVRec fields -> + return $ VRecord $ fmap (\t -> errorV sym rng t msg) $ fields - -- records - TVRec fields -> - return $ VRecord $ fmap (\t -> errorV sym t msg) $ fields + TVAbstract {} -> err - TVAbstract {} -> cryUserError sym msg {-# INLINE valueToChar #-} @@ -1953,7 +1993,7 @@ foldlV sym = PTyPoly \_b -> PFun \f -> PFun \z -> - PStrictFun \v -> + PStrict \v -> PPrim case v of VSeq n m -> go0 f z (enumerateSeqMap n m) @@ -1977,40 +2017,41 @@ foldl'V sym = PTyPoly \_b -> PFun \f -> PFun \z -> - PStrictFun \v -> + PStrict \v -> + PRange \rng -> PPrim case v of - VSeq n m -> go0 f z (enumerateSeqMap n m) - VWord _n wv -> go0 f z . map (pure . VBit) =<< (enumerateWordValue sym =<< wv) + VSeq n m -> go0 rng f z (enumerateSeqMap n m) + VWord _n wv -> go0 rng f z . map (pure . VBit) =<< (enumerateWordValue sym =<< wv) _ -> panic "Cryptol.Eval.Generic.foldlV" ["Expected finite sequence"] where - go0 _f a [] = a - go0 f a bs = + go0 _rng _f a [] = a + go0 rng f a bs = do f' <- fromVFun <$> f - a' <- sDelay sym Nothing a + a' <- sDelay sym rng Nothing a forceValue =<< a' - go1 f' a' bs + go1 rng f' a' bs - go1 _f a [] = a - go1 f a (b:bs) = + go1 _rng _f a [] = a + go1 rng f a (b:bs) = do f' <- fromVFun <$> (f a) - a' <- sDelay sym Nothing (f' b) + a' <- sDelay sym rng Nothing (f' b) forceValue =<< a' - go1 f a' bs + go1 rng f a' bs -- Random Values --------------------------------------------------------------- {-# SPECIALIZE randomV :: - Concrete -> TValue -> Integer -> SEval Concrete (GenValue Concrete) + Concrete -> Range -> TValue -> Integer -> SEval Concrete (GenValue Concrete) #-} -- | Produce a random value with the given seed. If we do not support -- making values of the given type, return zero of that type. -- TODO: do better than returning zero -randomV :: Backend sym => sym -> TValue -> Integer -> SEval sym (GenValue sym) -randomV sym ty seed = +randomV :: Backend sym => sym -> Range -> TValue -> Integer -> SEval sym (GenValue sym) +randomV sym rng ty seed = case randomValue sym ty of - Nothing -> zeroV sym ty + Nothing -> zeroV sym rng ty Just gen -> -- unpack the seed into four Word64s let mask64 = 0xFFFFFFFFFFFFFFFF @@ -2028,16 +2069,17 @@ parmapV sym = PFinPoly \_n -> PFun \f -> PFun \xs -> + PRange \rng -> PPrim do f' <- fromVFun <$> f xs' <- xs case xs' of VWord n w -> do m <- asBitsMap sym <$> w - m' <- sparkParMap sym f' n m + m' <- sparkParMap sym rng f' n m pure (VWord n (pure (LargeBitsVal n m'))) VSeq n m -> - VSeq n <$> sparkParMap sym f' n m + VSeq n <$> sparkParMap sym rng f' n m _ -> panic "parmapV" ["expected sequence!"] @@ -2045,15 +2087,16 @@ parmapV sym = sparkParMap :: Backend sym => sym -> + Range -> (SEval sym (GenValue sym) -> SEval sym (GenValue sym)) -> Integer -> SeqMap sym -> SEval sym (SeqMap sym) -sparkParMap sym f n m = - finiteSeqMap sym <$> mapM (sSpark sym . g) (enumerateSeqMap n m) +sparkParMap sym rng f n m = + finiteSeqMap <$> mapM (sSpark sym rng . g) (enumerateSeqMap n m) where g x = - do z <- sDelay sym Nothing (f x) + do z <- sDelay sym rng Nothing (f x) forceValue =<< z z @@ -2068,7 +2111,8 @@ fpBinArithV sym fun = PWordFun \r -> PFloatFun \x -> PFloatFun \y -> - PPrim (VFloat <$> fun sym r x y) + PRange \rng -> + PPrim (VFloat <$> fun sym rng r x y) -- | Rounding mode used in FP operations that do not specify it explicitly. fpRndMode, fpRndRNE, fpRndRNA, fpRndRTP, fpRndRTN, fpRndRTZ :: @@ -2099,7 +2143,9 @@ genericPrimTable sym = -- Zero , ("zero" , {-# SCC "Prelude::zero" #-} - PTyPoly (PPrim . zeroV sym)) + PTyPoly \ty -> + PRange \rng -> + PPrim (zeroV sym rng ty)) -- Logic , ("&&" , {-# SCC "Prelude::(&&)" #-} @@ -2194,14 +2240,16 @@ genericPrimTable sym = PTyPoly \elty -> PFun \l -> PFun \r -> - PPrim (join (ccatV sym (Nat front) back elty <$> l <*> r))) + PRange \rng -> + PPrim (join (ccatV sym rng (Nat front) back elty <$> l <*> r))) , ("join" , {-# SCC "Prelude::join" #-} PNumPoly \parts -> PFinPoly \each -> PTyPoly \a -> - PStrictFun \x -> - PPrim $ joinV sym parts each a x) + PStrict \x -> + PRange \rng -> + PPrim $ joinV sym rng parts each a x) , ("split" , {-# SCC "Prelude::split" #-} ecSplitV sym) @@ -2210,21 +2258,23 @@ genericPrimTable sym = PNumPoly \front -> PNumPoly \back -> PTyPoly \a -> - PStrictFun \x -> - PPrim $ splitAtV sym front back a x) + PStrict \x -> + PRange \rng -> + PPrim $ splitAtV sym rng front back a x) , ("reverse" , {-# SCC "Prelude::reverse" #-} PFinPoly \_a -> PTyPoly \_b -> - PStrictFun \xs -> + PStrict \xs -> PPrim $ reverseV sym xs) , ("transpose" , {-# SCC "Prelude::transpose" #-} PNumPoly \a -> PNumPoly \b -> PTyPoly \c -> - PStrictFun \xs -> - PPrim $ transposeV sym a b c xs) + PStrict \xs -> + PRange \rng -> + PPrim $ transposeV sym rng a b c xs) -- Misc @@ -2232,15 +2282,17 @@ genericPrimTable sym = , ("error" , {-# SCC "Prelude::error" #-} PTyPoly \a -> PFinPoly \_ -> - PStrictFun \s -> - PPrim (errorV sym a =<< valueToString sym s)) + PStrict \s -> + PRange \rng -> + PPrim (errorV sym rng a =<< valueToString sym s)) , ("random" , {-# SCC "Prelude::random" #-} PTyPoly \a -> PWordFun \x -> + PRange \rng -> PPrim case wordAsLit sym x of - Just (_,i) -> randomV sym a i + Just (_,i) -> randomV sym rng a i Nothing -> liftIO (X.throw (UnsupportedSymbolicOp "random"))) , ("foldl" , {-# SCC "Prelude::foldl" #-} diff --git a/src/Cryptol/Eval/Prims.hs b/src/Cryptol/Eval/Prims.hs index 561b3ea25..ceebf843c 100644 --- a/src/Cryptol/Eval/Prims.hs +++ b/src/Cryptol/Eval/Prims.hs @@ -1,33 +1,37 @@ +{-# LANGUAGE ImplicitParams #-} {-# LANGUAGE LambdaCase #-} module Cryptol.Eval.Prims where import Cryptol.Backend -import Cryptol.TypeCheck.Solver.InfNat(Nat'(..)) import Cryptol.Eval.Type import Cryptol.Eval.Value import Cryptol.ModuleSystem.Name +import Cryptol.Parser.Position +import Cryptol.TypeCheck.Solver.InfNat(Nat'(..)) import Cryptol.Utils.Panic data Prim sym = PFun (SEval sym (GenValue sym) -> Prim sym) - | PStrictFun (GenValue sym -> Prim sym) + | PStrict (GenValue sym -> Prim sym) | PWordFun (SWord sym -> Prim sym) | PFloatFun (SFloat sym -> Prim sym) | PTyPoly (TValue -> Prim sym) | PNumPoly (Nat' -> Prim sym) | PFinPoly (Integer -> Prim sym) + | PRange (Range -> Prim sym) | PPrim (SEval sym (GenValue sym)) | PVal (GenValue sym) -evalPrim :: Backend sym => sym -> Name -> Prim sym -> SEval sym (GenValue sym) +evalPrim :: (?range :: Range, Backend sym) => sym -> Name -> Prim sym -> SEval sym (GenValue sym) evalPrim sym nm p = case p of - PFun f -> pure (lam (evalPrim sym nm . f)) - PStrictFun f -> pure (lam (\x -> evalPrim sym nm . f =<< x)) - PWordFun f -> pure (lam (\x -> evalPrim sym nm . f =<< (fromVWord sym (show nm) =<< x))) - PFloatFun f -> pure (flam (evalPrim sym nm . f)) - PTyPoly f -> pure (VPoly (evalPrim sym nm . f)) - PNumPoly f -> pure (VNumPoly (evalPrim sym nm . f)) - PFinPoly f -> pure (VNumPoly (\case Inf -> panic "PFin" ["Unexpected `inf`", show nm]; + PFun f -> pure (lam (evalPrim sym nm . f)) + PStrict f -> pure (lam (\x -> evalPrim sym nm . f =<< x)) + PWordFun f -> pure (lam (\x -> evalPrim sym nm . f =<< (fromVWord sym (show nm) =<< x))) + PFloatFun f -> pure (flam (evalPrim sym nm . f)) + PTyPoly f -> pure (VPoly (evalPrim sym nm . f)) + PNumPoly f -> pure (VNumPoly (evalPrim sym nm . f)) + PFinPoly f -> pure (VNumPoly (\case Inf -> panic "PFin" ["Unexpected `inf`", show nm]; Nat n -> evalPrim sym nm (f n))) - PPrim m -> m - PVal v -> pure v + PRange f -> evalPrim sym nm (f ?range) + PPrim m -> m + PVal v -> pure v diff --git a/src/Cryptol/Eval/SBV.hs b/src/Cryptol/Eval/SBV.hs index eb73001c2..b0c7d1b59 100644 --- a/src/Cryptol/Eval/SBV.hs +++ b/src/Cryptol/Eval/SBV.hs @@ -30,13 +30,14 @@ import qualified Data.Text as T import Data.SBV.Dynamic as SBV import Cryptol.Backend -import Cryptol.Backend.Monad ( EvalError(..), Unsupported(..) ) +import Cryptol.Backend.Monad ( EvalError(..), EvalErrorEx(..), Unsupported(..) ) import Cryptol.Backend.SBV import Cryptol.Eval.Type (TValue(..)) import Cryptol.Eval.Generic import Cryptol.Eval.Prims import Cryptol.Eval.Value +import Cryptol.Parser.Position import Cryptol.TypeCheck.Solver.InfNat (Nat'(..), widthInteger) import Cryptol.Utils.Ident @@ -104,13 +105,14 @@ primTable sym = indexFront :: SBV -> + Range -> Nat' -> TValue -> SeqMap SBV -> TValue -> SVal -> SEval SBV Value -indexFront sym mblen a xs _ix idx +indexFront sym rng mblen a xs _ix idx | Just i <- SBV.svAsInteger idx = lookupSeqMap xs i @@ -128,7 +130,7 @@ indexFront sym mblen a xs _ix idx where k = SBV.kindOf idx - def = zeroV sym a + def = zeroV sym rng a f n y = iteValue sym (SBV.svEqual idx (SBV.svInteger k n)) (lookupSeqMap xs n) y folded = case k of @@ -143,31 +145,33 @@ indexFront sym mblen a xs _ix idx indexBack :: SBV -> + Range -> Nat' -> TValue -> SeqMap SBV -> TValue -> SWord SBV -> SEval SBV Value -indexBack sym (Nat n) a xs ix idx = indexFront sym (Nat n) a (reverseSeqMap n xs) ix idx -indexBack _ Inf _ _ _ _ = evalPanic "Expected finite sequence" ["indexBack"] +indexBack sym rng (Nat n) a xs ix idx = indexFront sym rng (Nat n) a (reverseSeqMap n xs) ix idx +indexBack _ _ Inf _ _ _ _ = evalPanic "Expected finite sequence" ["indexBack"] indexFront_bits :: SBV -> + Range -> Nat' -> TValue -> SeqMap SBV -> TValue -> [SBit SBV] -> SEval SBV Value -indexFront_bits sym mblen _a xs _ix bits0 = go 0 (length bits0) bits0 +indexFront_bits sym rng mblen _a xs _ix bits0 = go 0 (length bits0) bits0 where go :: Integer -> Int -> [SBit SBV] -> SEval SBV Value go i _k [] -- For indices out of range, fail | Nat n <- mblen , i >= n - = raiseError sym (InvalidIndex (Just i)) + = raiseError sym (EvalErrorEx rng (InvalidIndex (Just i))) | otherwise = lookupSeqMap xs i @@ -177,7 +181,7 @@ indexFront_bits sym mblen _a xs _ix bits0 = go 0 (length bits0) bits0 -- are out of bounds | Nat n <- mblen , (i `shiftL` k) >= n - = raiseError sym (InvalidIndex Nothing) + = raiseError sym (EvalErrorEx rng (InvalidIndex Nothing)) | otherwise = iteValue sym b @@ -187,14 +191,15 @@ indexFront_bits sym mblen _a xs _ix bits0 = go 0 (length bits0) bits0 indexBack_bits :: SBV -> + Range -> Nat' -> TValue -> SeqMap SBV -> TValue -> [SBit SBV] -> SEval SBV Value -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"] +indexBack_bits sym rng (Nat n) a xs ix idx = indexFront_bits sym rng (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. @@ -216,20 +221,21 @@ wordValueEqualsInteger sym wv i updateFrontSym :: SBV -> + Range -> Nat' -> TValue -> SeqMap SBV -> Either (SInteger SBV) (WordValue SBV) -> SEval SBV (GenValue SBV) -> SEval SBV (SeqMap SBV) -updateFrontSym sym _len _eltTy vs (Left idx) val = +updateFrontSym sym _rng _len _eltTy vs (Left idx) val = case SBV.svAsInteger idx of Just i -> return $ updateSeqMap vs i val Nothing -> return $ IndexSeqMap $ \i -> do b <- intEq sym idx =<< integerLit sym i iteValue sym b val (lookupSeqMap vs i) -updateFrontSym sym _len _eltTy vs (Right wv) val = +updateFrontSym sym _rng _len _eltTy vs (Right wv) val = case wv of WordVal w | Just j <- SBV.svAsInteger w -> return $ updateSeqMap vs j val @@ -240,26 +246,27 @@ updateFrontSym sym _len _eltTy vs (Right wv) val = updateFrontSym_word :: SBV -> + Range -> Nat' -> TValue -> WordValue SBV -> Either (SInteger SBV) (WordValue SBV) -> SEval SBV (GenValue SBV) -> SEval SBV (WordValue SBV) -updateFrontSym_word _ Inf _ _ _ _ = evalPanic "Expected finite sequence" ["updateFrontSym_bits"] +updateFrontSym_word _ _ Inf _ _ _ _ = evalPanic "Expected finite sequence" ["updateFrontSym_bits"] -updateFrontSym_word sym (Nat _) eltTy (LargeBitsVal n bv) idx val = - LargeBitsVal n <$> updateFrontSym sym (Nat n) eltTy bv idx val +updateFrontSym_word sym rng (Nat _) eltTy (LargeBitsVal n bv) idx val = + LargeBitsVal n <$> updateFrontSym sym rng (Nat n) eltTy bv idx val -updateFrontSym_word sym (Nat n) eltTy (WordVal bv) (Left idx) val = +updateFrontSym_word sym rng (Nat n) eltTy (WordVal bv) (Left idx) val = do idx' <- wordFromInt sym n idx - updateFrontSym_word sym (Nat n) eltTy (WordVal bv) (Right (WordVal idx')) val + updateFrontSym_word sym rng (Nat n) eltTy (WordVal bv) (Right (WordVal idx')) val -updateFrontSym_word sym (Nat n) eltTy bv (Right wv) val = +updateFrontSym_word sym rng (Nat n) eltTy bv (Right wv) val = case wv of WordVal idx | Just j <- SBV.svAsInteger idx -> - updateWordValue sym bv j (fromVBit <$> val) + updateWordValue sym rng bv j (fromVBit <$> val) | WordVal bw <- bv -> WordVal <$> @@ -272,27 +279,28 @@ updateFrontSym_word sym (Nat n) eltTy bv (Right wv) val = let bw' = SBV.svAnd bw (SBV.svNot msk) return $! SBV.svXOr bw' (SBV.svAnd q msk) - _ -> LargeBitsVal n <$> updateFrontSym sym (Nat n) eltTy (asBitsMap sym bv) (Right wv) val + _ -> LargeBitsVal n <$> updateFrontSym sym rng (Nat n) eltTy (asBitsMap sym bv) (Right wv) val updateBackSym :: SBV -> + Range -> Nat' -> TValue -> SeqMap SBV -> Either (SInteger SBV) (WordValue SBV) -> SEval SBV (GenValue SBV) -> SEval SBV (SeqMap SBV) -updateBackSym _ Inf _ _ _ _ = evalPanic "Expected finite sequence" ["updateBackSym"] +updateBackSym _ _ Inf _ _ _ _ = evalPanic "Expected finite sequence" ["updateBackSym"] -updateBackSym sym (Nat n) _eltTy vs (Left idx) val = +updateBackSym sym _rng (Nat n) _eltTy vs (Left idx) val = case SBV.svAsInteger idx of Just i -> return $ updateSeqMap vs (n - 1 - i) val Nothing -> return $ IndexSeqMap $ \i -> do b <- intEq sym idx =<< integerLit sym (n - 1 - i) iteValue sym b val (lookupSeqMap vs i) -updateBackSym sym (Nat n) _eltTy vs (Right wv) val = +updateBackSym sym _rng (Nat n) _eltTy vs (Right wv) val = case wv of WordVal w | Just j <- SBV.svAsInteger w -> return $ updateSeqMap vs (n - 1 - j) val @@ -303,26 +311,27 @@ updateBackSym sym (Nat n) _eltTy vs (Right wv) val = updateBackSym_word :: SBV -> + Range -> Nat' -> TValue -> WordValue SBV -> Either (SInteger SBV) (WordValue SBV) -> SEval SBV (GenValue SBV) -> SEval SBV (WordValue SBV) -updateBackSym_word _ Inf _ _ _ _ = evalPanic "Expected finite sequence" ["updateBackSym_bits"] +updateBackSym_word _ _ Inf _ _ _ _ = evalPanic "Expected finite sequence" ["updateBackSym_bits"] -updateBackSym_word sym (Nat _) eltTy (LargeBitsVal n bv) idx val = - LargeBitsVal n <$> updateBackSym sym (Nat n) eltTy bv idx val +updateBackSym_word sym rng (Nat _) eltTy (LargeBitsVal n bv) idx val = + LargeBitsVal n <$> updateBackSym sym rng (Nat n) eltTy bv idx val -updateBackSym_word sym (Nat n) eltTy (WordVal bv) (Left idx) val = +updateBackSym_word sym rng (Nat n) eltTy (WordVal bv) (Left idx) val = do idx' <- wordFromInt sym n idx - updateBackSym_word sym (Nat n) eltTy (WordVal bv) (Right (WordVal idx')) val + updateBackSym_word sym rng (Nat n) eltTy (WordVal bv) (Right (WordVal idx')) val -updateBackSym_word sym (Nat n) eltTy bv (Right wv) val = do +updateBackSym_word sym rng (Nat n) eltTy bv (Right wv) val = do case wv of WordVal idx | Just j <- SBV.svAsInteger idx -> - updateWordValue sym bv (n - 1 - j) (fromVBit <$> val) + updateWordValue sym rng bv (n - 1 - j) (fromVBit <$> val) | WordVal bw <- bv -> WordVal <$> @@ -335,7 +344,7 @@ updateBackSym_word sym (Nat n) eltTy bv (Right wv) val = do let bw' = SBV.svAnd bw (SBV.svNot msk) return $! SBV.svXOr bw' (SBV.svAnd q msk) - _ -> LargeBitsVal n <$> updateBackSym sym (Nat n) eltTy (asBitsMap sym bv) (Right wv) val + _ -> LargeBitsVal n <$> updateBackSym sym rng (Nat n) eltTy (asBitsMap sym bv) (Right wv) val asWordList :: [WordValue SBV] -> Maybe [SWord SBV] @@ -350,7 +359,7 @@ sshrV sym = PNumPoly \n -> PTyPoly \ix -> PWordFun \x -> - PStrictFun \y -> + PStrict \y -> PPrim $ asIndex sym ">>$" ix y >>= \case Left idx -> diff --git a/src/Cryptol/Eval/Type.hs b/src/Cryptol/Eval/Type.hs index ec5b51e35..49fad0521 100644 --- a/src/Cryptol/Eval/Type.hs +++ b/src/Cryptol/Eval/Type.hs @@ -11,7 +11,7 @@ {-# LANGUAGE DeriveGeneric #-} module Cryptol.Eval.Type where -import Cryptol.Backend.Monad (evalPanic, typeCannotBeDemoted) +import Cryptol.Backend.Monad (evalPanic) import Cryptol.TypeCheck.AST import Cryptol.TypeCheck.PP(pp) import Cryptol.TypeCheck.Solver.InfNat @@ -175,5 +175,5 @@ evalTF f vs | otherwise = evalPanic "evalTF" ["Unexpected type function:", show ty] - where mb = fromMaybe (typeCannotBeDemoted ty) + where mb = fromMaybe (evalPanic "evalTF" ["type cannot be demoted", show (pp ty)]) ty = TCon (TF f) (map tNat' vs) diff --git a/src/Cryptol/Eval/Value.hs b/src/Cryptol/Eval/Value.hs index 5af4bdd16..1b0586e4d 100644 --- a/src/Cryptol/Eval/Value.hs +++ b/src/Cryptol/Eval/Value.hs @@ -103,6 +103,7 @@ import qualified Cryptol.Backend.Arch as Arch import Cryptol.Backend.Monad ( PPOpts(..), evalPanic, wordTooWide, defaultPPOpts, asciiMode ) import Cryptol.Eval.Type +import Cryptol.Parser.Position (Range) import Cryptol.TypeCheck.Solver.InfNat(Nat'(..)) import Cryptol.Utils.Ident (Ident) import Cryptol.Utils.Panic(panic) @@ -135,11 +136,11 @@ largeBitSize :: Integer largeBitSize = 1 `shiftL` 48 -- | Generate a finite sequence map from a list of values -finiteSeqMap :: Backend sym => sym -> [SEval sym (GenValue sym)] -> SeqMap sym -finiteSeqMap sym xs = +finiteSeqMap :: [SEval sym (GenValue sym)] -> SeqMap sym +finiteSeqMap xs = UpdateSeqMap (Map.fromList (zip [0..] xs)) - (invalidIndex sym) + (\i -> panic "finiteSeqMap" ["Out of bounds access of finite seq map", "length: " ++ show (length xs), show i]) -- | Generate an infinite sequence map from a stream of values infiniteSeqMap :: Backend sym => [SEval sym (GenValue sym)] -> SEval sym (SeqMap sym) @@ -150,7 +151,7 @@ infiniteSeqMap xs = -- | Create a finite list of length @n@ of the values from @[0..n-1]@ in -- the given the sequence emap. enumerateSeqMap :: (Integral n) => n -> SeqMap sym -> [SEval sym (GenValue sym)] -enumerateSeqMap n m = [ lookupSeqMap m i | i <- [0 .. (toInteger n)-1] ] +enumerateSeqMap n m = [ lookupSeqMap m i | i <- [0 .. (toInteger n)-1] ] -- | Create an infinite stream of all the values in a sequence map streamSeqMap :: SeqMap sym -> [SEval sym (GenValue sym)] @@ -270,25 +271,26 @@ wordValueSize sym (WordVal w) = wordLen sym w wordValueSize _ (LargeBitsVal n _) = n -- | Select an individual bit from a word value -indexWordValue :: Backend sym => sym -> WordValue sym -> Integer -> SEval sym (SBit sym) -indexWordValue sym (WordVal w) idx +indexWordValue :: Backend sym => sym -> Range -> WordValue sym -> Integer -> SEval sym (SBit sym) +indexWordValue sym rng (WordVal w) idx | 0 <= idx && idx < wordLen sym w = wordBit sym w idx - | otherwise = invalidIndex sym idx -indexWordValue sym (LargeBitsVal n xs) idx + | otherwise = invalidIndex sym rng idx +indexWordValue sym rng (LargeBitsVal n xs) idx | 0 <= idx && idx < n = fromVBit <$> lookupSeqMap xs idx - | otherwise = invalidIndex sym idx + | otherwise = invalidIndex sym rng idx -- | Produce a new 'WordValue' from the one given by updating the @i@th bit with the -- given bit value. -updateWordValue :: Backend sym => sym -> WordValue sym -> Integer -> SEval sym (SBit sym) -> SEval sym (WordValue sym) -updateWordValue sym (WordVal w) idx b - | idx < 0 || idx >= wordLen sym w = invalidIndex sym idx +updateWordValue :: Backend sym => + sym -> Range -> WordValue sym -> Integer -> SEval sym (SBit sym) -> SEval sym (WordValue sym) +updateWordValue sym rng (WordVal w) idx b + | idx < 0 || idx >= wordLen sym w = invalidIndex sym rng idx | isReady sym b = WordVal <$> (wordUpdate sym w idx =<< b) -updateWordValue sym wv idx b +updateWordValue sym rng wv idx b | 0 <= idx && idx < wordValueSize sym wv = pure $ LargeBitsVal (wordValueSize sym wv) $ updateSeqMap (asBitsMap sym wv) idx (VBit <$> b) - | otherwise = invalidIndex sym idx + | otherwise = invalidIndex sym rng idx -- | Generic value type, parameterized by bit and word types. @@ -451,7 +453,7 @@ toFinSeq :: sym -> Integer -> TValue -> [GenValue sym] -> GenValue sym toFinSeq sym len elty vs | isTBit elty = VWord len (WordVal <$> packWord sym (map fromVBit vs)) - | otherwise = VSeq len $ finiteSeqMap sym (map pure vs) + | otherwise = VSeq len $ finiteSeqMap (map pure vs) -- | Construct either a finite sequence, or a stream. In the finite case, -- record whether or not the elements were bits, to aid pretty-printing. diff --git a/src/Cryptol/Eval/What4.hs b/src/Cryptol/Eval/What4.hs index a04fa0023..3f363fd4d 100644 --- a/src/Cryptol/Eval/What4.hs +++ b/src/Cryptol/Eval/What4.hs @@ -41,7 +41,7 @@ import qualified What4.SWord as SW import qualified What4.Utils.AbstractDomains as W4 import Cryptol.Backend -import Cryptol.Backend.Monad ( EvalError(..), Unsupported(..) ) +import Cryptol.Backend.Monad ( EvalError(..), EvalErrorEx(..), Unsupported(..) ) import Cryptol.Backend.What4 import qualified Cryptol.Backend.What4.SFloat as W4 @@ -54,6 +54,7 @@ import qualified Cryptol.SHA as SHA import Cryptol.TypeCheck.Solver.InfNat( Nat'(..), widthInteger ) +import Cryptol.Parser.Position(Range) import Cryptol.Utils.Ident import Cryptol.Utils.Panic import Cryptol.Utils.RecordMap @@ -258,7 +259,7 @@ suiteBPrims sym = Map.fromList $ [ (suiteBPrim n, v) | (n,v) <- prims ] case intIndex (fromInteger i) (size ret) of Just (Some idx) | Just W4.Refl <- W4.testEquality (ret!idx) (W4.BaseBVRepr (W4.knownNat @32)) -> fromWord32 =<< liftIO (W4.structField (w4 sym) z idx) - _ -> invalidIndex sym i + _ -> evalPanic "AESKeyExpand" ["Index out of range", show k, show i] -- {n} (fin n) => [n][16][32] -> [7][32] , "processSHA2_224" ~> @@ -275,8 +276,8 @@ suiteBPrims sym = Map.fromList $ [ (suiteBPrim n, v) | (n,v) <- prims ] do z <- liftIO $ W4.structField (w4 sym) finalSt idx case W4.testEquality (W4.exprType z) (W4.BaseBVRepr (W4.knownNat @32)) of Just W4.Refl -> fromWord32 z - Nothing -> invalidIndex sym i - Nothing -> invalidIndex sym i + Nothing -> evalPanic "processSHA2_224" ["Index out of range", show i] + Nothing -> evalPanic "processSHA2_224" ["Index out of range", show i] -- {n} (fin n) => [n][16][32] -> [8][32] , "processSHA2_256" ~> @@ -293,8 +294,8 @@ suiteBPrims sym = Map.fromList $ [ (suiteBPrim n, v) | (n,v) <- prims ] do z <- liftIO $ W4.structField (w4 sym) finalSt idx case W4.testEquality (W4.exprType z) (W4.BaseBVRepr (W4.knownNat @32)) of Just W4.Refl -> fromWord32 z - Nothing -> invalidIndex sym i - Nothing -> invalidIndex sym i + Nothing -> evalPanic "processSHA2_256" ["Index out of range", show i] + Nothing -> evalPanic "processSHA2_256" ["Index out of range", show i] -- {n} (fin n) => [n][16][64] -> [6][64] , "processSHA2_384" ~> @@ -311,8 +312,8 @@ suiteBPrims sym = Map.fromList $ [ (suiteBPrim n, v) | (n,v) <- prims ] do z <- liftIO $ W4.structField (w4 sym) finalSt idx case W4.testEquality (W4.exprType z) (W4.BaseBVRepr (W4.knownNat @64)) of Just W4.Refl -> fromWord64 z - Nothing -> invalidIndex sym i - Nothing -> invalidIndex sym i + Nothing -> evalPanic "processSHA2_384" ["Index out of range", show i] + Nothing -> evalPanic "processSHA2_384" ["Index out of range", show i] -- {n} (fin n) => [n][16][64] -> [8][64] , "processSHA2_512" ~> @@ -329,8 +330,8 @@ suiteBPrims sym = Map.fromList $ [ (suiteBPrim n, v) | (n,v) <- prims ] do z <- liftIO $ W4.structField (w4 sym) finalSt idx case W4.testEquality (W4.exprType z) (W4.BaseBVRepr (W4.knownNat @64)) of Just W4.Refl -> fromWord64 z - Nothing -> invalidIndex sym i - Nothing -> invalidIndex sym i + Nothing -> evalPanic "processSHA2_512" ["Index out of range", show i] + Nothing -> evalPanic "processSHA2_512" ["Index out of range", show i] ] @@ -520,7 +521,7 @@ applyAESStateFunc sym funNm x = | i == 1 -> fromWord32 =<< liftIO (W4.structField (w4 sym) z (natIndex @1)) | i == 2 -> fromWord32 =<< liftIO (W4.structField (w4 sym) z (natIndex @2)) | i == 3 -> fromWord32 =<< liftIO (W4.structField (w4 sym) z (natIndex @3)) - | otherwise -> invalidIndex sym i + | otherwise -> evalPanic "applyAESStateFunc" ["Index out of range", show funNm, show i] where nm = Text.unpack funNm @@ -535,7 +536,7 @@ sshrV sym = PFinPoly \n -> PTyPoly \ix -> PWordFun \x -> - PStrictFun \y -> + PStrict \y -> PPrim $ asIndex sym ">>$" ix y >>= \case Left i -> @@ -555,13 +556,14 @@ sshrV sym = indexFront_int :: W4.IsSymExprBuilder sym => What4 sym -> + Range -> Nat' -> TValue -> SeqMap (What4 sym) -> TValue -> SInteger (What4 sym) -> SEval (What4 sym) (Value sym) -indexFront_int sym mblen _a xs ix idx +indexFront_int sym rng mblen _a xs ix idx | Just i <- W4.asInteger idx = lookupSeqMap xs i @@ -574,7 +576,7 @@ indexFront_int sym mblen _a xs ix idx where w4sym = w4 sym - def = raiseError sym (InvalidIndex Nothing) + def = raiseError sym (EvalErrorEx rng (InvalidIndex Nothing)) f n y = do p <- liftIO (W4.intEq w4sym idx =<< W4.intLit w4sym n) @@ -604,25 +606,27 @@ indexFront_int sym mblen _a xs ix idx indexBack_int :: W4.IsSymExprBuilder sym => What4 sym -> + Range -> 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"] +indexBack_int sym rng (Nat n) a xs ix idx = indexFront_int sym rng (Nat n) a (reverseSeqMap n xs) ix idx +indexBack_int _ _ Inf _ _ _ _ = evalPanic "Expected finite sequence" ["indexBack_int"] indexFront_word :: W4.IsSymExprBuilder sym => What4 sym -> + Range -> Nat' -> TValue -> SeqMap (What4 sym) -> TValue -> SWord (What4 sym) -> SEval (What4 sym) (Value sym) -indexFront_word sym mblen _a xs _ix idx +indexFront_word sym rng mblen _a xs _ix idx | Just i <- SW.bvAsUnsignedInteger idx = lookupSeqMap xs i @@ -633,7 +637,7 @@ indexFront_word sym mblen _a xs _ix idx w4sym = w4 sym w = SW.bvWidth idx - def = raiseError sym (InvalidIndex Nothing) + def = raiseError sym (EvalErrorEx rng (InvalidIndex Nothing)) f n y = do p <- liftIO (SW.bvEq w4sym idx =<< SW.bvLit w4sym w n) @@ -657,32 +661,34 @@ indexFront_word sym mblen _a xs _ix idx indexBack_word :: W4.IsSymExprBuilder sym => What4 sym -> + Range -> 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"] +indexBack_word sym rng (Nat n) a xs ix idx = indexFront_word sym rng (Nat n) a (reverseSeqMap n xs) ix idx +indexBack_word _ _ Inf _ _ _ _ = evalPanic "Expected finite sequence" ["indexBack_word"] indexFront_bits :: forall sym. W4.IsSymExprBuilder sym => What4 sym -> + Range -> 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 +indexFront_bits sym rng mblen _a xs _ix bits0 = go 0 (length bits0) bits0 where go :: Integer -> Int -> [W4.Pred sym] -> W4Eval sym (Value sym) go i _k [] -- For indices out of range, fail | Nat n <- mblen , i >= n - = raiseError sym (InvalidIndex (Just i)) + = raiseError sym (EvalErrorEx rng (InvalidIndex (Just i))) | otherwise = lookupSeqMap xs i @@ -692,7 +698,7 @@ indexFront_bits sym mblen _a xs _ix bits0 = go 0 (length bits0) bits0 -- are out of bounds | Nat n <- mblen , (i `shiftL` k) >= n - = raiseError sym (InvalidIndex Nothing) + = raiseError sym (EvalErrorEx rng (InvalidIndex Nothing)) | otherwise = iteValue sym b @@ -702,14 +708,15 @@ indexFront_bits sym mblen _a xs _ix bits0 = go 0 (length bits0) bits0 indexBack_bits :: W4.IsSymExprBuilder sym => What4 sym -> + Range -> 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"] +indexBack_bits sym rng (Nat n) a xs ix idx = indexFront_bits sym rng (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. @@ -741,20 +748,21 @@ wordValueEqualsInteger sym wv i updateFrontSym :: W4.IsSymExprBuilder sym => What4 sym -> + Range -> 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 = +updateFrontSym sym _rng _len _eltTy vs (Left idx) val = case W4.asInteger idx of Just i -> return $ updateSeqMap vs i val Nothing -> return $ IndexSeqMap $ \i -> do b <- intEq sym idx =<< integerLit sym i iteValue sym b val (lookupSeqMap vs i) -updateFrontSym sym _len _eltTy vs (Right wv) val = +updateFrontSym sym _rng _len _eltTy vs (Right wv) val = case wv of WordVal w | Just j <- SW.bvAsUnsignedInteger w -> return $ updateSeqMap vs j val @@ -766,22 +774,23 @@ updateFrontSym sym _len _eltTy vs (Right wv) val = updateBackSym :: W4.IsSymExprBuilder sym => What4 sym -> + Range -> 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 _ _ Inf _ _ _ _ = evalPanic "Expected finite sequence" ["updateBackSym"] -updateBackSym sym (Nat n) _eltTy vs (Left idx) val = +updateBackSym sym _rng (Nat n) _eltTy vs (Left idx) val = case W4.asInteger idx of Just i -> return $ updateSeqMap vs (n - 1 - i) val Nothing -> return $ IndexSeqMap $ \i -> do b <- intEq sym idx =<< integerLit sym (n - 1 - i) iteValue sym b val (lookupSeqMap vs i) -updateBackSym sym (Nat n) _eltTy vs (Right wv) val = +updateBackSym sym _rng (Nat n) _eltTy vs (Right wv) val = case wv of WordVal w | Just j <- SW.bvAsUnsignedInteger w -> return $ updateSeqMap vs (n - 1 - j) val @@ -794,26 +803,27 @@ updateBackSym sym (Nat n) _eltTy vs (Right wv) val = updateFrontSym_word :: W4.IsSymExprBuilder sym => What4 sym -> + Range -> 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 _ _ 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 rng (Nat _) eltTy (LargeBitsVal n bv) idx val = + LargeBitsVal n <$> updateFrontSym sym rng (Nat n) eltTy bv idx val -updateFrontSym_word sym (Nat n) eltTy (WordVal bv) (Left idx) val = +updateFrontSym_word sym rng (Nat n) eltTy (WordVal bv) (Left idx) val = do idx' <- wordFromInt sym n idx - updateFrontSym_word sym (Nat n) eltTy (WordVal bv) (Right (WordVal idx')) val + updateFrontSym_word sym rng (Nat n) eltTy (WordVal bv) (Right (WordVal idx')) val -updateFrontSym_word sym (Nat n) eltTy bv (Right wv) val = +updateFrontSym_word sym rng (Nat n) eltTy bv (Right wv) val = case wv of WordVal idx | Just j <- SW.bvAsUnsignedInteger idx -> - updateWordValue sym bv j (fromVBit <$> val) + updateWordValue sym rng bv j (fromVBit <$> val) | WordVal bw <- bv -> WordVal <$> @@ -831,32 +841,33 @@ updateFrontSym_word sym (Nat n) eltTy bv (Right wv) val = SW.bvXor (w4 sym) bw' =<< SW.bvAnd (w4 sym) q msk _ -> LargeBitsVal (wordValueSize sym wv) <$> - updateFrontSym sym (Nat n) eltTy (asBitsMap sym bv) (Right wv) val + updateFrontSym sym rng (Nat n) eltTy (asBitsMap sym bv) (Right wv) val updateBackSym_word :: W4.IsSymExprBuilder sym => What4 sym -> + Range -> 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 _ _ 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 rng (Nat _) eltTy (LargeBitsVal n bv) idx val = + LargeBitsVal n <$> updateBackSym sym rng (Nat n) eltTy bv idx val -updateBackSym_word sym (Nat n) eltTy (WordVal bv) (Left idx) val = +updateBackSym_word sym rng (Nat n) eltTy (WordVal bv) (Left idx) val = do idx' <- wordFromInt sym n idx - updateBackSym_word sym (Nat n) eltTy (WordVal bv) (Right (WordVal idx')) val + updateBackSym_word sym rng (Nat n) eltTy (WordVal bv) (Right (WordVal idx')) val -updateBackSym_word sym (Nat n) eltTy bv (Right wv) val = +updateBackSym_word sym rng (Nat n) eltTy bv (Right wv) val = case wv of WordVal idx | Just j <- SW.bvAsUnsignedInteger idx -> - updateWordValue sym bv (n - 1 - j) (fromVBit <$> val) + updateWordValue sym rng bv (n - 1 - j) (fromVBit <$> val) | WordVal bw <- bv -> WordVal <$> @@ -874,7 +885,7 @@ updateBackSym_word sym (Nat n) eltTy bv (Right wv) val = SW.bvXor (w4 sym) bw' =<< SW.bvAnd (w4 sym) q msk _ -> LargeBitsVal (wordValueSize sym wv) <$> - updateBackSym sym (Nat n) eltTy (asBitsMap sym bv) (Right wv) val + updateBackSym sym rng (Nat n) eltTy (asBitsMap sym bv) (Right wv) val @@ -909,13 +920,16 @@ floatPrims sym = , "fpDiv" ~> fpBinArithV sym fpDiv , "fpFromRational" ~> - PFinPoly \e -> PFinPoly \p -> PWordFun \r -> PFun \x -> PPrim + PFinPoly \e -> PFinPoly \p -> PWordFun \r -> PFun \x -> + PRange \rng -> + PPrim do rat <- fromVRational <$> x - VFloat <$> fpCvtFromRational sym e p r rat + VFloat <$> fpCvtFromRational sym rng e p r rat , "fpToRational" ~> PFinPoly \_e -> PFinPoly \_p -> PFloatFun \fp -> - PPrim (VRational <$> fpCvtToRational sym fp) + PRange \rng -> + PPrim (VRational <$> fpCvtToRational sym rng fp) ] -- | A helper for definitng floating point constants. diff --git a/src/Cryptol/ModuleSystem/Base.hs b/src/Cryptol/ModuleSystem/Base.hs index dd7dff02d..6ac684eec 100644 --- a/src/Cryptol/ModuleSystem/Base.hs +++ b/src/Cryptol/ModuleSystem/Base.hs @@ -564,6 +564,7 @@ evalExpr e = do evopts <- getEvalOpts let tbl = Concrete.primTable evopts let ?evalPrim = \i -> Right <$> Map.lookup i tbl + let ?range = emptyRange io $ E.runEval $ (E.evalExpr Concrete (env <> deEnv denv) e) evalDecls :: [T.DeclGroup] -> ModuleM () diff --git a/src/Cryptol/Parser/Position.hs b/src/Cryptol/Parser/Position.hs index f2f6eb0ef..5959168f5 100644 --- a/src/Cryptol/Parser/Position.hs +++ b/src/Cryptol/Parser/Position.hs @@ -33,6 +33,11 @@ data Range = Range { from :: !Position , source :: FilePath } deriving (Eq, Ord, Show, Generic, NFData) +type CallStack = [ (Text, Range) ] + +emptyCallStack :: CallStack +emptyCallStack = [] + -- | An empty range. -- -- Caution: using this on the LHS of a use of rComb will cause the empty source diff --git a/src/Cryptol/REPL/Monad.hs b/src/Cryptol/REPL/Monad.hs index d94561cc8..b0d859f2a 100644 --- a/src/Cryptol/REPL/Monad.hs +++ b/src/Cryptol/REPL/Monad.hs @@ -76,7 +76,7 @@ module Cryptol.REPL.Monad ( import Cryptol.REPL.Trie -import Cryptol.Eval (EvalError, Unsupported) +import Cryptol.Eval (EvalErrorEx, Unsupported) import qualified Cryptol.ModuleSystem as M import qualified Cryptol.ModuleSystem.Env as M import qualified Cryptol.ModuleSystem.Name as M @@ -289,7 +289,7 @@ data REPLException | DirectoryNotFound FilePath | NoPatError [Error] | NoIncludeError [IncludeError] - | EvalError EvalError + | EvalError EvalErrorEx | Unsupported Unsupported | ModuleSystemError NameDisp M.ModuleError | EvalPolyError T.Schema @@ -350,7 +350,7 @@ rethrowEvalError m = run `X.catch` rethrow `X.catch` rethrowUnsupported a <- m return $! a - rethrow :: EvalError -> IO a + rethrow :: EvalErrorEx -> IO a rethrow exn = X.throwIO (EvalError exn) rethrowUnsupported :: Unsupported -> IO a diff --git a/src/Cryptol/Symbolic.hs b/src/Cryptol/Symbolic.hs index d8762cc20..02a6afd43 100644 --- a/src/Cryptol/Symbolic.hs +++ b/src/Cryptol/Symbolic.hs @@ -212,7 +212,7 @@ varShapeToValue sym var = VarRational n d -> VRational (SRational n d) VarWord w -> VWord (wordLen sym w) (return (WordVal w)) VarFloat f -> VFloat f - VarFinSeq n vs -> VSeq n (finiteSeqMap sym (map (pure . varShapeToValue sym) vs)) + VarFinSeq n vs -> VSeq n (finiteSeqMap (map (pure . varShapeToValue sym) vs)) VarTuple vs -> VTuple (map (pure . varShapeToValue sym) vs) VarRecord fs -> VRecord (fmap (pure . varShapeToValue sym) fs) diff --git a/src/Cryptol/Symbolic/SBV.hs b/src/Cryptol/Symbolic/SBV.hs index 7421db916..b4943e391 100644 --- a/src/Cryptol/Symbolic/SBV.hs +++ b/src/Cryptol/Symbolic/SBV.hs @@ -58,6 +58,7 @@ import qualified Cryptol.Eval as Eval import qualified Cryptol.Eval.Concrete as Concrete import qualified Cryptol.Eval.Value as Eval import Cryptol.Eval.SBV +import Cryptol.Parser.Position (emptyRange) import Cryptol.Symbolic import Cryptol.TypeCheck.AST import Cryptol.Utils.Ident (preludeReferenceName, prelPrim, identText) @@ -328,6 +329,8 @@ prepareQuery evo ProverCommand{..} = let tbl = primTable sym let ?evalPrim = \i -> (Right <$> Map.lookup i tbl) <|> (Left <$> Map.lookup i ds) + let ?range = emptyRange + -- Compute the symbolic inputs, and any domain constraints needed -- according to their types. args <- map (pure . varShapeToValue sym) <$> diff --git a/src/Cryptol/Symbolic/What4.hs b/src/Cryptol/Symbolic/What4.hs index d6f14cb6d..dcdd78d74 100644 --- a/src/Cryptol/Symbolic/What4.hs +++ b/src/Cryptol/Symbolic/What4.hs @@ -62,6 +62,7 @@ import qualified Cryptol.Eval as Eval import qualified Cryptol.Eval.Concrete as Concrete import qualified Cryptol.Eval.Value as Eval import Cryptol.Eval.What4 +import Cryptol.Parser.Position (emptyRange) import Cryptol.Symbolic import Cryptol.TypeCheck.AST import Cryptol.Utils.Logger(logPutStrLn,logPutStr,Logger) @@ -276,6 +277,7 @@ prepareQuery sym ProverCommand { .. } = let tbl = primTable sym let ?evalPrim = \i -> (Right <$> Map.lookup i tbl) <|> (Left <$> Map.lookup i ds) + let ?range = emptyRange modEnv <- M.getModuleEnv let extDgs = M.allDeclGroups modEnv ++ pcExtraDecls diff --git a/src/Cryptol/Testing/Random.hs b/src/Cryptol/Testing/Random.hs index dadf30da0..2f0179b60 100644 --- a/src/Cryptol/Testing/Random.hs +++ b/src/Cryptol/Testing/Random.hs @@ -37,7 +37,7 @@ import qualified Data.Sequence as Seq import System.Random (RandomGen, split, random, randomR) import Cryptol.Backend (Backend(..), SRational(..)) -import Cryptol.Backend.Monad (runEval,Eval,EvalError(..)) +import Cryptol.Backend.Monad (runEval,Eval,EvalErrorEx(..)) import Cryptol.Backend.Concrete import Cryptol.Eval.Type (TValue(..)) @@ -226,7 +226,8 @@ randomSequence w mkElem sz g0 = do let f g = let (x,g') = mkElem sz g in seq x (Just (x, g')) let xs = Seq.fromList $ genericTake w $ unfoldr f g1 - seq xs (pure $ VSeq w $ IndexSeqMap $ (Seq.index xs . fromInteger), g2) + let v = VSeq w $ IndexSeqMap $ \i -> Seq.index xs (fromInteger i) + seq xs (pure v, g2) {-# INLINE randomTuple #-} @@ -277,7 +278,7 @@ randomFloat sym e p w g = data TestResult = Pass | FailFalse [Value] - | FailError EvalError [Value] + | FailError EvalErrorEx [Value] isPass :: TestResult -> Bool isPass Pass = True @@ -374,7 +375,7 @@ typeValues ty = | x <- [ 0 .. 2^n - 1 ] ] TVSeq n el -> - [ VSeq n (finiteSeqMap Concrete (map pure xs)) + [ VSeq n (finiteSeqMap (map pure xs)) | xs <- sequence (genericReplicate n (typeValues el)) ] TVTuple ts -> From d7ade027b62e6c7f1f1afc74782b8aa21ac2e499 Mon Sep 17 00:00:00 2001 From: Rob Dockins Date: Tue, 24 Nov 2020 16:09:59 -0800 Subject: [PATCH 06/27] Handle WordToWide exceptions along with the other runtime exception types. --- src/Cryptol/Eval.hs | 1 + src/Cryptol/REPL/Monad.hs | 12 ++++++++++-- 2 files changed, 11 insertions(+), 2 deletions(-) diff --git a/src/Cryptol/Eval.hs b/src/Cryptol/Eval.hs index 78fefe842..b07f5c326 100644 --- a/src/Cryptol/Eval.hs +++ b/src/Cryptol/Eval.hs @@ -32,6 +32,7 @@ module Cryptol.Eval ( , EvalError(..) , EvalErrorEx(..) , Unsupported(..) + , WordTooWide(..) , forceValue ) where diff --git a/src/Cryptol/REPL/Monad.hs b/src/Cryptol/REPL/Monad.hs index b0d859f2a..fac336e15 100644 --- a/src/Cryptol/REPL/Monad.hs +++ b/src/Cryptol/REPL/Monad.hs @@ -76,7 +76,7 @@ module Cryptol.REPL.Monad ( import Cryptol.REPL.Trie -import Cryptol.Eval (EvalErrorEx, Unsupported) +import Cryptol.Eval (EvalErrorEx, Unsupported, WordTooWide) import qualified Cryptol.ModuleSystem as M import qualified Cryptol.ModuleSystem.Env as M import qualified Cryptol.ModuleSystem.Name as M @@ -290,6 +290,7 @@ data REPLException | NoPatError [Error] | NoIncludeError [IncludeError] | EvalError EvalErrorEx + | TooWide WordTooWide | Unsupported Unsupported | ModuleSystemError NameDisp M.ModuleError | EvalPolyError T.Schema @@ -319,6 +320,7 @@ instance PP REPLException where ModuleSystemError ns me -> fixNameDisp ns (pp me) EvalError e -> pp e Unsupported e -> pp e + TooWide e -> pp e EvalPolyError s -> text "Cannot evaluate polymorphic value." $$ text "Type:" <+> pp s TypeNotTestable t -> text "The expression is not of a testable type." @@ -344,7 +346,10 @@ finally m1 m2 = REPL (\ref -> unREPL m1 ref `X.finally` unREPL m2 ref) rethrowEvalError :: IO a -> IO a -rethrowEvalError m = run `X.catch` rethrow `X.catch` rethrowUnsupported +rethrowEvalError m = + run `X.catch` rethrow + `X.catch` rethrowTooWide + `X.catch` rethrowUnsupported where run = do a <- m @@ -353,6 +358,9 @@ rethrowEvalError m = run `X.catch` rethrow `X.catch` rethrowUnsupported rethrow :: EvalErrorEx -> IO a rethrow exn = X.throwIO (EvalError exn) + rethrowTooWide :: WordTooWide -> IO a + rethrowTooWide exn = X.throwIO (TooWide exn) + rethrowUnsupported :: Unsupported -> IO a rethrowUnsupported exn = X.throwIO (Unsupported exn) From 0aeb053369c48b9e43c70a42c6ef87814c1302de Mon Sep 17 00:00:00 2001 From: Rob Dockins Date: Wed, 25 Nov 2020 22:25:49 -0800 Subject: [PATCH 07/27] Add line number counting for batch mode and interactive inputs. Error messages now properly locate subexpressions inside batch interaction files, and line numbers count up on succesive REPL inputs. --- cryptol/REPL/Haskeline.hs | 34 +++--- src/Cryptol/Parser/Lexer.x | 2 +- src/Cryptol/Parser/LexerUtils.hs | 2 + src/Cryptol/REPL/Command.hs | 200 +++++++++++++++++-------------- 4 files changed, 133 insertions(+), 105 deletions(-) diff --git a/cryptol/REPL/Haskeline.hs b/cryptol/REPL/Haskeline.hs index cd03ec954..587f798a2 100644 --- a/cryptol/REPL/Haskeline.hs +++ b/cryptol/REPL/Haskeline.hs @@ -48,38 +48,38 @@ import Prelude.Compat crySession :: Maybe FilePath -> Bool -> REPL CommandExitCode crySession mbBatch stopOnError = do settings <- io (setHistoryFile (replSettings isBatch)) - let act = runInputTBehavior behavior settings (withInterrupt loop) + let act = runInputTBehavior behavior settings (withInterrupt (loop 1)) if isBatch then asBatch act else act where (isBatch,behavior) = case mbBatch of Nothing -> (False,defaultBehavior) Just path -> (True,useFile path) - loop :: InputT REPL CommandExitCode - loop = + loop :: Int -> InputT REPL CommandExitCode + loop lineNum = do ln <- getInputLines =<< MTL.lift getPrompt case ln of NoMoreLines -> return CommandOk Interrupted | isBatch && stopOnError -> return CommandError - | otherwise -> loop - NextLine line - | all isSpace line -> loop - | otherwise -> doCommand line - - doCommand txt = - case parseCommand findCommandExact txt of - Nothing | isBatch && stopOnError -> return CommandError - | otherwise -> loop -- say somtething? + | otherwise -> loop lineNum + NextLine ls + | all (all isSpace) ls -> loop (lineNum + length ls) + | otherwise -> doCommand lineNum ls + + doCommand lineNum txt = + case parseCommand findCommandExact (unlines txt) of + Nothing | isBatch && stopOnError -> return CommandError + | otherwise -> loop (lineNum + length txt) -- say somtething? Just cmd -> join $ MTL.lift $ - do status <- handleInterrupt (handleCtrlC CommandError) (runCommand cmd) + do status <- handleInterrupt (handleCtrlC CommandError) (runCommand lineNum mbBatch cmd) case status of CommandError | isBatch && stopOnError -> return (return status) _ -> do goOn <- shouldContinue - return (if goOn then loop else return status) + return (if goOn then loop (lineNum + length txt) else return status) -data NextLine = NextLine String | NoMoreLines | Interrupted +data NextLine = NextLine [String] | NoMoreLines | Interrupted getInputLines :: String -> InputT REPL NextLine getInputLines = handleInterrupt (MTL.lift (handleCtrlC Interrupted)) . loop [] @@ -91,7 +91,7 @@ getInputLines = handleInterrupt (MTL.lift (handleCtrlC Interrupted)) . loop [] Nothing -> return NoMoreLines Just l | not (null l) && last l == '\\' -> loop (init l : ls) newPropmpt - | otherwise -> return $ NextLine $ unlines $ reverse $ l : ls + | otherwise -> return $ NextLine $ reverse $ l : ls loadCryRC :: Cryptolrc -> REPL CommandExitCode loadCryRC cryrc = @@ -201,7 +201,7 @@ canDisplayColor = io (hSupportsANSI stdout) cryptolCommand :: CompletionFunc REPL cryptolCommand cursor@(l,r) | ":" `isPrefixOf` l' - , Just (cmd,rest) <- splitCommand l' = case nub (findCommand cmd) of + , Just (_,cmd,rest) <- splitCommand l' = case nub (findCommand cmd) of [c] | null rest && not (any isSpace l') -> do return (l, cmdComp cmd c) diff --git a/src/Cryptol/Parser/Lexer.x b/src/Cryptol/Parser/Lexer.x index 074290b4f..9f995680a 100644 --- a/src/Cryptol/Parser/Lexer.x +++ b/src/Cryptol/Parser/Lexer.x @@ -202,7 +202,7 @@ lexer cfg cs = ( case cfgLayout cfg of primLexer :: Config -> Text -> ([Located Token], Position) primLexer cfg cs = run inp Normal where - inp = Inp { alexPos = start + inp = Inp { alexPos = cfgStart cfg , alexInputPrevChar = '\n' , input = unLit (cfgPreProc cfg) cs } diff --git a/src/Cryptol/Parser/LexerUtils.hs b/src/Cryptol/Parser/LexerUtils.hs index 88caaef5a..c0fae8960 100644 --- a/src/Cryptol/Parser/LexerUtils.hs +++ b/src/Cryptol/Parser/LexerUtils.hs @@ -32,6 +32,7 @@ import Control.DeepSeq data Config = Config { cfgSource :: !FilePath -- ^ File that we are working on + , cfgStart :: !Position -- ^ Starting position for the parser , cfgLayout :: !Layout -- ^ Settings for layout processing , cfgPreProc :: PreProc -- ^ Preprocessor settings , cfgAutoInclude :: [FilePath] -- ^ Implicit includes @@ -43,6 +44,7 @@ data Config = Config defaultConfig :: Config defaultConfig = Config { cfgSource = "" + , cfgStart = start , cfgLayout = Layout , cfgPreProc = None , cfgAutoInclude = [] diff --git a/src/Cryptol/REPL/Command.hs b/src/Cryptol/REPL/Command.hs index eea350824..9b64e3a98 100644 --- a/src/Cryptol/REPL/Command.hs +++ b/src/Cryptol/REPL/Command.hs @@ -6,6 +6,8 @@ -- Stability : provisional -- Portability : portable +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} @@ -72,6 +74,7 @@ import qualified Cryptol.Testing.Random as TestR import Cryptol.Parser (parseExprWith,parseReplWith,ParseError(),Config(..),defaultConfig ,parseModName,parseHelpName) +import Cryptol.Parser.Position (Position(..)) import qualified Cryptol.TypeCheck.AST as T import qualified Cryptol.TypeCheck.Error as T import qualified Cryptol.TypeCheck.Parseable as T @@ -135,7 +138,7 @@ import qualified Data.SBV.Internals as SBV (showTDiff) -- | Commands. data Command - = Command (REPL ()) -- ^ Successfully parsed command + = Command (Int -> Maybe FilePath -> REPL ()) -- ^ Successfully parsed command | Ambiguous String [String] -- ^ Ambiguous command, list of conflicting -- commands | Unknown String -- ^ The unknown command @@ -159,8 +162,8 @@ instance Ord CommandDescr where compare = compare `on` cNames data CommandBody - = ExprArg (String -> REPL ()) - | FileExprArg (FilePath -> String -> REPL ()) + = ExprArg (String -> (Int,Int) -> Maybe FilePath -> REPL ()) + | FileExprArg (FilePath -> String -> (Int,Int) -> Maybe FilePath -> REPL ()) | DeclsArg (String -> REPL ()) | ExprTypeArg (String -> REPL ()) | ModNameArg (String -> REPL ()) @@ -214,10 +217,10 @@ nbCommandList = , CommandDescr [ ":s", ":set" ] ["[ OPTION [ = VALUE ] ]"] (OptionArg setOptionCmd) "Set an environmental option (:set on its own displays current values)." "" - , CommandDescr [ ":check" ] ["[ EXPR ]"] (ExprArg (void . qcCmd QCRandom)) + , CommandDescr [ ":check" ] ["[ EXPR ]"] (ExprArg (qcCmd QCRandom)) "Use random testing to check that the argument always returns true.\n(If no argument, check all properties.)" "" - , CommandDescr [ ":exhaust" ] ["[ EXPR ]"] (ExprArg (void . qcCmd QCExhaust)) + , CommandDescr [ ":exhaust" ] ["[ EXPR ]"] (ExprArg (qcCmd QCExhaust)) "Use exhaustive testing to prove that the argument always returns\ntrue. (If no argument, check all properties.)" "" , CommandDescr [ ":prove" ] ["[ EXPR ]"] (ExprArg proveCmd) @@ -295,10 +298,10 @@ genHelp cs = map cmdHelp cs -- Command Evaluation ---------------------------------------------------------- -- | Run a command. -runCommand :: Command -> REPL CommandExitCode -runCommand c = case c of +runCommand :: Int -> Maybe FilePath -> Command -> REPL CommandExitCode +runCommand lineNum mbBatch c = case c of - Command cmd -> (cmd >> return CommandOk) `Cryptol.REPL.Monad.catch` handler + Command cmd -> (cmd lineNum mbBatch >> return CommandOk) `Cryptol.REPL.Monad.catch` handler where handler re = rPutStrLn "" >> rPrint (pp re) >> return CommandError @@ -338,9 +341,9 @@ getEvalOpts = l <- getLogger return E.EvalOpts { E.evalPPOpts = ppOpts, E.evalLogger = l } -evalCmd :: String -> REPL () -evalCmd str = do - ri <- replParseInput str +evalCmd :: String -> Int -> Maybe FilePath -> REPL () +evalCmd str lineNum mbBatch = do + ri <- replParseInput str lineNum mbBatch case ri of P.ExprInput expr -> do (val,_ty) <- replEvalExpr expr @@ -381,9 +384,9 @@ printSatisfyingModel pexpr vs = rPrint $ hang doc 2 (sep docs) <+> text ("= True") -dumpTestsCmd :: FilePath -> String -> REPL () -dumpTestsCmd outFile str = - do expr <- replParseExpr str +dumpTestsCmd :: FilePath -> String -> (Int,Int) -> Maybe FilePath -> REPL () +dumpTestsCmd outFile str pos fnm = + do expr <- replParseExpr str pos fnm (val, ty) <- replEvalExpr expr ppopts <- getPPValOpts testNum <- getKnownUser "tests" :: REPL Int @@ -412,19 +415,21 @@ data QCMode = QCRandom | QCExhaust deriving (Eq, Show) -- | Randomly test a property, or exhaustively check it if the number -- of values in the type under test is smaller than the @tests@ -- environment variable, or we specify exhaustive testing. -qcCmd :: QCMode -> String -> REPL [TestReport] -qcCmd qcMode "" = +qcCmd :: QCMode -> String -> (Int,Int) -> Maybe FilePath -> REPL () +qcCmd qcMode "" pos fnm = do (xs,disp) <- getPropertyNames let nameStr x = show (fixNameDisp disp (pp x)) if null xs - then rPutStrLn "There are no properties in scope." *> return [] - else concat <$> (forM xs $ \x -> + then rPutStrLn "There are no properties in scope." + else forM_ xs $ \x -> + -- TOOD, this is pretty bogus. Should find a way to do + -- this directly from the 'Name' instead of parsing it again. do let str = nameStr x rPutStr $ "property " ++ str ++ " " - qcCmd qcMode str) + qcCmd qcMode str pos fnm -qcCmd qcMode str = - do expr <- replParseExpr str +qcCmd qcMode str pos fnm = + do expr <- replParseExpr str pos fnm (val,ty) <- replEvalExpr expr testNum <- (toInteger :: Int -> Integer) <$> getKnownUser "tests" tenv <- E.envTypes . M.deEnv <$> getDynEnv @@ -448,7 +453,7 @@ qcCmd qcMode str = delProgress delTesting ppReport (map E.tValTy tys) expr True report - return [report] + --return [report] Just (sz,tys,_,gens) | qcMode == QCRandom -> do rPutStrLn "Using random testing." @@ -472,7 +477,7 @@ qcCmd qcMode str = case sz of Just n | isPass res -> rPutStrLn $ coverageString testNum n _ -> return () - return [report] + --return [report] _ -> raise (TypeNotTestable ty) where @@ -606,7 +611,7 @@ expectedCoverage testNum sz = proportion = negate (expm1 (numD * log1p (negate (recip szD)))) -satCmd, proveCmd :: String -> REPL () +satCmd, proveCmd :: String -> (Int,Int) -> Maybe FilePath -> REPL () satCmd = cmdProveSat True proveCmd = cmdProveSat False @@ -628,16 +633,17 @@ rethrowErrorCall m = REPL (\r -> unREPL m r `X.catches` hs) ] -- | Attempts to prove the given term is safe for all inputs -safeCmd :: String -> REPL () -safeCmd str = do +safeCmd :: String -> (Int,Int) -> Maybe FilePath -> REPL () +safeCmd str pos fnm = do proverName <- getKnownUser "prover" fileName <- getKnownUser "smtfile" let mfile = if fileName == "-" then Nothing else Just fileName + pexpr <- replParseExpr str pos fnm if proverName `elem` ["offline","sbv-offline","w4-offline"] then - offlineProveSat proverName SafetyQuery str mfile + offlineProveSat proverName SafetyQuery pexpr mfile else - do (firstProver,result,stats) <- rethrowErrorCall (onlineProveSat proverName SafetyQuery str mfile) + do (firstProver,result,stats) <- rethrowErrorCall (onlineProveSat proverName SafetyQuery pexpr mfile) case result of EmptyResult -> panic "REPL.Command" [ "got EmptyResult for online prover query" ] @@ -652,7 +658,6 @@ safeCmd str = do vs = map ( \(_,_,v) -> v) tevs (t,e) <- mkSolverResult "counterexample" False (Right tes) - pexpr <- replParseExpr str ~(EnvBool yes) <- getUser "show-examples" when yes $ printCounterexample cexType pexpr vs @@ -670,8 +675,8 @@ safeCmd str = do -- console, and binds the @it@ variable to a record whose form depends -- on the expression given. See ticket #66 for a discussion of this -- design. -cmdProveSat :: Bool -> String -> REPL () -cmdProveSat isSat "" = +cmdProveSat :: Bool -> String -> (Int,Int) -> Maybe FilePath -> REPL () +cmdProveSat isSat "" pos fnm = do (xs,disp) <- getPropertyNames let nameStr x = show (fixNameDisp disp (pp x)) if null xs @@ -681,19 +686,20 @@ cmdProveSat isSat "" = if isSat then rPutStr $ ":sat " ++ str ++ "\n\t" else rPutStr $ ":prove " ++ str ++ "\n\t" - cmdProveSat isSat str -cmdProveSat isSat str = do + cmdProveSat isSat str pos fnm +cmdProveSat isSat str pos fnm = do let cexStr | isSat = "satisfying assignment" | otherwise = "counterexample" qtype <- if isSat then SatQuery <$> getUserSatNum else pure ProveQuery proverName <- getKnownUser "prover" fileName <- getKnownUser "smtfile" let mfile = if fileName == "-" then Nothing else Just fileName + pexpr <- replParseExpr str pos fnm if proverName `elem` ["offline","sbv-offline","w4-offline"] then - offlineProveSat proverName qtype str mfile + offlineProveSat proverName qtype pexpr mfile else - do (firstProver,result,stats) <- rethrowErrorCall (onlineProveSat proverName qtype str mfile) + do (firstProver,result,stats) <- rethrowErrorCall (onlineProveSat proverName qtype pexpr mfile) case result of EmptyResult -> panic "REPL.Command" [ "got EmptyResult for online prover query" ] @@ -711,7 +717,6 @@ cmdProveSat isSat str = do vs = map ( \(_,_,v) -> v) tevs (t,e) <- mkSolverResult cexStr isSat (Right tes) - pexpr <- replParseExpr str ~(EnvBool yes) <- getUser "show-examples" when yes $ printCounterexample cexType pexpr vs @@ -736,7 +741,6 @@ cmdProveSat isSat str = do [ "no satisfying assignments after mkSolverResult" ] [(t, e)] -> (t, [e]) _ -> collectTes resultRecs - pexpr <- replParseExpr str ~(EnvBool yes) <- getUser "show-examples" when yes $ forM_ vss (printSatisfyingModel pexpr) @@ -750,12 +754,12 @@ cmdProveSat isSat str = do onlineProveSat :: String -> QueryType - -> String -> Maybe FilePath + -> P.Expr P.PName + -> Maybe FilePath -> REPL (Maybe String,ProverResult,ProverStats) -onlineProveSat proverName qtype str mfile = do +onlineProveSat proverName qtype parseExpr mfile = do verbose <- getKnownUser "debug" modelValidate <- getUserProverValidate - parseExpr <- replParseExpr str (_, expr, schema) <- replCheckExpr parseExpr validEvalContext expr validEvalContext schema @@ -784,11 +788,10 @@ onlineProveSat proverName qtype str mfile = do stas <- io (readIORef timing) return (firstProver,res,stas) -offlineProveSat :: String -> QueryType -> String -> Maybe FilePath -> REPL () -offlineProveSat proverName qtype str mfile = do +offlineProveSat :: String -> QueryType -> P.Expr P.PName -> Maybe FilePath -> REPL () +offlineProveSat proverName qtype parseExpr mfile = do verbose <- getKnownUser "debug" modelValidate <- getUserProverValidate - parseExpr <- replParseExpr str (_, expr, schema) <- replCheckExpr parseExpr decls <- fmap M.deDecls getDynEnv timing <- io (newIORef 0) @@ -882,9 +885,9 @@ mkSolverResult thing result earg = let argName = M.packIdent ("arg" ++ show n) in ((argName,t),(argName,e)) -specializeCmd :: String -> REPL () -specializeCmd str = do - parseExpr <- replParseExpr str +specializeCmd :: String -> (Int,Int) -> Maybe FilePath -> REPL () +specializeCmd str pos fnm = do + parseExpr <- replParseExpr str pos fnm (_, expr, schema) <- replCheckExpr parseExpr spexpr <- replSpecExpr expr rPutStrLn "Expression type:" @@ -894,9 +897,9 @@ specializeCmd str = do rPutStrLn "Specialized expression:" rPutStrLn $ dump spexpr -refEvalCmd :: String -> REPL () -refEvalCmd str = do - parseExpr <- replParseExpr str +refEvalCmd :: String -> (Int,Int) -> Maybe FilePath -> REPL () +refEvalCmd str pos fnm = do + parseExpr <- replParseExpr str pos fnm (_, expr, schema) <- replCheckExpr parseExpr validEvalContext expr validEvalContext schema @@ -904,9 +907,9 @@ refEvalCmd str = do opts <- getPPValOpts rPrint $ R.ppEValue opts val -astOfCmd :: String -> REPL () -astOfCmd str = do - expr <- replParseExpr str +astOfCmd :: String -> (Int,Int) -> Maybe FilePath -> REPL () +astOfCmd str pos fnm = do + expr <- replParseExpr str pos fnm (re,_,_) <- replCheckExpr (P.noPos expr) rPrint (fmap M.nameUnique re) @@ -915,10 +918,10 @@ allTerms = do me <- getModuleEnv rPrint $ T.showParseable $ concatMap T.mDecls $ M.loadedModules me -typeOfCmd :: String -> REPL () -typeOfCmd str = do +typeOfCmd :: String -> (Int,Int) -> Maybe FilePath -> REPL () +typeOfCmd str pos fnm = do - expr <- replParseExpr str + expr <- replParseExpr str pos fnm (_re,def,sig) <- replCheckExpr expr -- XXX need more warnings from the module system @@ -963,9 +966,9 @@ byteStringToInteger bs x1 = byteStringToInteger bs1 x2 = byteStringToInteger bs2 -writeFileCmd :: FilePath -> String -> REPL () -writeFileCmd file str = do - expr <- replParseExpr str +writeFileCmd :: FilePath -> String -> (Int,Int) -> Maybe FilePath -> REPL () +writeFileCmd file str pos fnm = do + expr <- replParseExpr str pos fnm (val,ty) <- replEvalExpr expr if not (tIsByteSeq ty) then rPrint $ "Cannot write expression of types other than [n][8]." @@ -1348,9 +1351,9 @@ helpCmd cmd | null cmd = mapM_ rPutStrLn (genHelp commandList) | cmd0 : args <- words cmd, ":" `isPrefixOf` cmd0 = case findCommandExact cmd0 of - [] -> void $ runCommand (Unknown cmd0) + [] -> void $ runCommand 1 Nothing (Unknown cmd0) [c] -> showCmdHelp c args - cs -> void $ runCommand (Ambiguous cmd0 (concatMap cNames cs)) + cs -> void $ runCommand 1 Nothing (Ambiguous cmd0 (concatMap cNames cs)) | otherwise = case parseHelpName cmd of Just qname -> @@ -1557,11 +1560,25 @@ replParse parse str = case parse str of Right a -> return a Left e -> raise (ParseError e) -replParseInput :: String -> REPL (P.ReplInput P.PName) -replParseInput = replParse (parseReplWith interactiveConfig . T.pack) +replParseInput :: String -> Int -> Maybe FilePath -> REPL (P.ReplInput P.PName) +replParseInput str lineNum fnm = replParse (parseReplWith cfg . T.pack) str + where + cfg = case fnm of + Nothing -> interactiveConfig{ cfgStart = Position lineNum 1 } + Just f -> defaultConfig + { cfgSource = f + , cfgStart = Position lineNum 1 + } -replParseExpr :: String -> REPL (P.Expr P.PName) -replParseExpr = replParse (parseExprWith interactiveConfig . T.pack) +replParseExpr :: String -> (Int,Int) -> Maybe FilePath -> REPL (P.Expr P.PName) +replParseExpr str (l,c) fnm = replParse (parseExprWith cfg. T.pack) str + where + cfg = case fnm of + Nothing -> interactiveConfig{ cfgStart = Position l c } + Just f -> defaultConfig + { cfgSource = f + , cfgStart = Position l c + } interactiveConfig :: Config interactiveConfig = defaultConfig { cfgSource = "" } @@ -1770,19 +1787,26 @@ trim :: String -> String trim = sanitizeEnd . sanitize -- | Split at the first word boundary. -splitCommand :: String -> Maybe (String,String) -splitCommand txt = - case sanitize txt of - ':' : more +splitCommand :: String -> Maybe (Int,String,String) +splitCommand = go 0 + where + go !len (c : more) + | isSpace c = go (len+1) more + + go !len (':': more) | (as,bs) <- span (\x -> isPunctuation x || isSymbol x) more - , not (null as) -> Just (':' : as, sanitize bs) + , (ws,cs) <- span isSpace bs + , not (null as) = Just (len+1+length as+length ws, ':' : as, cs) | (as,bs) <- break isSpace more - , not (null as) -> Just (':' : as, sanitize bs) + , (ws,cs) <- span isSpace bs + , not (null as) = Just (len+1+length as+length ws, ':' : as, cs) - | otherwise -> Nothing + | otherwise = Nothing - expr -> guard (not (null expr)) >> return (expr,[]) + go !len expr + | null expr = Nothing + | otherwise = Just (len+length expr, expr, []) -- | Uncons a list. uncons :: [a] -> Maybe (a,[a]) @@ -1807,23 +1831,24 @@ findNbCommand False str = lookupTrie str nbCommands -- | Parse a line as a command. parseCommand :: (String -> [CommandDescr]) -> String -> Maybe Command parseCommand findCmd line = do - (cmd,args) <- splitCommand line + (cmdLen,cmd,args) <- splitCommand line let args' = sanitizeEnd args case findCmd cmd of [c] -> case cBody c of - ExprArg body -> Just (Command (body args')) - DeclsArg body -> Just (Command (body args')) - ExprTypeArg body -> Just (Command (body args')) - ModNameArg body -> Just (Command (body args')) - FilenameArg body -> Just (Command (body =<< expandHome args')) - OptionArg body -> Just (Command (body args')) - ShellArg body -> Just (Command (body args')) - HelpArg body -> Just (Command (body args')) - NoArg body -> Just (Command body) + ExprArg body -> Just (Command \l fp -> (body args' (l,cmdLen+1) fp)) + DeclsArg body -> Just (Command \_ _ -> (body args')) + ExprTypeArg body -> Just (Command \_ _ -> (body args')) + ModNameArg body -> Just (Command \_ _ -> (body args')) + FilenameArg body -> Just (Command \_ _ -> (body =<< expandHome args')) + OptionArg body -> Just (Command \_ _ -> (body args')) + ShellArg body -> Just (Command \_ _ -> (body args')) + HelpArg body -> Just (Command \_ _ -> (body args')) + NoArg body -> Just (Command \_ _ -> body) FileExprArg body -> - case extractFilePath args' of - Just (fp,expr) -> Just (Command (expandHome fp >>= flip body expr)) - Nothing -> Nothing + do (fpLen,fp,expr) <- extractFilePath args' + Just (Command \l fp' -> do let col = cmdLen + fpLen + 1 + hm <- expandHome fp + body hm expr (l,col) fp') [] -> case uncons cmd of Just (':',_) -> Just (Unknown cmd) Just _ -> Just (Command (evalCmd line)) @@ -1839,9 +1864,10 @@ parseCommand findCmd line = do _ -> return path extractFilePath ipt = - let quoted q = (\(a,b) -> (a, drop 1 b)) . break (== q) + let quoted q = (\(a,b) -> (length a + 2, a, drop 1 b)) . break (== q) in case ipt of "" -> Nothing '\'':rest -> Just $ quoted '\'' rest '"':rest -> Just $ quoted '"' rest - _ -> Just $ break isSpace ipt + _ -> let (a,b) = break isSpace ipt in + if null a then Nothing else Just (length a, a, b) From 80b558ab98130906cafb61a716cd256f7701e74a Mon Sep 17 00:00:00 2001 From: Rob Dockins Date: Thu, 26 Nov 2020 00:40:57 -0800 Subject: [PATCH 08/27] When safey violations are found via `:safe` or `:prove`, run the expression concretely with the computed inputs to find and print the actual concrete error generated by the counterexample. --- src/Cryptol/REPL/Command.hs | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) diff --git a/src/Cryptol/REPL/Command.hs b/src/Cryptol/REPL/Command.hs index 9b64e3a98..963c57472 100644 --- a/src/Cryptol/REPL/Command.hs +++ b/src/Cryptol/REPL/Command.hs @@ -661,6 +661,7 @@ safeCmd str pos fnm = do ~(EnvBool yes) <- getUser "show-examples" when yes $ printCounterexample cexType pexpr vs + when yes $ printSafetyViolation pexpr vs void $ bindItVariable t e @@ -721,6 +722,12 @@ cmdProveSat isSat str pos fnm = do ~(EnvBool yes) <- getUser "show-examples" when yes $ printCounterexample cexType pexpr vs + -- if there's a safety violation, evalute the counterexample to + -- find and print the actual concrete error + case cexType of + SafetyViolation -> when yes $ printSafetyViolation pexpr vs + _ -> return () + void $ bindItVariable t e AllSatResult tevss -> do @@ -752,6 +759,16 @@ cmdProveSat isSat str pos fnm = do seeStats <- getUserShowProverStats when seeStats (showProverStats firstProver stats) +printSafetyViolation :: P.Expr P.PName -> [E.GenValue Concrete] -> REPL () +printSafetyViolation pexpr vs = + catch + (do (fn,_) <- replEvalExpr pexpr + rEval (E.forceValue =<< foldM (\f v -> E.fromVFun f (pure v)) fn vs)) + (\case + EvalError eex -> rPutStrLn (show (pp eex)) + ex -> raise ex) + + onlineProveSat :: String -> QueryType -> P.Expr P.PName From 5c116e276ec1253b65b6ece08213614d4c8b0305 Mon Sep 17 00:00:00 2001 From: Rob Dockins Date: Wed, 25 Nov 2020 10:13:34 -0800 Subject: [PATCH 09/27] Fix test golden output: runtime errors now print source locations. --- tests/issues/T820.icry.stdout | 8 +- tests/issues/issue084.icry.stdout | 2 +- tests/issues/issue101.icry.stdout | 4 +- tests/issues/issue103.icry.stdout | 2 + tests/issues/issue211.icry.stdout | 1 + tests/issues/issue322.icry.stdout | 2 +- tests/issues/issue364.icry.stdout | 2 +- tests/issues/issue382.icry.stdout | 22 +- tests/issues/issue413.icry.stdout | 3 + tests/issues/issue582.icry.stdout | 24 +- tests/issues/issue712.icry.stdout | 2 +- tests/issues/issue713.icry.stdout | 2 +- tests/issues/issue746.icry.stdout | 2 +- tests/issues/issue818.icry.stdout | 6 +- tests/issues/issue835.icry.stdout | 4 +- tests/issues/issue845.icry.stdout | 20 +- tests/issues/issue861.icry.stdout | 8 + tests/issues/issue910.icry.stdout | 16 +- tests/issues/issue913.icry.stdout | 4 +- tests/regression/float.icry.stdout | 16 +- tests/regression/instance.icry.stdout | 284 +++++++++++----------- tests/regression/primes.icry.stdout | 8 +- tests/regression/repeatFields.icry.stdout | 6 +- tests/regression/safety.icry.stdout | 6 + tests/regression/tc-errors.icry.stdout | 22 +- 25 files changed, 248 insertions(+), 228 deletions(-) diff --git a/tests/issues/T820.icry.stdout b/tests/issues/T820.icry.stdout index b63b6350c..b0e989716 100644 --- a/tests/issues/T820.icry.stdout +++ b/tests/issues/T820.icry.stdout @@ -3,14 +3,14 @@ Showing a specific instance of polymorphic result: * Using 'Rational' for type argument 'a' of 'Cryptol::fraction' (ratio 1 2) -[error] at :1:1--1:8: +[error] at T820.icry:2:1--2:8: • `?a` is not an integral type. arising from use of expression (/) - at :1:1--1:8 + at T820.icry:2:1--2:8 • `1/1` is not a valid literal of type `?a` arising from use of fractional literal - at :1:1--1:8 + at T820.icry:2:1--2:8 where - ?a is type argument 'a' of 'fraction' at :1:1--1:8 + ?a is type argument 'a' of 'fraction' at T820.icry:2:1--2:8 diff --git a/tests/issues/issue084.icry.stdout b/tests/issues/issue084.icry.stdout index 0e3e8370e..5cfd7eeae 100644 --- a/tests/issues/issue084.icry.stdout +++ b/tests/issues/issue084.icry.stdout @@ -3,7 +3,7 @@ Showing a specific instance of polymorphic result: * Using '5' for type argument 'n' of 'Cryptol::lg2' 0x03 -[error] at :1:1--1:4: +[error] at issue084.icry:2:1--2:4: Type mismatch: Expected type: Integer Inferred type: [5] diff --git a/tests/issues/issue101.icry.stdout b/tests/issues/issue101.icry.stdout index f6c0dd270..7a5a248a1 100644 --- a/tests/issues/issue101.icry.stdout +++ b/tests/issues/issue101.icry.stdout @@ -1,8 +1,8 @@ Loading module Cryptol -[error] at :1:1--1:11: +[error] at issue101.icry:1:1--1:11: • Unsolvable constraint: 0 >= 1 arising from use of partial type function (-) - at :1:1--1:11 + at issue101.icry:1:1--1:11 diff --git a/tests/issues/issue103.icry.stdout b/tests/issues/issue103.icry.stdout index 6cdce3bd4..3dcc72ee0 100644 --- a/tests/issues/issue103.icry.stdout +++ b/tests/issues/issue103.icry.stdout @@ -1,7 +1,9 @@ Loading module Cryptol Run-time error: undefined +at Cryptol:951:13--951:18 Using exhaustive testing. Testing... ERROR for the following inputs: () invalid sequence index: 1 +at issue103.icry:2:11--2:21 diff --git a/tests/issues/issue211.icry.stdout b/tests/issues/issue211.icry.stdout index 424a3d266..1d241cf2b 100644 --- a/tests/issues/issue211.icry.stdout +++ b/tests/issues/issue211.icry.stdout @@ -4,3 +4,4 @@ Loading module Cryptol 0x0 Run-time error: boom +at issue211.icry:4:28--4:33 diff --git a/tests/issues/issue322.icry.stdout b/tests/issues/issue322.icry.stdout index 2ce58fcf7..09f127580 100644 --- a/tests/issues/issue322.icry.stdout +++ b/tests/issues/issue322.icry.stdout @@ -1,4 +1,4 @@ Loading module Cryptol -[error] at :1:2--1:7: +[error] at issue322.icry:1:5--1:10: Named and positional type applications may not be mixed. diff --git a/tests/issues/issue364.icry.stdout b/tests/issues/issue364.icry.stdout index ea60b1c5a..0943154a1 100644 --- a/tests/issues/issue364.icry.stdout +++ b/tests/issues/issue364.icry.stdout @@ -25,4 +25,4 @@ Q.E.D. Q.E.D. :prove moderately_bogus_property -Run-time error: cannot evaluate 'random' with symbolic inputs +operation can not be supported on symbolic values: random diff --git a/tests/issues/issue382.icry.stdout b/tests/issues/issue382.icry.stdout index 80e2e7e43..a9497e3dd 100644 --- a/tests/issues/issue382.icry.stdout +++ b/tests/issues/issue382.icry.stdout @@ -1,67 +1,67 @@ Loading module Cryptol -[error] at :1:1--1:5: +[error] at issue382.icry:1:1--1:5: Type mismatch: Expected type: Bit Inferred type: [2] When checking user annotation -[error] at :1:1--1:20: +[error] at issue382.icry:2:1--2:20: Type mismatch: Expected type: (Bit, Bit) Inferred type: (Bit, Bit, Bit) When checking user annotation -[error] at :1:1--1:8: +[error] at issue382.icry:3:1--3:8: Type mismatch: Expected type: 4 Inferred type: 5 When checking user annotation -[error] at :1:1--1:14: +[error] at issue382.icry:4:1--4:14: Type mismatch: Expected type: Bit Inferred type: (Bit, Bit) When checking user annotation -[error] at :1:1--1:11: +[error] at issue382.icry:5:1--5:11: Type mismatch: Expected type: {a : Bit, b : Bit} Inferred type: {a : Bit} Missing field b When checking user annotation -[error] at :1:1--1:5: +[error] at issue382.icry:6:1--6:5: Type mismatch: Expected type: [2] Inferred type: Bit When checking user annotation -[error] at :1:1--1:3: +[error] at issue382.icry:7:1--7:3: Type mismatch: Expected type: inf Inferred type: 0 When checking length of sequence -[error] at :1:9--1:11: +[error] at issue382.icry:8:9--8:11: Type mismatch: Expected type: [3] Inferred type: {} When checking type of function argument -[error] at :1:9--1:22: +[error] at issue382.icry:9:9--9:22: Type mismatch: Expected type: [3] Inferred type: (Bit, Bit) When checking type of function argument -[error] at :1:2--1:15: +[error] at issue382.icry:10:2--10:15: Type mismatch: Expected type: [2] Inferred type: Bit -> Bit When checking user annotation -[error] at :1:1--1:5: +[error] at issue382.icry:11:1--11:5: Type mismatch: Expected type: Bit -> Bit Inferred type: Bit diff --git a/tests/issues/issue413.icry.stdout b/tests/issues/issue413.icry.stdout index 4a6fbdd07..982affb80 100644 --- a/tests/issues/issue413.icry.stdout +++ b/tests/issues/issue413.icry.stdout @@ -1,7 +1,10 @@ Loading module Cryptol division by 0 +at issue413.icry:1:1--1:10 division by 0 +at issue413.icry:2:1--2:5 division by 0 +at issue413.icry:3:1--3:5 diff --git a/tests/issues/issue582.icry.stdout b/tests/issues/issue582.icry.stdout index cf51aa924..72056447d 100644 --- a/tests/issues/issue582.icry.stdout +++ b/tests/issues/issue582.icry.stdout @@ -1,46 +1,46 @@ Loading module Cryptol -[error] at :1:1--1:18: +[error] at issue582.icry:1:1--1:18: • Unsolvable constraint: fin inf arising from use of partial type function (/^) - at :1:1--1:18 + at issue582.icry:1:1--1:18 -[error] at :1:1--1:18: +[error] at issue582.icry:2:1--2:18: • Unsolvable constraint: fin inf arising from use of partial type function (/^) - at :1:1--1:18 + at issue582.icry:2:1--2:18 -[error] at :1:1--1:16: +[error] at issue582.icry:3:1--3:16: • Unsolvable constraint: 0 >= 1 arising from use of partial type function (/^) - at :1:1--1:16 + at issue582.icry:3:1--3:16 -[error] at :1:1--1:18: +[error] at issue582.icry:4:1--4:18: • Unsolvable constraint: fin inf arising from use of partial type function (%^) - at :1:1--1:18 + at issue582.icry:4:1--4:18 -[error] at :1:1--1:18: +[error] at issue582.icry:5:1--5:18: • Unsolvable constraint: fin inf arising from use of partial type function (%^) - at :1:1--1:18 + at issue582.icry:5:1--5:18 -[error] at :1:1--1:16: +[error] at issue582.icry:6:1--6:16: • Unsolvable constraint: 0 >= 1 arising from use of partial type function (%^) - at :1:1--1:16 + at issue582.icry:6:1--6:16 Loading module Cryptol Loading module Main diff --git a/tests/issues/issue712.icry.stdout b/tests/issues/issue712.icry.stdout index a4bc83ff8..b0059a398 100644 --- a/tests/issues/issue712.icry.stdout +++ b/tests/issues/issue712.icry.stdout @@ -1,4 +1,4 @@ Loading module Cryptol -Parse error at :1:1--1:28 +Parse error at issue712.icry:1:4--1:31 Polynomial literal too large: 18446744073709551617 diff --git a/tests/issues/issue713.icry.stdout b/tests/issues/issue713.icry.stdout index 5bb213c97..e9ac4d18e 100644 --- a/tests/issues/issue713.icry.stdout +++ b/tests/issues/issue713.icry.stdout @@ -1,4 +1,4 @@ Loading module Cryptol -Parse error at :1:13--1:17 +Parse error at issue713.icry:1:13--1:17 malformed selector: .0x1 diff --git a/tests/issues/issue746.icry.stdout b/tests/issues/issue746.icry.stdout index 08f97e109..2e5782fa3 100644 --- a/tests/issues/issue746.icry.stdout +++ b/tests/issues/issue746.icry.stdout @@ -1,6 +1,6 @@ Loading module Cryptol -[error] at :1:11--1:16: +[error] at issue746.icry:1:11--1:16: Type mismatch: Expected type: 3 Inferred type: 2 diff --git a/tests/issues/issue818.icry.stdout b/tests/issues/issue818.icry.stdout index 19b2dc415..4c0fa7a82 100644 --- a/tests/issues/issue818.icry.stdout +++ b/tests/issues/issue818.icry.stdout @@ -1,10 +1,10 @@ Loading module Cryptol -Parse error at :1:5--1:10 +Parse error at issue818.icry:1:5--1:10 malformed literal: 0b012 -Parse error at :1:5--1:7 +Parse error at issue818.icry:2:5--2:7 malformed literal: 2z -Parse error at :1:5--1:7 +Parse error at issue818.icry:3:5--3:7 malformed literal: 2z diff --git a/tests/issues/issue835.icry.stdout b/tests/issues/issue835.icry.stdout index 13187f61b..894a9b670 100644 --- a/tests/issues/issue835.icry.stdout +++ b/tests/issues/issue835.icry.stdout @@ -2,8 +2,8 @@ Loading module Cryptol Loading module Cryptol Loading module Float -[error] at :1:1--1:28: +[error] at issue835.icry:2:4--2:31: • Type `Float 5 11` does not support signed comparisons. arising from use of expression (<$) - at :1:1--1:28 + at issue835.icry:2:4--2:31 diff --git a/tests/issues/issue845.icry.stdout b/tests/issues/issue845.icry.stdout index 1a48ca0db..6adfc6ffd 100644 --- a/tests/issues/issue845.icry.stdout +++ b/tests/issues/issue845.icry.stdout @@ -26,36 +26,36 @@ Loading module Main at issue845.cry:2:9--2:17 (ratio 1 2) -[error] at :1:1--1:9: +[error] at issue845.icry:3:1--3:9: • `1/0` is not a valid literal of type `Rational` arising from use of fractional literal - at :1:1--1:9 + at issue845.icry:3:1--3:9 -[error] at :1:1--1:9: +[error] at issue845.icry:4:1--4:9: • `inf/2` is not a valid literal of type `Rational` arising from use of fractional literal - at :1:1--1:9 + at issue845.icry:4:1--4:9 Loading module Cryptol Loading module Float 0x0.8 -[error] at :1:1--1:9: +[error] at issue845.icry:7:1--7:9: • `1/0` is not a valid literal of type `Float64` arising from use of fractional literal - at :1:1--1:9 + at issue845.icry:7:1--7:9 -[error] at :1:1--1:9: +[error] at issue845.icry:8:1--8:9: • `inf/2` is not a valid literal of type `Float64` arising from use of fractional literal - at :1:1--1:9 + at issue845.icry:8:1--8:9 0x0.2 -[error] at :1:1--1:9: +[error] at issue845.icry:10:1--10:9: • `1/10` is not a valid literal of type `Float 3 2` arising from use of fractional literal - at :1:1--1:9 + at issue845.icry:10:1--10:9 diff --git a/tests/issues/issue861.icry.stdout b/tests/issues/issue861.icry.stdout index 6fc0462be..daf9162c8 100644 --- a/tests/issues/issue861.icry.stdout +++ b/tests/issues/issue861.icry.stdout @@ -4,26 +4,34 @@ Loading module Cryptol 2 invalid sequence index: 3 +at issue861.icry:7:1--7:5 invalid sequence index: -1 +at issue861.icry:8:1--8:8 2 1 0 invalid sequence index: 3 +at issue861.icry:13:1--13:5 invalid sequence index: -1 +at issue861.icry:14:1--14:8 [5, 1, 2] [0, 5, 2] [0, 1, 5] invalid sequence index: 3 +at issue861.icry:19:1--19:7 invalid sequence index: -1 +at issue861.icry:20:1--20:7 [0, 1, 5] [0, 5, 2] [5, 1, 2] invalid sequence index: 3 +at issue861.icry:25:1--25:10 invalid sequence index: -1 +at issue861.icry:26:1--26:10 diff --git a/tests/issues/issue910.icry.stdout b/tests/issues/issue910.icry.stdout index 6341a306c..82de9a6aa 100644 --- a/tests/issues/issue910.icry.stdout +++ b/tests/issues/issue910.icry.stdout @@ -1,25 +1,25 @@ Loading module Cryptol -[error] at :1:1--1:21: +[error] at issue910.icry:1:1--1:21: • `?a` is not an integral type. arising from use of expression (@) - at :1:8--1:21 + at issue910.icry:1:8--1:21 • Type `?a` does not support field operations. arising from use of expression (/.) - at :1:14--1:20 + at issue910.icry:1:14--1:20 where - ?a is type argument 'a' of '(/.)' at :1:14--1:20 + ?a is type argument 'a' of '(/.)' at issue910.icry:1:14--1:20 -[error] at :1:1--1:16: +[error] at issue910.icry:2:1--2:16: • `?a` is not an integral type. arising from use of expression (@) - at :1:8--1:16 + at issue910.icry:2:8--2:16 • `6/5` is not a valid literal of type `?a` arising from use of fractional literal - at :1:13--1:16 + at issue910.icry:2:13--2:16 where - ?a is type argument 'a' of 'fraction' at :1:13--1:16 + ?a is type argument 'a' of 'fraction' at issue910.icry:2:13--2:16 diff --git a/tests/issues/issue913.icry.stdout b/tests/issues/issue913.icry.stdout index a3ab7aca3..69cdaf29d 100644 --- a/tests/issues/issue913.icry.stdout +++ b/tests/issues/issue913.icry.stdout @@ -4,9 +4,9 @@ False 0x5b number`{rep = Bit} : {n} (1 >= n) => Bit -[error] at :1:1--1:2: +[error] at issue913.icry:5:1--5:2: • Unsolvable constraint: 1 >= 2 arising from use of literal or demoted expression - at :1:1--1:2 + at issue913.icry:5:1--5:2 diff --git a/tests/regression/float.icry.stdout b/tests/regression/float.icry.stdout index de525a4e8..e9d742038 100644 --- a/tests/regression/float.icry.stdout +++ b/tests/regression/float.icry.stdout @@ -44,19 +44,19 @@ Specifies the format to use when showing floating point numbers: IEEE-754 floating point numbers. -[error] at :1:1--1:17: +[error] at float.icry:36:1--36:17: Unsolved constraints: • ValidFloat 0 0 arising from use of partial type function Float - at :1:1--1:17 + at float.icry:36:1--36:17 -[error] at :1:1--1:21: +[error] at float.icry:37:1--37:21: Unsolved constraints: • ValidFloat 80 1000 arising from use of partial type function Float - at :1:1--1:21 + at float.icry:37:1--37:21 0x0.0p0 0x0.0p0 0x0.0p0 @@ -70,21 +70,21 @@ IEEE-754 floating point numbers. 0x1.0p8 0x4.0p0 -[error] at :1:1--1:20: +[error] at float.icry:53:1--53:20: • `5/1` is not a valid literal of type `Small` arising from use of fractional literal - at :1:1--1:6 + at float.icry:53:1--53:6 0x1.3p0 0x2.0p-4 0x2.0p-4 0x8.0p0 -[error] at :1:1--1:2: +[error] at float.icry:59:1--59:2: • `7` is not a valid literal of type `Small` arising from use of literal or demoted expression - at :1:1--1:2 + at float.icry:59:1--59:2 "-- NaN------------------------------------------------------------------------" fpNaN : {e, p} (ValidFloat e p) => Float e p diff --git a/tests/regression/instance.icry.stdout b/tests/regression/instance.icry.stdout index 2818b2a18..8ac471426 100644 --- a/tests/regression/instance.icry.stdout +++ b/tests/regression/instance.icry.stdout @@ -15,25 +15,25 @@ zero`{{x : _, y : _}} : {a, b} (Zero b, Zero a) => {x : a, y : b} zero`{Float _ _} : {n, m} (ValidFloat n m) => Float n m complement`{Bit} : Bit -> Bit -[error] at :1:1--1:11: +[error] at instance.icry:16:4--16:14: • Type `Integer` does not support logical operations. arising from use of expression complement - at :1:1--1:11 + at instance.icry:16:4--16:14 -[error] at :1:1--1:11: +[error] at instance.icry:17:4--17:14: • Type `Rational` does not support logical operations. arising from use of expression complement - at :1:1--1:11 + at instance.icry:17:4--17:14 -[error] at :1:1--1:11: +[error] at instance.icry:18:4--18:14: • Type `Z ?m` does not support logical operations. arising from use of expression complement - at :1:1--1:11 + at instance.icry:18:4--18:14 where - ?m is type wildcard (_) at :1:15--1:16 + ?m is type wildcard (_) at instance.icry:18:18--18:19 complement`{[_]_} : {n, a} (Logic a) => [n]a -> [n]a complement`{(_ -> _)} : {a, b} (Logic b) => (a -> b) -> a -> b complement`{()} : () -> () @@ -42,20 +42,20 @@ complement`{{}} : {} -> {} complement`{{x : _, y : _}} : {a, b} (Logic b, Logic a) => {x : a, y : b} -> {x : a, y : b} -[error] at :1:1--1:11: +[error] at instance.icry:25:4--25:14: • Type `Float ?m ?n` does not support logical operations. arising from use of expression complement - at :1:1--1:11 + at instance.icry:25:4--25:14 where - ?m is type wildcard (_) at :1:19--1:20 - ?n is type wildcard (_) at :1:21--1:22 + ?m is type wildcard (_) at instance.icry:25:22--25:23 + ?n is type wildcard (_) at instance.icry:25:24--25:25 -[error] at :1:1--1:7: +[error] at instance.icry:27:4--27:10: • Type `Bit` does not support ring operations. arising from use of expression negate - at :1:1--1:7 + at instance.icry:27:4--27:10 negate`{Integer} : Integer -> Integer negate`{Rational} : Rational -> Rational negate`{Z _} : {n} (n >= 1, fin n) => Z n -> Z n @@ -70,208 +70,208 @@ negate`{{x : _, y : _}} : {a, b} (Ring b, Ring a) => negate`{Float _ _} : {n, m} (ValidFloat n m) => Float n m -> Float n m -[error] at :1:1--1:4: +[error] at instance.icry:40:4--40:7: • `Bit` is not an integral type. arising from use of expression (%) - at :1:1--1:4 + at instance.icry:40:4--40:7 (%)`{Integer} : Integer -> Integer -> Integer -[error] at :1:1--1:4: +[error] at instance.icry:42:4--42:7: • `Rational` is not an integral type. arising from use of expression (%) - at :1:1--1:4 + at instance.icry:42:4--42:7 -[error] at :1:1--1:4: +[error] at instance.icry:43:4--43:7: • `Z ?m` is not an integral type. arising from use of expression (%) - at :1:1--1:4 + at instance.icry:43:4--43:7 where - ?m is type wildcard (_) at :1:8--1:9 + ?m is type wildcard (_) at instance.icry:43:11--43:12 (%)`{[_]_} : {n, a} (Integral ([n]a)) => [n]a -> [n]a -> [n]a -[error] at :1:1--1:4: +[error] at instance.icry:45:4--45:7: • `?a -> ?b` is not an integral type. arising from use of expression (%) - at :1:1--1:4 + at instance.icry:45:4--45:7 where - ?a is type wildcard (_) at :1:7--1:8 - ?b is type wildcard (_) at :1:12--1:13 + ?a is type wildcard (_) at instance.icry:45:10--45:11 + ?b is type wildcard (_) at instance.icry:45:15--45:16 -[error] at :1:1--1:4: +[error] at instance.icry:46:4--46:7: • `()` is not an integral type. arising from use of expression (%) - at :1:1--1:4 + at instance.icry:46:4--46:7 -[error] at :1:1--1:4: +[error] at instance.icry:47:4--47:7: • `(?a, ?b)` is not an integral type. arising from use of expression (%) - at :1:1--1:4 + at instance.icry:47:4--47:7 where - ?a is type wildcard (_) at :1:7--1:8 - ?b is type wildcard (_) at :1:10--1:11 + ?a is type wildcard (_) at instance.icry:47:10--47:11 + ?b is type wildcard (_) at instance.icry:47:13--47:14 -[error] at :1:1--1:4: +[error] at instance.icry:48:4--48:7: • `{}` is not an integral type. arising from use of expression (%) - at :1:1--1:4 + at instance.icry:48:4--48:7 -[error] at :1:1--1:4: +[error] at instance.icry:49:4--49:7: • `{x : ?a, y : ?b}` is not an integral type. arising from use of expression (%) - at :1:1--1:4 + at instance.icry:49:4--49:7 where - ?a is type wildcard (_) at :1:11--1:12 - ?b is type wildcard (_) at :1:18--1:19 + ?a is type wildcard (_) at instance.icry:49:14--49:15 + ?b is type wildcard (_) at instance.icry:49:21--49:22 -[error] at :1:1--1:4: +[error] at instance.icry:50:4--50:7: • `Float ?m ?n` is not an integral type. arising from use of expression (%) - at :1:1--1:4 + at instance.icry:50:4--50:7 where - ?m is type wildcard (_) at :1:12--1:13 - ?n is type wildcard (_) at :1:14--1:15 + ?m is type wildcard (_) at instance.icry:50:15--50:16 + ?n is type wildcard (_) at instance.icry:50:17--50:18 -[error] at :1:1--1:6: +[error] at instance.icry:52:4--52:9: • Type `Bit` does not support field operations. arising from use of expression recip - at :1:1--1:6 + at instance.icry:52:4--52:9 -[error] at :1:1--1:6: +[error] at instance.icry:53:4--53:9: • Type `Integer` does not support field operations. arising from use of expression recip - at :1:1--1:6 + at instance.icry:53:4--53:9 recip`{Rational} : Rational -> Rational recip`{Z _} : {n} (prime n, n >= 1) => Z n -> Z n -[error] at :1:1--1:6: +[error] at instance.icry:56:4--56:9: • Type `[?m]?a` does not support field operations. arising from use of expression recip - at :1:1--1:6 + at instance.icry:56:4--56:9 where - ?m is type wildcard (_) at :1:9--1:10 - ?a is type wildcard (_) at :1:11--1:12 + ?m is type wildcard (_) at instance.icry:56:12--56:13 + ?a is type wildcard (_) at instance.icry:56:14--56:15 -[error] at :1:1--1:6: +[error] at instance.icry:57:4--57:9: • Type `?a -> ?b` does not support field operations. arising from use of expression recip - at :1:1--1:6 + at instance.icry:57:4--57:9 where - ?a is type wildcard (_) at :1:9--1:10 - ?b is type wildcard (_) at :1:14--1:15 + ?a is type wildcard (_) at instance.icry:57:12--57:13 + ?b is type wildcard (_) at instance.icry:57:17--57:18 -[error] at :1:1--1:6: +[error] at instance.icry:58:4--58:9: • Type `()` does not support field operations. arising from use of expression recip - at :1:1--1:6 + at instance.icry:58:4--58:9 -[error] at :1:1--1:6: +[error] at instance.icry:59:4--59:9: • Type `(?a, ?b)` does not support field operations. arising from use of expression recip - at :1:1--1:6 + at instance.icry:59:4--59:9 where - ?a is type wildcard (_) at :1:9--1:10 - ?b is type wildcard (_) at :1:12--1:13 + ?a is type wildcard (_) at instance.icry:59:12--59:13 + ?b is type wildcard (_) at instance.icry:59:15--59:16 -[error] at :1:1--1:6: +[error] at instance.icry:60:4--60:9: • Type `{}` does not support field operations. arising from use of expression recip - at :1:1--1:6 + at instance.icry:60:4--60:9 -[error] at :1:1--1:6: +[error] at instance.icry:61:4--61:9: • Type `{x : ?a, y : ?b}` does not support field operations. arising from use of expression recip - at :1:1--1:6 + at instance.icry:61:4--61:9 where - ?a is type wildcard (_) at :1:13--1:14 - ?b is type wildcard (_) at :1:20--1:21 + ?a is type wildcard (_) at instance.icry:61:16--61:17 + ?b is type wildcard (_) at instance.icry:61:23--61:24 recip`{Float _ _} : {n, m} (ValidFloat n m) => Float n m -> Float n m -[error] at :1:1--1:6: +[error] at instance.icry:64:4--64:9: • Type `Bit` does not support rounding operations. arising from use of expression floor - at :1:1--1:6 + at instance.icry:64:4--64:9 -[error] at :1:1--1:6: +[error] at instance.icry:65:4--65:9: • Type `Integer` does not support rounding operations. arising from use of expression floor - at :1:1--1:6 + at instance.icry:65:4--65:9 floor`{Rational} : Rational -> Integer -[error] at :1:1--1:6: +[error] at instance.icry:67:4--67:9: • Type `Z ?m` does not support rounding operations. arising from use of expression floor - at :1:1--1:6 + at instance.icry:67:4--67:9 where - ?m is type wildcard (_) at :1:10--1:11 + ?m is type wildcard (_) at instance.icry:67:13--67:14 -[error] at :1:1--1:6: +[error] at instance.icry:68:4--68:9: • Type `[?m]?a` does not support rounding operations. arising from use of expression floor - at :1:1--1:6 + at instance.icry:68:4--68:9 where - ?m is type wildcard (_) at :1:9--1:10 - ?a is type wildcard (_) at :1:11--1:12 + ?m is type wildcard (_) at instance.icry:68:12--68:13 + ?a is type wildcard (_) at instance.icry:68:14--68:15 -[error] at :1:1--1:6: +[error] at instance.icry:69:4--69:9: • Type `?a -> ?b` does not support rounding operations. arising from use of expression floor - at :1:1--1:6 + at instance.icry:69:4--69:9 where - ?a is type wildcard (_) at :1:9--1:10 - ?b is type wildcard (_) at :1:14--1:15 + ?a is type wildcard (_) at instance.icry:69:12--69:13 + ?b is type wildcard (_) at instance.icry:69:17--69:18 -[error] at :1:1--1:6: +[error] at instance.icry:70:4--70:9: • Type `()` does not support rounding operations. arising from use of expression floor - at :1:1--1:6 + at instance.icry:70:4--70:9 -[error] at :1:1--1:6: +[error] at instance.icry:71:4--71:9: • Type `(?a, ?b)` does not support rounding operations. arising from use of expression floor - at :1:1--1:6 + at instance.icry:71:4--71:9 where - ?a is type wildcard (_) at :1:9--1:10 - ?b is type wildcard (_) at :1:12--1:13 + ?a is type wildcard (_) at instance.icry:71:12--71:13 + ?b is type wildcard (_) at instance.icry:71:15--71:16 -[error] at :1:1--1:6: +[error] at instance.icry:72:4--72:9: • Type `{}` does not support rounding operations. arising from use of expression floor - at :1:1--1:6 + at instance.icry:72:4--72:9 -[error] at :1:1--1:6: +[error] at instance.icry:73:4--73:9: • Type `{x : ?a, y : ?b}` does not support rounding operations. arising from use of expression floor - at :1:1--1:6 + at instance.icry:73:4--73:9 where - ?a is type wildcard (_) at :1:13--1:14 - ?b is type wildcard (_) at :1:20--1:21 + ?a is type wildcard (_) at instance.icry:73:16--73:17 + ?b is type wildcard (_) at instance.icry:73:23--73:24 floor`{Float _ _} : {n, m} (ValidFloat n m) => Float n m -> Integer (==)`{Bit} : Bit -> Bit -> Bit (==)`{Integer} : Integer -> Integer -> Bit @@ -279,14 +279,14 @@ floor`{Float _ _} : {n, m} (ValidFloat n m) => Float n m -> Integer (==)`{Z _} : {n} (n >= 1, fin n) => Z n -> Z n -> Bit (==)`{[_]_} : {n, a} (Eq a, fin n) => [n]a -> [n]a -> Bit -[error] at :1:1--1:5: +[error] at instance.icry:81:4--81:8: • Type `?a -> ?b` does not support equality. arising from use of expression (==) - at :1:1--1:5 + at instance.icry:81:4--81:8 where - ?a is type wildcard (_) at :1:8--1:9 - ?b is type wildcard (_) at :1:13--1:14 + ?a is type wildcard (_) at instance.icry:81:11--81:12 + ?b is type wildcard (_) at instance.icry:81:16--81:17 (==)`{()} : () -> () -> Bit (==)`{(_, _)} : {a, b} (Eq b, Eq a) => (a, b) -> (a, b) -> Bit (==)`{{}} : {} -> {} -> Bit @@ -298,23 +298,23 @@ floor`{Float _ _} : {n, m} (ValidFloat n m) => Float n m -> Integer (<)`{Integer} : Integer -> Integer -> Bit (<)`{Rational} : Rational -> Rational -> Bit -[error] at :1:1--1:4: +[error] at instance.icry:91:4--91:7: • Type `Z ?m` does not support comparisons. arising from use of expression (<) - at :1:1--1:4 + at instance.icry:91:4--91:7 where - ?m is type wildcard (_) at :1:8--1:9 + ?m is type wildcard (_) at instance.icry:91:11--91:12 (<)`{[_]_} : {n, a} (Cmp a, fin n) => [n]a -> [n]a -> Bit -[error] at :1:1--1:4: +[error] at instance.icry:93:4--93:7: • Type `?a -> ?b` does not support comparisons. arising from use of expression (<) - at :1:1--1:4 + at instance.icry:93:4--93:7 where - ?a is type wildcard (_) at :1:7--1:8 - ?b is type wildcard (_) at :1:12--1:13 + ?a is type wildcard (_) at instance.icry:93:10--93:11 + ?b is type wildcard (_) at instance.icry:93:15--93:16 (<)`{()} : () -> () -> Bit (<)`{(_, _)} : {a, b} (Cmp b, Cmp a) => (a, b) -> (a, b) -> Bit (<)`{{}} : {} -> {} -> Bit @@ -323,41 +323,41 @@ floor`{Float _ _} : {n, m} (ValidFloat n m) => Float n m -> Integer (<)`{Float _ _} : {n, m} (ValidFloat n m) => Float n m -> Float n m -> Bit -[error] at :1:1--1:5: +[error] at instance.icry:100:4--100:8: • Type `Bit` does not support signed comparisons. arising from use of expression (<$) - at :1:1--1:5 + at instance.icry:100:4--100:8 -[error] at :1:1--1:5: +[error] at instance.icry:101:4--101:8: • Type `Integer` does not support signed comparisons. arising from use of expression (<$) - at :1:1--1:5 + at instance.icry:101:4--101:8 -[error] at :1:1--1:5: +[error] at instance.icry:102:4--102:8: • Type `Rational` does not support signed comparisons. arising from use of expression (<$) - at :1:1--1:5 + at instance.icry:102:4--102:8 -[error] at :1:1--1:5: +[error] at instance.icry:103:4--103:8: • Type `Z ?m` does not support signed comparisons. arising from use of expression (<$) - at :1:1--1:5 + at instance.icry:103:4--103:8 where - ?m is type wildcard (_) at :1:9--1:10 + ?m is type wildcard (_) at instance.icry:103:12--103:13 (<$)`{[_]_} : {n, a} (SignedCmp ([n]a)) => [n]a -> [n]a -> Bit -[error] at :1:1--1:5: +[error] at instance.icry:105:4--105:8: • Type `?a -> ?b` does not support signed comparisons. arising from use of expression (<$) - at :1:1--1:5 + at instance.icry:105:4--105:8 where - ?a is type wildcard (_) at :1:8--1:9 - ?b is type wildcard (_) at :1:13--1:14 + ?a is type wildcard (_) at instance.icry:105:11--105:12 + ?b is type wildcard (_) at instance.icry:105:16--105:17 (<$)`{()} : () -> () -> Bit (<$)`{(_, _)} : {a, b} (SignedCmp b, SignedCmp a) => (a, b) -> (a, b) -> Bit @@ -365,70 +365,70 @@ floor`{Float _ _} : {n, m} (ValidFloat n m) => Float n m -> Integer (<$)`{{x : _, y : _}} : {a, b} (SignedCmp b, SignedCmp a) => {x : a, y : b} -> {x : a, y : b} -> Bit -[error] at :1:1--1:5: +[error] at instance.icry:110:4--110:8: • Type `Float ?m ?n` does not support signed comparisons. arising from use of expression (<$) - at :1:1--1:5 + at instance.icry:110:4--110:8 where - ?m is type wildcard (_) at :1:13--1:14 - ?n is type wildcard (_) at :1:15--1:16 + ?m is type wildcard (_) at instance.icry:110:16--110:17 + ?n is type wildcard (_) at instance.icry:110:18--110:19 number`{rep = Bit} : {n} (1 >= n) => Bit -[error] at :1:1--1:7: +[error] at instance.icry:113:4--113:10: Ambiguous numeric type: type argument 'val' of 'number' -[error] at :1:1--1:7: +[error] at instance.icry:114:4--114:10: Ambiguous numeric type: type argument 'val' of 'number' number`{rep = Z _} : {n, m} (m >= 1 + n, m >= 1, fin m, fin n) => Z m number`{rep = [_]_} : {n, m} (m >= width n, fin m, fin n) => [m] -[error] at :1:1--1:7: +[error] at instance.icry:117:4--117:10: • `?m` is not a valid literal of type `?a -> ?b` arising from use of literal or demoted expression - at :1:1--1:7 + at instance.icry:117:4--117:10 where - ?m is type argument 'val' of 'number' at :1:1--1:7 - ?a is type wildcard (_) at :1:15--1:16 - ?b is type wildcard (_) at :1:20--1:21 + ?m is type argument 'val' of 'number' at instance.icry:117:4--117:10 + ?a is type wildcard (_) at instance.icry:117:18--117:19 + ?b is type wildcard (_) at instance.icry:117:23--117:24 -[error] at :1:1--1:7: +[error] at instance.icry:118:4--118:10: • `?m` is not a valid literal of type `()` arising from use of literal or demoted expression - at :1:1--1:7 + at instance.icry:118:4--118:10 where - ?m is type argument 'val' of 'number' at :1:1--1:7 + ?m is type argument 'val' of 'number' at instance.icry:118:4--118:10 -[error] at :1:1--1:7: +[error] at instance.icry:119:4--119:10: • `?m` is not a valid literal of type `(?a, ?b)` arising from use of literal or demoted expression - at :1:1--1:7 + at instance.icry:119:4--119:10 where - ?m is type argument 'val' of 'number' at :1:1--1:7 - ?a is type wildcard (_) at :1:16--1:17 - ?b is type wildcard (_) at :1:19--1:20 + ?m is type argument 'val' of 'number' at instance.icry:119:4--119:10 + ?a is type wildcard (_) at instance.icry:119:19--119:20 + ?b is type wildcard (_) at instance.icry:119:22--119:23 -[error] at :1:1--1:7: +[error] at instance.icry:120:4--120:10: • `?m` is not a valid literal of type `{}` arising from use of literal or demoted expression - at :1:1--1:7 + at instance.icry:120:4--120:10 where - ?m is type argument 'val' of 'number' at :1:1--1:7 + ?m is type argument 'val' of 'number' at instance.icry:120:4--120:10 -[error] at :1:1--1:7: +[error] at instance.icry:121:4--121:10: • `?m` is not a valid literal of type `{x : ?a, y : ?b}` arising from use of literal or demoted expression - at :1:1--1:7 + at instance.icry:121:4--121:10 where - ?m is type argument 'val' of 'number' at :1:1--1:7 - ?a is type wildcard (_) at :1:20--1:21 - ?b is type wildcard (_) at :1:27--1:28 + ?m is type argument 'val' of 'number' at instance.icry:121:4--121:10 + ?a is type wildcard (_) at instance.icry:121:23--121:24 + ?b is type wildcard (_) at instance.icry:121:30--121:31 number`{rep = Float _ _} : {n, m, i} (ValidFloat m i, Literal n (Float m i)) => Float m i diff --git a/tests/regression/primes.icry.stdout b/tests/regression/primes.icry.stdout index 2233014d9..dfaf748d9 100644 --- a/tests/regression/primes.icry.stdout +++ b/tests/regression/primes.icry.stdout @@ -48,19 +48,19 @@ Expected test coverage: 0.00% (100 of 2^^1042 values) 1 1 -[error] at :1:1--1:8: +[error] at primes.icry:9:1--9:8: • Unsolvable constraint: prime 8 arising from use of expression z1prime - at :1:1--1:8 + at primes.icry:9:1--9:8 -[error] at :1:1--1:8: +[error] at primes.icry:10:1--10:8: • Unsolvable constraint: prime 43091033305484275771318189120554014028061750499173210735564075069516863836988716943216254409932734872431737796205873180054667648466751626159946491190398490019830895369540999907009814461968819338016648922197947056129 arising from use of expression z1prime - at :1:1--1:8 + at primes.icry:10:1--10:8 Q.E.D. Q.E.D. Q.E.D. diff --git a/tests/regression/repeatFields.icry.stdout b/tests/regression/repeatFields.icry.stdout index 1df81ca83..8fb4a5348 100644 --- a/tests/regression/repeatFields.icry.stdout +++ b/tests/regression/repeatFields.icry.stdout @@ -1,10 +1,10 @@ Loading module Cryptol -Parse error at :1:22--1:23 +Parse error at repeatFields.icry:1:22--1:23 Record has repeated field: a -Parse error at :1:22--1:23 +Parse error at repeatFields.icry:3:22--3:23 Record has repeated field: b -Parse error at :1:16--1:17 +Parse error at repeatFields.icry:5:16--5:17 Record has repeated field: c diff --git a/tests/regression/safety.icry.stdout b/tests/regression/safety.icry.stdout index a5e02ff6e..432444d69 100644 --- a/tests/regression/safety.icry.stdout +++ b/tests/regression/safety.icry.stdout @@ -1,10 +1,16 @@ Loading module Cryptol Counterexample (\x -> assert x "asdf" "asdf") False ~> ERROR +Run-time error: asdf +at Cryptol:959:41--959:46 Counterexample (\(x : [4]) -> [0 .. 14] @ x == x) 0xf ~> ERROR +invalid sequence index: 15 +at safety.icry:4:20--4:34 Counterexample (\y -> (10 : Integer) / y) 0 ~> ERROR +division by 0 +at safety.icry:5:14--5:30 Safe Safe Safe diff --git a/tests/regression/tc-errors.icry.stdout b/tests/regression/tc-errors.icry.stdout index a2bde3033..a04ecbfad 100644 --- a/tests/regression/tc-errors.icry.stdout +++ b/tests/regression/tc-errors.icry.stdout @@ -1,42 +1,42 @@ Loading module Cryptol -[error] at :1:8--1:15: +[error] at tc-errors.icry:1:8--1:15: Incorrect type form. Expected: a numeric type Inferred: a value type -[error] at :1:12--1:17: +[error] at tc-errors.icry:2:12--2:17: Malformed type. Kind '*' is not a function, but it was applied to 1 parameter. -[error] at :1:3--1:6: +[error] at tc-errors.icry:3:3--3:6: Ambiguous numeric type: type argument 'n' of '(@)' Must be at least: 1 -[error] at :1:9--1:10: +[error] at tc-errors.icry:4:9--4:10: Matching would result in an infinite type. The type: ?b occurs in: ?b -> ?a When checking type of function argument where - ?a is type of function result at :1:1--1:10 - ?b is type of function argument at :1:7--1:10 + ?a is type of function result at tc-errors.icry:4:1--4:10 + ?b is type of function argument at tc-errors.icry:4:7--4:10 -[error] at :1:1--1:5: +[error] at tc-errors.icry:5:1--5:5: • Unsolvable constraint: fin inf arising from use of expression take - at :1:1--1:5 + at tc-errors.icry:5:1--5:5 -Parse error at :1:8, +Parse error at tc-errors.icry:6:8, unexpected: , -[error] at :1:1--1:5: +[error] at tc-errors.icry:7:1--7:5: Named and positional type applications may not be mixed. -[error] at :1:1--1:5: +[error] at tc-errors.icry:8:1--8:5: Type mismatch: Expected type: Integer Inferred type: Bit From 81ca04f3be26d3a031474c86e57496e842795df5 Mon Sep 17 00:00:00 2001 From: Rob Dockins Date: Tue, 1 Dec 2020 11:06:29 -0800 Subject: [PATCH 10/27] remove some stray code --- src/Cryptol/Backend/Monad.hs | 6 ------ src/Cryptol/Parser/Position.hs | 5 ----- 2 files changed, 11 deletions(-) diff --git a/src/Cryptol/Backend/Monad.hs b/src/Cryptol/Backend/Monad.hs index 45d1d40ab..d6726333a 100644 --- a/src/Cryptol/Backend/Monad.hs +++ b/src/Cryptol/Backend/Monad.hs @@ -360,7 +360,6 @@ instance PP EvalError where ppPrec _ e = case e of InvalidIndex (Just i) -> text "invalid sequence index:" <+> integer i InvalidIndex Nothing -> text "invalid sequence index" --- TypeCannotBeDemoted t -> text "type cannot be demoted:" <+> pp t DivideByZero -> text "division by 0" NegativeExponent -> text "negative exponent" LogNegative -> text "logarithm of negative" @@ -397,11 +396,6 @@ instance PP Unsupported where instance X.Exception Unsupported - --- | For things like @`(inf)@ or @`(0-1)@. ---typeCannotBeDemoted :: Type -> a ---typeCannotBeDemoted t = X.throw (TypeCannotBeDemoted t) - -- | For when we know that a word is too wide and will exceed gmp's -- limits (though words approaching this size will probably cause the -- system to crash anyway due to lack of memory). diff --git a/src/Cryptol/Parser/Position.hs b/src/Cryptol/Parser/Position.hs index 5959168f5..f2f6eb0ef 100644 --- a/src/Cryptol/Parser/Position.hs +++ b/src/Cryptol/Parser/Position.hs @@ -33,11 +33,6 @@ data Range = Range { from :: !Position , source :: FilePath } deriving (Eq, Ord, Show, Generic, NFData) -type CallStack = [ (Text, Range) ] - -emptyCallStack :: CallStack -emptyCallStack = [] - -- | An empty range. -- -- Caution: using this on the LHS of a use of rComb will cause the empty source From eaf37467ad4d3b2616950a54580e43f06daffff7 Mon Sep 17 00:00:00 2001 From: Rob Dockins Date: Tue, 1 Dec 2020 12:29:11 -0800 Subject: [PATCH 11/27] Improve source location tracking for <> errors --- src/Cryptol/Backend.hs | 6 ++--- src/Cryptol/Backend/Monad.hs | 43 ++++++++++++++++++++++-------------- src/Cryptol/Backend/SBV.hs | 4 ++-- src/Cryptol/Backend/What4.hs | 4 ++-- src/Cryptol/Eval.hs | 9 +++++--- 5 files changed, 39 insertions(+), 27 deletions(-) diff --git a/src/Cryptol/Backend.hs b/src/Cryptol/Backend.hs index 916029ff9..d93abbc5d 100644 --- a/src/Cryptol/Backend.hs +++ b/src/Cryptol/Backend.hs @@ -58,9 +58,7 @@ cryNoPrimError sym nm = raiseError sym (EvalErrorEx (nameLoc nm) (NoPrim nm)) sDelay :: Backend sym => sym -> Range -> Maybe String -> SEval sym a -> SEval sym (SEval sym a) sDelay sym rng msg m = let msg' = maybe "" ("while evaluating "++) msg - retry = raiseError sym (EvalErrorEx rng (LoopError msg')) - in sDelayFill sym m retry - + in sDelayFill sym m Nothing msg' rng -- | Representation of rational numbers. -- Invariant: denominator is not 0 @@ -235,7 +233,7 @@ class MonadIO (SEval sym) => Backend sym where -- which will run the computation when forced. Run the 'retry' -- computation instead if the resulting thunk is forced during -- its own evaluation. - sDelayFill :: sym -> SEval sym a -> SEval sym a -> SEval sym (SEval sym a) + sDelayFill :: sym -> SEval sym a -> Maybe (SEval sym a) -> String -> Range -> SEval sym (SEval sym a) -- | Begin evaluating the given computation eagerly in a separate thread -- and return a thunk which will await the completion of the given computation diff --git a/src/Cryptol/Backend/Monad.hs b/src/Cryptol/Backend/Monad.hs index d6726333a..3f3219948 100644 --- a/src/Cryptol/Backend/Monad.hs +++ b/src/Cryptol/Backend/Monad.hs @@ -131,15 +131,19 @@ data Eval a data ThunkState a = Void !String -- ^ This thunk has not yet been initialized - | Unforced !(IO a) !(IO a) + | Unforced !(IO a) !(Maybe (IO a)) String Range -- ^ This thunk has not yet been forced. We keep track of the "main" -- computation to run and a "backup" computation to run if we -- detect a tight loop when evaluating the first one. - | UnderEvaluation !ThreadId !(IO a) + -- The final two arguments are used to throw a loop exception + -- if the backup computation also causes a tight loop. + | UnderEvaluation !ThreadId !(Maybe (IO a)) String Range -- ^ This thunk is currently being evaluated by the thread with the given -- thread ID. We track the "backup" computation to run if we detect -- a tight loop evaluating this thunk. If the thunk is being evaluated -- by some other thread, the current thread will await its completion. + -- The final two arguments are used to throw a loop exception + -- if the backup computation also causes a tight loop. | ForcedErr !EvalErrorEx -- ^ This thunk has been forced, and its evaluation results in an exception | Forced !a @@ -165,11 +169,14 @@ maybeReady (Eval _) = pure Nothing -- its own evaluation. delayFill :: Eval a {- ^ Computation to delay -} -> - Eval a {- ^ Backup computation to run if a tight loop is detected -} -> + Maybe (Eval a) {- ^ Optional backup computation to run if a tight loop is detected -} -> + String {- ^ message for the <> exceprion if a tight loop is detecrted -} -> + Range {- ^ location information for the <> exceprion if a tight loop is detecrted -} -> Eval (Eval a) -delayFill e@(Ready _) _ = return e -delayFill e@(Thunk _) _ = return e -delayFill (Eval x) backup = Eval (Thunk <$> newTVarIO (Unforced x (runEval backup))) +delayFill e@(Ready _) _ _ _ = return e +delayFill e@(Thunk _) _ _ _ = return e +delayFill (Eval x) backup msg rng = + Eval (Thunk <$> newTVarIO (Unforced x (runEval <$> backup) msg rng)) -- | Begin executing the given operation in a separate thread, -- returning a thunk which will await the completion of @@ -197,7 +204,7 @@ evalSpark _ (Thunk tv) = Eval $ -- If the computation is nontrivial but not already a thunk, -- create a thunk and fork a thread to force it. evalSpark rng (Eval x) = Eval $ - do tv <- newTVarIO (Unforced x (X.throwIO (EvalErrorEx rng (LoopError "")))) + do tv <- newTVarIO (Unforced x Nothing "" rng) _ <- forkIO (sparkThunk tv) return (Thunk tv) @@ -215,13 +222,13 @@ sparkThunk tv = do st <- readTVar tv case st of Void _ -> retry - Unforced _ backup -> writeTVar tv (UnderEvaluation tid backup) + Unforced _ backup msg rng -> writeTVar tv (UnderEvaluation tid backup msg rng) _ -> return () return st -- If we successfully claimed the thunk to work on, run the computation and -- update the thunk state with the result. case st of - Unforced work _ -> + Unforced work _ _ _ -> X.try work >>= \case Left err -> atomically (writeTVar tv (ForcedErr err)) Right a -> atomically (writeTVar tv (Forced a)) @@ -238,9 +245,8 @@ blackhole :: Eval (Eval a, Eval a -> Eval ()) blackhole msg rng = Eval $ do tv <- newTVarIO (Void msg) - let ex = EvalErrorEx rng (LoopError msg) let set (Ready x) = io $ atomically (writeTVar tv (Forced x)) - set m = io $ atomically (writeTVar tv (Unforced (runEval m) (X.throwIO ex))) + set m = io $ atomically (writeTVar tv (Unforced (runEval m) Nothing msg rng)) return (Thunk tv, set) -- | Force a thunk to get the result. @@ -259,15 +265,18 @@ unDelay tv = case res of -- In this case, we claim the thunk. Update the state to indicate -- that we are working on it. - Unforced _ backup -> writeTVar tv (UnderEvaluation tid backup) + Unforced _ backup msg rng -> writeTVar tv (UnderEvaluation tid backup msg rng) -- In this case, the thunk is already being evaluated. If it is -- under evaluation by this thread, we have to run the backup computation, -- and "consume" it by updating the backup computation to one that throws -- a loop error. If some other thread is evaluating, reset the -- transaction to await completion of the thunk. - UnderEvaluation t _ - | tid == t -> writeTVar tv (UnderEvaluation tid (X.throwIO (EvalErrorEx emptyRange (LoopError "")))) -- TODO? better range info + UnderEvaluation t backup msg rng + | tid == t -> + case backup of + Just _ -> writeTVar tv (UnderEvaluation tid Nothing msg rng) + Nothing -> writeTVar tv (ForcedErr (EvalErrorEx rng (LoopError msg))) | otherwise -> retry -- wait, if some other thread is evaualting _ -> return () @@ -288,8 +297,10 @@ unDelay tv = Void msg -> evalPanic "unDelay" ["Thunk forced before it was initialized", msg] Forced x -> pure x ForcedErr e -> X.throwIO e - UnderEvaluation _ backup -> doWork backup -- this thread was already evaluating this thunk - Unforced work _ -> doWork work + -- this thread was already evaluating this thunk + UnderEvaluation _ (Just backup) _ _ -> doWork backup + UnderEvaluation _ Nothing msg rng -> X.throwIO (EvalErrorEx rng (LoopError msg)) + Unforced work _ _ _ -> doWork work -- | Execute the given evaluation action. runEval :: Eval a -> IO a diff --git a/src/Cryptol/Backend/SBV.hs b/src/Cryptol/Backend/SBV.hs index 79276c7ed..6bbbbaa7c 100644 --- a/src/Cryptol/Backend/SBV.hs +++ b/src/Cryptol/Backend/SBV.hs @@ -164,8 +164,8 @@ instance Backend SBV where isReady _ (SBVEval (Ready _)) = True isReady _ _ = False - sDelayFill _ m retry = SBVEval $ - do m' <- delayFill (sbvEval m) (sbvEval retry) + sDelayFill _ m retry msg rng = SBVEval $ + do m' <- delayFill (sbvEval m) (sbvEval <$> retry) msg rng pure (pure (SBVEval m')) sSpark _ rng m = SBVEval $ diff --git a/src/Cryptol/Backend/What4.hs b/src/Cryptol/Backend/What4.hs index 81562c321..2900ca1b6 100644 --- a/src/Cryptol/Backend/What4.hs +++ b/src/Cryptol/Backend/What4.hs @@ -221,10 +221,10 @@ instance W4.IsSymExprBuilder sym => Backend (What4 sym) where Ready _ -> True _ -> False - sDelayFill _ m retry = + sDelayFill _ m retry msg rng = total do sym <- getSym - doEval (w4Thunk <$> delayFill (w4Eval m sym) (w4Eval retry sym)) + doEval (w4Thunk <$> delayFill (w4Eval m sym) (w4Eval <$> retry <*> pure sym) msg rng) sSpark _ rng m = total diff --git a/src/Cryptol/Eval.hs b/src/Cryptol/Eval.hs index b07f5c326..2bf1517ef 100644 --- a/src/Cryptol/Eval.hs +++ b/src/Cryptol/Eval.hs @@ -328,7 +328,10 @@ fillHole :: fillHole sym env (nm, sch, _, fill) = do case lookupVar nm env of Just (Right v) - | isValueType env sch -> fill =<< sDelayFill sym v (etaDelay sym (nameLoc nm) (show (ppLocName nm)) env sch v) + | isValueType env sch -> fill =<< sDelayFill sym v + (Just (etaDelay sym (nameLoc nm) (show (ppLocName nm)) env sch v)) + (show (ppLocName nm)) + (nameLoc nm) | otherwise -> fill (etaDelay sym (nameLoc nm) (show (ppLocName nm)) env sch v) _ -> evalPanic "fillHole" ["Recursive definition not completed", show (ppLocName nm)] @@ -462,7 +465,7 @@ etaDelay sym rng msg env0 Forall{ sVars = vs0, sType = tp0 } = goTpVars env0 vs0 TVArray{} -> v TVSeq n TVBit -> - do w <- sDelayFill sym (fromWordVal "during eta-expansion" =<< v) (etaWord sym rng n v) + do w <- sDelayFill sym (fromWordVal "during eta-expansion" =<< v) (Just (etaWord sym rng n v)) msg rng return $ VWord n w TVSeq n el -> @@ -517,7 +520,7 @@ declHole sym d = where nm = dName d sch = dSignature d - msg = unwords ["<> while evaluating", show (pp nm)] + msg = unwords ["while evaluating", show (pp nm)] -- | Evaluate a declaration, extending the evaluation environment. From 553cbad8b953d501a72d283efd9b8fd18cb5ca38 Mon Sep 17 00:00:00 2001 From: Rob Dockins Date: Tue, 1 Dec 2020 12:59:15 -0800 Subject: [PATCH 12/27] Remove the mostly-unused message argument to `sDelay` --- src/Cryptol/Backend.hs | 6 +-- src/Cryptol/Eval.hs | 30 +++++++------ src/Cryptol/Eval/Env.hs | 2 +- src/Cryptol/Eval/Generic.hs | 84 ++++++++++++++++++------------------- 4 files changed, 59 insertions(+), 63 deletions(-) diff --git a/src/Cryptol/Backend.hs b/src/Cryptol/Backend.hs index d93abbc5d..135770687 100644 --- a/src/Cryptol/Backend.hs +++ b/src/Cryptol/Backend.hs @@ -55,10 +55,8 @@ cryNoPrimError sym nm = raiseError sym (EvalErrorEx (nameLoc nm) (NoPrim nm)) -- | Delay the given evaluation computation, returning a thunk -- which will run the computation when forced. Raise a loop -- error if the resulting thunk is forced during its own evaluation. -sDelay :: Backend sym => sym -> Range -> Maybe String -> SEval sym a -> SEval sym (SEval sym a) -sDelay sym rng msg m = - let msg' = maybe "" ("while evaluating "++) msg - in sDelayFill sym m Nothing msg' rng +sDelay :: Backend sym => sym -> Range -> SEval sym a -> SEval sym (SEval sym a) +sDelay sym rng m = sDelayFill sym m Nothing "" rng -- | Representation of rational numbers. -- Invariant: denominator is not 0 diff --git a/src/Cryptol/Eval.hs b/src/Cryptol/Eval.hs index 2bf1517ef..740f74cc3 100644 --- a/src/Cryptol/Eval.hs +++ b/src/Cryptol/Eval.hs @@ -123,10 +123,10 @@ evalExpr sym env expr = case expr of return $ VWord len $ case tryFromBits sym vs of Just w -> WordVal <$> w - Nothing -> do xs <- mapM (sDelay sym ?range Nothing) vs + Nothing -> do xs <- mapM (sDelay sym ?range) vs return $ LargeBitsVal len $ finiteSeqMap xs | otherwise -> {-# SCC "evalExpr->EList" #-} do - xs <- mapM (sDelay sym ?range Nothing) vs + xs <- mapM (sDelay sym ?range) vs return $ VSeq len $ finiteSeqMap xs where tyv = evalValType (envTypes env) ty @@ -134,11 +134,11 @@ evalExpr sym env expr = case expr of len = genericLength es ETuple es -> {-# SCC "evalExpr->ETuple" #-} do - xs <- mapM (sDelay sym ?range Nothing . eval) es + xs <- mapM (sDelay sym ?range . eval) es return $ VTuple xs ERec fields -> {-# SCC "evalExpr->ERec" #-} do - xs <- traverse (sDelay sym ?range Nothing . eval) fields + xs <- traverse (sDelay sym ?range . eval) fields return $ VRecord xs ESel e sel -> {-# SCC "evalExpr->ESel" #-} do @@ -329,10 +329,10 @@ fillHole sym env (nm, sch, _, fill) = do case lookupVar nm env of Just (Right v) | isValueType env sch -> fill =<< sDelayFill sym v - (Just (etaDelay sym (nameLoc nm) (show (ppLocName nm)) env sch v)) + (Just (etaDelay sym (nameLoc nm) env sch v)) (show (ppLocName nm)) (nameLoc nm) - | otherwise -> fill (etaDelay sym (nameLoc nm) (show (ppLocName nm)) env sch v) + | otherwise -> fill (etaDelay sym (nameLoc nm) env sch v) _ -> evalPanic "fillHole" ["Recursive definition not completed", show (ppLocName nm)] @@ -371,7 +371,7 @@ etaWord :: SEval sym (GenValue sym) -> SEval sym (WordValue sym) etaWord sym rng n val = do - w <- sDelay sym rng Nothing (fromWordVal "during eta-expansion" =<< val) + w <- sDelay sym rng (fromWordVal "during eta-expansion" =<< val) xs <- memoMap $ IndexSeqMap $ \i -> do w' <- w; VBit <$> indexWordValue sym rng w' i pure $ LargeBitsVal n xs @@ -379,7 +379,6 @@ etaWord sym rng n val = do {-# SPECIALIZE etaDelay :: Concrete -> Range -> - String -> GenEvalEnv Concrete -> Schema -> SEval Concrete (GenValue Concrete) -> @@ -396,12 +395,11 @@ etaDelay :: Backend sym => sym -> Range -> - String -> GenEvalEnv sym -> Schema -> SEval sym (GenValue sym) -> SEval sym (GenValue sym) -etaDelay sym rng msg env0 Forall{ sVars = vs0, sType = tp0 } = goTpVars env0 vs0 +etaDelay sym rng env0 Forall{ sVars = vs0, sType = tp0 } = goTpVars env0 vs0 where goTpVars env [] val = go (evalValType (envTypes env) tp0) val goTpVars env (v:vs) val = @@ -465,26 +463,26 @@ etaDelay sym rng msg env0 Forall{ sVars = vs0, sType = tp0 } = goTpVars env0 vs0 TVArray{} -> v TVSeq n TVBit -> - do w <- sDelayFill sym (fromWordVal "during eta-expansion" =<< v) (Just (etaWord sym rng n v)) msg rng + do w <- sDelayFill sym (fromWordVal "during eta-expansion" =<< v) (Just (etaWord sym rng n v)) "" rng return $ VWord n w TVSeq n el -> - do x' <- sDelay sym rng (Just msg) (fromSeq "during eta-expansion" =<< v) + do x' <- sDelay sym rng (fromSeq "during eta-expansion" =<< v) return $ VSeq n $ IndexSeqMap $ \i -> do go el (flip lookupSeqMap i =<< x') TVStream el -> - do x' <- sDelay sym rng (Just msg) (fromSeq "during eta-expansion" =<< v) + do x' <- sDelay sym rng (fromSeq "during eta-expansion" =<< v) return $ VStream $ IndexSeqMap $ \i -> go el (flip lookupSeqMap i =<< x') TVFun _t1 t2 -> - do v' <- sDelay sym rng (Just msg) (fromVFun <$> v) + do v' <- sDelay sym rng (fromVFun <$> v) return $ VFun $ \a -> go t2 ( ($a) =<< v' ) TVTuple ts -> do let n = length ts - v' <- sDelay sym rng (Just msg) (fromVTuple <$> v) + v' <- sDelay sym rng (fromVTuple <$> v) return $ VTuple $ [ go t =<< (flip genericIndex i <$> v') | i <- [0..(n-1)] @@ -492,7 +490,7 @@ etaDelay sym rng msg env0 Forall{ sVars = vs0, sType = tp0 } = goTpVars env0 vs0 ] TVRec fs -> - do v' <- sDelay sym rng (Just msg) (fromVRecord <$> v) + do v' <- sDelay sym rng (fromVRecord <$> v) let err f = evalPanic "expected record value with field" [show f] let eta f t = go t =<< (fromMaybe (err f) . lookupField f <$> v') return $ VRecord (mapWithFieldName eta fs) diff --git a/src/Cryptol/Eval/Env.hs b/src/Cryptol/Eval/Env.hs index 633dc9fe2..f563090e2 100644 --- a/src/Cryptol/Eval/Env.hs +++ b/src/Cryptol/Eval/Env.hs @@ -79,7 +79,7 @@ bindVar :: SEval sym (GenEvalEnv sym) bindVar sym n val env = do let nm = show $ ppLocName n - val' <- sDelay sym (nameLoc n) (Just nm) val + val' <- sDelayFill sym val Nothing nm (nameLoc n) return $ env{ envVars = IntMap.insert (nameUnique n) (Right val') (envVars env) } -- | Bind a variable to a value in the evaluation environment, without diff --git a/src/Cryptol/Eval/Generic.hs b/src/Cryptol/Eval/Generic.hs index 19062f730..c9d3f2455 100644 --- a/src/Cryptol/Eval/Generic.hs +++ b/src/Cryptol/Eval/Generic.hs @@ -234,15 +234,15 @@ ringBinary sym opw opi opz opq opfp rng = loop -- tuples TVTuple tys -> - do ls <- mapM (sDelay sym rng Nothing) (fromVTuple l) - rs <- mapM (sDelay sym rng Nothing) (fromVTuple r) + do ls <- mapM (sDelay sym rng) (fromVTuple l) + rs <- mapM (sDelay sym rng) (fromVTuple r) return $ VTuple (zipWith3 loop' tys ls rs) -- records TVRec fs -> do VRecord <$> traverseRecordMap - (\f fty -> sDelay sym rng Nothing (loop' fty (lookupRecord f l) (lookupRecord f r))) + (\f fty -> sDelay sym rng (loop' fty (lookupRecord f l) (lookupRecord f r))) fs TVAbstract {} -> @@ -311,14 +311,14 @@ ringUnary sym opw opi opz opq opfp rng = loop -- tuples TVTuple tys -> - do as <- mapM (sDelay sym rng Nothing) (fromVTuple v) + do as <- mapM (sDelay sym rng) (fromVTuple v) return $ VTuple (zipWith loop' tys as) -- records TVRec fs -> VRecord <$> traverseRecordMap - (\f fty -> sDelay sym rng Nothing (loop' fty (lookupRecord f v))) + (\f fty -> sDelay sym rng (loop' fty (lookupRecord f v))) fs TVAbstract {} -> evalPanic "ringUnary" ["Abstract type not in `Ring`"] @@ -367,23 +367,23 @@ ringNullary sym rng opw opi opz opq opfp = loop -- words and finite sequences | isTBit a -> pure $ VWord w $ (WordVal <$> opw w) | otherwise -> - do v <- sDelay sym rng Nothing (loop a) + do v <- sDelay sym rng (loop a) pure $ VSeq w $ IndexSeqMap \_i -> v TVStream a -> - do v <- sDelay sym rng Nothing (loop a) + do v <- sDelay sym rng (loop a) pure $ VStream $ IndexSeqMap \_i -> v TVFun _ b -> - do v <- sDelay sym rng Nothing (loop b) + do v <- sDelay sym rng (loop b) pure $ lam $ const $ v TVTuple tys -> - do xs <- mapM (sDelay sym rng Nothing . loop) tys + do xs <- mapM (sDelay sym rng . loop) tys pure $ VTuple xs TVRec fs -> - do xs <- traverse (sDelay sym rng Nothing . loop) fs + do xs <- traverse (sDelay sym rng . loop) fs pure $ VRecord xs TVAbstract {} -> @@ -911,26 +911,26 @@ zeroV sym rng ty = case ty of TVSeq w ety | isTBit ety -> pure $ word sym w 0 | otherwise -> - do z <- sDelay sym rng Nothing (zeroV sym rng ety) + do z <- sDelay sym rng (zeroV sym rng ety) pure $ VSeq w (IndexSeqMap \_i -> z) TVStream ety -> - do z <- sDelay sym rng Nothing (zeroV sym rng ety) + do z <- sDelay sym rng (zeroV sym rng ety) pure $ VStream (IndexSeqMap \_i -> z) -- functions TVFun _ bty -> - do z <- sDelay sym rng Nothing (zeroV sym rng bty) + do z <- sDelay sym rng (zeroV sym rng bty) pure $ lam (const z) -- tuples TVTuple tys -> - do xs <- mapM (sDelay sym rng Nothing . zeroV sym rng) tys + do xs <- mapM (sDelay sym rng . zeroV sym rng) tys pure $ VTuple xs -- records TVRec fields -> - do xs <- traverse (sDelay sym rng Nothing . zeroV sym rng) fields + do xs <- traverse (sDelay sym rng . zeroV sym rng) fields pure $ VRecord xs TVAbstract {} -> evalPanic "zeroV" [ "Abstract type not in `Zero`" ] @@ -970,7 +970,7 @@ joinWords sym rng nParts nEach xs = where loop :: SEval sym (WordValue sym) -> [SEval sym (GenValue sym)] -> SEval sym (GenValue sym) loop !wv [] = - VWord (nParts * nEach) <$> sDelay sym rng Nothing wv + VWord (nParts * nEach) <$> sDelay sym rng wv loop !wv (w : ws) = w >>= \case VWord _ w' -> @@ -1076,24 +1076,24 @@ splitAtV sym rng front back a val = case back of Nat rightWidth | aBit -> do - ws <- sDelay sym rng Nothing (splitWordVal sym leftWidth rightWidth =<< fromWordVal "splitAtV" val) + ws <- sDelay sym rng (splitWordVal sym leftWidth rightWidth =<< fromWordVal "splitAtV" val) return $ VTuple [ VWord leftWidth . pure . fst <$> ws , VWord rightWidth . pure . snd <$> ws ] Inf | aBit -> do - vs <- sDelay sym rng Nothing (fromSeq "splitAtV" val) - ls <- sDelay sym rng Nothing (fst . splitSeqMap leftWidth <$> vs) - rs <- sDelay sym rng Nothing (snd . splitSeqMap leftWidth <$> vs) + vs <- sDelay sym rng (fromSeq "splitAtV" val) + ls <- sDelay sym rng (fst . splitSeqMap leftWidth <$> vs) + rs <- sDelay sym rng (snd . splitSeqMap leftWidth <$> vs) return $ VTuple [ return $ VWord leftWidth (LargeBitsVal leftWidth <$> ls) , VStream <$> rs ] _ -> do - vs <- sDelay sym rng Nothing (fromSeq "splitAtV" val) - ls <- sDelay sym rng Nothing (fst . splitSeqMap leftWidth <$> vs) - rs <- sDelay sym rng Nothing (snd . splitSeqMap leftWidth <$> vs) + vs <- sDelay sym rng (fromSeq "splitAtV" val) + ls <- sDelay sym rng (fst . splitSeqMap leftWidth <$> vs) + rs <- sDelay sym rng (snd . splitSeqMap leftWidth <$> vs) return $ VTuple [ VSeq leftWidth <$> ls , mkSeq back a <$> rs ] @@ -1145,7 +1145,7 @@ ecSplitV sym = return $ VSeq p $ IndexSeqMap $ \i -> pure $ VWord e (extractWordVal sym e ((p-i-1)*e) =<< val') (Inf, Nat e) | isTBit a -> do - val' <- sDelay sym rng Nothing (fromSeq "ecSplitV" =<< val) + val' <- sDelay sym rng (fromSeq "ecSplitV" =<< val) return $ VStream $ IndexSeqMap $ \i -> return $ VWord e $ return $ LargeBitsVal e $ IndexSeqMap $ \j -> let idx = i*e + toInteger j @@ -1153,13 +1153,13 @@ ecSplitV sym = xs <- val' lookupSeqMap xs idx (Nat p, Nat e) -> do - val' <- sDelay sym rng Nothing (fromSeq "ecSplitV" =<< val) + val' <- sDelay sym rng (fromSeq "ecSplitV" =<< val) return $ VSeq p $ IndexSeqMap $ \i -> return $ VSeq e $ IndexSeqMap $ \j -> do xs <- val' lookupSeqMap xs (e * i + j) (Inf , Nat e) -> do - val' <- sDelay sym rng Nothing (fromSeq "ecSplitV" =<< val) + val' <- sDelay sym rng (fromSeq "ecSplitV" =<< val) return $ VStream $ IndexSeqMap $ \i -> return $ VSeq e $ IndexSeqMap $ \j -> do xs <- val' @@ -1251,7 +1251,7 @@ ccatV sym _rng _front _back _elty (VWord m l) (VWord n r) = return $ VWord (m+n) (join (joinWordVal sym <$> l <*> r)) ccatV sym rng _front _back _elty (VWord m l) (VStream r) = do - l' <- sDelay sym rng Nothing l + l' <- sDelay sym rng l return $ VStream $ IndexSeqMap $ \i -> if i < m then VBit <$> (flip (indexWordValue sym rng) i =<< l') @@ -1259,8 +1259,8 @@ ccatV sym rng _front _back _elty (VWord m l) (VStream r) = do lookupSeqMap r (i-m) ccatV sym rng front back elty l r = do - l'' <- sDelay sym rng Nothing (fromSeq "ccatV left" l) - r'' <- sDelay sym rng Nothing (fromSeq "ccatV right" r) + l'' <- sDelay sym rng (fromSeq "ccatV left" l) + r'' <- sDelay sym rng (fromSeq "ccatV right" r) let Nat n = front mkSeq (evalTF TCAdd [front,back]) elty <$> return (IndexSeqMap $ \i -> if i < n then do @@ -1326,7 +1326,7 @@ logicBinary sym opb opw rng = loop TVSeq w aty -- words | isTBit aty - -> do v <- sDelay sym rng Nothing $ join + -> do v <- sDelay sym rng $ join (wordValLogicOp sym opb opw <$> fromWordVal "logicBinary l" l <*> fromWordVal "logicBinary r" r) @@ -1344,8 +1344,8 @@ logicBinary sym opb opw rng = loop (fromSeq "logicBinary right" r))) TVTuple etys -> do - ls <- mapM (sDelay sym rng Nothing) (fromVTuple l) - rs <- mapM (sDelay sym rng Nothing) (fromVTuple r) + ls <- mapM (sDelay sym rng) (fromVTuple l) + rs <- mapM (sDelay sym rng) (fromVTuple r) return $ VTuple $ zipWith3 loop' etys ls rs TVFun _ bty -> @@ -1354,7 +1354,7 @@ logicBinary sym opb opw rng = loop TVRec fields -> VRecord <$> traverseRecordMap - (\f fty -> sDelay sym rng Nothing (loop' fty (lookupRecord f l) (lookupRecord f r))) + (\f fty -> sDelay sym rng (loop' fty (lookupRecord f l) (lookupRecord f r))) fields TVAbstract {} -> evalPanic "logicBinary" @@ -1402,7 +1402,7 @@ logicUnary sym opb opw rng = loop TVSeq w ety -- words | isTBit ety - -> do v <- sDelay sym rng Nothing (wordValUnaryOp opb opw =<< fromWordVal "logicUnary" val) + -> do v <- sDelay sym rng (wordValUnaryOp opb opw =<< fromWordVal "logicUnary" val) return $ VWord w v -- finite sequences @@ -1414,7 +1414,7 @@ logicUnary sym opb opw rng = loop VStream <$> (mapSeqMap (loop ety) =<< fromSeq "logicUnary" val) TVTuple etys -> - do as <- mapM (sDelay sym rng Nothing) (fromVTuple val) + do as <- mapM (sDelay sym rng) (fromVTuple val) return $ VTuple (zipWith loop' etys as) TVFun _ bty -> @@ -1423,7 +1423,7 @@ logicUnary sym opb opw rng = loop TVRec fields -> VRecord <$> traverseRecordMap - (\f fty -> sDelay sym rng Nothing (loop' fty (lookupRecord f val))) + (\f fty -> sDelay sym rng (loop' fty (lookupRecord f val))) fields TVAbstract {} -> evalPanic "logicUnary" [ "Abstract type not in `Logic`" ] @@ -1558,7 +1558,7 @@ updatePrim sym updateWord updateSeq = do idx' <- asIndex sym "update" ix =<< idx assertIndexInBounds sym rng len idx' xs >>= \case - VWord l w -> do w' <- sDelay sym rng Nothing w + VWord l w -> do w' <- sDelay sym rng w return $ VWord l (w' >>= \w'' -> updateWord rng len eltTy w'' idx' val) VSeq l vs -> VSeq l <$> updateSeq rng len eltTy vs idx' val VStream vs -> VStream <$> updateSeq rng len eltTy vs idx' val @@ -1605,7 +1605,7 @@ infFromV sym = PFun \x -> PRange \rng -> PPrim - do mx <- sDelay sym rng Nothing x + do mx <- sDelay sym rng x return $ VStream $ IndexSeqMap $ \i -> do x' <- mx i' <- integerLit sym i @@ -1619,7 +1619,7 @@ infFromThenV sym = PFun \next -> PRange \rng -> PPrim - do mxd <- sDelay sym rng Nothing + do mxd <- sDelay sym rng (do x <- first y <- next d <- subV sym rng ty y x @@ -2028,14 +2028,14 @@ foldl'V sym = go0 _rng _f a [] = a go0 rng f a bs = do f' <- fromVFun <$> f - a' <- sDelay sym rng Nothing a + a' <- sDelay sym rng a forceValue =<< a' go1 rng f' a' bs go1 _rng _f a [] = a go1 rng f a (b:bs) = do f' <- fromVFun <$> (f a) - a' <- sDelay sym rng Nothing (f' b) + a' <- sDelay sym rng (f' b) forceValue =<< a' go1 rng f a' bs @@ -2096,7 +2096,7 @@ sparkParMap sym rng f n m = finiteSeqMap <$> mapM (sSpark sym rng . g) (enumerateSeqMap n m) where g x = - do z <- sDelay sym rng Nothing (f x) + do z <- sDelay sym rng (f x) forceValue =<< z z From d0f39d1ab0c992127f4dafd478f961fe76c96d1a Mon Sep 17 00:00:00 2001 From: Rob Dockins Date: Wed, 2 Dec 2020 18:29:08 -0800 Subject: [PATCH 13/27] Add support for call stacks to the Cryptol interpreter. This allows us to print call stacks in addition to just the source location on program errors. --- .../src/CryptolServer/Data/Expression.hs | 2 +- src/Cryptol/Backend.hs | 24 ++-- src/Cryptol/Backend/Concrete.hs | 31 +++-- src/Cryptol/Backend/Monad.hs | 131 +++++++++++++----- src/Cryptol/Backend/SBV.hs | 30 ++-- src/Cryptol/Backend/What4.hs | 29 ++-- src/Cryptol/Eval.hs | 64 ++++++--- src/Cryptol/Eval/Concrete.hs | 15 +- src/Cryptol/Eval/Generic.hs | 42 +++--- src/Cryptol/Eval/Prims.hs | 16 +-- src/Cryptol/Eval/SBV.hs | 6 +- src/Cryptol/Eval/Value.hs | 90 ++++++------ src/Cryptol/Eval/What4.hs | 10 +- src/Cryptol/ModuleSystem/Base.hs | 4 +- src/Cryptol/ModuleSystem/Monad.hs | 2 +- src/Cryptol/Parser/Position.hs | 1 - src/Cryptol/REPL/Command.hs | 6 +- src/Cryptol/Symbolic/SBV.hs | 4 +- src/Cryptol/Symbolic/What4.hs | 4 +- src/Cryptol/Testing/Random.hs | 23 +-- 20 files changed, 318 insertions(+), 216 deletions(-) diff --git a/cryptol-remote-api/src/CryptolServer/Data/Expression.hs b/cryptol-remote-api/src/CryptolServer/Data/Expression.hs index bf5d0c4b6..1bef5948d 100644 --- a/cryptol-remote-api/src/CryptolServer/Data/Expression.hs +++ b/cryptol-remote-api/src/CryptolServer/Data/Expression.hs @@ -370,7 +370,7 @@ readBack prims ty val = observe :: Eval a -> Method ServerState a -observe e = liftIO (runEval e) +observe e = liftIO (runEval mempty e) mkEApp :: Expr PName -> [Expr PName] -> Expr PName mkEApp f args = foldl EApp f args diff --git a/src/Cryptol/Backend.hs b/src/Cryptol/Backend.hs index 135770687..cdb6415b4 100644 --- a/src/Cryptol/Backend.hs +++ b/src/Cryptol/Backend.hs @@ -35,21 +35,21 @@ import Data.Kind (Type) import Data.Ratio ( (%), numerator, denominator ) import Cryptol.Backend.FloatHelpers (BF) -import Cryptol.Backend.Monad ( PPOpts(..), EvalError(..), EvalErrorEx(..) ) +import Cryptol.Backend.Monad + ( PPOpts(..), EvalError(..), CallStack, pushCallFrame ) import Cryptol.ModuleSystem.Name(Name,nameLoc) import Cryptol.Parser.Position import Cryptol.Utils.PP invalidIndex :: Backend sym => sym -> Range -> Integer -> SEval sym a -invalidIndex sym rng = raiseError sym . EvalErrorEx rng . InvalidIndex . Just +invalidIndex sym rng i = raiseError sym rng (InvalidIndex (Just i)) cryUserError :: Backend sym => sym -> Range -> String -> SEval sym a -cryUserError sym rng = raiseError sym . EvalErrorEx rng . UserError +cryUserError sym rng msg = raiseError sym rng (UserError msg) cryNoPrimError :: Backend sym => sym -> Name -> SEval sym a -cryNoPrimError sym nm = raiseError sym (EvalErrorEx (nameLoc nm) (NoPrim nm)) - +cryNoPrimError sym nm = raiseError sym (nameLoc nm) (NoPrim nm) {-# INLINE sDelay #-} -- | Delay the given evaluation computation, returning a thunk @@ -72,7 +72,7 @@ intToRational sym x = SRational x <$> (integerLit sym 1) ratio :: Backend sym => sym -> Range -> SInteger sym -> SInteger sym -> SEval sym (SRational sym) ratio sym rng n d = do pz <- bitComplement sym =<< intEq sym d =<< integerLit sym 0 - assertSideCondition sym pz (EvalErrorEx rng DivideByZero) + assertSideCondition sym pz rng DivideByZero pure (SRational n d) rationalRecip :: Backend sym => sym -> Range -> SRational sym -> SEval sym (SRational sym) @@ -238,6 +238,13 @@ class MonadIO (SEval sym) => Backend sym where -- when forced. sSpark :: sym -> Range -> SEval sym a -> SEval sym (SEval sym a) + sPushFrame :: sym -> Name -> Range -> SEval sym a -> SEval sym a + sPushFrame sym nm rng m = sModifyCallStack sym (pushCallFrame nm rng) m + + sModifyCallStack :: sym -> (CallStack -> CallStack) -> SEval sym a -> SEval sym a + + sGetCallStack :: sym -> SEval sym CallStack + -- | Merge the two given computations according to the predicate. mergeEval :: sym -> @@ -249,11 +256,10 @@ class MonadIO (SEval sym) => Backend sym where -- | Assert that a condition must hold, and indicate what sort of -- error is indicated if the condition fails. - assertSideCondition :: sym -> SBit sym -> EvalErrorEx -> SEval sym () + assertSideCondition :: sym -> SBit sym -> Range -> EvalError -> SEval sym () -- | Indiciate that an error condition exists - raiseError :: sym -> EvalErrorEx -> SEval sym a - + raiseError :: sym -> Range -> EvalError -> SEval sym a -- ==== Pretty printing ==== -- | Pretty-print an individual bit diff --git a/src/Cryptol/Backend/Concrete.hs b/src/Cryptol/Backend/Concrete.hs index 7f54db9c7..c9a0e16eb 100644 --- a/src/Cryptol/Backend/Concrete.hs +++ b/src/Cryptol/Backend/Concrete.hs @@ -137,10 +137,12 @@ instance Backend Concrete where type SFloat Concrete = FP.BF type SEval Concrete = Eval - raiseError _ err = io (X.throwIO err) + raiseError _ rng err = + do stk <- getCallStack + io (X.throwIO (EvalErrorEx rng stk err)) - assertSideCondition _ True _ = return () - assertSideCondition _ False err = io (X.throwIO err) + assertSideCondition _ True _ _ = return () + assertSideCondition sym False rng err = raiseError sym rng err wordLen _ (BV w _) = w wordAsChar _ (BV _ x) = Just $! integerToChar x @@ -161,6 +163,8 @@ instance Backend Concrete where sDeclareHole _ rng = blackhole rng sDelayFill _ = delayFill sSpark _ = evalSpark + sModifyCallStack _ f m = modifyCallStack f m + sGetCallStack _ = getCallStack ppBit _ b | b = text "True" | otherwise = text "False" @@ -260,21 +264,21 @@ instance Backend Concrete where wordDiv sym rng (BV i x) (BV j y) | i == 0 && j == 0 = pure $! mkBv 0 0 | i == j = - do assertSideCondition sym (y /= 0) (EvalErrorEx rng DivideByZero) + do assertSideCondition sym (y /= 0) rng DivideByZero pure $! mkBv i (x `div` y) | otherwise = panic "Attempt to divide words of different sizes: wordDiv" [show i, show j] wordMod sym rng (BV i x) (BV j y) | i == 0 && j == 0 = pure $! mkBv 0 0 | i == j = - do assertSideCondition sym (y /= 0) (EvalErrorEx rng DivideByZero) + do assertSideCondition sym (y /= 0) rng DivideByZero pure $! mkBv i (x `mod` y) | otherwise = panic "Attempt to mod words of different sizes: wordMod" [show i, show j] wordSignedDiv sym rng (BV i x) (BV j y) | i == 0 && j == 0 = pure $! mkBv 0 0 | i == j = - do assertSideCondition sym (y /= 0) (EvalErrorEx rng DivideByZero) + do assertSideCondition sym (y /= 0) rng DivideByZero let sx = signedValue i x sy = signedValue i y pure $! mkBv i (sx `quot` sy) @@ -283,7 +287,7 @@ instance Backend Concrete where wordSignedMod sym rng (BV i x) (BV j y) | i == 0 && j == 0 = pure $! mkBv 0 0 | i == j = - do assertSideCondition sym (y /= 0) (EvalErrorEx rng DivideByZero) + do assertSideCondition sym (y /= 0) rng DivideByZero let sx = signedValue i x sy = signedValue i y pure $! mkBv i (sx `rem` sy) @@ -300,10 +304,10 @@ instance Backend Concrete where intNegate _ x = pure $! negate x intMult _ x y = pure $! x * y intDiv sym rng x y = - do assertSideCondition sym (y /= 0) (EvalErrorEx rng DivideByZero) + do assertSideCondition sym (y /= 0) rng DivideByZero pure $! x `div` y intMod sym rng x y = - do assertSideCondition sym (y /= 0) (EvalErrorEx rng DivideByZero) + do assertSideCondition sym (y /= 0) rng DivideByZero pure $! x `mod` y intToZn _ 0 _ = evalPanic "intToZn" ["0 modulus not allowed"] @@ -318,7 +322,7 @@ instance Backend Concrete where -- the only values for which no inverse exists are -- congruent to 0 modulo m. znRecip sym rng m x - | r == 0 = raiseError sym (EvalErrorEx rng DivideByZero) + | r == 0 = raiseError sym rng DivideByZero | otherwise = pure r where r = Integer.recipModInteger x m @@ -387,15 +391,12 @@ fpCvtToInteger sym fun rng rnd flt = do mode <- fpRoundMode sym rng rnd case FP.floatToInteger fun mode flt of Right i -> pure i - Left err -> raiseError sym (EvalErrorEx rng err) + Left err -> raiseError sym rng err fpRoundMode :: Concrete -> Range -> SWord Concrete -> SEval Concrete FP.RoundMode fpRoundMode sym rng w = case FP.fpRound (bvVal w) of - Left err -> raiseError sym (EvalErrorEx rng err) + Left err -> raiseError sym rng err Right a -> pure a - - - diff --git a/src/Cryptol/Backend/Monad.hs b/src/Cryptol/Backend/Monad.hs index 3f3219948..daa16109d 100644 --- a/src/Cryptol/Backend/Monad.hs +++ b/src/Cryptol/Backend/Monad.hs @@ -28,6 +28,14 @@ module Cryptol.Backend.Monad , blackhole , evalSpark , maybeReady + -- * Call stacks +, CallStack +, getCallStack +, withCallStack +, modifyCallStack +, combineCallStacks +, pushCallFrame +, displayCallStack -- * Error reporting , Unsupported(..) , EvalError(..) @@ -44,6 +52,9 @@ import Control.Monad import qualified Control.Monad.Fail as Fail import Control.Monad.Fix import Control.Monad.IO.Class +import Data.Foldable (toList) +import Data.Sequence (Seq) +import qualified Data.Sequence as Seq import Data.Typeable (Typeable) import qualified Control.Exception as X @@ -92,6 +103,34 @@ data EvalOpts = EvalOpts , evalPPOpts :: PPOpts -- ^ How to pretty print things. } + +-- | The type of dynamic call stacks for the interpreter. +-- New frames are pushed onto the right side of the sequence. +type CallStack = Seq (Name, Range) + +displayCallStack :: CallStack -> Doc +displayCallStack = vcat . map f . toList . Seq.reverse + where + f (nm,rng) = pp nm <+> text "called at" <+> pp rng + +combineCallStacks :: + CallStack {- ^ call stack of the application context -} -> + CallStack {- ^ call stack of the function being applied -} -> + CallStack +combineCallStacks appstk fnstk = appstk <> dropCommonPrefix appstk fnstk + where + dropCommonPrefix _ Seq.Empty = Seq.Empty + dropCommonPrefix Seq.Empty fs = fs + dropCommonPrefix (a Seq.:<| as) xs@(f Seq.:<| fs) + | a == f = dropCommonPrefix as fs + | otherwise = xs + +pushCallFrame :: Name -> Range -> CallStack -> CallStack +pushCallFrame nm rng stk@( _ Seq.:|> (nm',rng')) + | nm == nm', rng == rng' = stk +pushCallFrame nm rng stk = stk Seq.:|> (nm,rng) + + -- | The monad for Cryptol evaluation. -- A computation is either "ready", which means it represents -- only trivial computation, or is an "eval" action which must @@ -99,7 +138,7 @@ data EvalOpts = EvalOpts -- represents a delayed, shared computation. data Eval a = Ready !a - | Eval !(IO a) + | Eval !(CallStack -> IO a) | Thunk !(TVar (ThunkState a)) -- | This datastructure tracks the lifecycle of a thunk. @@ -131,13 +170,13 @@ data Eval a data ThunkState a = Void !String -- ^ This thunk has not yet been initialized - | Unforced !(IO a) !(Maybe (IO a)) String Range + | Unforced !(IO a) !(Maybe (IO a)) String Range CallStack -- ^ This thunk has not yet been forced. We keep track of the "main" -- computation to run and a "backup" computation to run if we -- detect a tight loop when evaluating the first one. -- The final two arguments are used to throw a loop exception -- if the backup computation also causes a tight loop. - | UnderEvaluation !ThreadId !(Maybe (IO a)) String Range + | UnderEvaluation !ThreadId !(Maybe (IO a)) String Range CallStack -- ^ This thunk is currently being evaluated by the thread with the given -- thread ID. We track the "backup" computation to run if we detect -- a tight loop evaluating this thunk. If the thunk is being evaluated @@ -154,7 +193,7 @@ data ThunkState a -- it requires no computation to return. maybeReady :: Eval a -> Eval (Maybe a) maybeReady (Ready a) = pure (Just a) -maybeReady (Thunk tv) = Eval $ +maybeReady (Thunk tv) = Eval $ \_ -> readTVarIO tv >>= \case Forced a -> pure (Just a) _ -> pure Nothing @@ -176,7 +215,7 @@ delayFill :: delayFill e@(Ready _) _ _ _ = return e delayFill e@(Thunk _) _ _ _ = return e delayFill (Eval x) backup msg rng = - Eval (Thunk <$> newTVarIO (Unforced x (runEval <$> backup) msg rng)) + Eval (\stk -> Thunk <$> newTVarIO (Unforced (x stk) (runEval stk <$> backup) msg rng stk)) -- | Begin executing the given operation in a separate thread, -- returning a thunk which will await the completion of @@ -193,18 +232,18 @@ evalSpark _ e@(Ready _) = return e -- been forced. If so, return the result. Otherwise, -- fork a thread to force this computation and return -- the thunk. -evalSpark _ (Thunk tv) = Eval $ +evalSpark _ (Thunk tv) = Eval $ \_stk -> readTVarIO tv >>= \case Forced x -> return (Ready x) - ForcedErr ex -> return (Eval (X.throwIO ex)) + ForcedErr ex -> return (Eval $ \_ -> (X.throwIO ex)) _ -> do _ <- forkIO (sparkThunk tv) return (Thunk tv) -- If the computation is nontrivial but not already a thunk, -- create a thunk and fork a thread to force it. -evalSpark rng (Eval x) = Eval $ - do tv <- newTVarIO (Unforced x Nothing "" rng) +evalSpark rng (Eval x) = Eval $ \stk -> + do tv <- newTVarIO (Unforced (x stk) Nothing "" rng stk) _ <- forkIO (sparkThunk tv) return (Thunk tv) @@ -222,13 +261,13 @@ sparkThunk tv = do st <- readTVar tv case st of Void _ -> retry - Unforced _ backup msg rng -> writeTVar tv (UnderEvaluation tid backup msg rng) + Unforced _ backup msg rng stk -> writeTVar tv (UnderEvaluation tid backup msg rng stk) _ -> return () return st -- If we successfully claimed the thunk to work on, run the computation and -- update the thunk state with the result. case st of - Unforced work _ _ _ -> + Unforced work _ _ _ _ -> X.try work >>= \case Left err -> atomically (writeTVar tv (ForcedErr err)) Right a -> atomically (writeTVar tv (Forced a)) @@ -243,10 +282,10 @@ blackhole :: String {- ^ A name to associate with this thunk. -} -> Range -> Eval (Eval a, Eval a -> Eval ()) -blackhole msg rng = Eval $ +blackhole msg rng = Eval $ \stk -> do tv <- newTVarIO (Void msg) let set (Ready x) = io $ atomically (writeTVar tv (Forced x)) - set m = io $ atomically (writeTVar tv (Unforced (runEval m) Nothing msg rng)) + set m = io $ atomically (writeTVar tv (Unforced (runEval stk m) Nothing msg rng stk)) return (Thunk tv, set) -- | Force a thunk to get the result. @@ -265,18 +304,18 @@ unDelay tv = case res of -- In this case, we claim the thunk. Update the state to indicate -- that we are working on it. - Unforced _ backup msg rng -> writeTVar tv (UnderEvaluation tid backup msg rng) + Unforced _ backup msg rng stk -> writeTVar tv (UnderEvaluation tid backup msg rng stk) -- In this case, the thunk is already being evaluated. If it is -- under evaluation by this thread, we have to run the backup computation, -- and "consume" it by updating the backup computation to one that throws -- a loop error. If some other thread is evaluating, reset the -- transaction to await completion of the thunk. - UnderEvaluation t backup msg rng + UnderEvaluation t backup msg rng stk | tid == t -> case backup of - Just _ -> writeTVar tv (UnderEvaluation tid Nothing msg rng) - Nothing -> writeTVar tv (ForcedErr (EvalErrorEx rng (LoopError msg))) + Just _ -> writeTVar tv (UnderEvaluation tid Nothing msg rng stk) + Nothing -> writeTVar tv (ForcedErr (EvalErrorEx rng stk (LoopError msg))) | otherwise -> retry -- wait, if some other thread is evaualting _ -> return () @@ -298,26 +337,42 @@ unDelay tv = Forced x -> pure x ForcedErr e -> X.throwIO e -- this thread was already evaluating this thunk - UnderEvaluation _ (Just backup) _ _ -> doWork backup - UnderEvaluation _ Nothing msg rng -> X.throwIO (EvalErrorEx rng (LoopError msg)) - Unforced work _ _ _ -> doWork work + UnderEvaluation _ (Just backup) _ _ _ -> doWork backup + UnderEvaluation _ Nothing msg rng stk -> X.throwIO (EvalErrorEx rng stk (LoopError msg)) + Unforced work _ _ _ _ -> doWork work + +-- | Get the current call stack +getCallStack :: Eval CallStack +getCallStack = Eval (\stk -> pure stk) + +-- | Execute the action with the given call stack +withCallStack :: CallStack -> Eval a -> Eval a +withCallStack stk m = Eval (\_ -> runEval stk m) + +-- | Run the given action with a modify call stack +modifyCallStack :: (CallStack -> CallStack) -> Eval a -> Eval a +modifyCallStack f m = + Eval $ \stk -> + do let stk' = f stk + -- putStrLn $ unwords ["Pushing call stack", show (displayCallStack stk')] + runEval stk' m -- | Execute the given evaluation action. -runEval :: Eval a -> IO a -runEval (Ready a) = return a -runEval (Eval x) = x -runEval (Thunk tv) = unDelay tv +runEval :: CallStack -> Eval a -> IO a +runEval _ (Ready a) = return a +runEval stk (Eval x) = x stk +runEval _ (Thunk tv) = unDelay tv {-# INLINE evalBind #-} evalBind :: Eval a -> (a -> Eval b) -> Eval b evalBind (Ready a) f = f a -evalBind (Eval x) f = Eval (x >>= runEval . f) -evalBind (Thunk x) f = Eval (unDelay x >>= runEval . f) +evalBind (Eval x) f = Eval (\stk -> x stk >>= runEval stk . f) +evalBind (Thunk x) f = Eval (\stk -> unDelay x >>= runEval stk . f) instance Functor Eval where fmap f (Ready x) = Ready (f x) - fmap f (Eval m) = Eval (f <$> m) - fmap f (Thunk tv) = Eval (f <$> unDelay tv) + fmap f (Eval m) = Eval (\stk -> f <$> m stk) + fmap f (Thunk tv) = Eval (\_ -> f <$> unDelay tv) {-# INLINE fmap #-} instance Applicative Eval where @@ -333,17 +388,17 @@ instance Monad Eval where {-# INLINE (>>=) #-} instance Fail.MonadFail Eval where - fail x = Eval (fail x) + fail x = Eval (\_stk -> fail x) instance MonadIO Eval where liftIO = io instance MonadFix Eval where - mfix f = Eval $ mfix (\x -> runEval (f x)) + mfix f = Eval $ \stk -> mfix (\x -> runEval stk (f x)) -- | Lift an 'IO' computation into the 'Eval' monad. io :: IO a -> Eval a -io m = Eval m +io m = Eval (\_stk -> m) {-# INLINE io #-} @@ -384,16 +439,20 @@ instance Show EvalError where show = show . pp data EvalErrorEx = - EvalErrorEx Range EvalError + EvalErrorEx Range CallStack EvalError deriving Typeable instance PP EvalErrorEx where - ppPrec _ (EvalErrorEx rng ex) - | rng == emptyRange = pp ex - | otherwise = vcat [ pp ex, text "at" <+> pp rng ] + ppPrec _ (EvalErrorEx rng stk ex) + | rng == emptyRange = vcat ([ pp ex ] ++ callStk) + | otherwise = vcat ([ pp ex, text "at" <+> pp rng] ++ callStk) + + where + callStk | Seq.null stk = [] + | otherwise = [ text "-- Backtrace --", displayCallStack stk ] instance Show EvalErrorEx where - show = show . pp + show = show . pp instance X.Exception EvalErrorEx diff --git a/src/Cryptol/Backend/SBV.hs b/src/Cryptol/Backend/SBV.hs index 6bbbbaa7c..0d1b3f1f7 100644 --- a/src/Cryptol/Backend/SBV.hs +++ b/src/Cryptol/Backend/SBV.hs @@ -48,6 +48,7 @@ import Cryptol.Backend.Concrete ( integerToChar, ppBV, BV(..) ) import Cryptol.Backend.Monad ( Eval(..), blackhole, delayFill, evalSpark , EvalError(..), EvalErrorEx(..), Unsupported(..) + , modifyCallStack, getCallStack ) import Cryptol.Parser.Position (Range) @@ -155,10 +156,12 @@ instance Backend SBV where type SFloat SBV = () -- XXX: not implemented type SEval SBV = SBVEval - raiseError _ err = SBVEval (pure (SBVError err)) + raiseError _ rng err = SBVEval $ + do stk <- getCallStack + pure (SBVError (EvalErrorEx rng stk err)) - assertSideCondition _ cond err - | Just False <- svAsBool cond = SBVEval (pure (SBVError err)) + assertSideCondition sym cond rng err + | Just False <- svAsBool cond = raiseError sym rng err | otherwise = SBVEval (pure (SBVResult cond ())) isReady _ (SBVEval (Ready _)) = True @@ -176,6 +179,11 @@ instance Backend SBV where do (hole, fill) <- blackhole msg rng pure (pure (SBVEval hole, \m -> SBVEval (fmap pure $ fill (sbvEval m)))) + sModifyCallStack _ f (SBVEval m) = SBVEval $ + modifyCallStack f m + + sGetCallStack _ = SBVEval (pure <$> getCallStack) + mergeEval _sym f c mx my = SBVEval $ do rx <- sbvEval mx ry <- sbvEval my @@ -268,22 +276,22 @@ instance Backend SBV where wordDiv sym rng a b = do let z = literalSWord (intSizeOf b) 0 - assertSideCondition sym (svNot (svEqual b z)) (EvalErrorEx rng DivideByZero) + assertSideCondition sym (svNot (svEqual b z)) rng DivideByZero pure $! svQuot a b wordMod sym rng a b = do let z = literalSWord (intSizeOf b) 0 - assertSideCondition sym (svNot (svEqual b z)) (EvalErrorEx rng DivideByZero) + assertSideCondition sym (svNot (svEqual b z)) rng DivideByZero pure $! svRem a b wordSignedDiv sym rng a b = do let z = literalSWord (intSizeOf b) 0 - assertSideCondition sym (svNot (svEqual b z)) (EvalErrorEx rng DivideByZero) + assertSideCondition sym (svNot (svEqual b z)) rng DivideByZero pure $! signedQuot a b wordSignedMod sym rng a b = do let z = literalSWord (intSizeOf b) 0 - assertSideCondition sym (svNot (svEqual b z)) (EvalErrorEx rng DivideByZero) + assertSideCondition sym (svNot (svEqual b z)) rng DivideByZero pure $! signedRem a b wordLg2 _ a = sLg2 a @@ -302,12 +310,12 @@ instance Backend SBV where intDiv sym rng a b = do let z = svInteger KUnbounded 0 - assertSideCondition sym (svNot (svEqual b z)) (EvalErrorEx rng DivideByZero) + assertSideCondition sym (svNot (svEqual b z)) rng DivideByZero let p = svLessThan z b pure $! svSymbolicMerge KUnbounded True p (svQuot a b) (svQuot (svUNeg a) (svUNeg b)) intMod sym rng a b = do let z = svInteger KUnbounded 0 - assertSideCondition sym (svNot (svEqual b z)) (EvalErrorEx rng DivideByZero) + assertSideCondition sym (svNot (svEqual b z)) rng DivideByZero let p = svLessThan z b pure $! svSymbolicMerge KUnbounded True p (svRem a b) (svUNeg (svRem (svUNeg a) (svUNeg b))) @@ -409,7 +417,7 @@ sModRecip sym rng m x -- If the input is concrete, evaluate the answer | Just xi <- svAsInteger x = let r = Integer.recipModInteger xi m - in if r == 0 then raiseError sym (EvalErrorEx rng DivideByZero) else integerLit sym r + in if r == 0 then raiseError sym rng DivideByZero else integerLit sym r -- If the input is symbolic, create a new symbolic constant -- and assert that it is the desired multiplicitive inverse. @@ -417,7 +425,7 @@ sModRecip sym rng m x -- the modulus is prime, and as long as the input is nonzero. | otherwise = do divZero <- svDivisible sym m x - assertSideCondition sym (svNot divZero) (EvalErrorEx rng DivideByZero) + assertSideCondition sym (svNot divZero) rng DivideByZero z <- liftIO (freshSInteger_ sym) let xz = svTimes x z diff --git a/src/Cryptol/Backend/What4.hs b/src/Cryptol/Backend/What4.hs index 2900ca1b6..02added35 100644 --- a/src/Cryptol/Backend/What4.hs +++ b/src/Cryptol/Backend/What4.hs @@ -41,6 +41,7 @@ import Cryptol.Backend.FloatHelpers import Cryptol.Backend.Monad ( Eval(..), EvalError(..), EvalErrorEx(..) , Unsupported(..), delayFill, blackhole, evalSpark + , modifyCallStack, getCallStack ) import Cryptol.Parser.Position import Cryptol.Utils.Panic @@ -186,8 +187,10 @@ addSafety :: W4.IsSymExprBuilder sym => W4.Pred sym -> W4Eval sym () addSafety p = W4Eval (pure (W4Result p ())) -- | A fully undefined symbolic value -evalError :: W4.IsSymExprBuilder sym => EvalErrorEx -> W4Eval sym a -evalError err = W4Eval (pure (W4Error err)) +evalError :: W4.IsSymExprBuilder sym => Range -> EvalError -> W4Eval sym a +evalError rng err = W4Eval $ W4Conn $ \_sym -> + do stk <- getCallStack + pure (W4Error (EvalErrorEx rng stk err)) -------------------------------------------------------------------------------- @@ -195,13 +198,13 @@ evalError err = W4Eval (pure (W4Error err)) assertBVDivisor :: W4.IsSymExprBuilder sym => What4 sym -> Range -> SW.SWord sym -> W4Eval sym () assertBVDivisor sym rng x = do p <- liftIO (SW.bvIsNonzero (w4 sym) x) - assertSideCondition sym p (EvalErrorEx rng DivideByZero) + assertSideCondition sym p rng DivideByZero assertIntDivisor :: W4.IsSymExprBuilder sym => What4 sym -> Range -> W4.SymInteger sym -> W4Eval sym () assertIntDivisor sym rng x = do p <- liftIO (W4.notPred (w4 sym) =<< W4.intEq (w4 sym) x =<< W4.intLit (w4 sym) 0) - assertSideCondition sym p (EvalErrorEx rng DivideByZero) + assertSideCondition sym p rng DivideByZero instance W4.IsSymExprBuilder sym => Backend (What4 sym) where type SBit (What4 sym) = W4.Pred sym @@ -212,8 +215,8 @@ instance W4.IsSymExprBuilder sym => Backend (What4 sym) where raiseError _ = evalError - assertSideCondition _ cond err - | Just False <- W4.asConstantPred cond = evalError err + assertSideCondition _ cond rng err + | Just False <- W4.asConstantPred cond = evalError rng err | otherwise = addSafety cond isReady sym m = @@ -231,6 +234,10 @@ instance W4.IsSymExprBuilder sym => Backend (What4 sym) where do sym <- getSym doEval (w4Thunk <$> evalSpark rng (w4Eval m sym)) + sModifyCallStack _ f (W4Eval (W4Conn m)) = + W4Eval (W4Conn \sym -> modifyCallStack f (m sym)) + + sGetCallStack _ = total (doEval getCallStack) sDeclareHole _ msg rng = total @@ -576,7 +583,7 @@ fpRoundingMode sym rng v = 2 -> pure W4.RTP 3 -> pure W4.RTN 4 -> pure W4.RTZ - x -> raiseError sym (EvalErrorEx rng (BadRoundingMode x)) + x -> raiseError sym rng (BadRoundingMode x) _ -> liftIO $ X.throwIO $ UnsupportedSymbolicOp "rounding mode" fpBinArith :: @@ -601,7 +608,7 @@ fpCvtToInteger sym fun rng r x = do bad1 <- FP.fpIsInf (w4 sym) x bad2 <- FP.fpIsNaN (w4 sym) x W4.notPred (w4 sym) =<< W4.orPred (w4 sym) bad1 bad2 - assertSideCondition sym grd (EvalErrorEx rng (BadValue fun)) + assertSideCondition sym grd rng (BadValue fun) rnd <- fpRoundingMode sym rng r liftIO do y <- FP.fpToReal (w4 sym) x @@ -621,7 +628,7 @@ fpCvtToRational sym rng fp = do bad1 <- FP.fpIsInf (w4 sym) fp bad2 <- FP.fpIsNaN (w4 sym) fp W4.notPred (w4 sym) =<< W4.orPred (w4 sym) bad1 bad2 - assertSideCondition sym grd (EvalErrorEx rng (BadValue "fpToRational")) + assertSideCondition sym grd rng (BadValue "fpToRational") (rel,x,y) <- liftIO (FP.fpToRational (w4 sym) fp) addDefEqn sym =<< liftIO (W4.impliesPred (w4 sym) grd rel) ratio sym rng x y @@ -650,7 +657,7 @@ sModRecip sym rng m x -- If the input is concrete, evaluate the answer | Just xi <- W4.asInteger x = let r = Integer.recipModInteger xi m - in if r == 0 then raiseError sym (EvalErrorEx rng DivideByZero) else integerLit sym r + in if r == 0 then raiseError sym rng DivideByZero else integerLit sym r -- If the input is symbolic, create a new symbolic constant -- and assert that it is the desired multiplicitive inverse. @@ -659,7 +666,7 @@ sModRecip sym rng m x | otherwise = do divZero <- liftIO (W4.intDivisible (w4 sym) x (fromInteger m)) ok <- liftIO (W4.notPred (w4 sym) divZero) - assertSideCondition sym ok (EvalErrorEx rng DivideByZero) + assertSideCondition sym ok rng DivideByZero z <- liftIO (W4.freshBoundedInt (w4 sym) W4.emptySymbol (Just 1) (Just (m-1))) xz <- liftIO (W4.intMul (w4 sym) x z) diff --git a/src/Cryptol/Eval.hs b/src/Cryptol/Eval.hs index 740f74cc3..0a5ee2fd4 100644 --- a/src/Cryptol/Eval.hs +++ b/src/Cryptol/Eval.hs @@ -161,8 +161,11 @@ evalExpr sym env expr = case expr of EVar n -> {-# SCC "evalExpr->EVar" #-} do case lookupVar n env of - Just (Left p) -> evalPrim sym n p - Just (Right val) -> val + Just (Left p) -> sPushFrame sym n ?range (cacheCallStack sym =<< evalPrim sym n p) + Just (Right val) -> + case nameInfo n of + Declared{} -> sPushFrame sym n ?range (cacheCallStack sym =<< val) + Parameter -> cacheCallStack sym =<< val Nothing -> do envdoc <- ppEnv sym defaultPPOpts env panic "[Eval] evalExpr" @@ -172,14 +175,14 @@ evalExpr sym env expr = case expr of ETAbs tv b -> {-# SCC "evalExpr->ETAbs" #-} case tpKind tv of - KType -> return $ VPoly $ \ty -> evalExpr sym (bindType (tpVar tv) (Right ty) env) b - KNum -> return $ VNumPoly $ \n -> evalExpr sym (bindType (tpVar tv) (Left n) env) b + KType -> tlam sym $ \ty -> evalExpr sym (bindType (tpVar tv) (Right ty) env) b + KNum -> nlam sym $ \n -> evalExpr sym (bindType (tpVar tv) (Left n) env) b k -> panic "[Eval] evalExpr" ["invalid kind on type abstraction", show k] ETApp e ty -> {-# SCC "evalExpr->ETApp" #-} do eval e >>= \case - VPoly f -> f $! (evalValType (envTypes env) ty) - VNumPoly f -> f $! (evalNumType (envTypes env) ty) + f@VPoly{} -> fromVPoly sym f $! (evalValType (envTypes env) ty) + f@VNumPoly{} -> fromVNumPoly sym f $! (evalNumType (envTypes env) ty) val -> do vdoc <- ppV val panic "[Eval] evalExpr" ["expected a polymorphic value" @@ -188,13 +191,13 @@ evalExpr sym env expr = case expr of EApp f v -> {-# SCC "evalExpr->EApp" #-} do eval f >>= \case - VFun f' -> f' (eval v) - it -> do itdoc <- ppV it - panic "[Eval] evalExpr" ["not a function", show itdoc ] + f'@VFun {} -> fromVFun sym f' (eval v) + it -> do itdoc <- ppV it + panic "[Eval] evalExpr" ["not a function", show itdoc ] EAbs n _ty b -> {-# SCC "evalExpr->EAbs" #-} - return $ VFun (\v -> do env' <- bindVar sym n v env - evalExpr sym env' b) + lam sym (\v -> do env' <- bindVar sym n v env + evalExpr sym env' b) -- XXX these will likely change once there is an evidence value EProofAbs _ e -> eval e @@ -211,6 +214,23 @@ evalExpr sym env expr = case expr of ppV = ppValue sym defaultPPOpts +cacheCallStack :: + Backend sym => + sym -> + GenValue sym -> + SEval sym (GenValue sym) +cacheCallStack sym v = case v of + VFun fnstk f -> + do stk <- sGetCallStack sym + pure (VFun (combineCallStacks stk fnstk) f) + VPoly fnstk f -> + do stk <- sGetCallStack sym + pure (VPoly (combineCallStacks stk fnstk) f) + VNumPoly fnstk f -> + do stk <- sGetCallStack sym + pure (VNumPoly (combineCallStacks stk fnstk) f) + _ -> pure v + -- Newtypes -------------------------------------------------------------------- {-# SPECIALIZE evalNewtypes :: @@ -236,10 +256,10 @@ evalNewtype :: Newtype -> GenEvalEnv sym -> SEval sym (GenEvalEnv sym) -evalNewtype sym nt = bindVar sym (ntName nt) (return (foldr tabs con (ntParams nt))) +evalNewtype _sym nt = pure . bindVarDirect (ntName nt) (foldr tabs con (ntParams nt)) where - tabs _tp body = tlam (\ _ -> body) - con = VFun id + tabs _tp body = PTyPoly (\ _ -> body) + con = PFun PPrim {-# INLINE evalNewtype #-} @@ -404,10 +424,10 @@ etaDelay sym rng env0 Forall{ sVars = vs0, sType = tp0 } = goTpVars env0 vs0 goTpVars env [] val = go (evalValType (envTypes env) tp0) val goTpVars env (v:vs) val = case tpKind v of - KType -> return $ VPoly $ \t -> - goTpVars (bindType (tpVar v) (Right t) env) vs ( ($t) . fromVPoly =<< val ) - KNum -> return $ VNumPoly $ \n -> - goTpVars (bindType (tpVar v) (Left n) env) vs ( ($n) . fromVNumPoly =<< val ) + KType -> tlam sym $ \t -> + goTpVars (bindType (tpVar v) (Right t) env) vs ( ($t) . fromVPoly sym =<< val ) + KNum -> nlam sym $ \n -> + goTpVars (bindType (tpVar v) (Left n) env) vs ( ($n) . fromVNumPoly sym =<< val ) k -> panic "[Eval] etaDelay" ["invalid kind on type abstraction", show k] go tp x | isReady sym x = x >>= \case @@ -442,9 +462,9 @@ etaDelay sym rng env0 Forall{ sVars = vs0, sType = tp0 } = goTpVars env0 vs0 Right fs' -> return (VRecord fs') _ -> evalPanic "type mismatch during eta-expansion" ["Expected record type, but got " ++ show tp] - VFun f -> + f@VFun{} -> case tp of - TVFun _t1 t2 -> return $ VFun $ \a -> go t2 (f a) + TVFun _t1 t2 -> lam sym $ \a -> go t2 (fromVFun sym f a) _ -> evalPanic "type mismatch during eta-expansion" ["Expected function type but got " ++ show tp] VPoly{} -> @@ -477,8 +497,8 @@ etaDelay sym rng env0 Forall{ sVars = vs0, sType = tp0 } = goTpVars env0 vs0 go el (flip lookupSeqMap i =<< x') TVFun _t1 t2 -> - do v' <- sDelay sym rng (fromVFun <$> v) - return $ VFun $ \a -> go t2 ( ($a) =<< v' ) + do v' <- sDelay sym rng (fromVFun sym <$> v) + lam sym $ \a -> go t2 ( ($a) =<< v' ) TVTuple ts -> do let n = length ts diff --git a/src/Cryptol/Eval/Concrete.hs b/src/Cryptol/Eval/Concrete.hs index 33adf7a3c..e25f4b437 100644 --- a/src/Cryptol/Eval/Concrete.hs +++ b/src/Cryptol/Eval/Concrete.hs @@ -106,9 +106,9 @@ toExpr prims t0 v0 = findOne (go t0 v0) do BV _ v <- lift (asWordVal Concrete =<< wval) pure $ ETApp (ETApp (prim "number") (tNum v)) ty VStream _ -> fail "cannot construct infinite expressions" - VFun _ -> fail "cannot convert function values to expressions" - VPoly _ -> fail "cannot convert polymorphic values to expressions" - VNumPoly _ -> fail "cannot convert polymorphic values to expressions" + VFun{} -> fail "cannot convert function values to expressions" + VPoly{} -> fail "cannot convert polymorphic values to expressions" + VNumPoly{} -> fail "cannot convert polymorphic values to expressions" where mismatch :: forall a. ChoiceT Eval a mismatch = @@ -186,10 +186,9 @@ primTable eOpts = let sym = Concrete in do msg <- valueToString sym =<< s let EvalOpts { evalPPOpts, evalLogger } = eOpts doc <- ppValue sym evalPPOpts =<< x - yv <- y io $ logPrint evalLogger $ if null msg then doc else text msg <+> doc - return yv) + y) , ("pmult", PFinPoly \u -> @@ -210,7 +209,7 @@ primTable eOpts = let sym = Concrete in PWordFun \(BV _ m) -> PRange \rng -> PPrim - do assertSideCondition sym (m /= 0) (EvalErrorEx rng DivideByZero) + do assertSideCondition sym (m /= 0) rng DivideByZero return . VWord v . pure . WordVal . mkBv v $! F2.pmod (fromInteger w) x m) , ("pdiv", @@ -220,7 +219,7 @@ primTable eOpts = let sym = Concrete in PWordFun \(BV _ m) -> PRange \rng -> PPrim - do assertSideCondition sym (m /= 0) (EvalErrorEx rng DivideByZero) + do assertSideCondition sym (m /= 0) rng DivideByZero return . VWord w . pure . WordVal . mkBv w $! F2.pdiv (fromInteger w) x m) ] @@ -708,7 +707,7 @@ floatPrims sym = Map.fromList [ (floatPrim i,v) | (i,v) <- nonInfixTable ] PRange \rng -> PPrim case floatToRational "fpToRational" fp of - Left err -> raiseError sym (EvalErrorEx rng err) + Left err -> raiseError sym rng err Right r -> pure $ VRational SRational { sNum = numerator r, sDenom = denominator r } diff --git a/src/Cryptol/Eval/Generic.hs b/src/Cryptol/Eval/Generic.hs index c9d3f2455..d8cffafb4 100644 --- a/src/Cryptol/Eval/Generic.hs +++ b/src/Cryptol/Eval/Generic.hs @@ -37,7 +37,7 @@ import Cryptol.TypeCheck.AST import Cryptol.TypeCheck.Solver.InfNat (Nat'(..),nMul,widthInteger) import Cryptol.Backend import Cryptol.Backend.Concrete (Concrete(..)) -import Cryptol.Backend.Monad ( Eval, evalPanic, EvalError(..), EvalErrorEx(..), Unsupported(..) ) +import Cryptol.Backend.Monad ( Eval, evalPanic, EvalError(..), Unsupported(..) ) import Cryptol.Parser.Position (Range,emptyRange) import Cryptol.Testing.Random( randomValue ) @@ -230,7 +230,7 @@ ringBinary sym opw opi opz opq opfp rng = loop -- functions TVFun _ ety -> - return $ lam $ \ x -> loop' ety (fromVFun l x) (fromVFun r x) + lam sym $ \ x -> loop' ety (fromVFun sym l x) (fromVFun sym r x) -- tuples TVTuple tys -> @@ -307,7 +307,7 @@ ringUnary sym opw opi opz opq opfp rng = loop -- functions TVFun _ ety -> - return $ lam $ \ y -> loop' ety (fromVFun v y) + lam sym $ \ y -> loop' ety (fromVFun sym v y) -- tuples TVTuple tys -> @@ -376,7 +376,7 @@ ringNullary sym rng opw opi opz opq opfp = loop TVFun _ b -> do v <- sDelay sym rng (loop b) - pure $ lam $ const $ v + lam sym (const v) TVTuple tys -> do xs <- mapM (sDelay sym rng . loop) tys @@ -503,7 +503,7 @@ expV sym = do ebits <- enumerateIntBits' sym n ei computeExponent sym rng aty a ebits - | otherwise -> raiseError sym (EvalErrorEx rng NegativeExponent) + | otherwise -> raiseError sym rng NegativeExponent Nothing -> liftIO (X.throw (UnsupportedSymbolicOp "integer exponentiation")) @@ -921,7 +921,7 @@ zeroV sym rng ty = case ty of -- functions TVFun _ bty -> do z <- sDelay sym rng (zeroV sym rng bty) - pure $ lam (const z) + lam sym (const z) -- tuples TVTuple tys -> @@ -1349,7 +1349,7 @@ logicBinary sym opb opw rng = loop return $ VTuple $ zipWith3 loop' etys ls rs TVFun _ bty -> - return $ lam $ \ a -> loop' bty (fromVFun l a) (fromVFun r a) + lam sym $ \ a -> loop' bty (fromVFun sym l a) (fromVFun sym r a) TVRec fields -> VRecord <$> @@ -1418,7 +1418,7 @@ logicUnary sym opb opw rng = loop return $ VTuple (zipWith loop' etys as) TVFun _ bty -> - return $ lam $ \ a -> loop' bty (fromVFun val a) + lam sym $ \ a -> loop' bty (fromVFun sym val a) TVRec fields -> VRecord <$> @@ -1467,7 +1467,7 @@ assertIndexInBounds :: -- All nonnegative integers are in bounds for an infinite sequence assertIndexInBounds sym rng Inf (Left idx) = do ppos <- bitComplement sym =<< intLessThan sym idx =<< integerLit sym 0 - assertSideCondition sym ppos (EvalErrorEx rng (InvalidIndex (integerAsLit sym idx))) + assertSideCondition sym ppos rng (InvalidIndex (integerAsLit sym idx)) -- If the index is an integer, test that it -- is nonnegative and less than the concrete value of n. @@ -1476,7 +1476,7 @@ assertIndexInBounds sym rng (Nat n) (Left idx) = ppos <- bitComplement sym =<< intLessThan sym idx =<< integerLit sym 0 pn <- intLessThan sym idx n' p <- bitAnd sym ppos pn - assertSideCondition sym p (EvalErrorEx rng (InvalidIndex (integerAsLit sym idx))) + assertSideCondition sym p rng (InvalidIndex (integerAsLit sym idx)) -- Bitvectors can't index out of bounds for an infinite sequence assertIndexInBounds _sym _rng Inf (Right _) = return () @@ -1490,7 +1490,7 @@ assertIndexInBounds sym _rng (Nat n) (Right idx) -- If the index is concrete, test it directly assertIndexInBounds sym rng (Nat n) (Right (WordVal idx)) | Just (_w,i) <- wordAsLit sym idx - = unless (i < n) (raiseError sym (EvalErrorEx rng (InvalidIndex (Just i)))) + = unless (i < n) (raiseError sym rng (InvalidIndex (Just i))) -- If the index is a packed word, test that it -- is less than the concrete value of n, which @@ -1498,14 +1498,14 @@ assertIndexInBounds sym rng (Nat n) (Right (WordVal idx)) assertIndexInBounds sym rng (Nat n) (Right (WordVal idx)) = do n' <- wordLit sym (wordLen sym idx) n p <- wordLessThan sym idx n' - assertSideCondition sym p (EvalErrorEx rng (InvalidIndex Nothing)) + assertSideCondition sym p rng (InvalidIndex Nothing) -- If the index is an unpacked word, force all the bits -- and compute the unsigned less-than test directly. assertIndexInBounds sym rng (Nat n) (Right (LargeBitsVal w bits)) = do bitsList <- traverse (fromVBit <$>) (enumerateSeqMap w bits) p <- bitsValueLessThan sym w bitsList n - assertSideCondition sym p (EvalErrorEx rng (InvalidIndex Nothing)) + assertSideCondition sym p rng (InvalidIndex Nothing) -- | Indexing operations. @@ -1872,7 +1872,7 @@ errorV sym rng ty msg = -- functions TVFun _ bty -> - return $ lam (\ _ -> errorV sym rng bty msg) + lam sym (\ _ -> errorV sym rng bty msg) -- tuples TVTuple tys -> @@ -1968,8 +1968,8 @@ mergeValue sym c v1 v2 = (VWord n1 w1 , VWord n2 w2 ) | n1 == n2 -> pure $ VWord n1 $ mergeWord' sym c w1 w2 (VSeq n1 vs1 , VSeq n2 vs2 ) | n1 == n2 -> VSeq n1 <$> memoMap (mergeSeqMap sym c vs1 vs2) (VStream vs1 , VStream vs2 ) -> VStream <$> memoMap (mergeSeqMap sym c vs1 vs2) - (VFun f1 , VFun f2 ) -> pure $ VFun $ \x -> mergeValue' sym c (f1 x) (f2 x) - (VPoly f1 , VPoly f2 ) -> pure $ VPoly $ \x -> mergeValue' sym c (f1 x) (f2 x) + (f1@VFun{} , f2@VFun{} ) -> lam sym $ \x -> mergeValue' sym c (fromVFun sym f1 x) (fromVFun sym f2 x) + (f1@VPoly{} , f2@VPoly{} ) -> tlam sym $ \x -> mergeValue' sym c (fromVPoly sym f1 x) (fromVPoly sym f2 x) (_ , _ ) -> panic "Cryptol.Eval.Generic" [ "mergeValue: incompatible values" ] @@ -2002,12 +2002,12 @@ foldlV sym = where go0 _f a [] = a go0 f a bs = - do f' <- fromVFun <$> f + do f' <- fromVFun sym <$> f go1 f' a bs go1 _f a [] = a go1 f a (b:bs) = - do f' <- fromVFun <$> (f a) + do f' <- fromVFun sym <$> (f a) go1 f (f' b) bs foldl'V :: Backend sym => sym -> Prim sym @@ -2027,14 +2027,14 @@ foldl'V sym = where go0 _rng _f a [] = a go0 rng f a bs = - do f' <- fromVFun <$> f + do f' <- fromVFun sym <$> f a' <- sDelay sym rng a forceValue =<< a' go1 rng f' a' bs go1 _rng _f a [] = a go1 rng f a (b:bs) = - do f' <- fromVFun <$> (f a) + do f' <- fromVFun sym <$> (f a) a' <- sDelay sym rng (f' b) forceValue =<< a' go1 rng f a' bs @@ -2071,7 +2071,7 @@ parmapV sym = PFun \xs -> PRange \rng -> PPrim - do f' <- fromVFun <$> f + do f' <- fromVFun sym <$> f xs' <- xs case xs' of VWord n w -> diff --git a/src/Cryptol/Eval/Prims.hs b/src/Cryptol/Eval/Prims.hs index ceebf843c..d26d7f8c0 100644 --- a/src/Cryptol/Eval/Prims.hs +++ b/src/Cryptol/Eval/Prims.hs @@ -24,14 +24,14 @@ data Prim sym evalPrim :: (?range :: Range, Backend sym) => sym -> Name -> Prim sym -> SEval sym (GenValue sym) evalPrim sym nm p = case p of - PFun f -> pure (lam (evalPrim sym nm . f)) - PStrict f -> pure (lam (\x -> evalPrim sym nm . f =<< x)) - PWordFun f -> pure (lam (\x -> evalPrim sym nm . f =<< (fromVWord sym (show nm) =<< x))) - PFloatFun f -> pure (flam (evalPrim sym nm . f)) - PTyPoly f -> pure (VPoly (evalPrim sym nm . f)) - PNumPoly f -> pure (VNumPoly (evalPrim sym nm . f)) - PFinPoly f -> pure (VNumPoly (\case Inf -> panic "PFin" ["Unexpected `inf`", show nm]; - Nat n -> evalPrim sym nm (f n))) + PFun f -> lam sym (evalPrim sym nm . f) + PStrict f -> lam sym (\x -> evalPrim sym nm . f =<< x) + PWordFun f -> lam sym (\x -> evalPrim sym nm . f =<< (fromVWord sym (show nm) =<< x)) + PFloatFun f -> flam sym (evalPrim sym nm . f) + PTyPoly f -> tlam sym (evalPrim sym nm . f) + PNumPoly f -> nlam sym (evalPrim sym nm . f) + PFinPoly f -> nlam sym (\case Inf -> panic "PFin" ["Unexpected `inf`", show nm]; + Nat n -> evalPrim sym nm (f n)) PRange f -> evalPrim sym nm (f ?range) PPrim m -> m PVal v -> pure v diff --git a/src/Cryptol/Eval/SBV.hs b/src/Cryptol/Eval/SBV.hs index b0c7d1b59..f5ff446d5 100644 --- a/src/Cryptol/Eval/SBV.hs +++ b/src/Cryptol/Eval/SBV.hs @@ -30,7 +30,7 @@ import qualified Data.Text as T import Data.SBV.Dynamic as SBV import Cryptol.Backend -import Cryptol.Backend.Monad ( EvalError(..), EvalErrorEx(..), Unsupported(..) ) +import Cryptol.Backend.Monad ( EvalError(..), Unsupported(..) ) import Cryptol.Backend.SBV import Cryptol.Eval.Type (TValue(..)) @@ -171,7 +171,7 @@ indexFront_bits sym rng mblen _a xs _ix bits0 = go 0 (length bits0) bits0 -- For indices out of range, fail | Nat n <- mblen , i >= n - = raiseError sym (EvalErrorEx rng (InvalidIndex (Just i))) + = raiseError sym rng (InvalidIndex (Just i)) | otherwise = lookupSeqMap xs i @@ -181,7 +181,7 @@ indexFront_bits sym rng mblen _a xs _ix bits0 = go 0 (length bits0) bits0 -- are out of bounds | Nat n <- mblen , (i `shiftL` k) >= n - = raiseError sym (EvalErrorEx rng (InvalidIndex Nothing)) + = raiseError sym rng (InvalidIndex Nothing) | otherwise = iteValue sym b diff --git a/src/Cryptol/Eval/Value.hs b/src/Cryptol/Eval/Value.hs index 1b0586e4d..a7fc56281 100644 --- a/src/Cryptol/Eval/Value.hs +++ b/src/Cryptol/Eval/Value.hs @@ -33,7 +33,6 @@ module Cryptol.Eval.Value -- ** Value introduction operations , word , lam - , wlam , flam , tlam , nlam @@ -100,7 +99,10 @@ import MonadLib import Cryptol.Backend import qualified Cryptol.Backend.Arch as Arch -import Cryptol.Backend.Monad ( PPOpts(..), evalPanic, wordTooWide, defaultPPOpts, asciiMode ) +import Cryptol.Backend.Monad + ( PPOpts(..), evalPanic, wordTooWide, defaultPPOpts, asciiMode + , CallStack, combineCallStacks + ) import Cryptol.Eval.Type import Cryptol.Parser.Position (Range) @@ -310,9 +312,9 @@ data GenValue sym -- Invariant: VSeq is never a sequence of bits | VWord !Integer !(SEval sym (WordValue sym)) -- ^ @ [n]Bit @ | VStream !(SeqMap sym) -- ^ @ [inf]a @ - | VFun (SEval sym (GenValue sym) -> SEval sym (GenValue sym)) -- ^ functions - | VPoly (TValue -> SEval sym (GenValue sym)) -- ^ polymorphic values (kind *) - | VNumPoly (Nat' -> SEval sym (GenValue sym)) -- ^ polymorphic values (kind #) + | VFun CallStack (SEval sym (GenValue sym) -> SEval sym (GenValue sym)) -- ^ functions + | VPoly CallStack (TValue -> SEval sym (GenValue sym)) -- ^ polymorphic values (kind *) + | VNumPoly CallStack (Nat' -> SEval sym (GenValue sym)) -- ^ polymorphic values (kind #) deriving Generic @@ -333,9 +335,9 @@ forceValue v = case v of VFloat f -> seq f (return ()) VWord _ wv -> forceWordValue =<< wv VStream _ -> return () - VFun _ -> return () - VPoly _ -> return () - VNumPoly _ -> return () + VFun{} -> return () + VPoly{} -> return () + VNumPoly{} -> return () @@ -350,9 +352,9 @@ instance Backend sym => Show (GenValue sym) where VSeq n _ -> "seq:" ++ show n VWord n _ -> "word:" ++ show n VStream _ -> "stream" - VFun _ -> "fun" - VPoly _ -> "poly" - VNumPoly _ -> "numpoly" + VFun{} -> "fun" + VPoly{} -> "poly" + VNumPoly{} -> "numpoly" -- Pretty Printing ------------------------------------------------------------- @@ -384,9 +386,9 @@ ppValue x opts = loop $ punctuate comma ( vals' ++ [text "..."] ) - VFun _ -> return $ text "" - VPoly _ -> return $ text "" - VNumPoly _ -> return $ text "" + VFun{} -> return $ text "" + VPoly{} -> return $ text "" + VNumPoly{} -> return $ text "" ppWordVal :: WordValue sym -> SEval sym Doc ppWordVal w = ppWord x opts <$> asWordVal x w @@ -415,33 +417,28 @@ word sym n i | otherwise = VWord n (WordVal <$> wordLit sym n i) -lam :: (SEval sym (GenValue sym) -> SEval sym (GenValue sym)) -> GenValue sym -lam = VFun - --- | Functions that assume word inputs -wlam :: Backend sym => sym -> (SWord sym -> SEval sym (GenValue sym)) -> GenValue sym -wlam sym f = VFun (\arg -> arg >>= fromVWord sym "wlam" >>= f) +lam :: Backend sym => sym -> (SEval sym (GenValue sym) -> SEval sym (GenValue sym)) -> SEval sym (GenValue sym) +lam sym f = VFun <$> sGetCallStack sym <*> pure 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) - - +flam :: Backend sym => sym -> + (SFloat sym -> SEval sym (GenValue sym)) -> SEval sym (GenValue sym) +flam sym f = VFun <$> sGetCallStack sym <*> pure (\arg -> arg >>= f . fromVFloat) -- | A type lambda that expects a 'Type'. -tlam :: Backend sym => (TValue -> GenValue sym) -> GenValue sym -tlam f = VPoly (return . f) +tlam :: Backend sym => sym -> (TValue -> SEval sym (GenValue sym)) -> SEval sym (GenValue sym) +tlam sym f = VPoly <$> sGetCallStack sym <*> pure f -- | A type lambda that expects a 'Type' of kind #. -nlam :: Backend sym => (Nat' -> GenValue sym) -> GenValue sym -nlam f = VNumPoly (return . f) +nlam :: Backend sym => sym -> (Nat' -> SEval sym (GenValue sym)) -> SEval sym (GenValue sym) +nlam sym f = VNumPoly <$> sGetCallStack sym <*> pure f -- | A type lambda that expects a finite numeric type. -ilam :: Backend sym => (Integer -> GenValue sym) -> GenValue sym -ilam f = nlam (\n -> case n of - Nat i -> f i - Inf -> panic "ilam" [ "Unexpected `inf`" ]) +ilam :: Backend sym => sym -> (Integer -> SEval sym (GenValue sym)) -> SEval sym (GenValue sym) +ilam sym f = + nlam sym (\n -> case n of + Nat i -> f i + Inf -> panic "ilam" [ "Unexpected `inf`" ]) -- | Generate a stream. toStream :: Backend sym => [GenValue sym] -> SEval sym (GenValue sym) @@ -539,22 +536,25 @@ tryFromBits sym = go id go _ (_ : _) = Nothing -- | Extract a function from a value. -fromVFun :: GenValue sym -> (SEval sym (GenValue sym) -> SEval sym (GenValue sym)) -fromVFun val = case val of - VFun f -> f - _ -> evalPanic "fromVFun" ["not a function"] +fromVFun :: Backend sym => sym -> GenValue sym -> (SEval sym (GenValue sym) -> SEval sym (GenValue sym)) +fromVFun sym val = case val of + VFun fnstk f -> + \x -> sModifyCallStack sym (\stk -> combineCallStacks stk fnstk) (f x) + _ -> evalPanic "fromVFun" ["not a function"] -- | Extract a polymorphic function from a value. -fromVPoly :: GenValue sym -> (TValue -> SEval sym (GenValue sym)) -fromVPoly val = case val of - VPoly f -> f - _ -> evalPanic "fromVPoly" ["not a polymorphic value"] +fromVPoly :: Backend sym => sym -> GenValue sym -> (TValue -> SEval sym (GenValue sym)) +fromVPoly sym val = case val of + VPoly fnstk f -> + \x -> sModifyCallStack sym (\stk -> combineCallStacks stk fnstk) (f x) + _ -> evalPanic "fromVPoly" ["not a polymorphic value"] -- | Extract a polymorphic function from a value. -fromVNumPoly :: GenValue sym -> (Nat' -> SEval sym (GenValue sym)) -fromVNumPoly val = case val of - VNumPoly f -> f - _ -> evalPanic "fromVNumPoly" ["not a polymorphic value"] +fromVNumPoly :: Backend sym => sym -> GenValue sym -> (Nat' -> SEval sym (GenValue sym)) +fromVNumPoly sym val = case val of + VNumPoly fnstk f -> + \x -> sModifyCallStack sym (\stk -> combineCallStacks stk fnstk) (f x) + _ -> evalPanic "fromVNumPoly" ["not a polymorphic value"] -- | Extract a tuple from a value. fromVTuple :: GenValue sym -> [SEval sym (GenValue sym)] diff --git a/src/Cryptol/Eval/What4.hs b/src/Cryptol/Eval/What4.hs index 3f363fd4d..cf4183999 100644 --- a/src/Cryptol/Eval/What4.hs +++ b/src/Cryptol/Eval/What4.hs @@ -41,7 +41,7 @@ import qualified What4.SWord as SW import qualified What4.Utils.AbstractDomains as W4 import Cryptol.Backend -import Cryptol.Backend.Monad ( EvalError(..), EvalErrorEx(..), Unsupported(..) ) +import Cryptol.Backend.Monad ( EvalError(..), Unsupported(..) ) import Cryptol.Backend.What4 import qualified Cryptol.Backend.What4.SFloat as W4 @@ -576,7 +576,7 @@ indexFront_int sym rng mblen _a xs ix idx where w4sym = w4 sym - def = raiseError sym (EvalErrorEx rng (InvalidIndex Nothing)) + def = raiseError sym rng (InvalidIndex Nothing) f n y = do p <- liftIO (W4.intEq w4sym idx =<< W4.intLit w4sym n) @@ -637,7 +637,7 @@ indexFront_word sym rng mblen _a xs _ix idx w4sym = w4 sym w = SW.bvWidth idx - def = raiseError sym (EvalErrorEx rng (InvalidIndex Nothing)) + def = raiseError sym rng (InvalidIndex Nothing) f n y = do p <- liftIO (SW.bvEq w4sym idx =<< SW.bvLit w4sym w n) @@ -688,7 +688,7 @@ indexFront_bits sym rng mblen _a xs _ix bits0 = go 0 (length bits0) bits0 -- For indices out of range, fail | Nat n <- mblen , i >= n - = raiseError sym (EvalErrorEx rng (InvalidIndex (Just i))) + = raiseError sym rng (InvalidIndex (Just i)) | otherwise = lookupSeqMap xs i @@ -698,7 +698,7 @@ indexFront_bits sym rng mblen _a xs _ix bits0 = go 0 (length bits0) bits0 -- are out of bounds | Nat n <- mblen , (i `shiftL` k) >= n - = raiseError sym (EvalErrorEx rng (InvalidIndex Nothing)) + = raiseError sym rng (InvalidIndex Nothing) | otherwise = iteValue sym b diff --git a/src/Cryptol/ModuleSystem/Base.hs b/src/Cryptol/ModuleSystem/Base.hs index 6ac684eec..802a6fe06 100644 --- a/src/Cryptol/ModuleSystem/Base.hs +++ b/src/Cryptol/ModuleSystem/Base.hs @@ -565,7 +565,7 @@ evalExpr e = do let tbl = Concrete.primTable evopts let ?evalPrim = \i -> Right <$> Map.lookup i tbl let ?range = emptyRange - io $ E.runEval $ (E.evalExpr Concrete (env <> deEnv denv) e) + io $ E.runEval mempty (E.evalExpr Concrete (env <> deEnv denv) e) evalDecls :: [T.DeclGroup] -> ModuleM () evalDecls dgs = do @@ -575,7 +575,7 @@ evalDecls dgs = do let env' = env <> deEnv denv let tbl = Concrete.primTable evOpts let ?evalPrim = \i -> Right <$> Map.lookup i tbl - deEnv' <- io $ E.runEval $ E.evalDecls Concrete dgs env' + deEnv' <- io $ E.runEval mempty (E.evalDecls Concrete dgs env') let denv' = denv { deDecls = deDecls denv ++ dgs , deEnv = deEnv' } diff --git a/src/Cryptol/ModuleSystem/Monad.hs b/src/Cryptol/ModuleSystem/Monad.hs index d40680c8f..bfa42638a 100644 --- a/src/Cryptol/ModuleSystem/Monad.hs +++ b/src/Cryptol/ModuleSystem/Monad.hs @@ -489,7 +489,7 @@ modifyEvalEnv :: (EvalEnv -> E.Eval EvalEnv) -> ModuleM () modifyEvalEnv f = ModuleT $ do env <- get let evalEnv = meEvalEnv env - evalEnv' <- inBase $ E.runEval (f evalEnv) + evalEnv' <- inBase $ E.runEval mempty (f evalEnv) set $! env { meEvalEnv = evalEnv' } getEvalEnv :: ModuleM EvalEnv diff --git a/src/Cryptol/Parser/Position.hs b/src/Cryptol/Parser/Position.hs index f2f6eb0ef..96fc4ff46 100644 --- a/src/Cryptol/Parser/Position.hs +++ b/src/Cryptol/Parser/Position.hs @@ -124,4 +124,3 @@ combLoc f l1 l2 = Located { srcRange = rComb (srcRange l1) (srcRange l2) , thing = f (thing l1) (thing l2) } - diff --git a/src/Cryptol/REPL/Command.hs b/src/Cryptol/REPL/Command.hs index 963c57472..eb2ad3e3b 100644 --- a/src/Cryptol/REPL/Command.hs +++ b/src/Cryptol/REPL/Command.hs @@ -763,7 +763,7 @@ printSafetyViolation :: P.Expr P.PName -> [E.GenValue Concrete] -> REPL () printSafetyViolation pexpr vs = catch (do (fn,_) <- replEvalExpr pexpr - rEval (E.forceValue =<< foldM (\f v -> E.fromVFun f (pure v)) fn vs)) + rEval (E.forceValue =<< foldM (\f v -> E.fromVFun Concrete f (pure v)) fn vs)) (\case EvalError eex -> rPutStrLn (show (pp eex)) ex -> raise ex) @@ -1010,10 +1010,10 @@ writeFileCmd file str pos fnm = do rEval :: E.Eval a -> REPL a -rEval m = io (E.runEval m) +rEval m = io (E.runEval mempty m) rEvalRethrow :: E.Eval a -> REPL a -rEvalRethrow m = io $ rethrowEvalError $ E.runEval m +rEvalRethrow m = io $ rethrowEvalError $ E.runEval mempty m reloadCmd :: REPL () reloadCmd = do diff --git a/src/Cryptol/Symbolic/SBV.hs b/src/Cryptol/Symbolic/SBV.hs index b4943e391..4f2aa77f4 100644 --- a/src/Cryptol/Symbolic/SBV.hs +++ b/src/Cryptol/Symbolic/SBV.hs @@ -72,7 +72,7 @@ import Prelude.Compat doSBVEval :: MonadIO m => SBVEval a -> m (SBV.SVal, a) doSBVEval m = - (liftIO $ Eval.runEval (sbvEval m)) >>= \case + (liftIO $ Eval.runEval mempty (sbvEval m)) >>= \case SBVError err -> liftIO (X.throwIO err) SBVResult p x -> pure (p, x) @@ -341,7 +341,7 @@ prepareQuery evo ProverCommand{..} = (safety,b) <- doSBVEval $ do env <- Eval.evalDecls sym extDgs mempty v <- Eval.evalExpr sym env pcExpr - appliedVal <- foldM Eval.fromVFun v args + appliedVal <- foldM (Eval.fromVFun sym) v args case pcQueryType of SafetyQuery -> do Eval.forceValue appliedVal diff --git a/src/Cryptol/Symbolic/What4.hs b/src/Cryptol/Symbolic/What4.hs index dcdd78d74..bd3c987bb 100644 --- a/src/Cryptol/Symbolic/What4.hs +++ b/src/Cryptol/Symbolic/What4.hs @@ -124,7 +124,7 @@ doW4Eval :: (W4.IsExprBuilder sym, MonadIO m) => sym -> W4Eval sym a -> m (W4.Pred sym, a) doW4Eval sym m = - do res <- liftIO $ Eval.runEval (w4Eval m sym) + do res <- liftIO $ Eval.runEval mempty (w4Eval m sym) case res of W4Error err -> liftIO (X.throwIO err) W4Result p x -> pure (p,x) @@ -286,7 +286,7 @@ prepareQuery sym ProverCommand { .. } = do env <- Eval.evalDecls sym extDgs mempty v <- Eval.evalExpr sym env pcExpr appliedVal <- - foldM Eval.fromVFun v (map (pure . varShapeToValue sym) args) + foldM (Eval.fromVFun sym) v (map (pure . varShapeToValue sym) args) case pcQueryType of SafetyQuery -> diff --git a/src/Cryptol/Testing/Random.hs b/src/Cryptol/Testing/Random.hs index 2f0179b60..9b5a2926e 100644 --- a/src/Cryptol/Testing/Random.hs +++ b/src/Cryptol/Testing/Random.hs @@ -28,7 +28,7 @@ module Cryptol.Testing.Random ) where import qualified Control.Exception as X -import Control.Monad (join, liftM2) +import Control.Monad (liftM2) import Control.Monad.IO.Class (MonadIO(..)) import Data.Ratio ((%)) import Data.List (unfoldr, genericTake, genericIndex, genericReplicate) @@ -42,7 +42,7 @@ import Cryptol.Backend.Concrete import Cryptol.Eval.Type (TValue(..)) import Cryptol.Eval.Value (GenValue(..),SeqMap(..), WordValue(..), - ppValue, defaultPPOpts, finiteSeqMap) + ppValue, defaultPPOpts, finiteSeqMap, fromVFun) import Cryptol.Utils.Ident (Ident) import Cryptol.Utils.Panic (panic) import Cryptol.Utils.RecordMap @@ -68,7 +68,7 @@ runOneTest :: RandomGen g runOneTest fun argGens sz g0 = do let (args, g1) = foldr mkArg ([], g0) argGens mkArg argGen (as, g) = let (a, g') = argGen sz g in (a:as, g') - args' <- runEval (sequence args) + args' <- runEval mempty (sequence args) result <- evalTest fun args' return (result, g1) @@ -81,12 +81,14 @@ returnOneTest :: RandomGen g returnOneTest fun argGens sz g0 = do let (args, g1) = foldr mkArg ([], g0) argGens mkArg argGen (as, g) = let (a, g') = argGen sz g in (a:as, g') - args' <- runEval (sequence args) - result <- runEval (go fun args') + args' <- runEval mempty (sequence args) + result <- runEval mempty (go fun args') return (args', result, g1) where - go (VFun f) (v : vs) = join (go <$> (f (pure v)) <*> pure vs) - go (VFun _) [] = panic "Cryptol.Testing.Random" ["Not enough arguments to function while generating tests"] + go f@VFun{} (v : vs) = + do f' <- fromVFun Concrete f (pure v) + go f' vs + go VFun{} [] = panic "Cryptol.Testing.Random" ["Not enough arguments to function while generating tests"] go _ (_ : _) = panic "Cryptol.Testing.Random" ["Too many arguments to function while generating tests"] go v [] = return v @@ -292,15 +294,16 @@ evalTest :: Value -> [Value] -> IO TestResult evalTest v0 vs0 = run `X.catch` handle where run = do - result <- runEval (go v0 vs0) + result <- runEval mempty (go v0 vs0) if result then return Pass else return (FailFalse vs0) handle e = return (FailError e vs0) go :: Value -> [Value] -> Eval Bool - go (VFun f) (v : vs) = join (go <$> (f (pure v)) <*> return vs) - go (VFun _) [] = panic "Not enough arguments while applying function" + go f@VFun{} (v : vs) = do f' <- fromVFun Concrete f (pure v) + go f' vs + go VFun{} [] = panic "Not enough arguments while applying function" [] go (VBit b) [] = return b go v vs = do vdoc <- ppValue Concrete defaultPPOpts v From b635a51fa68f284810fa68ddea926ad25a4018fa Mon Sep 17 00:00:00 2001 From: Rob Dockins Date: Wed, 2 Dec 2020 18:30:06 -0800 Subject: [PATCH 14/27] Update test suite with backtraces --- tests/issues/issue211.icry.stdout | 3 +++ tests/issues/issue413.icry.stdout | 4 ++++ tests/issues/issue861.icry.stdout | 16 ++++++++++++++++ tests/regression/safety.icry.stdout | 7 +++++++ 4 files changed, 30 insertions(+) diff --git a/tests/issues/issue211.icry.stdout b/tests/issues/issue211.icry.stdout index 1d241cf2b..f3435082c 100644 --- a/tests/issues/issue211.icry.stdout +++ b/tests/issues/issue211.icry.stdout @@ -5,3 +5,6 @@ Loading module Cryptol Run-time error: boom at issue211.icry:4:28--4:33 +-- Backtrace -- +Cryptol::error called at issue211.icry:4:28--4:33 +Cryptol::splitAt called at issue211.icry:4:2--4:9 diff --git a/tests/issues/issue413.icry.stdout b/tests/issues/issue413.icry.stdout index 982affb80..2515f0c57 100644 --- a/tests/issues/issue413.icry.stdout +++ b/tests/issues/issue413.icry.stdout @@ -5,6 +5,10 @@ at issue413.icry:1:1--1:10 division by 0 at issue413.icry:2:1--2:5 +-- Backtrace -- +Cryptol::pdiv called at issue413.icry:2:1--2:5 division by 0 at issue413.icry:3:1--3:5 +-- Backtrace -- +Cryptol::pmod called at issue413.icry:3:1--3:5 diff --git a/tests/issues/issue861.icry.stdout b/tests/issues/issue861.icry.stdout index daf9162c8..745bda47c 100644 --- a/tests/issues/issue861.icry.stdout +++ b/tests/issues/issue861.icry.stdout @@ -5,33 +5,49 @@ Loading module Cryptol invalid sequence index: 3 at issue861.icry:7:1--7:5 +-- Backtrace -- +(Cryptol::@) called at issue861.icry:7:1--7:5 invalid sequence index: -1 at issue861.icry:8:1--8:8 +-- Backtrace -- +(Cryptol::@) called at issue861.icry:8:1--8:8 2 1 0 invalid sequence index: 3 at issue861.icry:13:1--13:5 +-- Backtrace -- +(Cryptol::!) called at issue861.icry:13:1--13:5 invalid sequence index: -1 at issue861.icry:14:1--14:8 +-- Backtrace -- +(Cryptol::!) called at issue861.icry:14:1--14:8 [5, 1, 2] [0, 5, 2] [0, 1, 5] invalid sequence index: 3 at issue861.icry:19:1--19:7 +-- Backtrace -- +Cryptol::update called at issue861.icry:19:1--19:7 invalid sequence index: -1 at issue861.icry:20:1--20:7 +-- Backtrace -- +Cryptol::update called at issue861.icry:20:1--20:7 [0, 1, 5] [0, 5, 2] [5, 1, 2] invalid sequence index: 3 at issue861.icry:25:1--25:10 +-- Backtrace -- +Cryptol::updateEnd called at issue861.icry:25:1--25:10 invalid sequence index: -1 at issue861.icry:26:1--26:10 +-- Backtrace -- +Cryptol::updateEnd called at issue861.icry:26:1--26:10 diff --git a/tests/regression/safety.icry.stdout b/tests/regression/safety.icry.stdout index 432444d69..aafa9378c 100644 --- a/tests/regression/safety.icry.stdout +++ b/tests/regression/safety.icry.stdout @@ -7,10 +7,17 @@ Counterexample (\(x : [4]) -> [0 .. 14] @ x == x) 0xf ~> ERROR invalid sequence index: 15 at safety.icry:4:20--4:34 +-- Backtrace -- +(Cryptol::@) called at safety.icry:4:20--4:34 +(Cryptol::==) called at safety.icry:4:20--4:34 +::it called at :1:1--1:1 Counterexample (\y -> (10 : Integer) / y) 0 ~> ERROR division by 0 at safety.icry:5:14--5:30 +-- Backtrace -- +(Cryptol::/) called at safety.icry:5:14--5:30 +::it called at :1:1--1:1 Safe Safe Safe From fe7c458b7ea32e0d32a0a5942415c6975358d921 Mon Sep 17 00:00:00 2001 From: Rob Dockins Date: Sun, 6 Dec 2020 18:41:41 -0800 Subject: [PATCH 15/27] Remove the `Range` argument from most backend functions and primitives. We rely on the tracked call stack information instead. --- src/Cryptol/Backend.hs | 54 ++-- src/Cryptol/Backend/Concrete.hs | 59 ++--- src/Cryptol/Backend/Monad.hs | 51 ++-- src/Cryptol/Backend/SBV.hs | 66 +++-- src/Cryptol/Backend/What4.hs | 105 ++++---- src/Cryptol/Eval.hs | 48 ++-- src/Cryptol/Eval/Concrete.hs | 106 ++++---- src/Cryptol/Eval/Env.hs | 2 +- src/Cryptol/Eval/Generic.hs | 451 +++++++++++++++----------------- src/Cryptol/Eval/Prims.hs | 5 +- src/Cryptol/Eval/SBV.hs | 69 +++-- src/Cryptol/Eval/Value.hs | 21 +- src/Cryptol/Eval/What4.hs | 85 +++--- 13 files changed, 511 insertions(+), 611 deletions(-) diff --git a/src/Cryptol/Backend.hs b/src/Cryptol/Backend.hs index cdb6415b4..dddecfad2 100644 --- a/src/Cryptol/Backend.hs +++ b/src/Cryptol/Backend.hs @@ -37,26 +37,26 @@ import Data.Ratio ( (%), numerator, denominator ) import Cryptol.Backend.FloatHelpers (BF) import Cryptol.Backend.Monad ( PPOpts(..), EvalError(..), CallStack, pushCallFrame ) -import Cryptol.ModuleSystem.Name(Name,nameLoc) +import Cryptol.ModuleSystem.Name(Name) import Cryptol.Parser.Position import Cryptol.Utils.PP -invalidIndex :: Backend sym => sym -> Range -> Integer -> SEval sym a -invalidIndex sym rng i = raiseError sym rng (InvalidIndex (Just i)) +invalidIndex :: Backend sym => sym -> Integer -> SEval sym a +invalidIndex sym i = raiseError sym (InvalidIndex (Just i)) -cryUserError :: Backend sym => sym -> Range -> String -> SEval sym a -cryUserError sym rng msg = raiseError sym rng (UserError msg) +cryUserError :: Backend sym => sym -> String -> SEval sym a +cryUserError sym msg = raiseError sym (UserError msg) cryNoPrimError :: Backend sym => sym -> Name -> SEval sym a -cryNoPrimError sym nm = raiseError sym (nameLoc nm) (NoPrim nm) +cryNoPrimError sym nm = raiseError sym (NoPrim nm) {-# INLINE sDelay #-} -- | Delay the given evaluation computation, returning a thunk -- which will run the computation when forced. Raise a loop -- error if the resulting thunk is forced during its own evaluation. -sDelay :: Backend sym => sym -> Range -> SEval sym a -> SEval sym (SEval sym a) -sDelay sym rng m = sDelayFill sym m Nothing "" rng +sDelay :: Backend sym => sym -> SEval sym a -> SEval sym (SEval sym a) +sDelay sym m = sDelayFill sym m Nothing "" -- | Representation of rational numbers. -- Invariant: denominator is not 0 @@ -69,21 +69,21 @@ data SRational sym = intToRational :: Backend sym => sym -> SInteger sym -> SEval sym (SRational sym) intToRational sym x = SRational x <$> (integerLit sym 1) -ratio :: Backend sym => sym -> Range -> SInteger sym -> SInteger sym -> SEval sym (SRational sym) -ratio sym rng n d = +ratio :: Backend sym => sym -> SInteger sym -> SInteger sym -> SEval sym (SRational sym) +ratio sym n d = do pz <- bitComplement sym =<< intEq sym d =<< integerLit sym 0 - assertSideCondition sym pz rng DivideByZero + assertSideCondition sym pz DivideByZero pure (SRational n d) -rationalRecip :: Backend sym => sym -> Range -> SRational sym -> SEval sym (SRational sym) -rationalRecip sym rng (SRational a b) = ratio sym rng b a +rationalRecip :: Backend sym => sym -> SRational sym -> SEval sym (SRational sym) +rationalRecip sym (SRational a b) = ratio sym b a -rationalDivide :: Backend sym => sym -> Range -> SRational sym -> SRational sym -> SEval sym (SRational sym) -rationalDivide sym rng x y = rationalMul sym x =<< rationalRecip sym rng y +rationalDivide :: Backend sym => sym -> SRational sym -> SRational sym -> SEval sym (SRational sym) +rationalDivide sym x y = rationalMul sym x =<< rationalRecip sym y rationalFloor :: Backend sym => sym -> SRational sym -> SEval sym (SInteger sym) -- NB, relies on integer division being round-to-negative-inf division -rationalFloor sym (SRational n d) = intDiv sym emptyRange n d +rationalFloor sym (SRational n d) = intDiv sym n d rationalCeiling :: Backend sym => sym -> SRational sym -> SEval sym (SInteger sym) rationalCeiling sym r = intNegate sym =<< rationalFloor sym =<< rationalNegate sym r @@ -117,7 +117,7 @@ rationalRoundToEven sym r = where isEven x = - do parity <- intMod sym emptyRange x =<< integerLit sym 2 + do parity <- intMod sym x =<< integerLit sym 2 intEq sym parity =<< integerLit sym 0 ite x t e = @@ -225,18 +225,18 @@ class MonadIO (SEval sym) => Backend sym where -- after the fact. A preallocated thunk is returned, along with an operation to -- fill the thunk with the associated computation. -- This is used to implement recursive declaration groups. - sDeclareHole :: sym -> String -> Range -> SEval sym (SEval sym a, SEval sym a -> SEval sym ()) + sDeclareHole :: sym -> String -> SEval sym (SEval sym a, SEval sym a -> SEval sym ()) -- | Delay the given evaluation computation, returning a thunk -- which will run the computation when forced. Run the 'retry' -- computation instead if the resulting thunk is forced during -- its own evaluation. - sDelayFill :: sym -> SEval sym a -> Maybe (SEval sym a) -> String -> Range -> SEval sym (SEval sym a) + sDelayFill :: sym -> SEval sym a -> Maybe (SEval sym a) -> String -> SEval sym (SEval sym a) -- | Begin evaluating the given computation eagerly in a separate thread -- and return a thunk which will await the completion of the given computation -- when forced. - sSpark :: sym -> Range -> SEval sym a -> SEval sym (SEval sym a) + sSpark :: sym -> SEval sym a -> SEval sym (SEval sym a) sPushFrame :: sym -> Name -> Range -> SEval sym a -> SEval sym a sPushFrame sym nm rng m = sModifyCallStack sym (pushCallFrame nm rng) m @@ -256,10 +256,10 @@ class MonadIO (SEval sym) => Backend sym where -- | Assert that a condition must hold, and indicate what sort of -- error is indicated if the condition fails. - assertSideCondition :: sym -> SBit sym -> Range -> EvalError -> SEval sym () + assertSideCondition :: sym -> SBit sym -> EvalError -> SEval sym () -- | Indiciate that an error condition exists - raiseError :: sym -> Range -> EvalError -> SEval sym a + raiseError :: sym -> EvalError -> SEval sym a -- ==== Pretty printing ==== -- | Pretty-print an individual bit @@ -478,7 +478,6 @@ class MonadIO (SEval sym) => Backend sym where -- call with a second argument concretely equal to 0. wordDiv :: sym -> - Range -> SWord sym -> SWord sym -> SEval sym (SWord sym) @@ -488,7 +487,6 @@ class MonadIO (SEval sym) => Backend sym where -- call with a second argument concretely equal to 0. wordMod :: sym -> - Range -> SWord sym -> SWord sym -> SEval sym (SWord sym) @@ -498,7 +496,6 @@ class MonadIO (SEval sym) => Backend sym where -- call with a second argument concretely equal to 0. wordSignedDiv :: sym -> - Range -> SWord sym -> SWord sym -> SEval sym (SWord sym) @@ -508,7 +505,6 @@ class MonadIO (SEval sym) => Backend sym where -- call with a second argument concretely equal to 0. wordSignedMod :: sym -> - Range -> SWord sym -> SWord sym -> SEval sym (SWord sym) @@ -593,7 +589,6 @@ class MonadIO (SEval sym) => Backend sym where -- Same semantics as Haskell's @div@ operation. intDiv :: sym -> - Range -> SInteger sym -> SInteger sym -> SEval sym (SInteger sym) @@ -603,7 +598,6 @@ class MonadIO (SEval sym) => Backend sym where -- Same semantics as Haskell's @mod@ operation. intMod :: sym -> - Range -> SInteger sym -> SInteger sym -> SEval sym (SInteger sym) @@ -690,7 +684,6 @@ class MonadIO (SEval sym) => Backend sym where -- PRECONDITION: the modulus is a prime znRecip :: sym -> - Range -> Integer {- ^ modulus -} -> SInteger sym -> SEval sym (SInteger sym) @@ -708,13 +701,11 @@ class MonadIO (SEval sym) => Backend sym where fpToInteger :: sym -> String {- ^ Name of the function for error reporting -} -> - Range -> SWord sym {-^ Rounding mode -} -> SFloat sym -> SEval sym (SInteger sym) fpFromInteger :: sym -> - Range -> Integer {- exp width -} -> Integer {- prec width -} -> SWord sym {- ^ rounding mode -} -> @@ -723,7 +714,6 @@ class MonadIO (SEval sym) => Backend sym where type FPArith2 sym = sym -> - Range -> SWord sym -> SFloat sym -> SFloat sym -> diff --git a/src/Cryptol/Backend/Concrete.hs b/src/Cryptol/Backend/Concrete.hs index c9a0e16eb..b1ae62e67 100644 --- a/src/Cryptol/Backend/Concrete.hs +++ b/src/Cryptol/Backend/Concrete.hs @@ -45,7 +45,6 @@ import qualified Cryptol.Backend.Arch as Arch import qualified Cryptol.Backend.FloatHelpers as FP import Cryptol.Backend import Cryptol.Backend.Monad -import Cryptol.Parser.Position import Cryptol.TypeCheck.Solver.InfNat (genLog) import Cryptol.Utils.Panic (panic) import Cryptol.Utils.PP @@ -137,12 +136,12 @@ instance Backend Concrete where type SFloat Concrete = FP.BF type SEval Concrete = Eval - raiseError _ rng err = + raiseError _ err = do stk <- getCallStack - io (X.throwIO (EvalErrorEx rng stk err)) + io (X.throwIO (EvalErrorEx stk err)) - assertSideCondition _ True _ _ = return () - assertSideCondition sym False rng err = raiseError sym rng err + assertSideCondition _ True _ = return () + assertSideCondition sym False err = raiseError sym err wordLen _ (BV w _) = w wordAsChar _ (BV _ x) = Just $! integerToChar x @@ -261,33 +260,33 @@ instance Backend Concrete where | i == j = pure $! mkBv i (x*y) | otherwise = panic "Attempt to multiply words of different sizes: wordMult" [show i, show j] - wordDiv sym rng (BV i x) (BV j y) + wordDiv sym (BV i x) (BV j y) | i == 0 && j == 0 = pure $! mkBv 0 0 | i == j = - do assertSideCondition sym (y /= 0) rng DivideByZero + do assertSideCondition sym (y /= 0) DivideByZero pure $! mkBv i (x `div` y) | otherwise = panic "Attempt to divide words of different sizes: wordDiv" [show i, show j] - wordMod sym rng (BV i x) (BV j y) + wordMod sym (BV i x) (BV j y) | i == 0 && j == 0 = pure $! mkBv 0 0 | i == j = - do assertSideCondition sym (y /= 0) rng DivideByZero + do assertSideCondition sym (y /= 0) DivideByZero pure $! mkBv i (x `mod` y) | otherwise = panic "Attempt to mod words of different sizes: wordMod" [show i, show j] - wordSignedDiv sym rng (BV i x) (BV j y) + wordSignedDiv sym (BV i x) (BV j y) | i == 0 && j == 0 = pure $! mkBv 0 0 | i == j = - do assertSideCondition sym (y /= 0) rng DivideByZero + do assertSideCondition sym (y /= 0) DivideByZero let sx = signedValue i x sy = signedValue i y pure $! mkBv i (sx `quot` sy) | otherwise = panic "Attempt to divide words of different sizes: wordSignedDiv" [show i, show j] - wordSignedMod sym rng (BV i x) (BV j y) + wordSignedMod sym (BV i x) (BV j y) | i == 0 && j == 0 = pure $! mkBv 0 0 | i == j = - do assertSideCondition sym (y /= 0) rng DivideByZero + do assertSideCondition sym (y /= 0) DivideByZero let sx = signedValue i x sy = signedValue i y pure $! mkBv i (sx `rem` sy) @@ -303,11 +302,11 @@ instance Backend Concrete where intMinus _ x y = pure $! x - y intNegate _ x = pure $! negate x intMult _ x y = pure $! x * y - intDiv sym rng x y = - do assertSideCondition sym (y /= 0) rng DivideByZero + intDiv sym x y = + do assertSideCondition sym (y /= 0) DivideByZero pure $! x `div` y - intMod sym rng x y = - do assertSideCondition sym (y /= 0) rng DivideByZero + intMod sym x y = + do assertSideCondition sym (y /= 0) DivideByZero pure $! x `mod` y intToZn _ 0 _ = evalPanic "intToZn" ["0 modulus not allowed"] @@ -321,8 +320,8 @@ instance Backend Concrete where -- NB: under the precondition that `m` is prime, -- the only values for which no inverse exists are -- congruent to 0 modulo m. - znRecip sym rng m x - | r == 0 = raiseError sym rng DivideByZero + znRecip sym m x + | r == 0 = raiseError sym DivideByZero | otherwise = pure r where r = Integer.recipModInteger x m @@ -346,8 +345,8 @@ instance Backend Concrete where fpMult = fpBinArith FP.bfMul fpDiv = fpBinArith FP.bfDiv fpNeg _ x = pure x { FP.bfValue = FP.bfNeg (FP.bfValue x) } - fpFromInteger sym rng e p r x = - do opts <- FP.fpOpts e p <$> fpRoundMode sym rng r + fpFromInteger sym e p r x = + do opts <- FP.fpOpts e p <$> fpRoundMode sym r pure FP.BF { FP.bfExpWidth = e , FP.bfPrecWidth = p , FP.bfValue = FP.fpCheckStatus $ @@ -369,34 +368,32 @@ liftBinIntMod op m x y fpBinArith :: (FP.BFOpts -> FP.BigFloat -> FP.BigFloat -> (FP.BigFloat, FP.Status)) -> Concrete -> - Range -> SWord Concrete {- ^ Rouding mode -} -> SFloat Concrete -> SFloat Concrete -> SEval Concrete (SFloat Concrete) -fpBinArith fun = \sym rng r x y -> +fpBinArith fun = \sym r x y -> do opts <- FP.fpOpts (FP.bfExpWidth x) (FP.bfPrecWidth x) - <$> fpRoundMode sym rng r + <$> fpRoundMode sym r pure x { FP.bfValue = FP.fpCheckStatus (fun opts (FP.bfValue x) (FP.bfValue y)) } fpCvtToInteger :: Concrete -> String -> - Range -> SWord Concrete {- ^ Rounding mode -} -> SFloat Concrete -> SEval Concrete (SInteger Concrete) -fpCvtToInteger sym fun rng rnd flt = - do mode <- fpRoundMode sym rng rnd +fpCvtToInteger sym fun rnd flt = + do mode <- fpRoundMode sym rnd case FP.floatToInteger fun mode flt of Right i -> pure i - Left err -> raiseError sym rng err + Left err -> raiseError sym err -fpRoundMode :: Concrete -> Range -> SWord Concrete -> SEval Concrete FP.RoundMode -fpRoundMode sym rng w = +fpRoundMode :: Concrete -> SWord Concrete -> SEval Concrete FP.RoundMode +fpRoundMode sym w = case FP.fpRound (bvVal w) of - Left err -> raiseError sym rng err + Left err -> raiseError sym err Right a -> pure a diff --git a/src/Cryptol/Backend/Monad.hs b/src/Cryptol/Backend/Monad.hs index daa16109d..8a587f1a3 100644 --- a/src/Cryptol/Backend/Monad.hs +++ b/src/Cryptol/Backend/Monad.hs @@ -170,13 +170,13 @@ data Eval a data ThunkState a = Void !String -- ^ This thunk has not yet been initialized - | Unforced !(IO a) !(Maybe (IO a)) String Range CallStack + | Unforced !(IO a) !(Maybe (IO a)) String CallStack -- ^ This thunk has not yet been forced. We keep track of the "main" -- computation to run and a "backup" computation to run if we -- detect a tight loop when evaluating the first one. -- The final two arguments are used to throw a loop exception -- if the backup computation also causes a tight loop. - | UnderEvaluation !ThreadId !(Maybe (IO a)) String Range CallStack + | UnderEvaluation !ThreadId !(Maybe (IO a)) String CallStack -- ^ This thunk is currently being evaluated by the thread with the given -- thread ID. We track the "backup" computation to run if we detect -- a tight loop evaluating this thunk. If the thunk is being evaluated @@ -210,29 +210,27 @@ delayFill :: Eval a {- ^ Computation to delay -} -> Maybe (Eval a) {- ^ Optional backup computation to run if a tight loop is detected -} -> String {- ^ message for the <> exceprion if a tight loop is detecrted -} -> - Range {- ^ location information for the <> exceprion if a tight loop is detecrted -} -> Eval (Eval a) -delayFill e@(Ready _) _ _ _ = return e -delayFill e@(Thunk _) _ _ _ = return e -delayFill (Eval x) backup msg rng = - Eval (\stk -> Thunk <$> newTVarIO (Unforced (x stk) (runEval stk <$> backup) msg rng stk)) +delayFill e@(Ready _) _ _ = return e +delayFill e@(Thunk _) _ _ = return e +delayFill (Eval x) backup msg = + Eval (\stk -> Thunk <$> newTVarIO (Unforced (x stk) (runEval stk <$> backup) msg stk)) -- | Begin executing the given operation in a separate thread, -- returning a thunk which will await the completion of -- the computation when forced. evalSpark :: - Range -> Eval a -> Eval (Eval a) -- Ready computations need no additional evaluation. -evalSpark _ e@(Ready _) = return e +evalSpark e@(Ready _) = return e -- A thunked computation might already have -- been forced. If so, return the result. Otherwise, -- fork a thread to force this computation and return -- the thunk. -evalSpark _ (Thunk tv) = Eval $ \_stk -> +evalSpark (Thunk tv) = Eval $ \_stk -> readTVarIO tv >>= \case Forced x -> return (Ready x) ForcedErr ex -> return (Eval $ \_ -> (X.throwIO ex)) @@ -242,8 +240,8 @@ evalSpark _ (Thunk tv) = Eval $ \_stk -> -- If the computation is nontrivial but not already a thunk, -- create a thunk and fork a thread to force it. -evalSpark rng (Eval x) = Eval $ \stk -> - do tv <- newTVarIO (Unforced (x stk) Nothing "" rng stk) +evalSpark (Eval x) = Eval $ \stk -> + do tv <- newTVarIO (Unforced (x stk) Nothing "" stk) _ <- forkIO (sparkThunk tv) return (Thunk tv) @@ -261,13 +259,13 @@ sparkThunk tv = do st <- readTVar tv case st of Void _ -> retry - Unforced _ backup msg rng stk -> writeTVar tv (UnderEvaluation tid backup msg rng stk) + Unforced _ backup msg stk -> writeTVar tv (UnderEvaluation tid backup msg stk) _ -> return () return st -- If we successfully claimed the thunk to work on, run the computation and -- update the thunk state with the result. case st of - Unforced work _ _ _ _ -> + Unforced work _ _ _ -> X.try work >>= \case Left err -> atomically (writeTVar tv (ForcedErr err)) Right a -> atomically (writeTVar tv (Forced a)) @@ -280,12 +278,11 @@ sparkThunk tv = -- This is used to implement recursive declaration groups. blackhole :: String {- ^ A name to associate with this thunk. -} -> - Range -> Eval (Eval a, Eval a -> Eval ()) -blackhole msg rng = Eval $ \stk -> +blackhole msg = Eval $ \stk -> do tv <- newTVarIO (Void msg) let set (Ready x) = io $ atomically (writeTVar tv (Forced x)) - set m = io $ atomically (writeTVar tv (Unforced (runEval stk m) Nothing msg rng stk)) + set m = io $ atomically (writeTVar tv (Unforced (runEval stk m) Nothing msg stk)) return (Thunk tv, set) -- | Force a thunk to get the result. @@ -304,18 +301,18 @@ unDelay tv = case res of -- In this case, we claim the thunk. Update the state to indicate -- that we are working on it. - Unforced _ backup msg rng stk -> writeTVar tv (UnderEvaluation tid backup msg rng stk) + Unforced _ backup msg stk -> writeTVar tv (UnderEvaluation tid backup msg stk) -- In this case, the thunk is already being evaluated. If it is -- under evaluation by this thread, we have to run the backup computation, -- and "consume" it by updating the backup computation to one that throws -- a loop error. If some other thread is evaluating, reset the -- transaction to await completion of the thunk. - UnderEvaluation t backup msg rng stk + UnderEvaluation t backup msg stk | tid == t -> case backup of - Just _ -> writeTVar tv (UnderEvaluation tid Nothing msg rng stk) - Nothing -> writeTVar tv (ForcedErr (EvalErrorEx rng stk (LoopError msg))) + Just _ -> writeTVar tv (UnderEvaluation tid Nothing msg stk) + Nothing -> writeTVar tv (ForcedErr (EvalErrorEx stk (LoopError msg))) | otherwise -> retry -- wait, if some other thread is evaualting _ -> return () @@ -337,9 +334,9 @@ unDelay tv = Forced x -> pure x ForcedErr e -> X.throwIO e -- this thread was already evaluating this thunk - UnderEvaluation _ (Just backup) _ _ _ -> doWork backup - UnderEvaluation _ Nothing msg rng stk -> X.throwIO (EvalErrorEx rng stk (LoopError msg)) - Unforced work _ _ _ _ -> doWork work + UnderEvaluation _ (Just backup) _ _ -> doWork backup + UnderEvaluation _ Nothing msg stk -> X.throwIO (EvalErrorEx stk (LoopError msg)) + Unforced work _ _ _ -> doWork work -- | Get the current call stack getCallStack :: Eval CallStack @@ -439,13 +436,11 @@ instance Show EvalError where show = show . pp data EvalErrorEx = - EvalErrorEx Range CallStack EvalError + EvalErrorEx CallStack EvalError deriving Typeable instance PP EvalErrorEx where - ppPrec _ (EvalErrorEx rng stk ex) - | rng == emptyRange = vcat ([ pp ex ] ++ callStk) - | otherwise = vcat ([ pp ex, text "at" <+> pp rng] ++ callStk) + ppPrec _ (EvalErrorEx stk ex) = vcat ([ pp ex ] ++ callStk) where callStk | Seq.null stk = [] diff --git a/src/Cryptol/Backend/SBV.hs b/src/Cryptol/Backend/SBV.hs index 0d1b3f1f7..78c184374 100644 --- a/src/Cryptol/Backend/SBV.hs +++ b/src/Cryptol/Backend/SBV.hs @@ -51,7 +51,6 @@ import Cryptol.Backend.Monad , modifyCallStack, getCallStack ) -import Cryptol.Parser.Position (Range) import Cryptol.Utils.Panic (panic) import Cryptol.Utils.PP @@ -156,27 +155,27 @@ instance Backend SBV where type SFloat SBV = () -- XXX: not implemented type SEval SBV = SBVEval - raiseError _ rng err = SBVEval $ + raiseError _ err = SBVEval $ do stk <- getCallStack - pure (SBVError (EvalErrorEx rng stk err)) + pure (SBVError (EvalErrorEx stk err)) - assertSideCondition sym cond rng err - | Just False <- svAsBool cond = raiseError sym rng err + assertSideCondition sym cond err + | Just False <- svAsBool cond = raiseError sym err | otherwise = SBVEval (pure (SBVResult cond ())) isReady _ (SBVEval (Ready _)) = True isReady _ _ = False - sDelayFill _ m retry msg rng = SBVEval $ - do m' <- delayFill (sbvEval m) (sbvEval <$> retry) msg rng + sDelayFill _ m retry msg = SBVEval $ + do m' <- delayFill (sbvEval m) (sbvEval <$> retry) msg pure (pure (SBVEval m')) - sSpark _ rng m = SBVEval $ - do m' <- evalSpark rng (sbvEval m) + sSpark _ m = SBVEval $ + do m' <- evalSpark (sbvEval m) pure (pure (SBVEval m')) - sDeclareHole _ msg rng = SBVEval $ - do (hole, fill) <- blackhole msg rng + sDeclareHole _ msg = SBVEval $ + do (hole, fill) <- blackhole msg pure (pure (SBVEval hole, \m -> SBVEval (fmap pure $ fill (sbvEval m)))) sModifyCallStack _ f (SBVEval m) = SBVEval $ @@ -274,24 +273,24 @@ instance Backend SBV where wordMult _ a b = pure $! svTimes a b wordNegate _ a = pure $! svUNeg a - wordDiv sym rng a b = + wordDiv sym a b = do let z = literalSWord (intSizeOf b) 0 - assertSideCondition sym (svNot (svEqual b z)) rng DivideByZero + assertSideCondition sym (svNot (svEqual b z)) DivideByZero pure $! svQuot a b - wordMod sym rng a b = + wordMod sym a b = do let z = literalSWord (intSizeOf b) 0 - assertSideCondition sym (svNot (svEqual b z)) rng DivideByZero + assertSideCondition sym (svNot (svEqual b z)) DivideByZero pure $! svRem a b - wordSignedDiv sym rng a b = + wordSignedDiv sym a b = do let z = literalSWord (intSizeOf b) 0 - assertSideCondition sym (svNot (svEqual b z)) rng DivideByZero + assertSideCondition sym (svNot (svEqual b z)) DivideByZero pure $! signedQuot a b - wordSignedMod sym rng a b = + wordSignedMod sym a b = do let z = literalSWord (intSizeOf b) 0 - assertSideCondition sym (svNot (svEqual b z)) rng DivideByZero + assertSideCondition sym (svNot (svEqual b z)) DivideByZero pure $! signedRem a b wordLg2 _ a = sLg2 a @@ -308,14 +307,14 @@ instance Backend SBV where intMult _ a b = pure $! svTimes a b intNegate _ a = pure $! SBV.svUNeg a - intDiv sym rng a b = + intDiv sym a b = do let z = svInteger KUnbounded 0 - assertSideCondition sym (svNot (svEqual b z)) rng DivideByZero + assertSideCondition sym (svNot (svEqual b z)) DivideByZero let p = svLessThan z b pure $! svSymbolicMerge KUnbounded True p (svQuot a b) (svQuot (svUNeg a) (svUNeg b)) - intMod sym rng a b = + intMod sym a b = do let z = svInteger KUnbounded 0 - assertSideCondition sym (svNot (svEqual b z)) rng DivideByZero + assertSideCondition sym (svNot (svEqual b z)) DivideByZero let p = svLessThan z b pure $! svSymbolicMerge KUnbounded True p (svRem a b) (svUNeg (svRem (svUNeg a) (svUNeg b))) @@ -343,13 +342,13 @@ instance Backend SBV where fpEq _ _ _ = unsupported "fpEq" fpLessThan _ _ _ = unsupported "fpLessThan" fpGreaterThan _ _ _ = unsupported "fpGreaterThan" - fpPlus _ _ _ _ _ = unsupported "fpPlus" - fpMinus _ _ _ _ _ = unsupported "fpMinus" - fpMult _ _ _ _ _ = unsupported "fpMult" - fpDiv _ _ _ _ _ = unsupported "fpDiv" + fpPlus _ _ _ _ = unsupported "fpPlus" + fpMinus _ _ _ _ = unsupported "fpMinus" + fpMult _ _ _ _ = unsupported "fpMult" + fpDiv _ _ _ _ = unsupported "fpDiv" fpNeg _ _ = unsupported "fpNeg" - fpFromInteger _ _ _ _ _ _ = unsupported "fpFromInteger" - fpToInteger _ _ _ _ _ = unsupported "fpToInteger" + fpFromInteger _ _ _ _ _ = unsupported "fpFromInteger" + fpToInteger _ _ _ _ = unsupported "fpToInteger" unsupported :: String -> SEval SBV a unsupported x = liftIO (X.throw (UnsupportedSymbolicOp x)) @@ -408,16 +407,15 @@ sModMult sym modulus x y = -- that the modulus is prime and the input is nonzero. sModRecip :: SBV -> - Range -> Integer {- ^ modulus: must be prime -} -> SInteger SBV -> SEval SBV (SInteger SBV) -sModRecip _sym _ 0 _ = panic "sModRecip" ["0 modulus not allowed"] -sModRecip sym rng m x +sModRecip _sym 0 _ = panic "sModRecip" ["0 modulus not allowed"] +sModRecip sym m x -- If the input is concrete, evaluate the answer | Just xi <- svAsInteger x = let r = Integer.recipModInteger xi m - in if r == 0 then raiseError sym rng DivideByZero else integerLit sym r + in if r == 0 then raiseError sym DivideByZero else integerLit sym r -- If the input is symbolic, create a new symbolic constant -- and assert that it is the desired multiplicitive inverse. @@ -425,7 +423,7 @@ sModRecip sym rng m x -- the modulus is prime, and as long as the input is nonzero. | otherwise = do divZero <- svDivisible sym m x - assertSideCondition sym (svNot divZero) rng DivideByZero + assertSideCondition sym (svNot divZero) DivideByZero z <- liftIO (freshSInteger_ sym) let xz = svTimes x z diff --git a/src/Cryptol/Backend/What4.hs b/src/Cryptol/Backend/What4.hs index 02added35..1c30726ef 100644 --- a/src/Cryptol/Backend/What4.hs +++ b/src/Cryptol/Backend/What4.hs @@ -43,7 +43,6 @@ import Cryptol.Backend.Monad , Unsupported(..), delayFill, blackhole, evalSpark , modifyCallStack, getCallStack ) -import Cryptol.Parser.Position import Cryptol.Utils.Panic import Cryptol.Utils.PP @@ -187,24 +186,24 @@ addSafety :: W4.IsSymExprBuilder sym => W4.Pred sym -> W4Eval sym () addSafety p = W4Eval (pure (W4Result p ())) -- | A fully undefined symbolic value -evalError :: W4.IsSymExprBuilder sym => Range -> EvalError -> W4Eval sym a -evalError rng err = W4Eval $ W4Conn $ \_sym -> +evalError :: W4.IsSymExprBuilder sym => EvalError -> W4Eval sym a +evalError err = W4Eval $ W4Conn $ \_sym -> do stk <- getCallStack - pure (W4Error (EvalErrorEx rng stk err)) + pure (W4Error (EvalErrorEx stk err)) -------------------------------------------------------------------------------- -assertBVDivisor :: W4.IsSymExprBuilder sym => What4 sym -> Range -> SW.SWord sym -> W4Eval sym () -assertBVDivisor sym rng x = +assertBVDivisor :: W4.IsSymExprBuilder sym => What4 sym -> SW.SWord sym -> W4Eval sym () +assertBVDivisor sym x = do p <- liftIO (SW.bvIsNonzero (w4 sym) x) - assertSideCondition sym p rng DivideByZero + assertSideCondition sym p DivideByZero assertIntDivisor :: - W4.IsSymExprBuilder sym => What4 sym -> Range -> W4.SymInteger sym -> W4Eval sym () -assertIntDivisor sym rng x = + W4.IsSymExprBuilder sym => What4 sym -> W4.SymInteger sym -> W4Eval sym () +assertIntDivisor sym x = do p <- liftIO (W4.notPred (w4 sym) =<< W4.intEq (w4 sym) x =<< W4.intLit (w4 sym) 0) - assertSideCondition sym p rng DivideByZero + assertSideCondition sym p DivideByZero instance W4.IsSymExprBuilder sym => Backend (What4 sym) where type SBit (What4 sym) = W4.Pred sym @@ -215,8 +214,8 @@ instance W4.IsSymExprBuilder sym => Backend (What4 sym) where raiseError _ = evalError - assertSideCondition _ cond rng err - | Just False <- W4.asConstantPred cond = evalError rng err + assertSideCondition _ cond err + | Just False <- W4.asConstantPred cond = evalError err | otherwise = addSafety cond isReady sym m = @@ -224,24 +223,24 @@ instance W4.IsSymExprBuilder sym => Backend (What4 sym) where Ready _ -> True _ -> False - sDelayFill _ m retry msg rng = + sDelayFill _ m retry msg = total do sym <- getSym - doEval (w4Thunk <$> delayFill (w4Eval m sym) (w4Eval <$> retry <*> pure sym) msg rng) + doEval (w4Thunk <$> delayFill (w4Eval m sym) (w4Eval <$> retry <*> pure sym) msg) - sSpark _ rng m = + sSpark _ m = total do sym <- getSym - doEval (w4Thunk <$> evalSpark rng (w4Eval m sym)) + doEval (w4Thunk <$> evalSpark (w4Eval m sym)) sModifyCallStack _ f (W4Eval (W4Conn m)) = W4Eval (W4Conn \sym -> modifyCallStack f (m sym)) sGetCallStack _ = total (doEval getCallStack) - sDeclareHole _ msg rng = + sDeclareHole _ msg = total - do (hole, fill) <- doEval (blackhole msg rng) + do (hole, fill) <- doEval (blackhole msg) pure ( w4Thunk hole , \m -> total do sym <- getSym @@ -361,17 +360,17 @@ instance W4.IsSymExprBuilder sym => Backend (What4 sym) where wordNegate sym x = liftIO (SW.bvNeg (w4 sym) x) wordLg2 sym x = sLg2 (w4 sym) x - wordDiv sym rng x y = - do assertBVDivisor sym rng y + wordDiv sym x y = + do assertBVDivisor sym y liftIO (SW.bvUDiv (w4 sym) x y) - wordMod sym rng x y = - do assertBVDivisor sym rng y + wordMod sym x y = + do assertBVDivisor sym y liftIO (SW.bvURem (w4 sym) x y) - wordSignedDiv sym rng x y = - do assertBVDivisor sym rng y + wordSignedDiv sym x y = + do assertBVDivisor sym y liftIO (SW.bvSDiv (w4 sym) x y) - wordSignedMod sym rng x y = - do assertBVDivisor sym rng y + wordSignedMod sym x y = + do assertBVDivisor sym y liftIO (SW.bvSRem (w4 sym) x y) wordToInt sym x = liftIO (SW.bvToInteger (w4 sym) x) @@ -385,8 +384,8 @@ instance W4.IsSymExprBuilder sym => Backend (What4 sym) where -- NB: What4's division operation provides SMTLib's euclidean division, -- which doesn't match the round-to-neg-infinity semantics of Cryptol, -- so we have to do some work to get the desired semantics. - intDiv sym rng x y = - do assertIntDivisor sym rng y + intDiv sym x y = + do assertIntDivisor sym y liftIO $ do neg <- liftIO (W4.intLt (w4 sym) y =<< W4.intLit (w4 sym) 0) case W4.asConstantPred neg of @@ -405,8 +404,8 @@ instance W4.IsSymExprBuilder sym => Backend (What4 sym) where -- NB: What4's division operation provides SMTLib's euclidean division, -- which doesn't match the round-to-neg-infinity semantics of Cryptol, -- so we have to do some work to get the desired semantics. - intMod sym rng x y = - do assertIntDivisor sym rng y + intMod sym x y = + do assertIntDivisor sym y liftIO $ do neg <- liftIO (W4.intLt (w4 sym) y =<< W4.intLit (w4 sym) 0) case W4.asConstantPred neg of @@ -467,8 +466,8 @@ instance W4.IsSymExprBuilder sym => Backend (What4 sym) where fpNeg sym x = liftIO $ FP.fpNeg (w4 sym) x - fpFromInteger sym rng e p r x = - do rm <- fpRoundingMode sym rng r + fpFromInteger sym e p r x = + do rm <- fpRoundingMode sym r liftIO $ FP.fpFromInteger (w4 sym) e p rm x fpToInteger = fpCvtToInteger @@ -573,8 +572,8 @@ w4bvRor sym x y = liftIO $ SW.bvRor sym x y fpRoundingMode :: W4.IsSymExprBuilder sym => - What4 sym -> Range -> SWord (What4 sym) -> SEval (What4 sym) W4.RoundingMode -fpRoundingMode sym rng v = + What4 sym -> SWord (What4 sym) -> SEval (What4 sym) W4.RoundingMode +fpRoundingMode sym v = case wordAsLit sym v of Just (_w,i) -> case i of @@ -583,33 +582,32 @@ fpRoundingMode sym rng v = 2 -> pure W4.RTP 3 -> pure W4.RTN 4 -> pure W4.RTZ - x -> raiseError sym rng (BadRoundingMode x) + x -> raiseError sym (BadRoundingMode x) _ -> liftIO $ X.throwIO $ UnsupportedSymbolicOp "rounding mode" fpBinArith :: W4.IsSymExprBuilder sym => FP.SFloatBinArith sym -> What4 sym -> - Range -> SWord (What4 sym) -> SFloat (What4 sym) -> SFloat (What4 sym) -> SEval (What4 sym) (SFloat (What4 sym)) -fpBinArith fun = \sym rng r x y -> - do m <- fpRoundingMode sym rng r +fpBinArith fun = \sym r x y -> + do m <- fpRoundingMode sym r liftIO (fun (w4 sym) m x y) fpCvtToInteger :: (W4.IsSymExprBuilder sy, sym ~ What4 sy) => - sym -> String -> Range -> SWord sym -> SFloat sym -> SEval sym (SInteger sym) -fpCvtToInteger sym fun rng r x = + sym -> String -> SWord sym -> SFloat sym -> SEval sym (SInteger sym) +fpCvtToInteger sym fun r x = do grd <- liftIO do bad1 <- FP.fpIsInf (w4 sym) x bad2 <- FP.fpIsNaN (w4 sym) x W4.notPred (w4 sym) =<< W4.orPred (w4 sym) bad1 bad2 - assertSideCondition sym grd rng (BadValue fun) - rnd <- fpRoundingMode sym rng r + assertSideCondition sym grd (BadValue fun) + rnd <- fpRoundingMode sym r liftIO do y <- FP.fpToReal (w4 sym) x case rnd of @@ -622,23 +620,23 @@ fpCvtToInteger sym fun rng r x = fpCvtToRational :: (W4.IsSymExprBuilder sy, sym ~ What4 sy) => - sym -> Range -> SFloat sym -> SEval sym (SRational sym) -fpCvtToRational sym rng fp = + sym -> SFloat sym -> SEval sym (SRational sym) +fpCvtToRational sym fp = do grd <- liftIO do bad1 <- FP.fpIsInf (w4 sym) fp bad2 <- FP.fpIsNaN (w4 sym) fp W4.notPred (w4 sym) =<< W4.orPred (w4 sym) bad1 bad2 - assertSideCondition sym grd rng (BadValue "fpToRational") + assertSideCondition sym grd (BadValue "fpToRational") (rel,x,y) <- liftIO (FP.fpToRational (w4 sym) fp) addDefEqn sym =<< liftIO (W4.impliesPred (w4 sym) grd rel) - ratio sym rng x y + ratio sym x y fpCvtFromRational :: (W4.IsSymExprBuilder sy, sym ~ What4 sy) => - sym -> Range -> Integer -> Integer -> SWord sym -> + sym -> Integer -> Integer -> SWord sym -> SRational sym -> SEval sym (SFloat sym) -fpCvtFromRational sym rng e p r rat = - do rnd <- fpRoundingMode sym rng r +fpCvtFromRational sym e p r rat = + do rnd <- fpRoundingMode sym r liftIO (FP.fpFromRational (w4 sym) e p rnd (sNum rat) (sDenom rat)) -- Create a fresh constant and assert that it is the @@ -648,16 +646,15 @@ fpCvtFromRational sym rng e p r rat = sModRecip :: W4.IsSymExprBuilder sym => What4 sym -> - Range -> Integer -> W4.SymInteger sym -> W4Eval sym (W4.SymInteger sym) -sModRecip _sym _ 0 _ = panic "sModRecip" ["0 modulus not allowed"] -sModRecip sym rng m x +sModRecip _sym 0 _ = panic "sModRecip" ["0 modulus not allowed"] +sModRecip sym m x -- If the input is concrete, evaluate the answer | Just xi <- W4.asInteger x = let r = Integer.recipModInteger xi m - in if r == 0 then raiseError sym rng DivideByZero else integerLit sym r + in if r == 0 then raiseError sym DivideByZero else integerLit sym r -- If the input is symbolic, create a new symbolic constant -- and assert that it is the desired multiplicitive inverse. @@ -666,7 +663,7 @@ sModRecip sym rng m x | otherwise = do divZero <- liftIO (W4.intDivisible (w4 sym) x (fromInteger m)) ok <- liftIO (W4.notPred (w4 sym) divZero) - assertSideCondition sym ok rng DivideByZero + assertSideCondition sym ok DivideByZero z <- liftIO (W4.freshBoundedInt (w4 sym) W4.emptySymbol (Just 1) (Just (m-1))) xz <- liftIO (W4.intMul (w4 sym) x z) diff --git a/src/Cryptol/Eval.hs b/src/Cryptol/Eval.hs index 0a5ee2fd4..8932dd88d 100644 --- a/src/Cryptol/Eval.hs +++ b/src/Cryptol/Eval.hs @@ -123,10 +123,10 @@ evalExpr sym env expr = case expr of return $ VWord len $ case tryFromBits sym vs of Just w -> WordVal <$> w - Nothing -> do xs <- mapM (sDelay sym ?range) vs + Nothing -> do xs <- mapM (sDelay sym) vs return $ LargeBitsVal len $ finiteSeqMap xs | otherwise -> {-# SCC "evalExpr->EList" #-} do - xs <- mapM (sDelay sym ?range) vs + xs <- mapM (sDelay sym) vs return $ VSeq len $ finiteSeqMap xs where tyv = evalValType (envTypes env) ty @@ -134,11 +134,11 @@ evalExpr sym env expr = case expr of len = genericLength es ETuple es -> {-# SCC "evalExpr->ETuple" #-} do - xs <- mapM (sDelay sym ?range . eval) es + xs <- mapM (sDelay sym . eval) es return $ VTuple xs ERec fields -> {-# SCC "evalExpr->ERec" #-} do - xs <- traverse (sDelay sym ?range . eval) fields + xs <- traverse (sDelay sym . eval) fields return $ VRecord xs ESel e sel -> {-# SCC "evalExpr->ESel" #-} do @@ -349,10 +349,10 @@ fillHole sym env (nm, sch, _, fill) = do case lookupVar nm env of Just (Right v) | isValueType env sch -> fill =<< sDelayFill sym v - (Just (etaDelay sym (nameLoc nm) env sch v)) + (Just (etaDelay sym env sch v)) (show (ppLocName nm)) - (nameLoc nm) - | otherwise -> fill (etaDelay sym (nameLoc nm) env sch v) + + | otherwise -> fill (etaDelay sym env sch v) _ -> evalPanic "fillHole" ["Recursive definition not completed", show (ppLocName nm)] @@ -376,7 +376,6 @@ isValueType _ _ = False {-# SPECIALIZE etaWord :: Concrete -> - Range -> Integer -> SEval Concrete (GenValue Concrete) -> SEval Concrete (WordValue Concrete) @@ -386,19 +385,17 @@ isValueType _ _ = False etaWord :: Backend sym => sym -> - Range -> Integer -> SEval sym (GenValue sym) -> SEval sym (WordValue sym) -etaWord sym rng n val = do - w <- sDelay sym rng (fromWordVal "during eta-expansion" =<< val) +etaWord sym n val = do + w <- sDelay sym (fromWordVal "during eta-expansion" =<< val) xs <- memoMap $ IndexSeqMap $ \i -> - do w' <- w; VBit <$> indexWordValue sym rng w' i + do w' <- w; VBit <$> indexWordValue sym w' i pure $ LargeBitsVal n xs {-# SPECIALIZE etaDelay :: Concrete -> - Range -> GenEvalEnv Concrete -> Schema -> SEval Concrete (GenValue Concrete) -> @@ -414,12 +411,11 @@ etaWord sym rng n val = do etaDelay :: Backend sym => sym -> - Range -> GenEvalEnv sym -> Schema -> SEval sym (GenValue sym) -> SEval sym (GenValue sym) -etaDelay sym rng env0 Forall{ sVars = vs0, sType = tp0 } = goTpVars env0 vs0 +etaDelay sym env0 Forall{ sVars = vs0, sType = tp0 } = goTpVars env0 vs0 where goTpVars env [] val = go (evalValType (envTypes env) tp0) val goTpVars env (v:vs) val = @@ -483,26 +479,26 @@ etaDelay sym rng env0 Forall{ sVars = vs0, sType = tp0 } = goTpVars env0 vs0 TVArray{} -> v TVSeq n TVBit -> - do w <- sDelayFill sym (fromWordVal "during eta-expansion" =<< v) (Just (etaWord sym rng n v)) "" rng + do w <- sDelayFill sym (fromWordVal "during eta-expansion" =<< v) (Just (etaWord sym n v)) "" return $ VWord n w TVSeq n el -> - do x' <- sDelay sym rng (fromSeq "during eta-expansion" =<< v) + do x' <- sDelay sym (fromSeq "during eta-expansion" =<< v) return $ VSeq n $ IndexSeqMap $ \i -> do go el (flip lookupSeqMap i =<< x') TVStream el -> - do x' <- sDelay sym rng (fromSeq "during eta-expansion" =<< v) + do x' <- sDelay sym (fromSeq "during eta-expansion" =<< v) return $ VStream $ IndexSeqMap $ \i -> go el (flip lookupSeqMap i =<< x') TVFun _t1 t2 -> - do v' <- sDelay sym rng (fromVFun sym <$> v) + do v' <- sDelay sym (fromVFun sym <$> v) lam sym $ \a -> go t2 ( ($a) =<< v' ) TVTuple ts -> do let n = length ts - v' <- sDelay sym rng (fromVTuple <$> v) + v' <- sDelay sym (fromVTuple <$> v) return $ VTuple $ [ go t =<< (flip genericIndex i <$> v') | i <- [0..(n-1)] @@ -510,7 +506,7 @@ etaDelay sym rng env0 Forall{ sVars = vs0, sType = tp0 } = goTpVars env0 vs0 ] TVRec fs -> - do v' <- sDelay sym rng (fromVRecord <$> v) + do v' <- sDelay sym (fromVRecord <$> v) let err f = evalPanic "expected record value with field" [show f] let eta f t = go t =<< (fromMaybe (err f) . lookupField f <$> v') return $ VRecord (mapWithFieldName eta fs) @@ -533,7 +529,7 @@ declHole sym d = DPrim -> evalPanic "Unexpected primitive declaration in recursive group" [show (ppLocName nm)] DExpr _ -> do - (hole, fill) <- sDeclareHole sym msg (nameLoc nm) + (hole, fill) <- sDeclareHole sym msg return (nm, sch, hole, fill) where nm = dName d @@ -613,7 +609,7 @@ evalSel sym val sel = case sel of case v of VSeq _ vs -> lookupSeqMap vs (toInteger n) VStream vs -> lookupSeqMap vs (toInteger n) - VWord _ wv -> VBit <$> (flip (indexWordValue sym ?range) (toInteger n) =<< wv) + VWord _ wv -> VBit <$> (flip (indexWordValue sym) (toInteger n) =<< wv) _ -> do vdoc <- ppValue sym defaultPPOpts val evalPanic "Cryptol.Eval.evalSel" [ "Unexpected value in list selection" @@ -664,7 +660,7 @@ evalSetSel sym _tyv e sel v = VSeq i mp -> pure $ VSeq i $ updateSeqMap mp n v VStream mp -> pure $ VStream $ updateSeqMap mp n v VWord i m -> pure $ VWord i $ do m1 <- m - updateWordValue sym ?range m1 n asBit + updateWordValue sym m1 n asBit _ -> bad "Sequence update on a non-sequence." asBit = do res <- v @@ -802,7 +798,7 @@ evalMatch sym lenv m = case m of let lenv' = lenv { leVars = fmap stutter (leVars lenv) } let vs i = do let (q, r) = i `divMod` nLen lookupSeqMap vss q >>= \case - VWord _ w -> VBit <$> (flip (indexWordValue sym ?range) r =<< w) + VWord _ w -> VBit <$> (flip (indexWordValue sym) r =<< w) VSeq _ xs' -> lookupSeqMap xs' r VStream xs' -> lookupSeqMap xs' r _ -> evalPanic "evalMatch" ["Not a list value"] @@ -820,7 +816,7 @@ evalMatch sym lenv m = case m of let env = EvalEnv allvars (leTypes lenv) xs <- evalExpr sym env expr let vs i = case xs of - VWord _ w -> VBit <$> (flip (indexWordValue sym ?range) i =<< w) + VWord _ w -> VBit <$> (flip (indexWordValue sym) i =<< w) VSeq _ xs' -> lookupSeqMap xs' i VStream xs' -> lookupSeqMap xs' i _ -> evalPanic "evalMatch" ["Not a list value"] diff --git a/src/Cryptol/Eval/Concrete.hs b/src/Cryptol/Eval/Concrete.hs index e25f4b437..f8a91d067 100644 --- a/src/Cryptol/Eval/Concrete.hs +++ b/src/Cryptol/Eval/Concrete.hs @@ -50,7 +50,6 @@ import Cryptol.Eval.Value import qualified Cryptol.SHA as SHA import qualified Cryptol.AES as AES import qualified Cryptol.PrimeEC as PrimeEC -import Cryptol.Parser.Position (Range) import Cryptol.ModuleSystem.Name import Cryptol.TypeCheck.AST as AST import Cryptol.Utils.Panic (panic) @@ -207,9 +206,8 @@ primTable eOpts = let sym = Concrete in PFinPoly \v -> PWordFun \(BV w x) -> PWordFun \(BV _ m) -> - PRange \rng -> PPrim - do assertSideCondition sym (m /= 0) rng DivideByZero + do assertSideCondition sym (m /= 0) DivideByZero return . VWord v . pure . WordVal . mkBv v $! F2.pmod (fromInteger w) x m) , ("pdiv", @@ -217,9 +215,8 @@ primTable eOpts = let sym = Concrete in PFinPoly \_v -> PWordFun \(BV w x) -> PWordFun \(BV _ m) -> - PRange \rng -> PPrim - do assertSideCondition sym (m /= 0) rng DivideByZero + do assertSideCondition sym (m /= 0) DivideByZero return . VWord w . pure . WordVal . mkBv w $! F2.pdiv (fromInteger w) x m) ] @@ -474,7 +471,7 @@ sshrV = logicShift :: (Integer -> Integer -> Integer -> Integer) -- ^ The function may assume its arguments are masked. -- It is responsible for masking its result if needed. - -> (Range -> Nat' -> TValue -> SeqMap Concrete -> Integer -> SeqMap Concrete) + -> (Nat' -> TValue -> SeqMap Concrete -> Integer -> SeqMap Concrete) -> Prim Concrete logicShift opW opS = PNumPoly \a -> @@ -482,7 +479,6 @@ logicShift opW opS = PTyPoly \c -> PFun \l -> PFun \r -> - PRange \rng -> PPrim do i <- r >>= \case VInteger i -> pure i @@ -491,9 +487,9 @@ logicShift opW opS = l >>= \case VWord w wv -> return $ VWord w $ wv >>= \case WordVal (BV _ x) -> return $ WordVal (BV w (opW w x i)) - LargeBitsVal n xs -> return $ LargeBitsVal n $ opS rng (Nat n) c xs i + LargeBitsVal n xs -> return $ LargeBitsVal n $ opS (Nat n) c xs i - _ -> mkSeq a c <$> (opS rng a c <$> (fromSeq "logicShift" =<< l) <*> return i) + _ -> mkSeq a c <$> (opS a c <$> (fromSeq "logicShift" =<< l) <*> return i) -- Left shift for words. shiftLW :: Integer -> Integer -> Integer -> Integer @@ -522,31 +518,31 @@ signedShiftRW w ival by else shiftR (signedValue w ival) (fromInteger by') -shiftLS :: Range -> Nat' -> TValue -> SeqMap Concrete -> Integer -> SeqMap Concrete -shiftLS rng w ety vs by - | by < 0 = shiftRS rng w ety vs (negate by) +shiftLS :: Nat' -> TValue -> SeqMap Concrete -> Integer -> SeqMap Concrete +shiftLS w ety vs by + | by < 0 = shiftRS w ety vs (negate by) -shiftLS rng w ety vs by = IndexSeqMap $ \i -> +shiftLS w ety vs by = IndexSeqMap $ \i -> case w of Nat len | i+by < len -> lookupSeqMap vs (i+by) - | i < len -> zeroV Concrete rng ety + | i < len -> zeroV Concrete ety | otherwise -> evalPanic "shiftLS" ["Index out of bounds"] Inf -> lookupSeqMap vs (i+by) -shiftRS :: Range -> Nat' -> TValue -> SeqMap Concrete -> Integer -> SeqMap Concrete -shiftRS rng w ety vs by - | by < 0 = shiftLS rng w ety vs (negate by) +shiftRS :: Nat' -> TValue -> SeqMap Concrete -> Integer -> SeqMap Concrete +shiftRS w ety vs by + | by < 0 = shiftLS w ety vs (negate by) -shiftRS rng w ety vs by = IndexSeqMap $ \i -> +shiftRS w ety vs by = IndexSeqMap $ \i -> case w of Nat len | i >= by -> lookupSeqMap vs (i-by) - | i < len -> zeroV Concrete rng ety + | i < len -> zeroV Concrete ety | otherwise -> evalPanic "shiftLS" ["Index out of bounds"] Inf | i >= by -> lookupSeqMap vs (i-by) - | otherwise -> zeroV Concrete rng ety + | otherwise -> zeroV Concrete ety -- XXX integer doesn't implement rotateL, as there's no bit bound @@ -555,8 +551,8 @@ rotateLW 0 i _ = i rotateLW w i by = mask w $ (i `shiftL` b) .|. (i `shiftR` (fromInteger w - b)) where b = fromInteger (by `mod` w) -rotateLS :: Range -> Nat' -> TValue -> SeqMap Concrete -> Integer -> SeqMap Concrete -rotateLS _ w _ vs by = IndexSeqMap $ \i -> +rotateLS :: Nat' -> TValue -> SeqMap Concrete -> Integer -> SeqMap Concrete +rotateLS w _ vs by = IndexSeqMap $ \i -> case w of Nat len -> lookupSeqMap vs ((by + i) `mod` len) _ -> panic "Cryptol.Eval.Prim.rotateLS" [ "unexpected infinite sequence" ] @@ -567,8 +563,8 @@ rotateRW 0 i _ = i rotateRW w i by = mask w $ (i `shiftR` b) .|. (i `shiftL` (fromInteger w - b)) where b = fromInteger (by `mod` w) -rotateRS :: Range -> Nat' -> TValue -> SeqMap Concrete -> Integer -> SeqMap Concrete -rotateRS _ w _ vs by = IndexSeqMap $ \i -> +rotateRS :: Nat' -> TValue -> SeqMap Concrete -> Integer -> SeqMap Concrete +rotateRS w _ vs by = IndexSeqMap $ \i -> case w of Nat len -> lookupSeqMap vs ((len - by + i) `mod` len) _ -> panic "Cryptol.Eval.Prim.rotateRS" [ "unexpected infinite sequence" ] @@ -576,88 +572,84 @@ rotateRS _ w _ vs by = IndexSeqMap $ \i -> -- Sequence Primitives --------------------------------------------------------- -indexFront :: Range -> Nat' -> TValue -> SeqMap Concrete -> TValue -> BV -> Eval Value -indexFront _rng _mblen _a vs _ix (bvVal -> ix) = lookupSeqMap vs ix +indexFront :: Nat' -> TValue -> SeqMap Concrete -> TValue -> BV -> Eval Value +indexFront _mblen _a vs _ix (bvVal -> ix) = lookupSeqMap vs ix -indexFront_bits :: Range -> Nat' -> TValue -> SeqMap Concrete -> TValue -> [Bool] -> Eval Value -indexFront_bits rng mblen a vs ix bs = indexFront rng mblen a vs ix =<< packWord Concrete bs +indexFront_bits :: Nat' -> TValue -> SeqMap Concrete -> TValue -> [Bool] -> Eval Value +indexFront_bits mblen a vs ix bs = indexFront mblen a vs ix =<< packWord Concrete bs -indexFront_int :: Range -> Nat' -> TValue -> SeqMap Concrete -> TValue -> Integer -> Eval Value -indexFront_int _rng _mblen _a vs _ix idx = lookupSeqMap vs idx +indexFront_int :: Nat' -> TValue -> SeqMap Concrete -> TValue -> Integer -> Eval Value +indexFront_int _mblen _a vs _ix idx = lookupSeqMap vs idx -indexBack :: Range -> Nat' -> TValue -> SeqMap Concrete -> TValue -> BV -> Eval Value -indexBack rng mblen a vs ix (bvVal -> idx) = indexBack_int rng mblen a vs ix idx +indexBack :: Nat' -> TValue -> SeqMap Concrete -> TValue -> BV -> Eval Value +indexBack mblen a vs ix (bvVal -> idx) = indexBack_int mblen a vs ix idx -indexBack_bits :: Range -> Nat' -> TValue -> SeqMap Concrete -> TValue -> [Bool] -> Eval Value -indexBack_bits rng mblen a vs ix bs = indexBack rng mblen a vs ix =<< packWord Concrete bs +indexBack_bits :: Nat' -> TValue -> SeqMap Concrete -> TValue -> [Bool] -> Eval Value +indexBack_bits mblen a vs ix bs = indexBack mblen a vs ix =<< packWord Concrete bs -indexBack_int :: Range -> Nat' -> TValue -> SeqMap Concrete -> TValue -> Integer -> Eval Value -indexBack_int _rng mblen _a vs _ix idx = +indexBack_int :: Nat' -> TValue -> SeqMap Concrete -> TValue -> Integer -> Eval Value +indexBack_int mblen _a vs _ix idx = case mblen of Nat len -> lookupSeqMap vs (len - idx - 1) Inf -> evalPanic "indexBack" ["unexpected infinite sequence"] updateFront :: - Range -> Nat' {- ^ length of the sequence -} -> TValue {- ^ type of values in the sequence -} -> SeqMap Concrete {- ^ sequence to update -} -> Either Integer (WordValue Concrete) {- ^ index -} -> Eval Value {- ^ new value at index -} -> Eval (SeqMap Concrete) -updateFront _rng _len _eltTy vs (Left idx) val = do +updateFront _len _eltTy vs (Left idx) val = do return $ updateSeqMap vs idx val -updateFront _rng _len _eltTy vs (Right w) val = do +updateFront _len _eltTy vs (Right w) val = do idx <- bvVal <$> asWordVal Concrete w return $ updateSeqMap vs idx val updateFront_word :: - Range -> Nat' {- ^ length of the sequence -} -> TValue {- ^ type of values in the sequence -} -> WordValue Concrete {- ^ bit sequence to update -} -> Either Integer (WordValue Concrete) {- ^ index -} -> Eval Value {- ^ new value at index -} -> Eval (WordValue Concrete) -updateFront_word rng _len _eltTy bs (Left idx) val = do - updateWordValue Concrete rng bs idx (fromVBit <$> val) +updateFront_word _len _eltTy bs (Left idx) val = do + updateWordValue Concrete bs idx (fromVBit <$> val) -updateFront_word rng _len _eltTy bs (Right w) val = do +updateFront_word _len _eltTy bs (Right w) val = do idx <- bvVal <$> asWordVal Concrete w - updateWordValue Concrete rng bs idx (fromVBit <$> val) + updateWordValue Concrete bs idx (fromVBit <$> val) updateBack :: - Range -> Nat' {- ^ length of the sequence -} -> TValue {- ^ type of values in the sequence -} -> SeqMap Concrete {- ^ sequence to update -} -> Either Integer (WordValue Concrete) {- ^ index -} -> Eval Value {- ^ new value at index -} -> Eval (SeqMap Concrete) -updateBack _ Inf _eltTy _vs _w _val = +updateBack Inf _eltTy _vs _w _val = evalPanic "Unexpected infinite sequence in updateEnd" [] -updateBack _ (Nat n) _eltTy vs (Left idx) val = do +updateBack (Nat n) _eltTy vs (Left idx) val = do return $ updateSeqMap vs (n - idx - 1) val -updateBack _ (Nat n) _eltTy vs (Right w) val = do +updateBack (Nat n) _eltTy vs (Right w) val = do idx <- bvVal <$> asWordVal Concrete w return $ updateSeqMap vs (n - idx - 1) val updateBack_word :: - Range -> Nat' {- ^ length of the sequence -} -> TValue {- ^ type of values in the sequence -} -> WordValue Concrete {- ^ bit sequence to update -} -> Either Integer (WordValue Concrete) {- ^ index -} -> Eval Value {- ^ new value at index -} -> Eval (WordValue Concrete) -updateBack_word _ Inf _eltTy _bs _w _val = +updateBack_word Inf _eltTy _bs _w _val = evalPanic "Unexpected infinite sequence in updateEnd" [] -updateBack_word rng (Nat n) _eltTy bs (Left idx) val = do - updateWordValue Concrete rng bs (n - idx - 1) (fromVBit <$> val) -updateBack_word rng (Nat n) _eltTy bs (Right w) val = do +updateBack_word (Nat n) _eltTy bs (Left idx) val = do + updateWordValue Concrete bs (n - idx - 1) (fromVBit <$> val) +updateBack_word (Nat n) _eltTy bs (Right w) val = do idx <- bvVal <$> asWordVal Concrete w - updateWordValue Concrete rng bs (n - idx - 1) (fromVBit <$> val) + updateWordValue Concrete bs (n - idx - 1) (fromVBit <$> val) floatPrims :: Concrete -> Map PrimIdent (Prim Concrete) @@ -696,18 +688,16 @@ floatPrims sym = Map.fromList [ (floatPrim i,v) | (i,v) <- nonInfixTable ] , "fpFromRational" ~> PFinPoly \e -> PFinPoly \p -> PWordFun \r -> PFun \x -> - PRange \rng -> PPrim do rat <- fromVRational <$> x - VFloat <$> do mode <- fpRoundMode sym rng r + VFloat <$> do mode <- fpRoundMode sym r pure $ floatFromRational e p mode $ sNum rat % sDenom rat , "fpToRational" ~> PFinPoly \_e -> PFinPoly \_p -> PFloatFun \fp -> - PRange \rng -> PPrim case floatToRational "fpToRational" fp of - Left err -> raiseError sym rng err + Left err -> raiseError sym err Right r -> pure $ VRational SRational { sNum = numerator r, sDenom = denominator r } diff --git a/src/Cryptol/Eval/Env.hs b/src/Cryptol/Eval/Env.hs index f563090e2..2a0ff3b49 100644 --- a/src/Cryptol/Eval/Env.hs +++ b/src/Cryptol/Eval/Env.hs @@ -79,7 +79,7 @@ bindVar :: SEval sym (GenEvalEnv sym) bindVar sym n val env = do let nm = show $ ppLocName n - val' <- sDelayFill sym val Nothing nm (nameLoc n) + val' <- sDelayFill sym val Nothing nm return $ env{ envVars = IntMap.insert (nameUnique n) (Right val') (envVars env) } -- | Bind a variable to a value in the evaluation environment, without diff --git a/src/Cryptol/Eval/Generic.hs b/src/Cryptol/Eval/Generic.hs index d8cffafb4..f54cd3a06 100644 --- a/src/Cryptol/Eval/Generic.hs +++ b/src/Cryptol/Eval/Generic.hs @@ -38,7 +38,6 @@ import Cryptol.TypeCheck.Solver.InfNat (Nat'(..),nMul,widthInteger) import Cryptol.Backend import Cryptol.Backend.Concrete (Concrete(..)) import Cryptol.Backend.Monad ( Eval, evalPanic, EvalError(..), Unsupported(..) ) -import Cryptol.Parser.Position (Range,emptyRange) import Cryptol.Testing.Random( randomValue ) import Cryptol.Eval.Prims @@ -86,27 +85,26 @@ ecNumberV sym = ] -{-# SPECIALIZE intV :: Concrete -> Range -> Integer -> TValue -> Eval (GenValue Concrete) +{-# SPECIALIZE intV :: Concrete -> Integer -> TValue -> Eval (GenValue Concrete) #-} -intV :: Backend sym => sym -> Range -> SInteger sym -> TValue -> SEval sym (GenValue sym) -intV sym rng i = - ringNullary sym rng +intV :: Backend sym => sym -> SInteger sym -> TValue -> SEval sym (GenValue sym) +intV sym i = + ringNullary sym (\w -> wordFromInt sym w i) (pure i) (\m -> intToZn sym m i) (intToRational sym i) - (\e p -> fpRndMode sym >>= \r -> fpFromInteger sym rng e p r i) + (\e p -> fpRndMode sym >>= \r -> fpFromInteger sym e p r i) {-# SPECIALIZE ratioV :: Concrete -> Prim Concrete #-} ratioV :: Backend sym => sym -> Prim sym ratioV sym = PFun \x -> PFun \y -> - PRange \rng -> PPrim do x' <- fromVInteger <$> x y' <- fromVInteger <$> y - VRational <$> ratio sym rng x' y' + VRational <$> ratio sym x' y' {-# SPECIALIZE ecFractionV :: Concrete -> Prim Concrete #-} @@ -116,14 +114,13 @@ ecFractionV sym = PFinPoly \d -> PFinPoly \_r -> PTyPoly \ty -> - PRange \rng -> PPrim 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 rng x y + VRational <$> ratio sym x y _ -> evalPanic "ecFractionV" [ "Unexpected `FLiteral` type: " ++ show ty ] @@ -141,7 +138,7 @@ fromZV sym = -- Operation Lifting ----------------------------------------------------------- -type Binary sym = Range -> TValue -> GenValue sym -> GenValue sym -> SEval sym (GenValue sym) +type Binary sym = TValue -> GenValue sym -> GenValue sym -> SEval sym (GenValue sym) {-# SPECIALIZE binary :: Binary Concrete -> Prim Concrete #-} @@ -149,18 +146,19 @@ binary :: Backend sym => Binary sym -> Prim sym binary f = PTyPoly \ty -> PFun \a -> PFun \b -> - PRange \rng -> - PPrim $ join (f rng ty <$> a <*> b) + PPrim $ + do x <- a + y <- b + f ty x y -type Unary sym = Range -> TValue -> GenValue sym -> SEval sym (GenValue sym) +type Unary sym = TValue -> GenValue sym -> SEval sym (GenValue sym) {-# SPECIALIZE unary :: Unary Concrete -> Prim Concrete #-} unary :: Backend sym => Unary sym -> Prim sym unary f = PTyPoly \ty -> PFun \a -> - PRange \rng -> - PPrim (f rng ty =<< a) + PPrim (f ty =<< a) type BinWord sym = Integer -> SWord sym -> SWord sym -> SEval sym (SWord sym) @@ -181,7 +179,7 @@ ringBinary :: forall sym. (SRational sym -> SRational sym -> SEval sym (SRational sym)) -> (SFloat sym -> SFloat sym -> SEval sym (SFloat sym)) -> Binary sym -ringBinary sym opw opi opz opq opfp rng = loop +ringBinary sym opw opi opz opq opfp = loop where loop' :: TValue -> SEval sym (GenValue sym) @@ -217,7 +215,8 @@ ringBinary sym opw opi opz opq opfp rng = loop | isTBit a -> do lw <- fromVWord sym "ringLeft" l rw <- fromVWord sym "ringRight" r - return $ VWord w (WordVal <$> opw w lw rw) + stk <- sGetCallStack sym + return $ VWord w (WordVal <$> (sModifyCallStack sym (\_ -> stk) (opw w lw rw))) | otherwise -> VSeq w <$> (join (zipSeqMap (loop a) <$> (fromSeq "ringBinary left" l) <*> (fromSeq "ringBinary right" r))) @@ -234,15 +233,15 @@ ringBinary sym opw opi opz opq opfp rng = loop -- tuples TVTuple tys -> - do ls <- mapM (sDelay sym rng) (fromVTuple l) - rs <- mapM (sDelay sym rng) (fromVTuple r) + do ls <- mapM (sDelay sym) (fromVTuple l) + rs <- mapM (sDelay sym) (fromVTuple r) return $ VTuple (zipWith3 loop' tys ls rs) -- records TVRec fs -> do VRecord <$> traverseRecordMap - (\f fty -> sDelay sym rng (loop' fty (lookupRecord f l) (lookupRecord f r))) + (\f fty -> sDelay sym (loop' fty (lookupRecord f l) (lookupRecord f r))) fs TVAbstract {} -> @@ -269,7 +268,7 @@ ringUnary :: forall sym. (SRational sym -> SEval sym (SRational sym)) -> (SFloat sym -> SEval sym (SFloat sym)) -> Unary sym -ringUnary sym opw opi opz opq opfp rng = loop +ringUnary sym opw opi opz opq opfp = loop where loop' :: TValue -> SEval sym (GenValue sym) -> SEval sym (GenValue sym) loop' ty v = loop ty =<< v @@ -299,7 +298,8 @@ ringUnary sym opw opi opz opq opfp rng = loop -- words and finite sequences | isTBit a -> do wx <- fromVWord sym "ringUnary" v - return $ VWord w (WordVal <$> opw w wx) + stk <- sGetCallStack sym + return $ VWord w (WordVal <$> sModifyCallStack sym (\_ -> stk) (opw w wx)) | otherwise -> VSeq w <$> (mapSeqMap (loop a) =<< fromSeq "ringUnary" v) TVStream a -> @@ -311,21 +311,20 @@ ringUnary sym opw opi opz opq opfp rng = loop -- tuples TVTuple tys -> - do as <- mapM (sDelay sym rng) (fromVTuple v) + do as <- mapM (sDelay sym) (fromVTuple v) return $ VTuple (zipWith loop' tys as) -- records TVRec fs -> VRecord <$> traverseRecordMap - (\f fty -> sDelay sym rng (loop' fty (lookupRecord f v))) + (\f fty -> sDelay sym (loop' fty (lookupRecord f v))) fs TVAbstract {} -> evalPanic "ringUnary" ["Abstract type not in `Ring`"] {-# SPECIALIZE ringNullary :: Concrete -> - Range -> (Integer -> SEval Concrete (SWord Concrete)) -> SEval Concrete (SInteger Concrete) -> (Integer -> SEval Concrete (SInteger Concrete)) -> @@ -338,7 +337,6 @@ ringUnary sym opw opi opz opq opfp rng = loop ringNullary :: forall sym. Backend sym => sym -> - Range -> (Integer -> SEval sym (SWord sym)) -> SEval sym (SInteger sym) -> (Integer -> SEval sym (SInteger sym)) -> @@ -346,7 +344,7 @@ ringNullary :: forall sym. (Integer -> Integer -> SEval sym (SFloat sym)) -> TValue -> SEval sym (GenValue sym) -ringNullary sym rng opw opi opz opq opfp = loop +ringNullary sym opw opi opz opq opfp = loop where loop :: TValue -> SEval sym (GenValue sym) loop ty = @@ -365,25 +363,27 @@ ringNullary sym rng opw opi opz opq opfp = loop TVSeq w a -- words and finite sequences - | isTBit a -> pure $ VWord w $ (WordVal <$> opw w) + | isTBit a -> + do stk <- sGetCallStack sym + pure $ VWord w $ (WordVal <$> sModifyCallStack sym (\_ -> stk) (opw w)) | otherwise -> - do v <- sDelay sym rng (loop a) + do v <- sDelay sym (loop a) pure $ VSeq w $ IndexSeqMap \_i -> v TVStream a -> - do v <- sDelay sym rng (loop a) + do v <- sDelay sym (loop a) pure $ VStream $ IndexSeqMap \_i -> v TVFun _ b -> - do v <- sDelay sym rng (loop b) + do v <- sDelay sym (loop b) lam sym (const v) TVTuple tys -> - do xs <- mapM (sDelay sym rng . loop) tys + do xs <- mapM (sDelay sym . loop) tys pure $ VTuple xs TVRec fs -> - do xs <- traverse (sDelay sym rng . loop) fs + do xs <- traverse (sDelay sym . loop) fs pure $ VRecord xs TVAbstract {} -> @@ -400,7 +400,7 @@ integralBinary :: forall sym. BinWord sym -> (SInteger sym -> SInteger sym -> SEval sym (SInteger sym)) -> Binary sym -integralBinary sym opw opi _rng ty l r = case ty of +integralBinary sym opw opi ty l r = case ty of TVInteger -> VInteger <$> opi (fromVInteger l) (fromVInteger r) @@ -409,7 +409,8 @@ integralBinary sym opw opi _rng ty l r = case ty of | isTBit a -> do wl <- fromVWord sym "integralBinary left" l wr <- fromVWord sym "integralBinary right" r - return $ VWord w (WordVal <$> opw w wl wr) + stk <- sGetCallStack sym + return $ VWord w (WordVal <$> sModifyCallStack sym (\_ -> stk) (opw w wl wr)) _ -> evalPanic "integralBinary" [show ty ++ " not int class `Integral`"] @@ -424,30 +425,29 @@ fromIntegerV :: Backend sym => sym -> Prim sym fromIntegerV sym = PTyPoly \a -> PFun \v -> - PRange \rng -> PPrim do i <- fromVInteger <$> v - intV sym rng i a + intV sym i a {-# INLINE addV #-} addV :: Backend sym => sym -> Binary sym -addV sym rng = ringBinary sym opw opi opz opq opfp rng +addV sym = ringBinary sym opw opi opz opq opfp where opw _w x y = wordPlus sym x y opi x y = intPlus sym x y opz m x y = znPlus sym m x y opq x y = rationalAdd sym x y - opfp x y = fpRndMode sym >>= \r -> fpPlus sym rng r x y + opfp x y = fpRndMode sym >>= \r -> fpPlus sym r x y {-# INLINE subV #-} subV :: Backend sym => sym -> Binary sym -subV sym rng = ringBinary sym opw opi opz opq opfp rng +subV sym = ringBinary sym opw opi opz opq opfp where opw _w x y = wordMinus sym x y opi x y = intMinus sym x y opz m x y = znMinus sym m x y opq x y = rationalSub sym x y - opfp x y = fpRndMode sym >>= \r -> fpMinus sym rng r x y + opfp x y = fpRndMode sym >>= \r -> fpMinus sym r x y {-# INLINE negateV #-} negateV :: Backend sym => sym -> Unary sym @@ -461,23 +461,23 @@ negateV sym = ringUnary sym opw opi opz opq opfp {-# INLINE mulV #-} mulV :: Backend sym => sym -> Binary sym -mulV sym rng = ringBinary sym opw opi opz opq opfp rng +mulV sym = ringBinary sym opw opi opz opq opfp where opw _w x y = wordMult sym x y opi x y = intMult sym x y opz m x y = znMult sym m x y opq x y = rationalMul sym x y - opfp x y = fpRndMode sym >>= \r -> fpMult sym rng r x y + opfp x y = fpRndMode sym >>= \r -> fpMult sym r x y -------------------------------------------------- -- Integral {-# INLINE divV #-} divV :: Backend sym => sym -> Binary sym -divV sym rng = integralBinary sym opw opi rng +divV sym = integralBinary sym opw opi where - opw _w x y = wordDiv sym rng x y - opi x y = intDiv sym rng x y + opw _w x y = wordDiv sym x y + opi x y = intDiv sym x y {-# SPECIALIZE expV :: Concrete -> Prim Concrete #-} expV :: Backend sym => sym -> Prim sym @@ -486,7 +486,6 @@ expV sym = PTyPoly \ety -> PFun \am -> PFun \em -> - PRange \rng -> PPrim do a <- am e <- em @@ -497,31 +496,31 @@ expV sym = Just n | n == 0 -> do onei <- integerLit sym 1 - intV sym rng onei aty + intV sym onei aty | n > 0 -> do ebits <- enumerateIntBits' sym n ei - computeExponent sym rng aty a ebits + computeExponent sym aty a ebits - | otherwise -> raiseError sym rng NegativeExponent + | otherwise -> raiseError sym NegativeExponent Nothing -> liftIO (X.throw (UnsupportedSymbolicOp "integer exponentiation")) TVSeq _w el | isTBit el -> do ebits <- enumerateWordValue sym =<< fromWordVal "(^^)" e - computeExponent sym rng aty a ebits + computeExponent sym aty a ebits _ -> evalPanic "expV" [show ety ++ " not int class `Integral`"] {-# SPECIALIZE computeExponent :: - Concrete -> Range -> TValue -> GenValue Concrete -> [SBit Concrete] -> SEval Concrete (GenValue Concrete) + Concrete -> TValue -> GenValue Concrete -> [SBit Concrete] -> SEval Concrete (GenValue Concrete) #-} computeExponent :: Backend sym => - sym -> Range -> TValue -> GenValue sym -> [SBit sym] -> SEval sym (GenValue sym) -computeExponent sym rng aty a bs0 = + sym -> TValue -> GenValue sym -> [SBit sym] -> SEval sym (GenValue sym) +computeExponent sym aty a bs0 = do onei <- integerLit sym 1 - one <- intV sym rng onei aty + one <- intV sym onei aty loop one (dropLeadingZeros bs0) where @@ -532,18 +531,18 @@ computeExponent sym rng aty a bs0 = loop acc [] = return acc loop acc (b:bs) = - do sq <- mulV sym rng aty acc acc + do sq <- mulV sym aty acc acc acc' <- iteValue sym b - (mulV sym rng aty a sq) + (mulV sym aty a sq) (pure sq) loop acc' bs {-# INLINE modV #-} modV :: Backend sym => sym -> Binary sym -modV sym rng = integralBinary sym opw opi rng +modV sym = integralBinary sym opw opi where - opw _w x y = wordMod sym rng x y - opi x y = intMod sym rng x y + opw _w x y = wordMod sym x y + opi x y = intMod sym x y {-# SPECIALIZE toIntegerV :: Concrete -> Prim Concrete #-} -- | Convert a word to a non-negative integer. @@ -566,16 +565,15 @@ recipV :: Backend sym => sym -> Prim sym recipV sym = PTyPoly \a -> PFun \x -> - PRange \rng -> PPrim case a of - TVRational -> VRational <$> (rationalRecip sym rng . 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 rng r one xv - TVIntMod m -> VInteger <$> (znRecip sym rng m . fromVInteger =<< x) + VFloat <$> fpDiv sym r one xv + TVIntMod m -> VInteger <$> (znRecip sym m . fromVInteger =<< x) _ -> evalPanic "recip" [show a ++ "is not a Field"] {-# SPECIALIZE fieldDivideV :: Concrete -> Prim Concrete #-} @@ -584,22 +582,21 @@ fieldDivideV sym = PTyPoly \a -> PFun \x -> PFun \y -> - PRange \rng -> PPrim case a of TVRational -> do x' <- fromVRational <$> x y' <- fromVRational <$> y - VRational <$> rationalDivide sym rng x' y' + VRational <$> rationalDivide sym x' y' TVFloat _e _p -> do xv <- fromVFloat <$> x yv <- fromVFloat <$> y r <- fpRndMode sym - VFloat <$> fpDiv sym rng r xv yv + VFloat <$> fpDiv sym r xv yv TVIntMod m -> do x' <- fromVInteger <$> x y' <- fromVInteger <$> y - yinv <- znRecip sym rng m y' + yinv <- znRecip sym m y' VInteger <$> znMult sym m x' yinv _ -> evalPanic "recip" [show a ++ "is not a Field"] @@ -621,7 +618,7 @@ roundOp :: (SRational sym -> SEval sym (SInteger sym)) -> (SFloat sym -> SEval sym (SInteger sym)) -> Unary sym -roundOp _sym nm qop opfp _rng ty v = +roundOp _sym nm qop opfp ty v = case ty of TVRational -> VInteger <$> (qop (fromVRational v)) TVFloat _ _ -> VInteger <$> opfp (fromVFloat v) @@ -629,38 +626,38 @@ roundOp _sym nm qop opfp _rng ty v = {-# INLINE floorV #-} floorV :: Backend sym => sym -> Unary sym -floorV sym rng = roundOp sym "floor" opq opfp rng +floorV sym = roundOp sym "floor" opq opfp where opq = rationalFloor sym - opfp = \x -> fpRndRTN sym >>= \r -> fpToInteger sym "floor" rng r x + opfp = \x -> fpRndRTN sym >>= \r -> fpToInteger sym "floor" r x {-# INLINE ceilingV #-} ceilingV :: Backend sym => sym -> Unary sym -ceilingV sym rng = roundOp sym "ceiling" opq opfp rng +ceilingV sym = roundOp sym "ceiling" opq opfp where opq = rationalCeiling sym - opfp = \x -> fpRndRTP sym >>= \r -> fpToInteger sym "ceiling" rng r x + opfp = \x -> fpRndRTP sym >>= \r -> fpToInteger sym "ceiling" r x {-# INLINE truncV #-} truncV :: Backend sym => sym -> Unary sym -truncV sym rng = roundOp sym "trunc" opq opfp rng +truncV sym = roundOp sym "trunc" opq opfp where opq = rationalTrunc sym - opfp = \x -> fpRndRTZ sym >>= \r -> fpToInteger sym "trunc" rng r x + opfp = \x -> fpRndRTZ sym >>= \r -> fpToInteger sym "trunc" r x {-# INLINE roundAwayV #-} roundAwayV :: Backend sym => sym -> Unary sym -roundAwayV sym rng = roundOp sym "roundAway" opq opfp rng +roundAwayV sym = roundOp sym "roundAway" opq opfp where opq = rationalRoundAway sym - opfp = \x -> fpRndRNA sym >>= \r -> fpToInteger sym "roundAway" rng r x + opfp = \x -> fpRndRNA sym >>= \r -> fpToInteger sym "roundAway" r x {-# INLINE roundToEvenV #-} roundToEvenV :: Backend sym => sym -> Unary sym -roundToEvenV sym rng = roundOp sym "roundToEven" opq opfp rng +roundToEvenV sym = roundOp sym "roundToEven" opq opfp where opq = rationalRoundToEven sym - opfp = \x -> fpRndRNE sym >>= \r -> fpToInteger sym "roundToEven" rng r x + opfp = \x -> fpRndRNE sym >>= \r -> fpToInteger sym "roundToEven" r x -------------------------------------------------------------- -- Logic @@ -696,8 +693,7 @@ sdivV sym = PFinPoly \w -> PWordFun \x -> PWordFun \y -> - PRange \rng -> - PVal (VWord w (WordVal <$> wordSignedDiv sym rng x y)) + PVal (VWord w (WordVal <$> wordSignedDiv sym x y)) {-# SPECIALIZE smodV :: Concrete -> Prim Concrete #-} smodV :: Backend sym => sym -> Prim sym @@ -705,8 +701,7 @@ smodV sym = PFinPoly \w -> PWordFun \x -> PWordFun \y -> - PRange \rng -> - PVal (VWord w (WordVal <$> wordSignedMod sym rng x y)) + PVal (VWord w (WordVal <$> wordSignedMod sym x y)) -- Cmp ------------------------------------------------------------------------- @@ -837,31 +832,31 @@ lexCombine sym cmp eq k = {-# INLINE eqV #-} eqV :: Backend sym => sym -> Binary sym -eqV sym _rng ty v1 v2 = VBit <$> valEq sym ty v1 v2 +eqV sym ty v1 v2 = VBit <$> valEq sym ty v1 v2 {-# INLINE distinctV #-} distinctV :: Backend sym => sym -> Binary sym -distinctV sym _rng ty v1 v2 = VBit <$> (bitComplement sym =<< valEq sym ty v1 v2) +distinctV sym ty v1 v2 = VBit <$> (bitComplement sym =<< valEq sym ty v1 v2) {-# INLINE lessThanV #-} lessThanV :: Backend sym => sym -> Binary sym -lessThanV sym _rng ty v1 v2 = VBit <$> valLt sym ty v1 v2 (bitLit sym False) +lessThanV sym ty v1 v2 = VBit <$> valLt sym ty v1 v2 (bitLit sym False) {-# INLINE lessThanEqV #-} lessThanEqV :: Backend sym => sym -> Binary sym -lessThanEqV sym _rng ty v1 v2 = VBit <$> valLt sym ty v1 v2 (bitLit sym True) +lessThanEqV sym ty v1 v2 = VBit <$> valLt sym ty v1 v2 (bitLit sym True) {-# INLINE greaterThanV #-} greaterThanV :: Backend sym => sym -> Binary sym -greaterThanV sym _rng ty v1 v2 = VBit <$> valGt sym ty v1 v2 (bitLit sym False) +greaterThanV sym ty v1 v2 = VBit <$> valGt sym ty v1 v2 (bitLit sym False) {-# INLINE greaterThanEqV #-} greaterThanEqV :: Backend sym => sym -> Binary sym -greaterThanEqV sym _rng ty v1 v2 = VBit <$> valGt sym ty v1 v2 (bitLit sym True) +greaterThanEqV sym ty v1 v2 = VBit <$> valGt sym ty v1 v2 (bitLit sym True) {-# INLINE signedLessThanV #-} signedLessThanV :: Backend sym => sym -> Binary sym -signedLessThanV sym _rng ty v1 v2 = VBit <$> cmpValue sym fb fw fi fz fq ff 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 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 @@ -874,17 +869,15 @@ signedLessThanV sym _rng ty v1 v2 = VBit <$> cmpValue sym fb fw fi fz fq ff ty v {-# SPECIALIZE zeroV :: Concrete -> - Range -> TValue -> SEval Concrete (GenValue Concrete) #-} zeroV :: forall sym. Backend sym => sym -> - Range -> TValue -> SEval sym (GenValue sym) -zeroV sym rng ty = case ty of +zeroV sym ty = case ty of -- bits TVBit -> @@ -911,26 +904,26 @@ zeroV sym rng ty = case ty of TVSeq w ety | isTBit ety -> pure $ word sym w 0 | otherwise -> - do z <- sDelay sym rng (zeroV sym rng ety) + do z <- sDelay sym (zeroV sym ety) pure $ VSeq w (IndexSeqMap \_i -> z) TVStream ety -> - do z <- sDelay sym rng (zeroV sym rng ety) + do z <- sDelay sym (zeroV sym ety) pure $ VStream (IndexSeqMap \_i -> z) -- functions TVFun _ bty -> - do z <- sDelay sym rng (zeroV sym rng bty) + do z <- sDelay sym (zeroV sym bty) lam sym (const z) -- tuples TVTuple tys -> - do xs <- mapM (sDelay sym rng . zeroV sym rng) tys + do xs <- mapM (sDelay sym . zeroV sym) tys pure $ VTuple xs -- records TVRec fields -> - do xs <- traverse (sDelay sym rng . zeroV sym rng) fields + do xs <- traverse (sDelay sym . zeroV sym) fields pure $ VRecord xs TVAbstract {} -> evalPanic "zeroV" [ "Abstract type not in `Zero`" ] @@ -950,7 +943,6 @@ joinWordVal sym w1 w2 {-# SPECIALIZE joinWords :: Concrete -> - Range -> Integer -> Integer -> SeqMap Concrete -> @@ -959,18 +951,17 @@ joinWordVal sym w1 w2 joinWords :: forall sym. Backend sym => sym -> - Range -> Integer -> Integer -> SeqMap sym -> SEval sym (GenValue sym) -joinWords sym rng nParts nEach xs = +joinWords sym nParts nEach xs = loop (WordVal <$> wordLit sym 0 0) (enumerateSeqMap nParts xs) where loop :: SEval sym (WordValue sym) -> [SEval sym (GenValue sym)] -> SEval sym (GenValue sym) loop !wv [] = - VWord (nParts * nEach) <$> sDelay sym rng wv + VWord (nParts * nEach) <$> sDelay sym wv loop !wv (w : ws) = w >>= \case VWord _ w' -> @@ -979,7 +970,6 @@ joinWords sym rng nParts nEach xs = {-# SPECIALIZE joinSeq :: Concrete -> - Range -> Nat' -> Integer -> TValue -> @@ -989,7 +979,6 @@ joinWords sym rng nParts nEach xs = joinSeq :: Backend sym => sym -> - Range -> Nat' -> Integer -> TValue -> @@ -997,29 +986,29 @@ joinSeq :: SEval sym (GenValue sym) -- Special case for 0 length inner sequences. -joinSeq sym rng _parts 0 a _xs - = zeroV sym rng (TVSeq 0 a) +joinSeq sym _parts 0 a _xs + = zeroV sym (TVSeq 0 a) -- finite sequence of words -joinSeq sym rng (Nat parts) each TVBit xs +joinSeq sym (Nat parts) each TVBit xs | parts * each < largeBitSize - = joinWords sym rng parts each xs + = joinWords sym parts each xs | otherwise = do let zs = IndexSeqMap $ \i -> do let (q,r) = divMod i each ys <- fromWordVal "join seq" =<< lookupSeqMap xs q - VBit <$> indexWordValue sym rng ys r + VBit <$> indexWordValue sym ys r return $ VWord (parts * each) $ pure $ LargeBitsVal (parts * each) zs -- infinite sequence of words -joinSeq sym rng Inf each TVBit xs +joinSeq sym Inf each TVBit xs = return $ VStream $ IndexSeqMap $ \i -> do let (q,r) = divMod i each ys <- fromWordVal "join seq" =<< lookupSeqMap xs q - VBit <$> indexWordValue sym rng ys r + VBit <$> indexWordValue sym ys r -- finite or infinite sequence of non-words -joinSeq _sym _rng parts each _a xs +joinSeq _sym parts each _a xs = return $ vSeq $ IndexSeqMap $ \i -> do let (q,r) = divMod i each ys <- fromSeq "join seq" =<< lookupSeqMap xs q @@ -1037,13 +1026,12 @@ joinSeq _sym _rng parts each _a xs joinV :: Backend sym => sym -> - Range -> Nat' -> Integer -> TValue -> GenValue sym -> SEval sym (GenValue sym) -joinV sym rng parts each a val = joinSeq sym rng parts each a =<< fromSeq "joinV" val +joinV sym parts each a val = joinSeq sym parts each a =<< fromSeq "joinV" val {-# INLINE splitWordVal #-} @@ -1066,34 +1054,33 @@ splitWordVal _ leftWidth rightWidth (LargeBitsVal _n xs) = splitAtV :: Backend sym => sym -> - Range -> Nat' -> Nat' -> TValue -> GenValue sym -> SEval sym (GenValue sym) -splitAtV sym rng front back a val = +splitAtV sym front back a val = case back of Nat rightWidth | aBit -> do - ws <- sDelay sym rng (splitWordVal sym leftWidth rightWidth =<< fromWordVal "splitAtV" val) + ws <- sDelay sym (splitWordVal sym leftWidth rightWidth =<< fromWordVal "splitAtV" val) return $ VTuple [ VWord leftWidth . pure . fst <$> ws , VWord rightWidth . pure . snd <$> ws ] Inf | aBit -> do - vs <- sDelay sym rng (fromSeq "splitAtV" val) - ls <- sDelay sym rng (fst . splitSeqMap leftWidth <$> vs) - rs <- sDelay sym rng (snd . splitSeqMap leftWidth <$> vs) + vs <- sDelay sym (fromSeq "splitAtV" val) + ls <- sDelay sym (fst . splitSeqMap leftWidth <$> vs) + rs <- sDelay sym (snd . splitSeqMap leftWidth <$> vs) return $ VTuple [ return $ VWord leftWidth (LargeBitsVal leftWidth <$> ls) , VStream <$> rs ] _ -> do - vs <- sDelay sym rng (fromSeq "splitAtV" val) - ls <- sDelay sym rng (fst . splitSeqMap leftWidth <$> vs) - rs <- sDelay sym rng (snd . splitSeqMap leftWidth <$> vs) + vs <- sDelay sym (fromSeq "splitAtV" val) + ls <- sDelay sym (fst . splitSeqMap leftWidth <$> vs) + rs <- sDelay sym (snd . splitSeqMap leftWidth <$> vs) return $ VTuple [ VSeq leftWidth <$> ls , mkSeq back a <$> rs ] @@ -1137,7 +1124,6 @@ ecSplitV sym = PNumPoly \each -> PTyPoly \a -> PFun \val -> - PRange \rng -> PPrim case (parts, each) of (Nat p, Nat e) | isTBit a -> do @@ -1145,7 +1131,7 @@ ecSplitV sym = return $ VSeq p $ IndexSeqMap $ \i -> pure $ VWord e (extractWordVal sym e ((p-i-1)*e) =<< val') (Inf, Nat e) | isTBit a -> do - val' <- sDelay sym rng (fromSeq "ecSplitV" =<< val) + val' <- sDelay sym (fromSeq "ecSplitV" =<< val) return $ VStream $ IndexSeqMap $ \i -> return $ VWord e $ return $ LargeBitsVal e $ IndexSeqMap $ \j -> let idx = i*e + toInteger j @@ -1153,13 +1139,13 @@ ecSplitV sym = xs <- val' lookupSeqMap xs idx (Nat p, Nat e) -> do - val' <- sDelay sym rng (fromSeq "ecSplitV" =<< val) + val' <- sDelay sym (fromSeq "ecSplitV" =<< val) return $ VSeq p $ IndexSeqMap $ \i -> return $ VSeq e $ IndexSeqMap $ \j -> do xs <- val' lookupSeqMap xs (e * i + j) (Inf , Nat e) -> do - val' <- sDelay sym rng (fromSeq "ecSplitV" =<< val) + val' <- sDelay sym (fromSeq "ecSplitV" =<< val) return $ VStream $ IndexSeqMap $ \i -> return $ VSeq e $ IndexSeqMap $ \j -> do xs <- val' @@ -1188,13 +1174,12 @@ reverseV _ _ = transposeV :: Backend sym => sym -> - Range -> Nat' -> Nat' -> TValue -> GenValue sym -> SEval sym (GenValue sym) -transposeV sym rng a b c xs +transposeV sym a b c xs | isTBit c, Nat na <- a = -- Fin a => [a][b]Bit -> [b][a]Bit return $ bseq $ IndexSeqMap $ \bi -> return $ VWord na $ return $ LargeBitsVal na $ IndexSeqMap $ \ai -> @@ -1202,7 +1187,7 @@ transposeV sym rng a b c xs ys <- lookupSeqMap xs' ai case ys of VStream ys' -> lookupSeqMap ys' bi - VWord _ wv -> VBit <$> (flip (indexWordValue sym rng) bi =<< wv) + VWord _ wv -> VBit <$> (flip (indexWordValue sym) bi =<< wv) _ -> evalPanic "transpose" ["expected sequence of bits"] | isTBit c, Inf <- a = -- [inf][b]Bit -> [b][inf]Bit @@ -1212,7 +1197,7 @@ transposeV sym rng a b c xs ys <- lookupSeqMap xs' ai case ys of VStream ys' -> lookupSeqMap ys' bi - VWord _ wv -> VBit <$> (flip (indexWordValue sym rng) bi =<< wv) + VWord _ wv -> VBit <$> (flip (indexWordValue sym) bi =<< wv) _ -> evalPanic "transpose" ["expected sequence of bits"] | otherwise = -- [a][b]c -> [b][a]c @@ -1239,7 +1224,6 @@ transposeV sym rng a b c xs ccatV :: Backend sym => sym -> - Range -> Nat' -> Nat' -> TValue -> @@ -1247,20 +1231,20 @@ ccatV :: (GenValue sym) -> SEval sym (GenValue sym) -ccatV sym _rng _front _back _elty (VWord m l) (VWord n r) = +ccatV sym _front _back _elty (VWord m l) (VWord n r) = return $ VWord (m+n) (join (joinWordVal sym <$> l <*> r)) -ccatV sym rng _front _back _elty (VWord m l) (VStream r) = do - l' <- sDelay sym rng l +ccatV sym _front _back _elty (VWord m l) (VStream r) = do + l' <- sDelay sym l return $ VStream $ IndexSeqMap $ \i -> if i < m then - VBit <$> (flip (indexWordValue sym rng) i =<< l') + VBit <$> (flip (indexWordValue sym) i =<< l') else lookupSeqMap r (i-m) -ccatV sym rng front back elty l r = do - l'' <- sDelay sym rng (fromSeq "ccatV left" l) - r'' <- sDelay sym rng (fromSeq "ccatV right" r) +ccatV sym front back elty l r = do + l'' <- sDelay sym (fromSeq "ccatV left" l) + r'' <- sDelay sym (fromSeq "ccatV right" r) let Nat n = front mkSeq (evalTF TCAdd [front,back]) elty <$> return (IndexSeqMap $ \i -> if i < n then do @@ -1302,7 +1286,7 @@ logicBinary :: forall sym. (SBit sym -> SBit sym -> SEval sym (SBit sym)) -> (SWord sym -> SWord sym -> SEval sym (SWord sym)) -> Binary sym -logicBinary sym opb opw rng = loop +logicBinary sym opb opw = loop where loop' :: TValue -> SEval sym (GenValue sym) @@ -1326,7 +1310,7 @@ logicBinary sym opb opw rng = loop TVSeq w aty -- words | isTBit aty - -> do v <- sDelay sym rng $ join + -> do v <- sDelay sym $ join (wordValLogicOp sym opb opw <$> fromWordVal "logicBinary l" l <*> fromWordVal "logicBinary r" r) @@ -1344,8 +1328,8 @@ logicBinary sym opb opw rng = loop (fromSeq "logicBinary right" r))) TVTuple etys -> do - ls <- mapM (sDelay sym rng) (fromVTuple l) - rs <- mapM (sDelay sym rng) (fromVTuple r) + ls <- mapM (sDelay sym) (fromVTuple l) + rs <- mapM (sDelay sym) (fromVTuple r) return $ VTuple $ zipWith3 loop' etys ls rs TVFun _ bty -> @@ -1354,7 +1338,7 @@ logicBinary sym opb opw rng = loop TVRec fields -> VRecord <$> traverseRecordMap - (\f fty -> sDelay sym rng (loop' fty (lookupRecord f l) (lookupRecord f r))) + (\f fty -> sDelay sym (loop' fty (lookupRecord f l) (lookupRecord f r))) fields TVAbstract {} -> evalPanic "logicBinary" @@ -1384,7 +1368,7 @@ logicUnary :: forall sym. (SBit sym -> SEval sym (SBit sym)) -> (SWord sym -> SEval sym (SWord sym)) -> Unary sym -logicUnary sym opb opw rng = loop +logicUnary sym opb opw = loop where loop' :: TValue -> SEval sym (GenValue sym) -> SEval sym (GenValue sym) loop' ty val = loop ty =<< val @@ -1402,7 +1386,7 @@ logicUnary sym opb opw rng = loop TVSeq w ety -- words | isTBit ety - -> do v <- sDelay sym rng (wordValUnaryOp opb opw =<< fromWordVal "logicUnary" val) + -> do v <- sDelay sym (wordValUnaryOp opb opw =<< fromWordVal "logicUnary" val) return $ VWord w v -- finite sequences @@ -1414,7 +1398,7 @@ logicUnary sym opb opw rng = loop VStream <$> (mapSeqMap (loop ety) =<< fromSeq "logicUnary" val) TVTuple etys -> - do as <- mapM (sDelay sym rng) (fromVTuple val) + do as <- mapM (sDelay sym) (fromVTuple val) return $ VTuple (zipWith loop' etys as) TVFun _ bty -> @@ -1423,7 +1407,7 @@ logicUnary sym opb opw rng = loop TVRec fields -> VRecord <$> traverseRecordMap - (\f fty -> sDelay sym rng (loop' fty (lookupRecord f val))) + (\f fty -> sDelay sym (loop' fty (lookupRecord f val))) fields TVAbstract {} -> evalPanic "logicUnary" [ "Abstract type not in `Logic`" ] @@ -1459,53 +1443,52 @@ bitsValueLessThan sym w (b:bs) n assertIndexInBounds :: Backend sym => sym -> - Range -> Nat' {- ^ Sequence size bounds -} -> Either (SInteger sym) (WordValue sym) {- ^ Index value -} -> SEval sym () -- All nonnegative integers are in bounds for an infinite sequence -assertIndexInBounds sym rng Inf (Left idx) = +assertIndexInBounds sym Inf (Left idx) = do ppos <- bitComplement sym =<< intLessThan sym idx =<< integerLit sym 0 - assertSideCondition sym ppos rng (InvalidIndex (integerAsLit sym idx)) + assertSideCondition sym ppos (InvalidIndex (integerAsLit sym idx)) -- If the index is an integer, test that it -- is nonnegative and less than the concrete value of n. -assertIndexInBounds sym rng (Nat n) (Left idx) = +assertIndexInBounds sym (Nat n) (Left idx) = do n' <- integerLit sym n ppos <- bitComplement sym =<< intLessThan sym idx =<< integerLit sym 0 pn <- intLessThan sym idx n' p <- bitAnd sym ppos pn - assertSideCondition sym p rng (InvalidIndex (integerAsLit sym idx)) + assertSideCondition sym p (InvalidIndex (integerAsLit sym idx)) -- Bitvectors can't index out of bounds for an infinite sequence -assertIndexInBounds _sym _rng Inf (Right _) = return () +assertIndexInBounds _sym Inf (Right _) = return () -- Can't index out of bounds for a sequence that is -- longer than the expressible index values -assertIndexInBounds sym _rng (Nat n) (Right idx) +assertIndexInBounds sym (Nat n) (Right idx) | n >= 2^(wordValueSize sym idx) = return () -- If the index is concrete, test it directly -assertIndexInBounds sym rng (Nat n) (Right (WordVal idx)) +assertIndexInBounds sym (Nat n) (Right (WordVal idx)) | Just (_w,i) <- wordAsLit sym idx - = unless (i < n) (raiseError sym rng (InvalidIndex (Just i))) + = unless (i < n) (raiseError sym (InvalidIndex (Just i))) -- If the index is a packed word, test that it -- is less than the concrete value of n, which -- fits into w bits because of the above test. -assertIndexInBounds sym rng (Nat n) (Right (WordVal idx)) = +assertIndexInBounds sym (Nat n) (Right (WordVal idx)) = do n' <- wordLit sym (wordLen sym idx) n p <- wordLessThan sym idx n' - assertSideCondition sym p rng (InvalidIndex Nothing) + assertSideCondition sym p (InvalidIndex Nothing) -- If the index is an unpacked word, force all the bits -- and compute the unsigned less-than test directly. -assertIndexInBounds sym rng (Nat n) (Right (LargeBitsVal w bits)) = +assertIndexInBounds sym (Nat n) (Right (LargeBitsVal w bits)) = do bitsList <- traverse (fromVBit <$>) (enumerateSeqMap w bits) p <- bitsValueLessThan sym w bitsList n - assertSideCondition sym p rng (InvalidIndex Nothing) + assertSideCondition sym p (InvalidIndex Nothing) -- | Indexing operations. @@ -1514,9 +1497,9 @@ assertIndexInBounds sym rng (Nat n) (Right (LargeBitsVal w bits)) = indexPrim :: Backend sym => sym -> - (Range -> Nat' -> TValue -> SeqMap sym -> TValue -> SInteger sym -> SEval sym (GenValue sym)) -> - (Range -> Nat' -> TValue -> SeqMap sym -> TValue -> [SBit sym] -> SEval sym (GenValue sym)) -> - (Range -> Nat' -> TValue -> SeqMap sym -> TValue -> SWord sym -> SEval sym (GenValue sym)) -> + (Nat' -> TValue -> SeqMap sym -> TValue -> SInteger sym -> SEval sym (GenValue sym)) -> + (Nat' -> TValue -> SeqMap sym -> TValue -> [SBit sym] -> SEval sym (GenValue sym)) -> + (Nat' -> TValue -> SeqMap sym -> TValue -> SWord sym -> SEval sym (GenValue sym)) -> Prim sym indexPrim sym int_op bits_op word_op = PNumPoly \len -> @@ -1524,27 +1507,26 @@ indexPrim sym int_op bits_op word_op = PTyPoly \ix -> PFun \xs -> PFun \idx -> - PRange \rng -> PPrim do vs <- xs >>= \case - VWord _ w -> w >>= \w' -> return $ IndexSeqMap (\i -> VBit <$> indexWordValue sym rng w' i) + VWord _ w -> w >>= \w' -> return $ IndexSeqMap (\i -> VBit <$> indexWordValue sym w' i) VSeq _ vs -> return vs VStream vs -> return vs _ -> evalPanic "Expected sequence value" ["indexPrim"] idx' <- asIndex sym "index" ix =<< idx - assertIndexInBounds sym rng len idx' + assertIndexInBounds sym len idx' case idx' of - Left i -> int_op rng len eltTy vs ix i - Right (WordVal w') -> word_op rng len eltTy vs ix w' - Right (LargeBitsVal m bs) -> bits_op rng len eltTy vs ix =<< traverse (fromVBit <$>) (enumerateSeqMap m bs) + Left i -> int_op len eltTy vs ix i + Right (WordVal w') -> word_op len eltTy vs ix w' + Right (LargeBitsVal m bs) -> bits_op len eltTy vs ix =<< traverse (fromVBit <$>) (enumerateSeqMap m bs) {-# INLINE updatePrim #-} updatePrim :: Backend sym => sym -> - (Range -> Nat' -> TValue -> WordValue sym -> Either (SInteger sym) (WordValue sym) -> SEval sym (GenValue sym) -> SEval sym (WordValue sym)) -> - (Range -> Nat' -> TValue -> SeqMap sym -> Either (SInteger sym) (WordValue sym) -> SEval sym (GenValue sym) -> SEval sym (SeqMap sym)) -> + (Nat' -> TValue -> WordValue sym -> Either (SInteger sym) (WordValue sym) -> SEval sym (GenValue sym) -> SEval sym (WordValue sym)) -> + (Nat' -> TValue -> SeqMap sym -> Either (SInteger sym) (WordValue sym) -> SEval sym (GenValue sym) -> SEval sym (SeqMap sym)) -> Prim sym updatePrim sym updateWord updateSeq = PNumPoly \len -> @@ -1553,15 +1535,14 @@ updatePrim sym updateWord updateSeq = PFun \xs -> PFun \idx -> PFun \val -> - PRange \rng -> PPrim do idx' <- asIndex sym "update" ix =<< idx - assertIndexInBounds sym rng len idx' + assertIndexInBounds sym len idx' xs >>= \case - VWord l w -> do w' <- sDelay sym rng w - return $ VWord l (w' >>= \w'' -> updateWord rng len eltTy w'' idx' val) - VSeq l vs -> VSeq l <$> updateSeq rng len eltTy vs idx' val - VStream vs -> VStream <$> updateSeq rng len eltTy vs idx' val + VWord l w -> do w' <- sDelay sym w + return $ VWord l (w' >>= \w'' -> updateWord len eltTy w'' idx' val) + VSeq l vs -> VSeq l <$> updateSeq len eltTy vs idx' val + VStream vs -> VStream <$> updateSeq len eltTy vs idx' val _ -> evalPanic "Expected sequence value" ["updatePrim"] {-# INLINE fromToV #-} @@ -1603,13 +1584,12 @@ infFromV :: Backend sym => sym -> Prim sym infFromV sym = PTyPoly \ty -> PFun \x -> - PRange \rng -> PPrim - do mx <- sDelay sym rng x + do mx <- sDelay sym x return $ VStream $ IndexSeqMap $ \i -> do x' <- mx i' <- integerLit sym i - addV sym rng ty x' =<< intV sym rng i' ty + addV sym ty x' =<< intV sym i' ty {-# INLINE infFromThenV #-} infFromThenV :: Backend sym => sym -> Prim sym @@ -1617,17 +1597,16 @@ infFromThenV sym = PTyPoly \ty -> PFun \first -> PFun \next -> - PRange \rng -> PPrim - do mxd <- sDelay sym rng + do mxd <- sDelay sym (do x <- first y <- next - d <- subV sym rng ty y x + d <- subV sym ty y x pure (x,d)) return $ VStream $ IndexSeqMap $ \i -> do (x,d) <- mxd i' <- integerLit sym i - addV sym rng ty x =<< mulV sym rng ty d =<< intV sym rng i' ty + addV sym ty x =<< mulV sym ty d =<< intV sym i' ty -- Shifting --------------------------------------------------- @@ -1733,7 +1712,6 @@ logicShift sym nm shrinkRange wopPos wopNeg reindexPos reindexNeg = PTyPoly \a -> PFun \xs -> PFun \y -> - PRange \rng -> PPrim do xs' <- xs y' <- asIndex sym "shift" ix =<< y @@ -1741,14 +1719,13 @@ logicShift sym nm shrinkRange wopPos wopNeg reindexPos reindexNeg = Left int_idx -> do pneg <- intLessThan sym int_idx =<< integerLit sym 0 iteValue sym pneg - (intShifter sym rng nm wopNeg reindexNeg m ix a xs' =<< shrinkRange sym m ix =<< intNegate sym int_idx) - (intShifter sym rng nm wopPos reindexPos m ix a xs' =<< shrinkRange sym m ix int_idx) + (intShifter sym nm wopNeg reindexNeg m ix a xs' =<< shrinkRange sym m ix =<< intNegate sym int_idx) + (intShifter sym nm wopPos reindexPos m ix a xs' =<< shrinkRange sym m ix int_idx) Right idx -> - wordShifter sym rng nm wopPos reindexPos m a xs' idx + wordShifter sym nm wopPos reindexPos m a xs' idx intShifter :: Backend sym => sym -> - Range -> String -> (SWord sym -> SWord sym -> SEval sym (SWord sym)) -> (Nat' -> Integer -> Integer -> Maybe Integer) -> @@ -1758,11 +1735,11 @@ intShifter :: Backend sym => GenValue sym -> SInteger sym -> SEval sym (GenValue sym) -intShifter sym rng nm wop reindex m ix a xs idx = +intShifter sym nm wop reindex m ix a xs idx = do let shiftOp vs shft = memoMap $ IndexSeqMap $ \i -> case reindex m i shft of - Nothing -> zeroV sym rng a + Nothing -> zeroV sym a Just i' -> lookupSeqMap vs i' case xs of VWord w x -> @@ -1786,7 +1763,6 @@ intShifter sym rng nm wop reindex m ix a xs idx = wordShifter :: Backend sym => sym -> - Range -> String -> (SWord sym -> SWord sym -> SEval sym (SWord sym)) -> (Nat' -> Integer -> Integer -> Maybe Integer) -> @@ -1795,11 +1771,11 @@ wordShifter :: Backend sym => GenValue sym -> WordValue sym -> SEval sym (GenValue sym) -wordShifter sym rng nm wop reindex m a xs idx = +wordShifter sym nm wop reindex m a xs idx = let shiftOp vs shft = memoMap $ IndexSeqMap $ \i -> case reindex m i shft of - Nothing -> zeroV sym rng a + Nothing -> zeroV sym a Just i' -> lookupSeqMap vs i' in case xs of VWord w x -> @@ -1833,13 +1809,12 @@ rotateShrink _sym Inf _ _ = panic "rotateShrink" ["expected finite sequence in r rotateShrink sym (Nat 0) _ _ = integerLit sym 0 rotateShrink sym (Nat w) _ x = do w' <- integerLit sym w - intMod sym emptyRange x w' + intMod sym x w' -- Miscellaneous --------------------------------------------------------------- {-# SPECIALIZE errorV :: Concrete -> - Range -> TValue -> String -> SEval Concrete (GenValue Concrete) @@ -1847,12 +1822,11 @@ rotateShrink sym (Nat w) _ x = errorV :: forall sym. Backend sym => sym -> - Range -> TValue -> String -> SEval sym (GenValue sym) -errorV sym rng ty msg = - let err = cryUserError sym rng msg in +errorV sym ty msg = + let err = cryUserError sym msg in case ty of -- bits TVBit -> err @@ -1865,22 +1839,22 @@ errorV sym rng ty msg = -- sequences TVSeq w ety | isTBit ety -> return $ VWord w $ return $ LargeBitsVal w $ IndexSeqMap $ \_ -> err - | otherwise -> return $ VSeq w (IndexSeqMap $ \_ -> errorV sym rng ety msg) + | otherwise -> return $ VSeq w (IndexSeqMap $ \_ -> errorV sym ety msg) TVStream ety -> - return $ VStream (IndexSeqMap $ \_ -> errorV sym rng ety msg) + return $ VStream (IndexSeqMap $ \_ -> errorV sym ety msg) -- functions TVFun _ bty -> - lam sym (\ _ -> errorV sym rng bty msg) + lam sym (\ _ -> errorV sym bty msg) -- tuples TVTuple tys -> - return $ VTuple (map (\t -> errorV sym rng t msg) tys) + return $ VTuple (map (\t -> errorV sym t msg) tys) -- records TVRec fields -> - return $ VRecord $ fmap (\t -> errorV sym rng t msg) $ fields + return $ VRecord $ fmap (\t -> errorV sym t msg) $ fields TVAbstract {} -> err @@ -2018,40 +1992,39 @@ foldl'V sym = PFun \f -> PFun \z -> PStrict \v -> - PRange \rng -> PPrim case v of - VSeq n m -> go0 rng f z (enumerateSeqMap n m) - VWord _n wv -> go0 rng f z . map (pure . VBit) =<< (enumerateWordValue sym =<< wv) + VSeq n m -> go0 f z (enumerateSeqMap n m) + VWord _n wv -> go0 f z . map (pure . VBit) =<< (enumerateWordValue sym =<< wv) _ -> panic "Cryptol.Eval.Generic.foldlV" ["Expected finite sequence"] where - go0 _rng _f a [] = a - go0 rng f a bs = + go0 _f a [] = a + go0 f a bs = do f' <- fromVFun sym <$> f - a' <- sDelay sym rng a + a' <- sDelay sym a forceValue =<< a' - go1 rng f' a' bs + go1 f' a' bs - go1 _rng _f a [] = a - go1 rng f a (b:bs) = + go1 _f a [] = a + go1 f a (b:bs) = do f' <- fromVFun sym <$> (f a) - a' <- sDelay sym rng (f' b) + a' <- sDelay sym (f' b) forceValue =<< a' - go1 rng f a' bs + go1 f a' bs -- Random Values --------------------------------------------------------------- {-# SPECIALIZE randomV :: - Concrete -> Range -> TValue -> Integer -> SEval Concrete (GenValue Concrete) + Concrete -> TValue -> Integer -> SEval Concrete (GenValue Concrete) #-} -- | Produce a random value with the given seed. If we do not support -- making values of the given type, return zero of that type. -- TODO: do better than returning zero -randomV :: Backend sym => sym -> Range -> TValue -> Integer -> SEval sym (GenValue sym) -randomV sym rng ty seed = +randomV :: Backend sym => sym -> TValue -> Integer -> SEval sym (GenValue sym) +randomV sym ty seed = case randomValue sym ty of - Nothing -> zeroV sym rng ty + Nothing -> zeroV sym ty Just gen -> -- unpack the seed into four Word64s let mask64 = 0xFFFFFFFFFFFFFFFF @@ -2069,17 +2042,16 @@ parmapV sym = PFinPoly \_n -> PFun \f -> PFun \xs -> - PRange \rng -> PPrim do f' <- fromVFun sym <$> f xs' <- xs case xs' of VWord n w -> do m <- asBitsMap sym <$> w - m' <- sparkParMap sym rng f' n m + m' <- sparkParMap sym f' n m pure (VWord n (pure (LargeBitsVal n m'))) VSeq n m -> - VSeq n <$> sparkParMap sym rng f' n m + VSeq n <$> sparkParMap sym f' n m _ -> panic "parmapV" ["expected sequence!"] @@ -2087,16 +2059,15 @@ parmapV sym = sparkParMap :: Backend sym => sym -> - Range -> (SEval sym (GenValue sym) -> SEval sym (GenValue sym)) -> Integer -> SeqMap sym -> SEval sym (SeqMap sym) -sparkParMap sym rng f n m = - finiteSeqMap <$> mapM (sSpark sym rng . g) (enumerateSeqMap n m) +sparkParMap sym f n m = + finiteSeqMap <$> mapM (sSpark sym . g) (enumerateSeqMap n m) where g x = - do z <- sDelay sym rng (f x) + do z <- sDelay sym (f x) forceValue =<< z z @@ -2111,8 +2082,7 @@ fpBinArithV sym fun = PWordFun \r -> PFloatFun \x -> PFloatFun \y -> - PRange \rng -> - PPrim (VFloat <$> fun sym rng r x y) + PPrim (VFloat <$> fun sym r x y) -- | Rounding mode used in FP operations that do not specify it explicitly. fpRndMode, fpRndRNE, fpRndRNA, fpRndRTP, fpRndRTN, fpRndRTZ :: @@ -2144,8 +2114,7 @@ genericPrimTable sym = -- Zero , ("zero" , {-# SCC "Prelude::zero" #-} PTyPoly \ty -> - PRange \rng -> - PPrim (zeroV sym rng ty)) + PPrim (zeroV sym ty)) -- Logic , ("&&" , {-# SCC "Prelude::(&&)" #-} @@ -2240,16 +2209,14 @@ genericPrimTable sym = PTyPoly \elty -> PFun \l -> PFun \r -> - PRange \rng -> - PPrim (join (ccatV sym rng (Nat front) back elty <$> l <*> r))) + PPrim (join (ccatV sym (Nat front) back elty <$> l <*> r))) , ("join" , {-# SCC "Prelude::join" #-} PNumPoly \parts -> PFinPoly \each -> PTyPoly \a -> PStrict \x -> - PRange \rng -> - PPrim $ joinV sym rng parts each a x) + PPrim $ joinV sym parts each a x) , ("split" , {-# SCC "Prelude::split" #-} ecSplitV sym) @@ -2259,8 +2226,7 @@ genericPrimTable sym = PNumPoly \back -> PTyPoly \a -> PStrict \x -> - PRange \rng -> - PPrim $ splitAtV sym rng front back a x) + PPrim $ splitAtV sym front back a x) , ("reverse" , {-# SCC "Prelude::reverse" #-} PFinPoly \_a -> @@ -2273,8 +2239,7 @@ genericPrimTable sym = PNumPoly \b -> PTyPoly \c -> PStrict \xs -> - PRange \rng -> - PPrim $ transposeV sym rng a b c xs) + PPrim $ transposeV sym a b c xs) -- Misc @@ -2283,16 +2248,14 @@ genericPrimTable sym = PTyPoly \a -> PFinPoly \_ -> PStrict \s -> - PRange \rng -> - PPrim (errorV sym rng a =<< valueToString sym s)) + PPrim (errorV sym a =<< valueToString sym s)) , ("random" , {-# SCC "Prelude::random" #-} PTyPoly \a -> PWordFun \x -> - PRange \rng -> PPrim case wordAsLit sym x of - Just (_,i) -> randomV sym rng a i + Just (_,i) -> randomV sym a i Nothing -> liftIO (X.throw (UnsupportedSymbolicOp "random"))) , ("foldl" , {-# SCC "Prelude::foldl" #-} diff --git a/src/Cryptol/Eval/Prims.hs b/src/Cryptol/Eval/Prims.hs index d26d7f8c0..324733238 100644 --- a/src/Cryptol/Eval/Prims.hs +++ b/src/Cryptol/Eval/Prims.hs @@ -6,7 +6,6 @@ import Cryptol.Backend import Cryptol.Eval.Type import Cryptol.Eval.Value import Cryptol.ModuleSystem.Name -import Cryptol.Parser.Position import Cryptol.TypeCheck.Solver.InfNat(Nat'(..)) import Cryptol.Utils.Panic @@ -18,11 +17,10 @@ data Prim sym | PTyPoly (TValue -> Prim sym) | PNumPoly (Nat' -> Prim sym) | PFinPoly (Integer -> Prim sym) - | PRange (Range -> Prim sym) | PPrim (SEval sym (GenValue sym)) | PVal (GenValue sym) -evalPrim :: (?range :: Range, Backend sym) => sym -> Name -> Prim sym -> SEval sym (GenValue sym) +evalPrim :: Backend sym => sym -> Name -> Prim sym -> SEval sym (GenValue sym) evalPrim sym nm p = case p of PFun f -> lam sym (evalPrim sym nm . f) PStrict f -> lam sym (\x -> evalPrim sym nm . f =<< x) @@ -32,6 +30,5 @@ evalPrim sym nm p = case p of PNumPoly f -> nlam sym (evalPrim sym nm . f) PFinPoly f -> nlam sym (\case Inf -> panic "PFin" ["Unexpected `inf`", show nm]; Nat n -> evalPrim sym nm (f n)) - PRange f -> evalPrim sym nm (f ?range) PPrim m -> m PVal v -> pure v diff --git a/src/Cryptol/Eval/SBV.hs b/src/Cryptol/Eval/SBV.hs index f5ff446d5..efeaf5974 100644 --- a/src/Cryptol/Eval/SBV.hs +++ b/src/Cryptol/Eval/SBV.hs @@ -37,7 +37,6 @@ import Cryptol.Eval.Type (TValue(..)) import Cryptol.Eval.Generic import Cryptol.Eval.Prims import Cryptol.Eval.Value -import Cryptol.Parser.Position import Cryptol.TypeCheck.Solver.InfNat (Nat'(..), widthInteger) import Cryptol.Utils.Ident @@ -105,14 +104,13 @@ primTable sym = indexFront :: SBV -> - Range -> Nat' -> TValue -> SeqMap SBV -> TValue -> SVal -> SEval SBV Value -indexFront sym rng mblen a xs _ix idx +indexFront sym mblen a xs _ix idx | Just i <- SBV.svAsInteger idx = lookupSeqMap xs i @@ -130,7 +128,7 @@ indexFront sym rng mblen a xs _ix idx where k = SBV.kindOf idx - def = zeroV sym rng a + def = zeroV sym a f n y = iteValue sym (SBV.svEqual idx (SBV.svInteger k n)) (lookupSeqMap xs n) y folded = case k of @@ -145,33 +143,31 @@ indexFront sym rng mblen a xs _ix idx indexBack :: SBV -> - Range -> Nat' -> TValue -> SeqMap SBV -> TValue -> SWord SBV -> SEval SBV Value -indexBack sym rng (Nat n) a xs ix idx = indexFront sym rng (Nat n) a (reverseSeqMap n xs) ix idx -indexBack _ _ Inf _ _ _ _ = evalPanic "Expected finite sequence" ["indexBack"] +indexBack sym (Nat n) a xs ix idx = indexFront sym (Nat n) a (reverseSeqMap n xs) ix idx +indexBack _ Inf _ _ _ _ = evalPanic "Expected finite sequence" ["indexBack"] indexFront_bits :: SBV -> - Range -> Nat' -> TValue -> SeqMap SBV -> TValue -> [SBit SBV] -> SEval SBV Value -indexFront_bits sym rng mblen _a xs _ix bits0 = go 0 (length bits0) bits0 +indexFront_bits sym mblen _a xs _ix bits0 = go 0 (length bits0) bits0 where go :: Integer -> Int -> [SBit SBV] -> SEval SBV Value go i _k [] -- For indices out of range, fail | Nat n <- mblen , i >= n - = raiseError sym rng (InvalidIndex (Just i)) + = raiseError sym (InvalidIndex (Just i)) | otherwise = lookupSeqMap xs i @@ -181,7 +177,7 @@ indexFront_bits sym rng mblen _a xs _ix bits0 = go 0 (length bits0) bits0 -- are out of bounds | Nat n <- mblen , (i `shiftL` k) >= n - = raiseError sym rng (InvalidIndex Nothing) + = raiseError sym (InvalidIndex Nothing) | otherwise = iteValue sym b @@ -191,15 +187,14 @@ indexFront_bits sym rng mblen _a xs _ix bits0 = go 0 (length bits0) bits0 indexBack_bits :: SBV -> - Range -> Nat' -> TValue -> SeqMap SBV -> TValue -> [SBit SBV] -> SEval SBV Value -indexBack_bits sym rng (Nat n) a xs ix idx = indexFront_bits sym rng (Nat n) a (reverseSeqMap n xs) ix idx -indexBack_bits _ _ Inf _ _ _ _ = evalPanic "Expected finite sequence" ["indexBack_bits"] +indexBack_bits sym (Nat n) a xs ix idx = indexFront_bits sym (Nat n) a (reverseSeqMap n xs) ix idx +indexBack_bits _ Inf _ _ _ _ = evalPanic "Expected finite sequence" ["indexBack_bits"] -- | Compare a symbolic word value with a concrete integer. @@ -221,21 +216,20 @@ wordValueEqualsInteger sym wv i updateFrontSym :: SBV -> - Range -> Nat' -> TValue -> SeqMap SBV -> Either (SInteger SBV) (WordValue SBV) -> SEval SBV (GenValue SBV) -> SEval SBV (SeqMap SBV) -updateFrontSym sym _rng _len _eltTy vs (Left idx) val = +updateFrontSym sym _len _eltTy vs (Left idx) val = case SBV.svAsInteger idx of Just i -> return $ updateSeqMap vs i val Nothing -> return $ IndexSeqMap $ \i -> do b <- intEq sym idx =<< integerLit sym i iteValue sym b val (lookupSeqMap vs i) -updateFrontSym sym _rng _len _eltTy vs (Right wv) val = +updateFrontSym sym _len _eltTy vs (Right wv) val = case wv of WordVal w | Just j <- SBV.svAsInteger w -> return $ updateSeqMap vs j val @@ -246,27 +240,26 @@ updateFrontSym sym _rng _len _eltTy vs (Right wv) val = updateFrontSym_word :: SBV -> - Range -> Nat' -> TValue -> WordValue SBV -> Either (SInteger SBV) (WordValue SBV) -> SEval SBV (GenValue SBV) -> SEval SBV (WordValue SBV) -updateFrontSym_word _ _ Inf _ _ _ _ = evalPanic "Expected finite sequence" ["updateFrontSym_bits"] +updateFrontSym_word _ Inf _ _ _ _ = evalPanic "Expected finite sequence" ["updateFrontSym_bits"] -updateFrontSym_word sym rng (Nat _) eltTy (LargeBitsVal n bv) idx val = - LargeBitsVal n <$> updateFrontSym sym rng (Nat n) eltTy bv idx val +updateFrontSym_word sym (Nat _) eltTy (LargeBitsVal n bv) idx val = + LargeBitsVal n <$> updateFrontSym sym (Nat n) eltTy bv idx val -updateFrontSym_word sym rng (Nat n) eltTy (WordVal bv) (Left idx) val = +updateFrontSym_word sym (Nat n) eltTy (WordVal bv) (Left idx) val = do idx' <- wordFromInt sym n idx - updateFrontSym_word sym rng (Nat n) eltTy (WordVal bv) (Right (WordVal idx')) val + updateFrontSym_word sym (Nat n) eltTy (WordVal bv) (Right (WordVal idx')) val -updateFrontSym_word sym rng (Nat n) eltTy bv (Right wv) val = +updateFrontSym_word sym (Nat n) eltTy bv (Right wv) val = case wv of WordVal idx | Just j <- SBV.svAsInteger idx -> - updateWordValue sym rng bv j (fromVBit <$> val) + updateWordValue sym bv j (fromVBit <$> val) | WordVal bw <- bv -> WordVal <$> @@ -279,28 +272,27 @@ updateFrontSym_word sym rng (Nat n) eltTy bv (Right wv) val = let bw' = SBV.svAnd bw (SBV.svNot msk) return $! SBV.svXOr bw' (SBV.svAnd q msk) - _ -> LargeBitsVal n <$> updateFrontSym sym rng (Nat n) eltTy (asBitsMap sym bv) (Right wv) val + _ -> LargeBitsVal n <$> updateFrontSym sym (Nat n) eltTy (asBitsMap sym bv) (Right wv) val updateBackSym :: SBV -> - Range -> Nat' -> TValue -> SeqMap SBV -> Either (SInteger SBV) (WordValue SBV) -> SEval SBV (GenValue SBV) -> SEval SBV (SeqMap SBV) -updateBackSym _ _ Inf _ _ _ _ = evalPanic "Expected finite sequence" ["updateBackSym"] +updateBackSym _ Inf _ _ _ _ = evalPanic "Expected finite sequence" ["updateBackSym"] -updateBackSym sym _rng (Nat n) _eltTy vs (Left idx) val = +updateBackSym sym (Nat n) _eltTy vs (Left idx) val = case SBV.svAsInteger idx of Just i -> return $ updateSeqMap vs (n - 1 - i) val Nothing -> return $ IndexSeqMap $ \i -> do b <- intEq sym idx =<< integerLit sym (n - 1 - i) iteValue sym b val (lookupSeqMap vs i) -updateBackSym sym _rng (Nat n) _eltTy vs (Right wv) val = +updateBackSym sym (Nat n) _eltTy vs (Right wv) val = case wv of WordVal w | Just j <- SBV.svAsInteger w -> return $ updateSeqMap vs (n - 1 - j) val @@ -311,27 +303,26 @@ updateBackSym sym _rng (Nat n) _eltTy vs (Right wv) val = updateBackSym_word :: SBV -> - Range -> Nat' -> TValue -> WordValue SBV -> Either (SInteger SBV) (WordValue SBV) -> SEval SBV (GenValue SBV) -> SEval SBV (WordValue SBV) -updateBackSym_word _ _ Inf _ _ _ _ = evalPanic "Expected finite sequence" ["updateBackSym_bits"] +updateBackSym_word _ Inf _ _ _ _ = evalPanic "Expected finite sequence" ["updateBackSym_bits"] -updateBackSym_word sym rng (Nat _) eltTy (LargeBitsVal n bv) idx val = - LargeBitsVal n <$> updateBackSym sym rng (Nat n) eltTy bv idx val +updateBackSym_word sym (Nat _) eltTy (LargeBitsVal n bv) idx val = + LargeBitsVal n <$> updateBackSym sym (Nat n) eltTy bv idx val -updateBackSym_word sym rng (Nat n) eltTy (WordVal bv) (Left idx) val = +updateBackSym_word sym (Nat n) eltTy (WordVal bv) (Left idx) val = do idx' <- wordFromInt sym n idx - updateBackSym_word sym rng (Nat n) eltTy (WordVal bv) (Right (WordVal idx')) val + updateBackSym_word sym (Nat n) eltTy (WordVal bv) (Right (WordVal idx')) val -updateBackSym_word sym rng (Nat n) eltTy bv (Right wv) val = do +updateBackSym_word sym (Nat n) eltTy bv (Right wv) val = do case wv of WordVal idx | Just j <- SBV.svAsInteger idx -> - updateWordValue sym rng bv (n - 1 - j) (fromVBit <$> val) + updateWordValue sym bv (n - 1 - j) (fromVBit <$> val) | WordVal bw <- bv -> WordVal <$> @@ -344,7 +335,7 @@ updateBackSym_word sym rng (Nat n) eltTy bv (Right wv) val = do let bw' = SBV.svAnd bw (SBV.svNot msk) return $! SBV.svXOr bw' (SBV.svAnd q msk) - _ -> LargeBitsVal n <$> updateBackSym sym rng (Nat n) eltTy (asBitsMap sym bv) (Right wv) val + _ -> LargeBitsVal n <$> updateBackSym sym (Nat n) eltTy (asBitsMap sym bv) (Right wv) val asWordList :: [WordValue SBV] -> Maybe [SWord SBV] diff --git a/src/Cryptol/Eval/Value.hs b/src/Cryptol/Eval/Value.hs index a7fc56281..e0785621e 100644 --- a/src/Cryptol/Eval/Value.hs +++ b/src/Cryptol/Eval/Value.hs @@ -105,7 +105,6 @@ import Cryptol.Backend.Monad ) import Cryptol.Eval.Type -import Cryptol.Parser.Position (Range) import Cryptol.TypeCheck.Solver.InfNat(Nat'(..)) import Cryptol.Utils.Ident (Ident) import Cryptol.Utils.Panic(panic) @@ -273,26 +272,26 @@ wordValueSize sym (WordVal w) = wordLen sym w wordValueSize _ (LargeBitsVal n _) = n -- | Select an individual bit from a word value -indexWordValue :: Backend sym => sym -> Range -> WordValue sym -> Integer -> SEval sym (SBit sym) -indexWordValue sym rng (WordVal w) idx +indexWordValue :: Backend sym => sym -> WordValue sym -> Integer -> SEval sym (SBit sym) +indexWordValue sym (WordVal w) idx | 0 <= idx && idx < wordLen sym w = wordBit sym w idx - | otherwise = invalidIndex sym rng idx -indexWordValue sym rng (LargeBitsVal n xs) idx + | otherwise = invalidIndex sym idx +indexWordValue sym (LargeBitsVal n xs) idx | 0 <= idx && idx < n = fromVBit <$> lookupSeqMap xs idx - | otherwise = invalidIndex sym rng idx + | otherwise = invalidIndex sym idx -- | Produce a new 'WordValue' from the one given by updating the @i@th bit with the -- given bit value. updateWordValue :: Backend sym => - sym -> Range -> WordValue sym -> Integer -> SEval sym (SBit sym) -> SEval sym (WordValue sym) -updateWordValue sym rng (WordVal w) idx b - | idx < 0 || idx >= wordLen sym w = invalidIndex sym rng idx + sym -> WordValue sym -> Integer -> SEval sym (SBit sym) -> SEval sym (WordValue sym) +updateWordValue sym (WordVal w) idx b + | idx < 0 || idx >= wordLen sym w = invalidIndex sym idx | isReady sym b = WordVal <$> (wordUpdate sym w idx =<< b) -updateWordValue sym rng wv idx b +updateWordValue sym wv idx b | 0 <= idx && idx < wordValueSize sym wv = pure $ LargeBitsVal (wordValueSize sym wv) $ updateSeqMap (asBitsMap sym wv) idx (VBit <$> b) - | otherwise = invalidIndex sym rng idx + | otherwise = invalidIndex sym idx -- | Generic value type, parameterized by bit and word types. diff --git a/src/Cryptol/Eval/What4.hs b/src/Cryptol/Eval/What4.hs index cf4183999..b55ed101d 100644 --- a/src/Cryptol/Eval/What4.hs +++ b/src/Cryptol/Eval/What4.hs @@ -54,7 +54,6 @@ import qualified Cryptol.SHA as SHA import Cryptol.TypeCheck.Solver.InfNat( Nat'(..), widthInteger ) -import Cryptol.Parser.Position(Range) import Cryptol.Utils.Ident import Cryptol.Utils.Panic import Cryptol.Utils.RecordMap @@ -556,14 +555,13 @@ sshrV sym = indexFront_int :: W4.IsSymExprBuilder sym => What4 sym -> - Range -> Nat' -> TValue -> SeqMap (What4 sym) -> TValue -> SInteger (What4 sym) -> SEval (What4 sym) (Value sym) -indexFront_int sym rng mblen _a xs ix idx +indexFront_int sym mblen _a xs ix idx | Just i <- W4.asInteger idx = lookupSeqMap xs i @@ -576,7 +574,7 @@ indexFront_int sym rng mblen _a xs ix idx where w4sym = w4 sym - def = raiseError sym rng (InvalidIndex Nothing) + def = raiseError sym (InvalidIndex Nothing) f n y = do p <- liftIO (W4.intEq w4sym idx =<< W4.intLit w4sym n) @@ -606,27 +604,25 @@ indexFront_int sym rng mblen _a xs ix idx indexBack_int :: W4.IsSymExprBuilder sym => What4 sym -> - Range -> Nat' -> TValue -> SeqMap (What4 sym) -> TValue -> SInteger (What4 sym) -> SEval (What4 sym) (Value sym) -indexBack_int sym rng (Nat n) a xs ix idx = indexFront_int sym rng (Nat n) a (reverseSeqMap n xs) ix idx -indexBack_int _ _ Inf _ _ _ _ = evalPanic "Expected finite sequence" ["indexBack_int"] +indexBack_int sym (Nat n) a xs ix idx = indexFront_int sym (Nat n) a (reverseSeqMap n xs) ix idx +indexBack_int _ Inf _ _ _ _ = evalPanic "Expected finite sequence" ["indexBack_int"] indexFront_word :: W4.IsSymExprBuilder sym => What4 sym -> - Range -> Nat' -> TValue -> SeqMap (What4 sym) -> TValue -> SWord (What4 sym) -> SEval (What4 sym) (Value sym) -indexFront_word sym rng mblen _a xs _ix idx +indexFront_word sym mblen _a xs _ix idx | Just i <- SW.bvAsUnsignedInteger idx = lookupSeqMap xs i @@ -637,7 +633,7 @@ indexFront_word sym rng mblen _a xs _ix idx w4sym = w4 sym w = SW.bvWidth idx - def = raiseError sym rng (InvalidIndex Nothing) + def = raiseError sym (InvalidIndex Nothing) f n y = do p <- liftIO (SW.bvEq w4sym idx =<< SW.bvLit w4sym w n) @@ -661,34 +657,32 @@ indexFront_word sym rng mblen _a xs _ix idx indexBack_word :: W4.IsSymExprBuilder sym => What4 sym -> - Range -> Nat' -> TValue -> SeqMap (What4 sym) -> TValue -> SWord (What4 sym) -> SEval (What4 sym) (Value sym) -indexBack_word sym rng (Nat n) a xs ix idx = indexFront_word sym rng (Nat n) a (reverseSeqMap n xs) ix idx -indexBack_word _ _ Inf _ _ _ _ = evalPanic "Expected finite sequence" ["indexBack_word"] +indexBack_word sym (Nat n) a xs ix idx = indexFront_word sym (Nat n) a (reverseSeqMap n xs) ix idx +indexBack_word _ Inf _ _ _ _ = evalPanic "Expected finite sequence" ["indexBack_word"] indexFront_bits :: forall sym. W4.IsSymExprBuilder sym => What4 sym -> - Range -> Nat' -> TValue -> SeqMap (What4 sym) -> TValue -> [SBit (What4 sym)] -> SEval (What4 sym) (Value sym) -indexFront_bits sym rng mblen _a xs _ix bits0 = go 0 (length bits0) bits0 +indexFront_bits sym mblen _a xs _ix bits0 = go 0 (length bits0) bits0 where go :: Integer -> Int -> [W4.Pred sym] -> W4Eval sym (Value sym) go i _k [] -- For indices out of range, fail | Nat n <- mblen , i >= n - = raiseError sym rng (InvalidIndex (Just i)) + = raiseError sym (InvalidIndex (Just i)) | otherwise = lookupSeqMap xs i @@ -698,7 +692,7 @@ indexFront_bits sym rng mblen _a xs _ix bits0 = go 0 (length bits0) bits0 -- are out of bounds | Nat n <- mblen , (i `shiftL` k) >= n - = raiseError sym rng (InvalidIndex Nothing) + = raiseError sym (InvalidIndex Nothing) | otherwise = iteValue sym b @@ -708,15 +702,14 @@ indexFront_bits sym rng mblen _a xs _ix bits0 = go 0 (length bits0) bits0 indexBack_bits :: W4.IsSymExprBuilder sym => What4 sym -> - Range -> Nat' -> TValue -> SeqMap (What4 sym) -> TValue -> [SBit (What4 sym)] -> SEval (What4 sym) (Value sym) -indexBack_bits sym rng (Nat n) a xs ix idx = indexFront_bits sym rng (Nat n) a (reverseSeqMap n xs) ix idx -indexBack_bits _ _ Inf _ _ _ _ = evalPanic "Expected finite sequence" ["indexBack_bits"] +indexBack_bits sym (Nat n) a xs ix idx = indexFront_bits sym (Nat n) a (reverseSeqMap n xs) ix idx +indexBack_bits _ Inf _ _ _ _ = evalPanic "Expected finite sequence" ["indexBack_bits"] -- | Compare a symbolic word value with a concrete integer. @@ -748,21 +741,20 @@ wordValueEqualsInteger sym wv i updateFrontSym :: W4.IsSymExprBuilder sym => What4 sym -> - Range -> 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 _rng _len _eltTy vs (Left idx) val = +updateFrontSym sym _len _eltTy vs (Left idx) val = case W4.asInteger idx of Just i -> return $ updateSeqMap vs i val Nothing -> return $ IndexSeqMap $ \i -> do b <- intEq sym idx =<< integerLit sym i iteValue sym b val (lookupSeqMap vs i) -updateFrontSym sym _rng _len _eltTy vs (Right wv) val = +updateFrontSym sym _len _eltTy vs (Right wv) val = case wv of WordVal w | Just j <- SW.bvAsUnsignedInteger w -> return $ updateSeqMap vs j val @@ -774,23 +766,22 @@ updateFrontSym sym _rng _len _eltTy vs (Right wv) val = updateBackSym :: W4.IsSymExprBuilder sym => What4 sym -> - Range -> 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 _ Inf _ _ _ _ = evalPanic "Expected finite sequence" ["updateBackSym"] -updateBackSym sym _rng (Nat n) _eltTy vs (Left idx) val = +updateBackSym sym (Nat n) _eltTy vs (Left idx) val = case W4.asInteger idx of Just i -> return $ updateSeqMap vs (n - 1 - i) val Nothing -> return $ IndexSeqMap $ \i -> do b <- intEq sym idx =<< integerLit sym (n - 1 - i) iteValue sym b val (lookupSeqMap vs i) -updateBackSym sym _rng (Nat n) _eltTy vs (Right wv) val = +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 @@ -803,27 +794,26 @@ updateBackSym sym _rng (Nat n) _eltTy vs (Right wv) val = updateFrontSym_word :: W4.IsSymExprBuilder sym => What4 sym -> - Range -> 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 _ Inf _ _ _ _ = evalPanic "Expected finite sequence" ["updateFrontSym_word"] -updateFrontSym_word sym rng (Nat _) eltTy (LargeBitsVal n bv) idx val = - LargeBitsVal n <$> updateFrontSym sym rng (Nat n) eltTy bv idx val +updateFrontSym_word sym (Nat _) eltTy (LargeBitsVal n bv) idx val = + LargeBitsVal n <$> updateFrontSym sym (Nat n) eltTy bv idx val -updateFrontSym_word sym rng (Nat n) eltTy (WordVal bv) (Left idx) val = +updateFrontSym_word sym (Nat n) eltTy (WordVal bv) (Left idx) val = do idx' <- wordFromInt sym n idx - updateFrontSym_word sym rng (Nat n) eltTy (WordVal bv) (Right (WordVal idx')) val + updateFrontSym_word sym (Nat n) eltTy (WordVal bv) (Right (WordVal idx')) val -updateFrontSym_word sym rng (Nat n) eltTy bv (Right wv) val = +updateFrontSym_word sym (Nat n) eltTy bv (Right wv) val = case wv of WordVal idx | Just j <- SW.bvAsUnsignedInteger idx -> - updateWordValue sym rng bv j (fromVBit <$> val) + updateWordValue sym bv j (fromVBit <$> val) | WordVal bw <- bv -> WordVal <$> @@ -841,33 +831,32 @@ updateFrontSym_word sym rng (Nat n) eltTy bv (Right wv) val = SW.bvXor (w4 sym) bw' =<< SW.bvAnd (w4 sym) q msk _ -> LargeBitsVal (wordValueSize sym wv) <$> - updateFrontSym sym rng (Nat n) eltTy (asBitsMap sym bv) (Right wv) val + updateFrontSym sym (Nat n) eltTy (asBitsMap sym bv) (Right wv) val updateBackSym_word :: W4.IsSymExprBuilder sym => What4 sym -> - Range -> 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 _ Inf _ _ _ _ = evalPanic "Expected finite sequence" ["updateBackSym_word"] -updateBackSym_word sym rng (Nat _) eltTy (LargeBitsVal n bv) idx val = - LargeBitsVal n <$> updateBackSym sym rng (Nat n) eltTy bv idx val +updateBackSym_word sym (Nat _) eltTy (LargeBitsVal n bv) idx val = + LargeBitsVal n <$> updateBackSym sym (Nat n) eltTy bv idx val -updateBackSym_word sym rng (Nat n) eltTy (WordVal bv) (Left idx) val = +updateBackSym_word sym (Nat n) eltTy (WordVal bv) (Left idx) val = do idx' <- wordFromInt sym n idx - updateBackSym_word sym rng (Nat n) eltTy (WordVal bv) (Right (WordVal idx')) val + updateBackSym_word sym (Nat n) eltTy (WordVal bv) (Right (WordVal idx')) val -updateBackSym_word sym rng (Nat n) eltTy bv (Right wv) val = +updateBackSym_word sym (Nat n) eltTy bv (Right wv) val = case wv of WordVal idx | Just j <- SW.bvAsUnsignedInteger idx -> - updateWordValue sym rng bv (n - 1 - j) (fromVBit <$> val) + updateWordValue sym bv (n - 1 - j) (fromVBit <$> val) | WordVal bw <- bv -> WordVal <$> @@ -885,7 +874,7 @@ updateBackSym_word sym rng (Nat n) eltTy bv (Right wv) val = SW.bvXor (w4 sym) bw' =<< SW.bvAnd (w4 sym) q msk _ -> LargeBitsVal (wordValueSize sym wv) <$> - updateBackSym sym rng (Nat n) eltTy (asBitsMap sym bv) (Right wv) val + updateBackSym sym (Nat n) eltTy (asBitsMap sym bv) (Right wv) val @@ -921,15 +910,13 @@ floatPrims sym = , "fpFromRational" ~> PFinPoly \e -> PFinPoly \p -> PWordFun \r -> PFun \x -> - PRange \rng -> PPrim do rat <- fromVRational <$> x - VFloat <$> fpCvtFromRational sym rng e p r rat + VFloat <$> fpCvtFromRational sym e p r rat , "fpToRational" ~> PFinPoly \_e -> PFinPoly \_p -> PFloatFun \fp -> - PRange \rng -> - PPrim (VRational <$> fpCvtToRational sym rng fp) + PPrim (VRational <$> fpCvtToRational sym fp) ] -- | A helper for definitng floating point constants. From 899b43398ad40c5b58593421001a8203c04dea31 Mon Sep 17 00:00:00 2001 From: Rob Dockins Date: Sun, 6 Dec 2020 20:22:37 -0800 Subject: [PATCH 16/27] Make sure that `error` properly tracks the call stack --- src/Cryptol/Eval/Generic.hs | 52 ++++++++++++++++++------------------- 1 file changed, 25 insertions(+), 27 deletions(-) diff --git a/src/Cryptol/Eval/Generic.hs b/src/Cryptol/Eval/Generic.hs index f54cd3a06..ac86a8b79 100644 --- a/src/Cryptol/Eval/Generic.hs +++ b/src/Cryptol/Eval/Generic.hs @@ -1825,39 +1825,37 @@ errorV :: forall sym. TValue -> String -> SEval sym (GenValue sym) -errorV sym ty msg = - let err = cryUserError sym msg in - case ty of - -- bits - TVBit -> err - TVInteger -> err - TVIntMod _ -> err - TVRational -> err - TVArray{} -> err - TVFloat {} -> err - - -- sequences - TVSeq w ety - | isTBit ety -> return $ VWord w $ return $ LargeBitsVal w $ IndexSeqMap $ \_ -> err - | otherwise -> return $ VSeq w (IndexSeqMap $ \_ -> errorV sym ety msg) +errorV sym ty0 msg = + do stk <- sGetCallStack sym + loop stk ty0 + where + err stk = sModifyCallStack sym (\_ -> stk) (cryUserError sym msg) - TVStream ety -> - return $ VStream (IndexSeqMap $ \_ -> errorV sym ety msg) + loop stk = \case + TVBit -> err stk + TVInteger -> err stk + TVIntMod _ -> err stk + TVRational -> err stk + TVArray{} -> err stk + TVFloat {} -> err stk - -- functions - TVFun _ bty -> - lam sym (\ _ -> errorV sym bty msg) + -- sequences + TVSeq w ety + | isTBit ety -> return $ VWord w $ return $ LargeBitsVal w $ IndexSeqMap $ \_ -> err stk + | otherwise -> return $ VSeq w $ IndexSeqMap $ \_ -> loop stk ety - -- tuples - TVTuple tys -> - return $ VTuple (map (\t -> errorV sym t msg) tys) + TVStream ety -> return $ VStream $ IndexSeqMap $ \_ -> loop stk ety - -- records - TVRec fields -> - return $ VRecord $ fmap (\t -> errorV sym t msg) $ fields + -- functions + TVFun _ bty -> lam sym (\ _ -> loop stk bty) + + -- tuples + TVTuple tys -> return $ VTuple (map (\t -> loop stk t) tys) - TVAbstract {} -> err + -- records + TVRec fields -> return $ VRecord $ fmap (\t -> loop stk t) $ fields + TVAbstract {} -> err stk {-# INLINE valueToChar #-} From ec1ce3c91aeb1f450932bbc4669da49134fbf9e1 Mon Sep 17 00:00:00 2001 From: Rob Dockins Date: Sun, 6 Dec 2020 20:23:14 -0800 Subject: [PATCH 17/27] Don't print trivial position information --- src/Cryptol/Backend/Monad.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Cryptol/Backend/Monad.hs b/src/Cryptol/Backend/Monad.hs index 8a587f1a3..9e2565dea 100644 --- a/src/Cryptol/Backend/Monad.hs +++ b/src/Cryptol/Backend/Monad.hs @@ -111,7 +111,9 @@ type CallStack = Seq (Name, Range) displayCallStack :: CallStack -> Doc displayCallStack = vcat . map f . toList . Seq.reverse where - f (nm,rng) = pp nm <+> text "called at" <+> pp rng + f (nm,rng) + | rng == emptyRange = pp nm + | otherwise = pp nm <+> text "called at" <+> pp rng combineCallStacks :: CallStack {- ^ call stack of the application context -} -> From d60b4f00f5135a4f99a785ff31f7036ff040d9b8 Mon Sep 17 00:00:00 2001 From: Rob Dockins Date: Sun, 6 Dec 2020 20:24:56 -0800 Subject: [PATCH 18/27] Add range information for auto-generated errors when counterexamples/models are not avalaible. --- src/Cryptol/REPL/Command.hs | 30 ++++++++++++++++++------------ 1 file changed, 18 insertions(+), 12 deletions(-) diff --git a/src/Cryptol/REPL/Command.hs b/src/Cryptol/REPL/Command.hs index eb2ad3e3b..662aa0a32 100644 --- a/src/Cryptol/REPL/Command.hs +++ b/src/Cryptol/REPL/Command.hs @@ -74,7 +74,7 @@ import qualified Cryptol.Testing.Random as TestR import Cryptol.Parser (parseExprWith,parseReplWith,ParseError(),Config(..),defaultConfig ,parseModName,parseHelpName) -import Cryptol.Parser.Position (Position(..)) +import Cryptol.Parser.Position (Position(..),Range,emptyRange,HasLoc(..)) import qualified Cryptol.TypeCheck.AST as T import qualified Cryptol.TypeCheck.Error as T import qualified Cryptol.TypeCheck.Parseable as T @@ -639,6 +639,7 @@ safeCmd str pos fnm = do fileName <- getKnownUser "smtfile" let mfile = if fileName == "-" then Nothing else Just fileName pexpr <- replParseExpr str pos fnm + let rng = fromMaybe emptyRange (getLoc pexpr) if proverName `elem` ["offline","sbv-offline","w4-offline"] then offlineProveSat proverName SafetyQuery pexpr mfile @@ -657,7 +658,7 @@ safeCmd str pos fnm = do let tes = map ( \(t,e,_) -> (t,e)) tevs vs = map ( \(_,_,v) -> v) tevs - (t,e) <- mkSolverResult "counterexample" False (Right tes) + (t,e) <- mkSolverResult "counterexample" rng False (Right tes) ~(EnvBool yes) <- getUser "show-examples" when yes $ printCounterexample cexType pexpr vs @@ -696,6 +697,7 @@ cmdProveSat isSat str pos fnm = do fileName <- getKnownUser "smtfile" let mfile = if fileName == "-" then Nothing else Just fileName pexpr <- replParseExpr str pos fnm + let rng = fromMaybe emptyRange (getLoc pexpr) if proverName `elem` ["offline","sbv-offline","w4-offline"] then offlineProveSat proverName qtype pexpr mfile @@ -709,7 +711,7 @@ cmdProveSat isSat str pos fnm = do ThmResult ts -> do rPutStrLn (if isSat then "Unsatisfiable" else "Q.E.D.") - (t, e) <- mkSolverResult cexStr (not isSat) (Left ts) + (t, e) <- mkSolverResult cexStr rng (not isSat) (Left ts) void $ bindItVariable t e CounterExample cexType tevs -> do @@ -717,7 +719,7 @@ cmdProveSat isSat str pos fnm = do let tes = map ( \(t,e,_) -> (t,e)) tevs vs = map ( \(_,_,v) -> v) tevs - (t,e) <- mkSolverResult cexStr isSat (Right tes) + (t,e) <- mkSolverResult cexStr rng isSat (Right tes) ~(EnvBool yes) <- getUser "show-examples" when yes $ printCounterexample cexType pexpr vs @@ -734,7 +736,7 @@ cmdProveSat isSat str pos fnm = do rPutStrLn "Satisfiable" let tess = map (map $ \(t,e,_) -> (t,e)) tevss vss = map (map $ \(_,_,v) -> v) tevss - resultRecs <- mapM (mkSolverResult cexStr isSat . Right) tess + resultRecs <- mapM (mkSolverResult cexStr rng isSat . Right) tess let collectTes tes = (t, es) where (ts, es) = unzip tes @@ -875,13 +877,15 @@ rIdent = M.packIdent "result" -- | Make a type/expression pair that is suitable for binding to @it@ -- after running @:sat@ or @:prove@ -mkSolverResult :: String - -> Bool - -> Either [T.Type] [(T.Type, T.Expr)] - -> REPL (T.Type, T.Expr) -mkSolverResult thing result earg = +mkSolverResult :: + String -> + Range -> + Bool -> + Either [T.Type] [(T.Type, T.Expr)] -> + REPL (T.Type, T.Expr) +mkSolverResult thing rng result earg = do prims <- getPrimMap - let addError t = (t, T.eError prims t ("no " ++ thing ++ " available")) + let addError t = (t, T.ELocated rng (T.eError prims t ("no " ++ thing ++ " available"))) argF = case earg of Left ts -> mkArgs (map addError ts) @@ -1680,6 +1684,7 @@ replEvalExpr expr = do (_,def,sig) <- replCheckExpr expr validEvalContext def validEvalContext sig + me <- getModuleEnv let cfg = M.meSolverConfig me mbDef <- io $ SMT.withSolver cfg (\s -> defaultReplExpr s def sig) @@ -1692,12 +1697,13 @@ replEvalExpr expr = let su = T.listParamSubst tys return (def1, T.apSubst su (T.sType sig)) + whenDebug (rPutStrLn (dump def1)) + -- add "it" to the namespace via a new declaration itVar <- bindItVariable ty def1 -- evaluate the it variable val <- liftModuleCmd (rethrowEvalError . M.evalExpr (T.EVar itVar)) - whenDebug (rPutStrLn (dump def1)) return (val,ty) where warnDefaults ts = From cec83cc098bcd0d4c6bf00f097d63438ac0a5e81 Mon Sep 17 00:00:00 2001 From: Rob Dockins Date: Sun, 6 Dec 2020 20:28:09 -0800 Subject: [PATCH 19/27] Updates to test results --- tests/issues/issue066.icry.stdout | 4 ++++ tests/issues/issue103.icry.stdout | 9 +++++++-- tests/issues/issue211.icry.stdout | 1 - tests/issues/issue413.icry.stdout | 5 ++--- tests/issues/issue861.icry.stdout | 8 -------- tests/regression/safety.icry.stdout | 11 ++++++----- 6 files changed, 19 insertions(+), 19 deletions(-) diff --git a/tests/issues/issue066.icry.stdout b/tests/issues/issue066.icry.stdout index 6fa1d21ec..5503ed6bf 100644 --- a/tests/issues/issue066.icry.stdout +++ b/tests/issues/issue066.icry.stdout @@ -3,6 +3,8 @@ Q.E.D. it : {result : Bit, arg1 : [4]} Run-time error: no counterexample available +-- Backtrace -- +Cryptol::error called at issue066.icry:2:8--2:9 True Counterexample f 0xc = False @@ -18,6 +20,8 @@ Unsatisfiable it : {result : Bit, arg1 : [4]} Run-time error: no satisfying assignment available +-- Backtrace -- +Cryptol::error called at issue066.icry:16:6--16:7 Counterexample g {x = 0xffffffff, y = 0x00000000} = False it : {result : Bit, arg1 : {x : [32], y : [32]}} diff --git a/tests/issues/issue103.icry.stdout b/tests/issues/issue103.icry.stdout index 3dcc72ee0..9e5c83480 100644 --- a/tests/issues/issue103.icry.stdout +++ b/tests/issues/issue103.icry.stdout @@ -1,9 +1,14 @@ Loading module Cryptol Run-time error: undefined -at Cryptol:951:13--951:18 +-- Backtrace -- +Cryptol::error called at Cryptol:951:13--951:18 +Cryptol::undefined called at issue103.icry:1:9--1:18 Using exhaustive testing. Testing... ERROR for the following inputs: () invalid sequence index: 1 -at issue103.icry:2:11--2:21 +-- Backtrace -- +(Cryptol::@) called at issue103.icry:2:11--2:21 +::f called at issue103.icry:3:9--3:10 +::it diff --git a/tests/issues/issue211.icry.stdout b/tests/issues/issue211.icry.stdout index f3435082c..d5dd3aa13 100644 --- a/tests/issues/issue211.icry.stdout +++ b/tests/issues/issue211.icry.stdout @@ -4,7 +4,6 @@ Loading module Cryptol 0x0 Run-time error: boom -at issue211.icry:4:28--4:33 -- Backtrace -- Cryptol::error called at issue211.icry:4:28--4:33 Cryptol::splitAt called at issue211.icry:4:2--4:9 diff --git a/tests/issues/issue413.icry.stdout b/tests/issues/issue413.icry.stdout index 2515f0c57..8fe90bbb2 100644 --- a/tests/issues/issue413.icry.stdout +++ b/tests/issues/issue413.icry.stdout @@ -1,14 +1,13 @@ Loading module Cryptol division by 0 -at issue413.icry:1:1--1:10 +-- Backtrace -- +(Cryptol::/) called at issue413.icry:1:1--1:10 division by 0 -at issue413.icry:2:1--2:5 -- Backtrace -- Cryptol::pdiv called at issue413.icry:2:1--2:5 division by 0 -at issue413.icry:3:1--3:5 -- Backtrace -- Cryptol::pmod called at issue413.icry:3:1--3:5 diff --git a/tests/issues/issue861.icry.stdout b/tests/issues/issue861.icry.stdout index 745bda47c..cd98e113e 100644 --- a/tests/issues/issue861.icry.stdout +++ b/tests/issues/issue861.icry.stdout @@ -4,12 +4,10 @@ Loading module Cryptol 2 invalid sequence index: 3 -at issue861.icry:7:1--7:5 -- Backtrace -- (Cryptol::@) called at issue861.icry:7:1--7:5 invalid sequence index: -1 -at issue861.icry:8:1--8:8 -- Backtrace -- (Cryptol::@) called at issue861.icry:8:1--8:8 2 @@ -17,12 +15,10 @@ at issue861.icry:8:1--8:8 0 invalid sequence index: 3 -at issue861.icry:13:1--13:5 -- Backtrace -- (Cryptol::!) called at issue861.icry:13:1--13:5 invalid sequence index: -1 -at issue861.icry:14:1--14:8 -- Backtrace -- (Cryptol::!) called at issue861.icry:14:1--14:8 [5, 1, 2] @@ -30,12 +26,10 @@ at issue861.icry:14:1--14:8 [0, 1, 5] invalid sequence index: 3 -at issue861.icry:19:1--19:7 -- Backtrace -- Cryptol::update called at issue861.icry:19:1--19:7 invalid sequence index: -1 -at issue861.icry:20:1--20:7 -- Backtrace -- Cryptol::update called at issue861.icry:20:1--20:7 [0, 1, 5] @@ -43,11 +37,9 @@ Cryptol::update called at issue861.icry:20:1--20:7 [5, 1, 2] invalid sequence index: 3 -at issue861.icry:25:1--25:10 -- Backtrace -- Cryptol::updateEnd called at issue861.icry:25:1--25:10 invalid sequence index: -1 -at issue861.icry:26:1--26:10 -- Backtrace -- Cryptol::updateEnd called at issue861.icry:26:1--26:10 diff --git a/tests/regression/safety.icry.stdout b/tests/regression/safety.icry.stdout index aafa9378c..7332ee27e 100644 --- a/tests/regression/safety.icry.stdout +++ b/tests/regression/safety.icry.stdout @@ -2,22 +2,23 @@ Loading module Cryptol Counterexample (\x -> assert x "asdf" "asdf") False ~> ERROR Run-time error: asdf -at Cryptol:959:41--959:46 +-- Backtrace -- +Cryptol::error called at Cryptol:959:41--959:46 +Cryptol::assert called at safety.icry:3:14--3:20 +::it Counterexample (\(x : [4]) -> [0 .. 14] @ x == x) 0xf ~> ERROR invalid sequence index: 15 -at safety.icry:4:20--4:34 -- Backtrace -- (Cryptol::@) called at safety.icry:4:20--4:34 (Cryptol::==) called at safety.icry:4:20--4:34 -::it called at :1:1--1:1 +::it Counterexample (\y -> (10 : Integer) / y) 0 ~> ERROR division by 0 -at safety.icry:5:14--5:30 -- Backtrace -- (Cryptol::/) called at safety.icry:5:14--5:30 -::it called at :1:1--1:1 +::it Safe Safe Safe From bdfefd5e929ca9c9ad2f65cae7b790dbef27916e Mon Sep 17 00:00:00 2001 From: Rob Dockins Date: Sun, 6 Dec 2020 20:28:48 -0800 Subject: [PATCH 20/27] squash a warning --- src/Cryptol/Symbolic/SBV.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Cryptol/Symbolic/SBV.hs b/src/Cryptol/Symbolic/SBV.hs index 4f2aa77f4..816679596 100644 --- a/src/Cryptol/Symbolic/SBV.hs +++ b/src/Cryptol/Symbolic/SBV.hs @@ -425,7 +425,7 @@ processResults ProverCommand{..} ts results = -- solver that completes the given query (if any) along with the result -- of executing the query. satProve :: SBVProverConfig -> ProverCommand -> M.ModuleCmd (Maybe String, ProverResult) -satProve proverCfg pc@ProverCommand {..} = +satProve proverCfg pc = protectStack proverError $ \(evo, byteReader, modEnv) -> M.runModuleM (evo, byteReader, modEnv) $ do From f533b23de8e5443558f5e09331c4c0bf03e07386 Mon Sep 17 00:00:00 2001 From: Rob Dockins Date: Mon, 7 Dec 2020 12:13:46 -0800 Subject: [PATCH 21/27] Be more precise about propigating call stacks in a few places --- src/Cryptol/Eval.hs | 39 ++++++++++++++++++++++--------------- src/Cryptol/Eval/Generic.hs | 37 ++++++++++++++++++----------------- src/Cryptol/Eval/Value.hs | 35 ++++++++++++++++++--------------- src/Cryptol/Eval/What4.hs | 4 ++-- 4 files changed, 63 insertions(+), 52 deletions(-) diff --git a/src/Cryptol/Eval.hs b/src/Cryptol/Eval.hs index 8932dd88d..2c6354403 100644 --- a/src/Cryptol/Eval.hs +++ b/src/Cryptol/Eval.hs @@ -214,6 +214,9 @@ evalExpr sym env expr = case expr of ppV = ppValue sym defaultPPOpts +-- | Capure the current call stack from the evaluation monad and +-- annotate function values. When arguments are later applied +-- to the function, the call stacks will be combined together. cacheCallStack :: Backend sym => sym -> @@ -229,6 +232,8 @@ cacheCallStack sym v = case v of VNumPoly fnstk f -> do stk <- sGetCallStack sym pure (VNumPoly (combineCallStacks stk fnstk) f) + + -- non-function types don't get annotated _ -> pure v -- Newtypes -------------------------------------------------------------------- @@ -390,7 +395,7 @@ etaWord :: SEval sym (WordValue sym) etaWord sym n val = do w <- sDelay sym (fromWordVal "during eta-expansion" =<< val) - xs <- memoMap $ IndexSeqMap $ \i -> + xs <- memoMap sym $ IndexSeqMap $ \i -> do w' <- w; VBit <$> indexWordValue sym w' i pure $ LargeBitsVal n xs @@ -417,7 +422,9 @@ etaDelay :: SEval sym (GenValue sym) etaDelay sym env0 Forall{ sVars = vs0, sType = tp0 } = goTpVars env0 vs0 where - goTpVars env [] val = go (evalValType (envTypes env) tp0) val + goTpVars env [] val = + do stk <- sGetCallStack sym + go stk (evalValType (envTypes env) tp0) val goTpVars env (v:vs) val = case tpKind v of KType -> tlam sym $ \t -> @@ -426,7 +433,7 @@ etaDelay sym env0 Forall{ sVars = vs0, sType = tp0 } = goTpVars env0 vs0 goTpVars (bindType (tpVar v) (Left n) env) vs ( ($n) . fromVNumPoly sym =<< val ) k -> panic "[Eval] etaDelay" ["invalid kind on type abstraction", show k] - go tp x | isReady sym x = x >>= \case + go stk tp x | isReady sym x = x >>= \case VBit{} -> x VInteger{} -> x VWord{} -> x @@ -434,24 +441,24 @@ etaDelay sym env0 Forall{ sVars = vs0, sType = tp0 } = goTpVars env0 vs0 VFloat{} -> x VSeq n xs -> case tp of - TVSeq _nt el -> return $ VSeq n $ IndexSeqMap $ \i -> go el (lookupSeqMap xs i) + TVSeq _nt el -> return $ VSeq n $ IndexSeqMap $ \i -> go stk el (lookupSeqMap xs i) _ -> evalPanic "type mismatch during eta-expansion" ["Expected sequence type, but got " ++ show tp] VStream xs -> case tp of - TVStream el -> return $ VStream $ IndexSeqMap $ \i -> go el (lookupSeqMap xs i) + TVStream el -> return $ VStream $ IndexSeqMap $ \i -> go stk el (lookupSeqMap xs i) _ -> evalPanic "type mismatch during eta-expansion" ["Expected stream type, but got " ++ show tp] VTuple xs -> case tp of - TVTuple ts | length ts == length xs -> return $ VTuple (zipWith go ts xs) + TVTuple ts | length ts == length xs -> return $ VTuple (zipWith (go stk) ts xs) _ -> evalPanic "type mismatch during eta-expansion" ["Expected tuple type with " ++ show (length xs) ++ " elements, but got " ++ show tp] VRecord fs -> case tp of TVRec fts -> - do let res = zipRecords (\_ v t -> go t v) fs fts + do let res = zipRecords (\_ v t -> go stk t v) fs fts case res of Left (Left f) -> evalPanic "type mismatch during eta-expansion" ["missing field " ++ show f] Left (Right f) -> evalPanic "type mismatch during eta-expansion" ["unexpected field " ++ show f] @@ -460,7 +467,7 @@ etaDelay sym env0 Forall{ sVars = vs0, sType = tp0 } = goTpVars env0 vs0 f@VFun{} -> case tp of - TVFun _t1 t2 -> lam sym $ \a -> go t2 (fromVFun sym f a) + TVFun _t1 t2 -> lam sym $ \a -> go stk t2 (fromVFun sym f a) _ -> evalPanic "type mismatch during eta-expansion" ["Expected function type but got " ++ show tp] VPoly{} -> @@ -469,7 +476,7 @@ etaDelay sym env0 Forall{ sVars = vs0, sType = tp0 } = goTpVars env0 vs0 VNumPoly{} -> evalPanic "type mismatch during eta-expansion" ["Encountered numeric polymorphic value"] - go tp v = + go stk tp v = sModifyCallStack sym (\_ -> stk) $ case tp of TVBit -> v TVInteger -> v @@ -485,22 +492,22 @@ etaDelay sym env0 Forall{ sVars = vs0, sType = tp0 } = goTpVars env0 vs0 TVSeq n el -> do x' <- sDelay sym (fromSeq "during eta-expansion" =<< v) return $ VSeq n $ IndexSeqMap $ \i -> do - go el (flip lookupSeqMap i =<< x') + go stk el (flip lookupSeqMap i =<< x') TVStream el -> do x' <- sDelay sym (fromSeq "during eta-expansion" =<< v) return $ VStream $ IndexSeqMap $ \i -> - go el (flip lookupSeqMap i =<< x') + go stk el (flip lookupSeqMap i =<< x') TVFun _t1 t2 -> do v' <- sDelay sym (fromVFun sym <$> v) - lam sym $ \a -> go t2 ( ($a) =<< v' ) + lam sym $ \a -> go stk t2 ( ($a) =<< v' ) TVTuple ts -> do let n = length ts v' <- sDelay sym (fromVTuple <$> v) return $ VTuple $ - [ go t =<< (flip genericIndex i <$> v') + [ go stk t =<< (flip genericIndex i <$> v') | i <- [0..(n-1)] | t <- ts ] @@ -508,7 +515,7 @@ etaDelay sym env0 Forall{ sVars = vs0, sType = tp0 } = goTpVars env0 vs0 TVRec fs -> do v' <- sDelay sym (fromVRecord <$> v) let err f = evalPanic "expected record value with field" [show f] - let eta f t = go t =<< (fromMaybe (err f) . lookupField f <$> v') + let eta f t = go stk t =<< (fromMaybe (err f) . lookupField f <$> v') return $ VRecord (mapWithFieldName eta fs) TVAbstract {} -> v @@ -750,7 +757,7 @@ evalComp :: SEval sym (GenValue sym) evalComp sym env len elty body ms = do lenv <- mconcat <$> mapM (branchEnvs sym (toListEnv env)) ms - mkSeq len elty <$> memoMap (IndexSeqMap $ \i -> do + mkSeq len elty <$> memoMap sym (IndexSeqMap $ \i -> do evalExpr sym (evalListEnv lenv i) body) {-# SPECIALIZE branchEnvs :: @@ -793,7 +800,7 @@ evalMatch sym lenv m = case m of -- Select from a sequence of finite length. This causes us to 'stutter' -- through our previous choices `nLen` times. Nat nLen -> do - vss <- memoMap $ IndexSeqMap $ \i -> evalExpr sym (evalListEnv lenv i) expr + vss <- memoMap sym $ IndexSeqMap $ \i -> evalExpr sym (evalListEnv lenv i) expr let stutter xs = \i -> xs (i `div` nLen) let lenv' = lenv { leVars = fmap stutter (leVars lenv) } let vs i = do let (q, r) = i `divMod` nLen diff --git a/src/Cryptol/Eval/Generic.hs b/src/Cryptol/Eval/Generic.hs index ac86a8b79..9d1b981ca 100644 --- a/src/Cryptol/Eval/Generic.hs +++ b/src/Cryptol/Eval/Generic.hs @@ -217,13 +217,13 @@ ringBinary sym opw opi opz opq opfp = loop rw <- fromVWord sym "ringRight" r stk <- sGetCallStack sym return $ VWord w (WordVal <$> (sModifyCallStack sym (\_ -> stk) (opw w lw rw))) - | otherwise -> VSeq w <$> (join (zipSeqMap (loop a) <$> + | otherwise -> VSeq w <$> (join (zipSeqMap sym (loop a) <$> (fromSeq "ringBinary left" l) <*> (fromSeq "ringBinary right" r))) TVStream a -> -- streams - VStream <$> (join (zipSeqMap (loop a) <$> + VStream <$> (join (zipSeqMap sym (loop a) <$> (fromSeq "ringBinary left" l) <*> (fromSeq "ringBinary right" r))) @@ -300,10 +300,10 @@ ringUnary sym opw opi opz opq opfp = loop wx <- fromVWord sym "ringUnary" v stk <- sGetCallStack sym return $ VWord w (WordVal <$> sModifyCallStack sym (\_ -> stk) (opw w wx)) - | otherwise -> VSeq w <$> (mapSeqMap (loop a) =<< fromSeq "ringUnary" v) + | otherwise -> VSeq w <$> (mapSeqMap sym (loop a) =<< fromSeq "ringUnary" v) TVStream a -> - VStream <$> (mapSeqMap (loop a) =<< fromSeq "ringUnary" v) + VStream <$> (mapSeqMap sym (loop a) =<< fromSeq "ringUnary" v) -- functions TVFun _ ety -> @@ -1267,7 +1267,7 @@ wordValLogicOp :: wordValLogicOp _sym _ wop (WordVal w1) (WordVal w2) = WordVal <$> wop w1 w2 wordValLogicOp sym bop _ w1 w2 = LargeBitsVal (wordValueSize sym w1) <$> zs - where zs = memoMap $ IndexSeqMap $ \i -> join (op <$> (lookupSeqMap xs i) <*> (lookupSeqMap ys i)) + where zs = memoMap sym $ IndexSeqMap $ \i -> join (op <$> (lookupSeqMap xs i) <*> (lookupSeqMap ys i)) xs = asBitsMap sym w1 ys = asBitsMap sym w2 op x y = VBit <$> (bop (fromVBit x) (fromVBit y)) @@ -1318,12 +1318,12 @@ logicBinary sym opb opw = loop -- finite sequences | otherwise -> VSeq w <$> - (join (zipSeqMap (loop aty) <$> + (join (zipSeqMap sym (loop aty) <$> (fromSeq "logicBinary left" l) <*> (fromSeq "logicBinary right" r))) TVStream aty -> - VStream <$> (join (zipSeqMap (loop aty) <$> + VStream <$> (join (zipSeqMap sym (loop aty) <$> (fromSeq "logicBinary left" l) <*> (fromSeq "logicBinary right" r))) @@ -1347,12 +1347,13 @@ logicBinary sym opb opw = loop {-# INLINE wordValUnaryOp #-} wordValUnaryOp :: Backend sym => + sym -> (SBit sym -> SEval sym (SBit sym)) -> (SWord sym -> SEval sym (SWord sym)) -> WordValue sym -> SEval sym (WordValue sym) -wordValUnaryOp _ wop (WordVal w) = WordVal <$> (wop w) -wordValUnaryOp bop _ (LargeBitsVal n xs) = LargeBitsVal n <$> mapSeqMap f xs +wordValUnaryOp _ _ wop (WordVal w) = WordVal <$> (wop w) +wordValUnaryOp sym bop _ (LargeBitsVal n xs) = LargeBitsVal n <$> mapSeqMap sym f xs where f x = VBit <$> (bop (fromVBit x)) {-# SPECIALIZE logicUnary :: @@ -1386,16 +1387,16 @@ logicUnary sym opb opw = loop TVSeq w ety -- words | isTBit ety - -> do v <- sDelay sym (wordValUnaryOp opb opw =<< fromWordVal "logicUnary" val) + -> do v <- sDelay sym (wordValUnaryOp sym opb opw =<< fromWordVal "logicUnary" val) return $ VWord w v -- finite sequences | otherwise - -> VSeq w <$> (mapSeqMap (loop ety) =<< fromSeq "logicUnary" val) + -> VSeq w <$> (mapSeqMap sym (loop ety) =<< fromSeq "logicUnary" val) -- streams TVStream ety -> - VStream <$> (mapSeqMap (loop ety) =<< fromSeq "logicUnary" val) + VStream <$> (mapSeqMap sym (loop ety) =<< fromSeq "logicUnary" val) TVTuple etys -> do as <- mapM (sDelay sym) (fromVTuple val) @@ -1631,7 +1632,7 @@ barrelShifter sym shift_op = go | otherwise = do x_shft <- shift_op x (2 ^ length bs) - x' <- memoMap (mergeSeqMap sym b x_shft x) + x' <- memoMap sym (mergeSeqMap sym b x_shft x) go x' bs {-# INLINE shiftLeftReindex #-} @@ -1737,7 +1738,7 @@ intShifter :: Backend sym => SEval sym (GenValue sym) intShifter sym nm wop reindex m ix a xs idx = do let shiftOp vs shft = - memoMap $ IndexSeqMap $ \i -> + memoMap sym $ IndexSeqMap $ \i -> case reindex m i shft of Nothing -> zeroV sym a Just i' -> lookupSeqMap vs i' @@ -1773,7 +1774,7 @@ wordShifter :: Backend sym => SEval sym (GenValue sym) wordShifter sym nm wop reindex m a xs idx = let shiftOp vs shft = - memoMap $ IndexSeqMap $ \i -> + memoMap sym $ IndexSeqMap $ \i -> case reindex m i shft of Nothing -> zeroV sym a Just i' -> lookupSeqMap vs i' @@ -1899,7 +1900,7 @@ mergeWord :: Backend sym => mergeWord sym c (WordVal w1) (WordVal w2) = WordVal <$> iteWord sym c w1 w2 mergeWord sym c w1 w2 = - LargeBitsVal (wordValueSize sym w1) <$> memoMap (mergeSeqMap sym c (asBitsMap sym w1) (asBitsMap sym w2)) + LargeBitsVal (wordValueSize sym w1) <$> memoMap sym (mergeSeqMap sym c (asBitsMap sym w1) (asBitsMap sym w2)) {-# INLINE mergeWord' #-} mergeWord' :: Backend sym => @@ -1938,8 +1939,8 @@ mergeValue sym c v1 v2 = (VInteger i1 , VInteger i2 ) -> VInteger <$> iteInteger sym c i1 i2 (VRational q1, VRational q2) -> VRational <$> iteRational sym c q1 q2 (VWord n1 w1 , VWord n2 w2 ) | n1 == n2 -> pure $ VWord n1 $ mergeWord' sym c w1 w2 - (VSeq n1 vs1 , VSeq n2 vs2 ) | n1 == n2 -> VSeq n1 <$> memoMap (mergeSeqMap sym c vs1 vs2) - (VStream vs1 , VStream vs2 ) -> VStream <$> memoMap (mergeSeqMap sym c vs1 vs2) + (VSeq n1 vs1 , VSeq n2 vs2 ) | n1 == n2 -> VSeq n1 <$> memoMap sym (mergeSeqMap sym c vs1 vs2) + (VStream vs1 , VStream vs2 ) -> VStream <$> memoMap sym (mergeSeqMap sym c vs1 vs2) (f1@VFun{} , f2@VFun{} ) -> lam sym $ \x -> mergeValue' sym c (fromVFun sym f1 x) (fromVFun sym f2 x) (f1@VPoly{} , f2@VPoly{} ) -> tlam sym $ \x -> mergeValue' sym c (fromVPoly sym f1 x) (fromVPoly sym f2 x) (_ , _ ) -> panic "Cryptol.Eval.Generic" diff --git a/src/Cryptol/Eval/Value.hs b/src/Cryptol/Eval/Value.hs index e0785621e..541e46a0a 100644 --- a/src/Cryptol/Eval/Value.hs +++ b/src/Cryptol/Eval/Value.hs @@ -144,10 +144,10 @@ finiteSeqMap xs = (\i -> panic "finiteSeqMap" ["Out of bounds access of finite seq map", "length: " ++ show (length xs), show i]) -- | Generate an infinite sequence map from a stream of values -infiniteSeqMap :: Backend sym => [SEval sym (GenValue sym)] -> SEval sym (SeqMap sym) -infiniteSeqMap xs = +infiniteSeqMap :: Backend sym => sym -> [SEval sym (GenValue sym)] -> SEval sym (SeqMap sym) +infiniteSeqMap sym xs = -- TODO: use an int-trie? - memoMap (IndexSeqMap $ \i -> genericIndex xs i) + memoMap sym (IndexSeqMap $ \i -> genericIndex xs i) -- | Create a finite list of length @n@ of the values from @[0..n-1]@ in -- the given the sequence emap. @@ -193,17 +193,18 @@ dropSeqMap n xs = IndexSeqMap $ \i -> lookupSeqMap xs (i+n) -- | Given a sequence map, return a new sequence map that is memoized using -- a finite map memo table. -memoMap :: (MonadIO m, Backend sym) => SeqMap sym -> m (SeqMap sym) -memoMap x = do +memoMap :: Backend sym => sym -> SeqMap sym -> SEval sym (SeqMap sym) +memoMap sym x = do + stk <- sGetCallStack sym cache <- liftIO $ newIORef $ Map.empty - return $ IndexSeqMap (memo cache) + return $ IndexSeqMap (memo cache stk) where - memo cache i = do + memo cache stk i = do mz <- liftIO (Map.lookup i <$> readIORef cache) case mz of Just z -> return z - Nothing -> doEval cache i + Nothing -> sModifyCallStack sym (\_ -> stk) (doEval cache i) doEval cache i = do v <- lookupSeqMap x i @@ -214,20 +215,22 @@ memoMap x = do -- sequence maps. zipSeqMap :: Backend sym => + sym -> (GenValue sym -> GenValue sym -> SEval sym (GenValue sym)) -> SeqMap sym -> SeqMap sym -> SEval sym (SeqMap sym) -zipSeqMap f x y = - memoMap (IndexSeqMap $ \i -> join (f <$> lookupSeqMap x i <*> lookupSeqMap y i)) +zipSeqMap sym f x y = + memoMap sym (IndexSeqMap $ \i -> join (f <$> lookupSeqMap x i <*> lookupSeqMap y i)) -- | Apply the given function to each value in the given sequence map mapSeqMap :: Backend sym => + sym -> (GenValue sym -> SEval sym (GenValue sym)) -> SeqMap sym -> SEval sym (SeqMap sym) -mapSeqMap f x = - memoMap (IndexSeqMap $ \i -> f =<< lookupSeqMap x i) +mapSeqMap sym f x = + memoMap sym (IndexSeqMap $ \i -> f =<< lookupSeqMap x i) -- | For efficiency reasons, we handle finite sequences of bits as special cases -- in the evaluator. In cases where we know it is safe to do so, we prefer to @@ -440,9 +443,9 @@ ilam sym f = Inf -> panic "ilam" [ "Unexpected `inf`" ]) -- | Generate a stream. -toStream :: Backend sym => [GenValue sym] -> SEval sym (GenValue sym) -toStream vs = - VStream <$> infiniteSeqMap (map pure vs) +toStream :: Backend sym => sym -> [GenValue sym] -> SEval sym (GenValue sym) +toStream sym vs = + VStream <$> infiniteSeqMap sym (map pure vs) toFinSeq :: Backend sym => @@ -458,7 +461,7 @@ toSeq :: sym -> Nat' -> TValue -> [GenValue sym] -> SEval sym (GenValue sym) toSeq sym len elty vals = case len of Nat n -> return $ toFinSeq sym n elty vals - Inf -> toStream vals + Inf -> toStream sym vals -- | Construct either a finite sequence, or a stream. In the finite case, diff --git a/src/Cryptol/Eval/What4.hs b/src/Cryptol/Eval/What4.hs index b55ed101d..84c2ea8b4 100644 --- a/src/Cryptol/Eval/What4.hs +++ b/src/Cryptol/Eval/What4.hs @@ -759,7 +759,7 @@ updateFrontSym sym _len _eltTy vs (Right wv) val = WordVal w | Just j <- SW.bvAsUnsignedInteger w -> return $ updateSeqMap vs j val _ -> - memoMap $ IndexSeqMap $ \i -> + memoMap sym $ IndexSeqMap $ \i -> do b <- wordValueEqualsInteger sym wv i iteValue sym b val (lookupSeqMap vs i) @@ -786,7 +786,7 @@ updateBackSym sym (Nat n) _eltTy vs (Right wv) val = WordVal w | Just j <- SW.bvAsUnsignedInteger w -> return $ updateSeqMap vs (n - 1 - j) val _ -> - memoMap $ IndexSeqMap $ \i -> + memoMap sym $ IndexSeqMap $ \i -> do b <- wordValueEqualsInteger sym wv (n - 1 - i) iteValue sym b val (lookupSeqMap vs i) From 105466bbd47c55895f9c28ebf9a757f2e228ab65 Mon Sep 17 00:00:00 2001 From: Rob Dockins Date: Mon, 7 Dec 2020 14:12:10 -0800 Subject: [PATCH 22/27] Add comments and minor cleanups --- src/Cryptol/Backend.hs | 8 +++---- src/Cryptol/Backend/Monad.hs | 43 +++++++++++++++++++++++------------- src/Cryptol/Eval/Concrete.hs | 10 ++++----- src/Cryptol/Eval/Prims.hs | 5 +++++ src/Cryptol/Eval/Value.hs | 1 + 5 files changed, 43 insertions(+), 24 deletions(-) diff --git a/src/Cryptol/Backend.hs b/src/Cryptol/Backend.hs index dddecfad2..2b8d5925c 100644 --- a/src/Cryptol/Backend.hs +++ b/src/Cryptol/Backend.hs @@ -238,11 +238,14 @@ class MonadIO (SEval sym) => Backend sym where -- when forced. sSpark :: sym -> SEval sym a -> SEval sym (SEval sym a) + -- | Push a call frame on to the current call stack while evaluating the given action sPushFrame :: sym -> Name -> Range -> SEval sym a -> SEval sym a sPushFrame sym nm rng m = sModifyCallStack sym (pushCallFrame nm rng) m + -- | Apply the given function to the current call stack while evaluating the given action sModifyCallStack :: sym -> (CallStack -> CallStack) -> SEval sym a -> SEval sym a + -- | Retrieve the current evaluation call stack sGetCallStack :: sym -> SEval sym CallStack -- | Merge the two given computations according to the predicate. @@ -339,9 +342,6 @@ class MonadIO (SEval sym) => Backend sym where -- ==== Word operations ==== - -- TODO, add error handling to wordBit and wordUpdate - - -- | Extract the numbered bit from the word. -- -- NOTE: this assumes that the sequence of bits is big-endian and finite, so the @@ -680,7 +680,7 @@ class MonadIO (SEval sym) => Backend sym where SInteger sym -> SEval sym (SBit sym) - -- | Multiplicitive inverse in (Z n). + -- | Multiplicative inverse in (Z n). -- PRECONDITION: the modulus is a prime znRecip :: sym -> diff --git a/src/Cryptol/Backend/Monad.hs b/src/Cryptol/Backend/Monad.hs index 9e2565dea..ff22c8b18 100644 --- a/src/Cryptol/Backend/Monad.hs +++ b/src/Cryptol/Backend/Monad.hs @@ -49,7 +49,6 @@ import Control.Concurrent import Control.Concurrent.STM import Control.Monad -import qualified Control.Monad.Fail as Fail import Control.Monad.Fix import Control.Monad.IO.Class import Data.Foldable (toList) @@ -82,7 +81,7 @@ asciiMode :: PPOpts -> Integer -> Bool asciiMode opts width = useAscii opts && (width == 7 || width == 8) data PPFloatFormat = - FloatFixed Int PPFloatExp -- ^ Use this many significant digis + FloatFixed Int PPFloatExp -- ^ Use this many significant digits | FloatFrac Int -- ^ Show this many digits after floating point | FloatFree PPFloatExp -- ^ Use the correct number of digits @@ -97,7 +96,7 @@ defaultPPOpts = PPOpts { useAscii = False, useBase = 10, useInfLength = 5 } --- | Some options for evalutaion +-- | Some options for evaluation data EvalOpts = EvalOpts { evalLogger :: Logger -- ^ Where to print stuff (e.g., for @trace@) , evalPPOpts :: PPOpts -- ^ How to pretty print things. @@ -108,6 +107,8 @@ data EvalOpts = EvalOpts -- New frames are pushed onto the right side of the sequence. type CallStack = Seq (Name, Range) +-- | Pretty print a call stack with each call frame on a separate +-- line, with most recent call frames at the top. displayCallStack :: CallStack -> Doc displayCallStack = vcat . map f . toList . Seq.reverse where @@ -115,6 +116,20 @@ displayCallStack = vcat . map f . toList . Seq.reverse | rng == emptyRange = pp nm | otherwise = pp nm <+> text "called at" <+> pp rng + +-- | Combine the call stack of a function value with the call +-- stack of the current calling context. This algorithm is +-- the same one GHC uses to compute profiling calling contexts. +-- +-- The algorithm is as follows. +-- +-- ccs ++> ccsfn = ccs ++ dropCommonPrefix ccs ccsfn +-- +-- where +-- +-- dropCommonPrefix A B +-- -- returns the suffix of B after removing any prefix common +-- -- to both A and B. combineCallStacks :: CallStack {- ^ call stack of the application context -} -> CallStack {- ^ call stack of the function being applied -} -> @@ -127,6 +142,7 @@ combineCallStacks appstk fnstk = appstk <> dropCommonPrefix appstk fnstk | a == f = dropCommonPrefix as fs | otherwise = xs +-- | Add a call frame to the top of a call stack pushCallFrame :: Name -> Range -> CallStack -> CallStack pushCallFrame nm rng stk@( _ Seq.:|> (nm',rng')) | nm == nm', rng == rng' = stk @@ -150,7 +166,7 @@ data Eval a -- cryptol expression that is bound to a name, and is not -- already obviously a value (and in a few other places as -- well) will get turned into a thunk in order to avoid --- recomputations. These thunks will start in the `Unforced` +-- recomputation. These thunks will start in the `Unforced` -- state, and have a backup computation that just raises -- the `LoopError` exception. -- @@ -172,15 +188,15 @@ data Eval a data ThunkState a = Void !String -- ^ This thunk has not yet been initialized - | Unforced !(IO a) !(Maybe (IO a)) String CallStack + | Unforced !(IO a) !(Maybe (IO a)) !String !CallStack -- ^ This thunk has not yet been forced. We keep track of the "main" - -- computation to run and a "backup" computation to run if we + -- computation to run and an optional "backup" computation to run if we -- detect a tight loop when evaluating the first one. -- The final two arguments are used to throw a loop exception -- if the backup computation also causes a tight loop. - | UnderEvaluation !ThreadId !(Maybe (IO a)) String CallStack + | UnderEvaluation !ThreadId !(Maybe (IO a)) !String !CallStack -- ^ This thunk is currently being evaluated by the thread with the given - -- thread ID. We track the "backup" computation to run if we detect + -- thread ID. We track an optional "backup" computation to run if we detect -- a tight loop evaluating this thunk. If the thunk is being evaluated -- by some other thread, the current thread will await its completion. -- The final two arguments are used to throw a loop exception @@ -211,7 +227,7 @@ maybeReady (Eval _) = pure Nothing delayFill :: Eval a {- ^ Computation to delay -} -> Maybe (Eval a) {- ^ Optional backup computation to run if a tight loop is detected -} -> - String {- ^ message for the <> exceprion if a tight loop is detecrted -} -> + String {- ^ message for the <> exception if a tight loop is detected -} -> Eval (Eval a) delayFill e@(Ready _) _ _ = return e delayFill e@(Thunk _) _ _ = return e @@ -249,7 +265,7 @@ evalSpark (Eval x) = Eval $ \stk -> -- | To the work of forcing a thunk. This is the worker computation --- that is foked off via @evalSpark@. +-- that is forked off via @evalSpark@. sparkThunk :: TVar (ThunkState a) -> IO () sparkThunk tv = do tid <- myThreadId @@ -315,7 +331,7 @@ unDelay tv = case backup of Just _ -> writeTVar tv (UnderEvaluation tid Nothing msg stk) Nothing -> writeTVar tv (ForcedErr (EvalErrorEx stk (LoopError msg))) - | otherwise -> retry -- wait, if some other thread is evaualting + | otherwise -> retry -- wait, if some other thread is evaluating _ -> return () -- Return the original thunk state so we can decide what work to do @@ -358,7 +374,7 @@ modifyCallStack f m = -- | Execute the given evaluation action. runEval :: CallStack -> Eval a -> IO a -runEval _ (Ready a) = return a +runEval _ (Ready a) = return a runEval stk (Eval x) = x stk runEval _ (Thunk tv) = unDelay tv @@ -386,9 +402,6 @@ instance Monad Eval where {-# INLINE return #-} {-# INLINE (>>=) #-} -instance Fail.MonadFail Eval where - fail x = Eval (\_stk -> fail x) - instance MonadIO Eval where liftIO = io diff --git a/src/Cryptol/Eval/Concrete.hs b/src/Cryptol/Eval/Concrete.hs index f8a91d067..28c7c0e9f 100644 --- a/src/Cryptol/Eval/Concrete.hs +++ b/src/Cryptol/Eval/Concrete.hs @@ -25,7 +25,7 @@ module Cryptol.Eval.Concrete , toExpr ) where -import Control.Monad (guard, zipWithM, foldM) +import Control.Monad (guard, zipWithM, foldM, mzero) import Data.Bits (Bits(..)) import Data.Ratio((%),numerator,denominator) import Data.Word(Word32, Word64) @@ -104,10 +104,10 @@ toExpr prims t0 v0 = findOne (go t0 v0) VWord _ wval -> do BV _ v <- lift (asWordVal Concrete =<< wval) pure $ ETApp (ETApp (prim "number") (tNum v)) ty - VStream _ -> fail "cannot construct infinite expressions" - VFun{} -> fail "cannot convert function values to expressions" - VPoly{} -> fail "cannot convert polymorphic values to expressions" - VNumPoly{} -> fail "cannot convert polymorphic values to expressions" + VStream _ -> mzero + VFun{} -> mzero + VPoly{} -> mzero + VNumPoly{} -> mzero where mismatch :: forall a. ChoiceT Eval a mismatch = diff --git a/src/Cryptol/Eval/Prims.hs b/src/Cryptol/Eval/Prims.hs index 324733238..ba07a2bb0 100644 --- a/src/Cryptol/Eval/Prims.hs +++ b/src/Cryptol/Eval/Prims.hs @@ -9,6 +9,10 @@ import Cryptol.ModuleSystem.Name import Cryptol.TypeCheck.Solver.InfNat(Nat'(..)) import Cryptol.Utils.Panic +-- | This type provides a lightweight syntactic framework for defining +-- Cryptol primitives. The main purpose of this type is to provide +-- an abstraction barrier that insulates the definitions of primitives +-- from possible changes in the representation of values. data Prim sym = PFun (SEval sym (GenValue sym) -> Prim sym) | PStrict (GenValue sym -> Prim sym) @@ -20,6 +24,7 @@ data Prim sym | PPrim (SEval sym (GenValue sym)) | PVal (GenValue sym) +-- | Evaluate a primitive into a value computation evalPrim :: Backend sym => sym -> Name -> Prim sym -> SEval sym (GenValue sym) evalPrim sym nm p = case p of PFun f -> lam sym (evalPrim sym nm . f) diff --git a/src/Cryptol/Eval/Value.hs b/src/Cryptol/Eval/Value.hs index 541e46a0a..e2c46fa73 100644 --- a/src/Cryptol/Eval/Value.hs +++ b/src/Cryptol/Eval/Value.hs @@ -419,6 +419,7 @@ word sym n i | otherwise = VWord n (WordVal <$> wordLit sym n i) +-- | Construct a function value lam :: Backend sym => sym -> (SEval sym (GenValue sym) -> SEval sym (GenValue sym)) -> SEval sym (GenValue sym) lam sym f = VFun <$> sGetCallStack sym <*> pure f From 1ae651a111f924be849cf3e49f74d15f5f612415 Mon Sep 17 00:00:00 2001 From: Rob Dockins Date: Tue, 8 Dec 2020 17:15:13 -0800 Subject: [PATCH 23/27] Add a new `--no-call-stacks` command line option that disables source location and call stack tracking. Computing call stacks, in particular, can add pretty significant interpreter overheads. --- cryptol/Main.hs | 10 ++++++++++ cryptol/REPL/Haskeline.hs | 6 +++--- src/Cryptol/Eval.hs | 18 +++++++++++------- src/Cryptol/Eval/Reference.lhs | 2 +- src/Cryptol/ModuleSystem.hs | 10 +++++----- src/Cryptol/ModuleSystem/Base.hs | 8 ++++++++ src/Cryptol/ModuleSystem/Monad.hs | 18 +++++++++++------- src/Cryptol/REPL/Command.hs | 3 ++- src/Cryptol/REPL/Monad.hs | 17 ++++++++++++----- src/Cryptol/Symbolic/SBV.hs | 13 ++++++++----- src/Cryptol/Symbolic/What4.hs | 14 ++++++++------ src/Cryptol/Transform/Specialize.hs | 4 ++-- src/Cryptol/TypeCheck.hs | 2 +- src/Cryptol/TypeCheck/Infer.hs | 9 +++++++-- src/Cryptol/TypeCheck/Monad.hs | 12 ++++++++++-- 15 files changed, 99 insertions(+), 47 deletions(-) diff --git a/cryptol/Main.hs b/cryptol/Main.hs index ef862dbae..a83ba7f5b 100644 --- a/cryptol/Main.hs +++ b/cryptol/Main.hs @@ -48,6 +48,7 @@ data Options = Options , optVersion :: Bool , optHelp :: Bool , optBatch :: Maybe FilePath + , optCallStacks :: Bool , optCommands :: [String] , optColorMode :: ColorMode , optCryptolrc :: Cryptolrc @@ -62,6 +63,7 @@ defaultOptions = Options , optVersion = False , optHelp = False , optBatch = Nothing + , optCallStacks = True , optCommands = [] , optColorMode = AutoColor , optCryptolrc = CryrcDefault @@ -95,6 +97,9 @@ options = , Option "h" ["help"] (NoArg setHelp) "display this message" + , Option "" ["no-call-stacks"] (NoArg setNoCallStacks) + "Disable tracking of call stack information, which reduces interpreter overhead" + , Option "" ["no-unicode-logo"] (NoArg setNoUnicodeLogo) "Don't use unicode characters in the REPL logo" @@ -149,6 +154,10 @@ setHelp = modify $ \ opts -> opts { optHelp = True } setCryrcDisabled :: OptParser Options setCryrcDisabled = modify $ \ opts -> opts { optCryptolrc = CryrcDisabled } +-- | Disable call stack tracking +setNoCallStacks :: OptParser Options +setNoCallStacks = modify $ \opts -> opts { optCallStacks = False } + -- | Add another file to read as a @.cryptolrc@ file, unless @.cryptolrc@ -- files have been disabled addCryrc :: String -> OptParser Options @@ -206,6 +215,7 @@ main = do (opts', mCleanup) <- setupCmdScript opts status <- repl (optCryptolrc opts') (optBatch opts') + (optCallStacks opts') (optStopOnError opts') (setupREPL opts') case mCleanup of diff --git a/cryptol/REPL/Haskeline.hs b/cryptol/REPL/Haskeline.hs index 587f798a2..4f704fe09 100644 --- a/cryptol/REPL/Haskeline.hs +++ b/cryptol/REPL/Haskeline.hs @@ -116,9 +116,9 @@ loadCryRC cryrc = _ -> return status -- | Haskeline-specific repl implementation. -repl :: Cryptolrc -> Maybe FilePath -> Bool -> REPL () -> IO CommandExitCode -repl cryrc mbBatch stopOnError begin = - runREPL (isJust mbBatch) stdoutLogger $ +repl :: Cryptolrc -> Maybe FilePath -> Bool -> Bool -> REPL () -> IO CommandExitCode +repl cryrc mbBatch callStacks stopOnError begin = + runREPL (isJust mbBatch) callStacks stdoutLogger $ do status <- loadCryRC cryrc case status of CommandOk -> begin >> crySession mbBatch stopOnError diff --git a/src/Cryptol/Eval.hs b/src/Cryptol/Eval.hs index 2c6354403..6d6c68539 100644 --- a/src/Cryptol/Eval.hs +++ b/src/Cryptol/Eval.hs @@ -67,9 +67,9 @@ import Prelude.Compat type EvalEnv = GenEvalEnv Concrete type EvalPrims sym = - ( Backend sym, ?evalPrim :: PrimIdent -> Maybe (Either Expr (Prim sym)) ) + ( Backend sym, ?callStacks :: Bool, ?evalPrim :: PrimIdent -> Maybe (Either Expr (Prim sym)) ) -type ConcPrims = ?evalPrim :: PrimIdent -> Maybe (Either Expr (Prim Concrete)) +type ConcPrims = (?callStacks :: Bool, ?evalPrim :: PrimIdent -> Maybe (Either Expr (Prim Concrete))) -- Expression Evaluation ------------------------------------------------------- @@ -161,11 +161,15 @@ evalExpr sym env expr = case expr of EVar n -> {-# SCC "evalExpr->EVar" #-} do case lookupVar n env of - Just (Left p) -> sPushFrame sym n ?range (cacheCallStack sym =<< evalPrim sym n p) - Just (Right val) -> - case nameInfo n of - Declared{} -> sPushFrame sym n ?range (cacheCallStack sym =<< val) - Parameter -> cacheCallStack sym =<< val + Just (Left p) + | ?callStacks -> sPushFrame sym n ?range (cacheCallStack sym =<< evalPrim sym n p) + | otherwise -> evalPrim sym n p + Just (Right val) + | ?callStacks -> + case nameInfo n of + Declared{} -> sPushFrame sym n ?range (cacheCallStack sym =<< val) + Parameter -> cacheCallStack sym =<< val + | otherwise -> val Nothing -> do envdoc <- ppEnv sym defaultPPOpts env panic "[Eval] evalExpr" diff --git a/src/Cryptol/Eval/Reference.lhs b/src/Cryptol/Eval/Reference.lhs index 62d070838..d0def3060 100644 --- a/src/Cryptol/Eval/Reference.lhs +++ b/src/Cryptol/Eval/Reference.lhs @@ -1692,7 +1692,7 @@ This module implements the core functionality of the `:eval running the reference evaluator on an expression. > evaluate :: Expr -> M.ModuleCmd (E Value) -> evaluate expr (_, _, modEnv) = return (Right (evalExpr env expr, modEnv), []) +> evaluate expr (_, _, _, modEnv) = return (Right (evalExpr env expr, modEnv), []) > where > extDgs = concatMap mDecls (M.loadedModules modEnv) > env = foldl evalDeclGroup mempty extDgs diff --git a/src/Cryptol/ModuleSystem.hs b/src/Cryptol/ModuleSystem.hs index d9b312b44..f558f73f3 100644 --- a/src/Cryptol/ModuleSystem.hs +++ b/src/Cryptol/ModuleSystem.hs @@ -50,7 +50,7 @@ import Data.ByteString (ByteString) -- Public Interface ------------------------------------------------------------ -type ModuleCmd a = (E.EvalOpts, FilePath -> IO ByteString, ModuleEnv) -> IO (ModuleRes a) +type ModuleCmd a = (Bool, E.EvalOpts, FilePath -> IO ByteString, ModuleEnv) -> IO (ModuleRes a) type ModuleRes a = (Either ModuleError (a,ModuleEnv), [ModuleWarning]) @@ -63,8 +63,8 @@ findModule n env = runModuleM env (Base.findModule n) -- | Load the module contained in the given file. loadModuleByPath :: FilePath -> ModuleCmd (ModulePath,T.Module) -loadModuleByPath path (evo, byteReader, env) = - runModuleM (evo, byteReader, resetModuleEnv env) $ do +loadModuleByPath path (callStacks, evo, byteReader, env) = + runModuleM (callStacks, evo, byteReader, resetModuleEnv env) $ do unloadModule ((InFile path ==) . lmFilePath) m <- Base.loadModuleByPath path setFocusedModule (T.mName m) @@ -72,8 +72,8 @@ loadModuleByPath path (evo, byteReader, env) = -- | Load the given parsed module. loadModuleByName :: P.ModName -> ModuleCmd (ModulePath,T.Module) -loadModuleByName n (evo, byteReader, env) = - runModuleM (evo, byteReader, resetModuleEnv env) $ do +loadModuleByName n (callStacks, evo, byteReader, env) = + runModuleM (callStacks, evo, byteReader, resetModuleEnv env) $ do unloadModule ((n ==) . lmName) (path,m') <- Base.loadModuleFrom False (FromModule n) setFocusedModule (T.mName m') diff --git a/src/Cryptol/ModuleSystem/Base.hs b/src/Cryptol/ModuleSystem/Base.hs index 802a6fe06..f9d6b533e 100644 --- a/src/Cryptol/ModuleSystem/Base.hs +++ b/src/Cryptol/ModuleSystem/Base.hs @@ -205,6 +205,8 @@ doLoadModule quiet isrc path fp pm0 = -- extend the eval env, unless a functor. tbl <- Concrete.primTable <$> getEvalOpts let ?evalPrim = \i -> Right <$> Map.lookup i tbl + callStacks <- getCallStacks + let ?callStacks = callStacks unless (T.isParametrizedModule tcm) $ modifyEvalEnv (E.moduleEnv Concrete tcm) loadedModule path fp tcm @@ -534,6 +536,7 @@ genInferInput r prims params env = do cfg <- getSolverConfig supply <- getSupply searchPath <- getSearchPath + callStacks <- getCallStacks -- TODO: include the environment needed by the module return T.InferInput @@ -544,6 +547,7 @@ genInferInput r prims params env = do , T.inpAbstractTypes = ifAbstractTypes env , T.inpNameSeeds = seeds , T.inpMonoBinds = monoBinds + , T.inpCallStacks = callStacks , T.inpSolverConfig = cfg , T.inpSearchPath = searchPath , T.inpSupply = supply @@ -565,6 +569,8 @@ evalExpr e = do let tbl = Concrete.primTable evopts let ?evalPrim = \i -> Right <$> Map.lookup i tbl let ?range = emptyRange + callStacks <- getCallStacks + let ?callStacks = callStacks io $ E.runEval mempty (E.evalExpr Concrete (env <> deEnv denv) e) evalDecls :: [T.DeclGroup] -> ModuleM () @@ -575,6 +581,8 @@ evalDecls dgs = do let env' = env <> deEnv denv let tbl = Concrete.primTable evOpts let ?evalPrim = \i -> Right <$> Map.lookup i tbl + callStacks <- getCallStacks + let ?callStacks = callStacks deEnv' <- io $ E.runEval mempty (E.evalDecls Concrete dgs env') let denv' = denv { deDecls = deDecls denv ++ dgs , deEnv = deEnv' diff --git a/src/Cryptol/ModuleSystem/Monad.hs b/src/Cryptol/ModuleSystem/Monad.hs index bfa42638a..833462105 100644 --- a/src/Cryptol/ModuleSystem/Monad.hs +++ b/src/Cryptol/ModuleSystem/Monad.hs @@ -301,12 +301,13 @@ renamerWarnings ws data RO m = RO { roLoading :: [ImportSource] , roEvalOpts :: EvalOpts + , roCallStacks :: Bool , roFileReader :: FilePath -> m ByteString } -emptyRO :: EvalOpts -> (FilePath -> m ByteString) -> RO m -emptyRO ev fileReader = - RO { roLoading = [], roEvalOpts = ev, roFileReader = fileReader } +emptyRO :: Bool -> EvalOpts -> (FilePath -> m ByteString) -> RO m +emptyRO callStacks ev fileReader = + RO { roLoading = [], roEvalOpts = ev, roCallStacks = callStacks, roFileReader = fileReader } newtype ModuleT m a = ModuleT { unModuleT :: ReaderT (RO m) @@ -352,19 +353,19 @@ instance MonadIO m => MonadIO (ModuleT m) where liftIO m = lift $ liftIO m runModuleT :: Monad m - => (EvalOpts, FilePath -> m ByteString, ModuleEnv) + => (Bool, EvalOpts, FilePath -> m ByteString, ModuleEnv) -> ModuleT m a -> m (Either ModuleError (a, ModuleEnv), [ModuleWarning]) -runModuleT (ev, byteReader, env) m = +runModuleT (callStacks, ev, byteReader, env) m = runWriterT $ runExceptionT $ runStateT env - $ runReaderT (emptyRO ev byteReader) + $ runReaderT (emptyRO callStacks ev byteReader) $ unModuleT m type ModuleM = ModuleT IO -runModuleM :: (EvalOpts, FilePath -> IO ByteString, ModuleEnv) -> ModuleM a +runModuleM :: (Bool, EvalOpts, FilePath -> IO ByteString, ModuleEnv) -> ModuleM a -> IO (Either ModuleError (a,ModuleEnv),[ModuleWarning]) runModuleM = runModuleT @@ -377,6 +378,9 @@ getByteReader = ModuleT $ do RO { roFileReader = readFileBytes } <- ask return readFileBytes +getCallStacks :: Monad m => ModuleT m Bool +getCallStacks = ModuleT (roCallStacks <$> ask) + readBytes :: Monad m => FilePath -> ModuleT m ByteString readBytes fn = do fileReader <- getByteReader diff --git a/src/Cryptol/REPL/Command.hs b/src/Cryptol/REPL/Command.hs index 662aa0a32..2a1077908 100644 --- a/src/Cryptol/REPL/Command.hs +++ b/src/Cryptol/REPL/Command.hs @@ -1611,7 +1611,8 @@ liftModuleCmd :: M.ModuleCmd a -> REPL a liftModuleCmd cmd = do evo <- getEvalOpts env <- getModuleEnv - moduleCmdResult =<< io (cmd (evo, BS.readFile, env)) + callStacks <- getCallStacks + moduleCmdResult =<< io (cmd (callStacks, evo, BS.readFile, env)) moduleCmdResult :: M.ModuleRes a -> REPL a moduleCmdResult (res,ws0) = do diff --git a/src/Cryptol/REPL/Monad.hs b/src/Cryptol/REPL/Monad.hs index fac336e15..040caf200 100644 --- a/src/Cryptol/REPL/Monad.hs +++ b/src/Cryptol/REPL/Monad.hs @@ -35,6 +35,7 @@ module Cryptol.REPL.Monad ( , getFocusedEnv , getModuleEnv, setModuleEnv , getDynEnv, setDynEnv + , getCallStacks , uniqify, freshName , whenDebug , getExprNames @@ -155,6 +156,8 @@ data RW = RW , eLogger :: Logger -- ^ Use this to send messages to the user + , eCallStacks :: Bool + , eUpdateTitle :: REPL () -- ^ Execute this every time we load a module. -- This is used to change the title of terminal when loading a module. @@ -163,8 +166,8 @@ data RW = RW } -- | Initial, empty environment. -defaultRW :: Bool -> Logger -> IO RW -defaultRW isBatch l = do +defaultRW :: Bool -> Bool ->Logger -> IO RW +defaultRW isBatch callStacks l = do env <- M.initialModuleEnv return RW { eLoadedMod = Nothing @@ -174,6 +177,7 @@ defaultRW isBatch l = do , eModuleEnv = env , eUserEnv = mkUserEnv userOptions , eLogger = l + , eCallStacks = callStacks , eUpdateTitle = return () , eProverConfig = Left SBV.defaultProver } @@ -220,9 +224,9 @@ mkPrompt rw newtype REPL a = REPL { unREPL :: IORef RW -> IO a } -- | Run a REPL action with a fresh environment. -runREPL :: Bool -> Logger -> REPL a -> IO a -runREPL isBatch l m = do - ref <- newIORef =<< defaultRW isBatch l +runREPL :: Bool -> Bool -> Logger -> REPL a -> IO a +runREPL isBatch callStacks l m = do + ref <- newIORef =<< defaultRW isBatch callStacks l unREPL m ref instance Functor REPL where @@ -384,6 +388,9 @@ modifyRW_ f = REPL (\ ref -> modifyIORef ref f) getPrompt :: REPL String getPrompt = mkPrompt `fmap` getRW +getCallStacks :: REPL Bool +getCallStacks = eCallStacks <$> getRW + clearLoadedMod :: REPL () clearLoadedMod = do modifyRW_ (\rw -> rw { eLoadedMod = upd <$> eLoadedMod rw }) updateREPLTitle diff --git a/src/Cryptol/Symbolic/SBV.hs b/src/Cryptol/Symbolic/SBV.hs index 816679596..04ee29242 100644 --- a/src/Cryptol/Symbolic/SBV.hs +++ b/src/Cryptol/Symbolic/SBV.hs @@ -171,7 +171,7 @@ thmSMTResults :: SBV.ThmResult -> [SBV.SMTResult] thmSMTResults (SBV.ThmResult r) = [r] proverError :: String -> M.ModuleCmd (Maybe String, ProverResult) -proverError msg (_, _, modEnv) = +proverError msg (_, _, _, modEnv) = return (Right ((Nothing, ProverError msg), modEnv), []) @@ -307,6 +307,9 @@ prepareQuery evo ProverCommand{..} = modEnv <- M.getModuleEnv let extDgs = M.allDeclGroups modEnv ++ pcExtraDecls + callStacks <- M.getCallStacks + let ?callStacks = callStacks + -- The `addAsm` function is used to combine assumptions that -- arise from the types of symbolic variables (e.g. Z n values -- are assumed to be integers in the range `0 <= x < n`) with @@ -426,9 +429,9 @@ processResults ProverCommand{..} ts results = -- of executing the query. satProve :: SBVProverConfig -> ProverCommand -> M.ModuleCmd (Maybe String, ProverResult) satProve proverCfg pc = - protectStack proverError $ \(evo, byteReader, modEnv) -> + protectStack proverError $ \(callStacks, evo, byteReader, modEnv) -> - M.runModuleM (evo, byteReader, modEnv) $ do + M.runModuleM (callStacks, evo, byteReader, modEnv) $ do let lPutStrLn = logPutStrLn (Eval.evalLogger evo) @@ -447,8 +450,8 @@ satProve proverCfg pc = -- the SMT input file corresponding to the given prover command. satProveOffline :: SBVProverConfig -> ProverCommand -> M.ModuleCmd (Either String String) satProveOffline _proverCfg pc@ProverCommand {..} = - protectStack (\msg (_,_,modEnv) -> return (Right (Left msg, modEnv), [])) $ - \(evo, byteReader, modEnv) -> M.runModuleM (evo,byteReader,modEnv) $ + protectStack (\msg (_,_,_,modEnv) -> return (Right (Left msg, modEnv), [])) $ + \(callStacks, evo, byteReader, modEnv) -> M.runModuleM (callStacks,evo,byteReader,modEnv) $ do let isSat = case pcQueryType of ProveQuery -> False SafetyQuery -> False diff --git a/src/Cryptol/Symbolic/What4.hs b/src/Cryptol/Symbolic/What4.hs index bd3c987bb..756a0a5b6 100644 --- a/src/Cryptol/Symbolic/What4.hs +++ b/src/Cryptol/Symbolic/What4.hs @@ -199,7 +199,7 @@ setupProver nm = proverError :: String -> M.ModuleCmd (Maybe String, ProverResult) -proverError msg (_, _, modEnv) = +proverError msg (_, _, _, modEnv) = return (Right ((Nothing, ProverError msg), modEnv), []) @@ -278,6 +278,8 @@ prepareQuery sym ProverCommand { .. } = let ?evalPrim = \i -> (Right <$> Map.lookup i tbl) <|> (Left <$> Map.lookup i ds) let ?range = emptyRange + callStacks <- M.getCallStacks + let ?callStacks = callStacks modEnv <- M.getModuleEnv let extDgs = M.allDeclGroups modEnv ++ pcExtraDecls @@ -304,8 +306,8 @@ satProve :: M.ModuleCmd (Maybe String, ProverResult) satProve solverCfg hashConsing warnUninterp ProverCommand {..} = - protectStack proverError \(evo, byteReader, modEnv) -> - M.runModuleM (evo, byteReader, modEnv) + protectStack proverError \modIn -> + M.runModuleM modIn do w4sym <- liftIO makeSym defVar <- liftIO (newMVar (W4.truePred w4sym)) funVar <- liftIO (newMVar mempty) @@ -376,8 +378,8 @@ satProveOffline (W4Portfolio (p:|_)) hashConsing warnUninterp cmd outputContinua satProveOffline (W4ProverConfig p) hashConsing warnUninterp cmd outputContinuation satProveOffline (W4ProverConfig (AnAdapter adpt)) hashConsing warnUninterp ProverCommand {..} outputContinuation = - protectStack onError \(evo,byteReader,modEnv) -> - M.runModuleM (evo,byteReader,modEnv) + protectStack onError \modIn -> + M.runModuleM modIn do w4sym <- liftIO makeSym defVar <- liftIO (newMVar (W4.truePred w4sym)) funVar <- liftIO (newMVar mempty) @@ -402,7 +404,7 @@ satProveOffline (W4ProverConfig (AnAdapter adpt)) hashConsing warnUninterp Prove when hashConsing (W4.startCaching sym) pure sym - onError msg (_,_,modEnv) = pure (Right (Just msg, modEnv), []) + onError msg (_,_,_,modEnv) = pure (Right (Just msg, modEnv), []) decSatNum :: SatNum -> SatNum diff --git a/src/Cryptol/Transform/Specialize.hs b/src/Cryptol/Transform/Specialize.hs index 76b89fe56..eca3ea235 100644 --- a/src/Cryptol/Transform/Specialize.hs +++ b/src/Cryptol/Transform/Specialize.hs @@ -59,13 +59,13 @@ modify f = get >>= (set . f) -- type-specialized versions of all functions called (transitively) by -- the body of the expression. specialize :: Expr -> M.ModuleCmd Expr -specialize expr (ev, byteReader, modEnv) = run $ do +specialize expr (callStacks, ev, byteReader, modEnv) = run $ do let extDgs = allDeclGroups modEnv let (tparams, expr') = destETAbs expr spec' <- specializeEWhere expr' extDgs return (foldr ETAbs spec' tparams) where - run = M.runModuleT (ev, byteReader, modEnv) . fmap fst . runSpecT Map.empty + run = M.runModuleT (callStacks, ev, byteReader, modEnv) . fmap fst . runSpecT Map.empty specializeExpr :: Expr -> SpecM Expr specializeExpr expr = diff --git a/src/Cryptol/TypeCheck.hs b/src/Cryptol/TypeCheck.hs index 88b943544..393fcc12d 100644 --- a/src/Cryptol/TypeCheck.hs +++ b/src/Cryptol/TypeCheck.hs @@ -80,7 +80,7 @@ tcExpr e0 inp = runInferM inp case expr of P.ELocated e loc' -> do (te, sch) <- go loc' e - pure (ELocated loc' te, sch) + pure $! if inpCallStacks inp then (ELocated loc' te, sch) else (te,sch) P.EVar x -> do res <- lookupVar x case res of diff --git a/src/Cryptol/TypeCheck/Infer.hs b/src/Cryptol/TypeCheck/Infer.hs index 67bca1cee..603f9c71e 100644 --- a/src/Cryptol/TypeCheck/Infer.hs +++ b/src/Cryptol/TypeCheck/Infer.hs @@ -169,7 +169,9 @@ appTys expr ts tGoal = -- XXX: Is there a scoping issue here? I think not, but check. P.ELocated e r -> - inRange r (ELocated r <$> appTys e ts tGoal) + do e' <- inRange r (appTys e ts tGoal) + cs <- getCallStacks + pure $! if cs then ELocated r e' else e' P.ENeg {} -> mono P.EComplement {} -> mono @@ -368,7 +370,10 @@ checkE expr tGoal = P.EFun ps e -> checkFun Nothing ps e tGoal - P.ELocated e r -> inRange r (ELocated r <$> checkE e tGoal) + P.ELocated e r -> + do e' <- inRange r (checkE e tGoal) + cs <- getCallStacks + pure $! if cs then ELocated r e' else e' P.ESplit e -> do prim <- mkPrim "splitAt" diff --git a/src/Cryptol/TypeCheck/Monad.hs b/src/Cryptol/TypeCheck/Monad.hs index aa5348ce0..7020506fb 100644 --- a/src/Cryptol/TypeCheck/Monad.hs +++ b/src/Cryptol/TypeCheck/Monad.hs @@ -74,6 +74,8 @@ data InferInput = InferInput , inpMonoBinds :: Bool -- ^ Should local bindings without -- signatures be monomorphized? + , inpCallStacks :: Bool -- ^ Are we tracking call stacks? + , inpSolverConfig :: SolverConfig -- ^ Options for the constraint solver , inpSearchPath :: [FilePath] -- ^ Where to look for Cryptol theory file. @@ -128,6 +130,7 @@ runInferM info (IM m) = SMT.withSolver (inpSolverConfig info) $ \solver -> , iSolvedHasLazy = iSolvedHas finalRW -- RECURSION , iMonoBinds = inpMonoBinds info + , iCallStacks = inpCallStacks info , iSolver = solver , iPrimNames = inpPrimNames info , iSolveCounter = counter @@ -232,6 +235,10 @@ data RO = RO -- in where-blocks will never be generalized. Bindings with type -- signatures, and all bindings at top level are unaffected. + , iCallStacks :: Bool + -- ^ When this flag is true, retain source location information + -- in typechecked terms + , iSolver :: SMT.Solver , iPrimNames :: !PrimMap @@ -692,6 +699,9 @@ getBoundInScope = getMonoBinds :: InferM Bool getMonoBinds = IM (asks iMonoBinds) +getCallStacks :: InferM Bool +getCallStacks = IM (asks iCallStacks) + {- | We disallow shadowing between type synonyms and type variables because it is confusing. As a bonus, in the implementation we don't need to worry about where we lookup things (i.e., in the variable or @@ -942,5 +952,3 @@ kNewGoals c ps = KM $ sets_ $ \s -> s { kCtrs = (c,ps) : kCtrs s } kInInferM :: InferM a -> KindM a kInInferM m = KM $ lift $ lift m - - From 3d117e4c86dd6318095acfa3644e3290f2f5a899 Mon Sep 17 00:00:00 2001 From: Rob Dockins Date: Tue, 8 Dec 2020 17:41:44 -0800 Subject: [PATCH 24/27] Introduce a record datatype for the inputs to module commands. The tuple approach was starting to become unwieldly. --- cryptol-remote-api/src/CryptolServer.hs | 10 ++++- .../src/CryptolServer/Data/Expression.hs | 1 + src/Cryptol/Eval/Reference.lhs | 3 +- src/Cryptol/ModuleSystem.hs | 14 +++---- src/Cryptol/ModuleSystem/Monad.hs | 41 +++++++++++++------ src/Cryptol/REPL/Command.hs | 8 +++- src/Cryptol/Symbolic/SBV.hs | 15 +++---- src/Cryptol/Symbolic/What4.hs | 6 +-- src/Cryptol/Transform/Specialize.hs | 6 +-- 9 files changed, 66 insertions(+), 38 deletions(-) diff --git a/cryptol-remote-api/src/CryptolServer.hs b/cryptol-remote-api/src/CryptolServer.hs index baf6230b2..09a917e16 100644 --- a/cryptol-remote-api/src/CryptolServer.hs +++ b/cryptol-remote-api/src/CryptolServer.hs @@ -6,7 +6,7 @@ import Control.Lens import Control.Monad.IO.Class import Cryptol.Backend.Monad (EvalOpts(..), PPOpts(..), PPFloatFormat(..), PPFloatExp(..)) -import Cryptol.ModuleSystem (ModuleCmd, ModuleEnv) +import Cryptol.ModuleSystem (ModuleCmd, ModuleEnv, ModuleInput(..)) import Cryptol.ModuleSystem.Env (getLoadedModules, lmFilePath, lmFingerprint, meLoadedModules, initialModuleEnv, meSearchPath, ModulePath(..)) @@ -21,7 +21,13 @@ runModuleCmd :: ModuleCmd a -> Method ServerState a runModuleCmd cmd = do s <- getState reader <- getFileReader - out <- liftIO $ cmd (theEvalOpts, reader, view moduleEnv s) + let minp = ModuleInput + { minpCallStacks = True -- TODO, where should we get this option from? + , minpEvalOpts = theEvalOpts + , minpByteReader = reader + , minpModuleEnv = view moduleEnv s + } + out <- liftIO $ cmd minp case out of (Left x, warns) -> raise (cryptolError x warns) diff --git a/cryptol-remote-api/src/CryptolServer/Data/Expression.hs b/cryptol-remote-api/src/CryptolServer/Data/Expression.hs index 1bef5948d..b81ba8530 100644 --- a/cryptol-remote-api/src/CryptolServer/Data/Expression.hs +++ b/cryptol-remote-api/src/CryptolServer/Data/Expression.hs @@ -319,6 +319,7 @@ readBack prims ty val = let tbl = primTable theEvalOpts in let ?evalPrim = \i -> Right <$> Map.lookup i tbl in let ?range = emptyRange in -- TODO? + let ?callStacks = False in -- TODO? case TC.tNoUser ty of TC.TRec tfs -> Record . HM.fromList <$> diff --git a/src/Cryptol/Eval/Reference.lhs b/src/Cryptol/Eval/Reference.lhs index d0def3060..ad6300f4c 100644 --- a/src/Cryptol/Eval/Reference.lhs +++ b/src/Cryptol/Eval/Reference.lhs @@ -1692,7 +1692,8 @@ This module implements the core functionality of the `:eval running the reference evaluator on an expression. > evaluate :: Expr -> M.ModuleCmd (E Value) -> evaluate expr (_, _, _, modEnv) = return (Right (evalExpr env expr, modEnv), []) +> evaluate expr minp = return (Right (evalExpr env expr, modEnv), []) > where +> modEnv = M.minpModuleEnv minp > extDgs = concatMap mDecls (M.loadedModules modEnv) > env = foldl evalDeclGroup mempty extDgs diff --git a/src/Cryptol/ModuleSystem.hs b/src/Cryptol/ModuleSystem.hs index f558f73f3..8c011c315 100644 --- a/src/Cryptol/ModuleSystem.hs +++ b/src/Cryptol/ModuleSystem.hs @@ -14,6 +14,7 @@ module Cryptol.ModuleSystem ( , DynamicEnv(..) , ModuleError(..), ModuleWarning(..) , ModuleCmd, ModuleRes + , ModuleInput(..) , findModule , loadModuleByPath , loadModuleByName @@ -32,7 +33,6 @@ module Cryptol.ModuleSystem ( , IfaceTySyn, IfaceDecl(..) ) where -import qualified Cryptol.Eval as E import qualified Cryptol.Eval.Concrete as Concrete import Cryptol.ModuleSystem.Env import Cryptol.ModuleSystem.Interface @@ -46,11 +46,9 @@ import Cryptol.Parser.NoPat (RemovePatterns) import qualified Cryptol.TypeCheck.AST as T import qualified Cryptol.Utils.Ident as M -import Data.ByteString (ByteString) - -- Public Interface ------------------------------------------------------------ -type ModuleCmd a = (Bool, E.EvalOpts, FilePath -> IO ByteString, ModuleEnv) -> IO (ModuleRes a) +type ModuleCmd a = ModuleInput IO -> IO (ModuleRes a) type ModuleRes a = (Either ModuleError (a,ModuleEnv), [ModuleWarning]) @@ -63,8 +61,8 @@ findModule n env = runModuleM env (Base.findModule n) -- | Load the module contained in the given file. loadModuleByPath :: FilePath -> ModuleCmd (ModulePath,T.Module) -loadModuleByPath path (callStacks, evo, byteReader, env) = - runModuleM (callStacks, evo, byteReader, resetModuleEnv env) $ do +loadModuleByPath path minp = + runModuleM minp{ minpModuleEnv = resetModuleEnv (minpModuleEnv minp) } $ do unloadModule ((InFile path ==) . lmFilePath) m <- Base.loadModuleByPath path setFocusedModule (T.mName m) @@ -72,8 +70,8 @@ loadModuleByPath path (callStacks, evo, byteReader, env) = -- | Load the given parsed module. loadModuleByName :: P.ModName -> ModuleCmd (ModulePath,T.Module) -loadModuleByName n (callStacks, evo, byteReader, env) = - runModuleM (callStacks, evo, byteReader, resetModuleEnv env) $ do +loadModuleByName n minp = + runModuleM minp{ minpModuleEnv = resetModuleEnv (minpModuleEnv minp) } $ do unloadModule ((n ==) . lmName) (path,m') <- Base.loadModuleFrom False (FromModule n) setFocusedModule (T.mName m') diff --git a/src/Cryptol/ModuleSystem/Monad.hs b/src/Cryptol/ModuleSystem/Monad.hs index 833462105..8d7793faa 100644 --- a/src/Cryptol/ModuleSystem/Monad.hs +++ b/src/Cryptol/ModuleSystem/Monad.hs @@ -305,9 +305,13 @@ data RO m = , roFileReader :: FilePath -> m ByteString } -emptyRO :: Bool -> EvalOpts -> (FilePath -> m ByteString) -> RO m -emptyRO callStacks ev fileReader = - RO { roLoading = [], roEvalOpts = ev, roCallStacks = callStacks, roFileReader = fileReader } +emptyRO :: ModuleInput m -> RO m +emptyRO minp = + RO { roLoading = [] + , roEvalOpts = minpEvalOpts minp + , roCallStacks = minpCallStacks minp + , roFileReader = minpByteReader minp + } newtype ModuleT m a = ModuleT { unModuleT :: ReaderT (RO m) @@ -352,21 +356,33 @@ instance Monad m => FreshM (ModuleT m) where instance MonadIO m => MonadIO (ModuleT m) where liftIO m = lift $ liftIO m -runModuleT :: Monad m - => (Bool, EvalOpts, FilePath -> m ByteString, ModuleEnv) - -> ModuleT m a - -> m (Either ModuleError (a, ModuleEnv), [ModuleWarning]) -runModuleT (callStacks, ev, byteReader, env) m = + +data ModuleInput m = + ModuleInput + { minpCallStacks :: Bool + , minpEvalOpts :: EvalOpts + , minpByteReader :: FilePath -> m ByteString + , minpModuleEnv :: ModuleEnv + } + +runModuleT :: + Monad m => + ModuleInput m -> + ModuleT m a -> + m (Either ModuleError (a, ModuleEnv), [ModuleWarning]) +runModuleT minp m = runWriterT $ runExceptionT - $ runStateT env - $ runReaderT (emptyRO callStacks ev byteReader) + $ runStateT (minpModuleEnv minp) + $ runReaderT (emptyRO minp) $ unModuleT m type ModuleM = ModuleT IO -runModuleM :: (Bool, EvalOpts, FilePath -> IO ByteString, ModuleEnv) -> ModuleM a - -> IO (Either ModuleError (a,ModuleEnv),[ModuleWarning]) +runModuleM :: + ModuleInput IO -> + ModuleM a -> + IO (Either ModuleError (a,ModuleEnv),[ModuleWarning]) runModuleM = runModuleT @@ -551,4 +567,3 @@ getSolverConfig = ModuleT $ do withLogger :: (Logger -> a -> IO b) -> a -> ModuleM b withLogger f a = do l <- getEvalOpts io (f (evalLogger l) a) - diff --git a/src/Cryptol/REPL/Command.hs b/src/Cryptol/REPL/Command.hs index 2a1077908..0c8039afe 100644 --- a/src/Cryptol/REPL/Command.hs +++ b/src/Cryptol/REPL/Command.hs @@ -1612,7 +1612,13 @@ liftModuleCmd cmd = do evo <- getEvalOpts env <- getModuleEnv callStacks <- getCallStacks - moduleCmdResult =<< io (cmd (callStacks, evo, BS.readFile, env)) + let minp = M.ModuleInput + { minpCallStacks = callStacks + , minpEvalOpts = evo + , minpByteReader = BS.readFile + , minpModuleEnv = env + } + moduleCmdResult =<< io (cmd minp) moduleCmdResult :: M.ModuleRes a -> REPL a moduleCmdResult (res,ws0) = do diff --git a/src/Cryptol/Symbolic/SBV.hs b/src/Cryptol/Symbolic/SBV.hs index 04ee29242..168a4c216 100644 --- a/src/Cryptol/Symbolic/SBV.hs +++ b/src/Cryptol/Symbolic/SBV.hs @@ -171,8 +171,8 @@ thmSMTResults :: SBV.ThmResult -> [SBV.SMTResult] thmSMTResults (SBV.ThmResult r) = [r] proverError :: String -> M.ModuleCmd (Maybe String, ProverResult) -proverError msg (_, _, _, modEnv) = - return (Right ((Nothing, ProverError msg), modEnv), []) +proverError msg minp = + return (Right ((Nothing, ProverError msg), M.minpModuleEnv minp), []) isFailedResult :: [SBV.SMTResult] -> Maybe String @@ -429,9 +429,9 @@ processResults ProverCommand{..} ts results = -- of executing the query. satProve :: SBVProverConfig -> ProverCommand -> M.ModuleCmd (Maybe String, ProverResult) satProve proverCfg pc = - protectStack proverError $ \(callStacks, evo, byteReader, modEnv) -> - - M.runModuleM (callStacks, evo, byteReader, modEnv) $ do + protectStack proverError $ \minp -> + M.runModuleM minp $ do + let evo = M.minpEvalOpts minp let lPutStrLn = logPutStrLn (Eval.evalLogger evo) @@ -450,12 +450,13 @@ satProve proverCfg pc = -- the SMT input file corresponding to the given prover command. satProveOffline :: SBVProverConfig -> ProverCommand -> M.ModuleCmd (Either String String) satProveOffline _proverCfg pc@ProverCommand {..} = - protectStack (\msg (_,_,_,modEnv) -> return (Right (Left msg, modEnv), [])) $ - \(callStacks, evo, byteReader, modEnv) -> M.runModuleM (callStacks,evo,byteReader,modEnv) $ + protectStack (\msg minp -> return (Right (Left msg, M.minpModuleEnv minp), [])) $ + \minp -> M.runModuleM minp $ do let isSat = case pcQueryType of ProveQuery -> False SafetyQuery -> False SatQuery _ -> True + let evo = M.minpEvalOpts minp prepareQuery evo pc >>= \case Left msg -> return (Left msg) diff --git a/src/Cryptol/Symbolic/What4.hs b/src/Cryptol/Symbolic/What4.hs index 756a0a5b6..b53a8af46 100644 --- a/src/Cryptol/Symbolic/What4.hs +++ b/src/Cryptol/Symbolic/What4.hs @@ -199,8 +199,8 @@ setupProver nm = proverError :: String -> M.ModuleCmd (Maybe String, ProverResult) -proverError msg (_, _, _, modEnv) = - return (Right ((Nothing, ProverError msg), modEnv), []) +proverError msg minp = + return (Right ((Nothing, ProverError msg), M.minpModuleEnv minp), []) data CryptolState t = CryptolState @@ -404,7 +404,7 @@ satProveOffline (W4ProverConfig (AnAdapter adpt)) hashConsing warnUninterp Prove when hashConsing (W4.startCaching sym) pure sym - onError msg (_,_,_,modEnv) = pure (Right (Just msg, modEnv), []) + onError msg minp = pure (Right (Just msg, M.minpModuleEnv minp), []) decSatNum :: SatNum -> SatNum diff --git a/src/Cryptol/Transform/Specialize.hs b/src/Cryptol/Transform/Specialize.hs index eca3ea235..d86c83115 100644 --- a/src/Cryptol/Transform/Specialize.hs +++ b/src/Cryptol/Transform/Specialize.hs @@ -59,13 +59,13 @@ modify f = get >>= (set . f) -- type-specialized versions of all functions called (transitively) by -- the body of the expression. specialize :: Expr -> M.ModuleCmd Expr -specialize expr (callStacks, ev, byteReader, modEnv) = run $ do - let extDgs = allDeclGroups modEnv +specialize expr minp = run $ do + let extDgs = allDeclGroups (M.minpModuleEnv minp) let (tparams, expr') = destETAbs expr spec' <- specializeEWhere expr' extDgs return (foldr ETAbs spec' tparams) where - run = M.runModuleT (callStacks, ev, byteReader, modEnv) . fmap fst . runSpecT Map.empty + run = M.runModuleT minp . fmap fst . runSpecT Map.empty specializeExpr :: Expr -> SpecM Expr specializeExpr expr = From 61f4dc0fc98fab407990c2d16df5adc7af608eb0 Mon Sep 17 00:00:00 2001 From: Rob Dockins Date: Wed, 9 Dec 2020 11:11:39 -0800 Subject: [PATCH 25/27] update CHANGES.md --- CHANGES.md | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/CHANGES.md b/CHANGES.md index e34d68e31..ecbc7b4a5 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,14 @@ +# NEXT + +## New features + +* By default, the interpreter will now track source locations of + expressions being evaluated, and retain call stack information. + This information is incorporated into error messages arising from + runtime errors. This additional bookkeeping incurs significant + runtime overhead, but may be disabled using the `--no-call-stacks` + command-line option. + # 2.10.0 ## Language changes From b5d66ffdc27c4983f32f0bc6b64aa9f29821cb5c Mon Sep 17 00:00:00 2001 From: Rob Dockins Date: Wed, 9 Dec 2020 11:44:12 -0800 Subject: [PATCH 26/27] Add a `sWithCallStack` method to capure a common pattern. Minor cleanups. --- src/Cryptol/Backend.hs | 4 ++++ src/Cryptol/Backend/Concrete.hs | 2 +- src/Cryptol/Eval.hs | 2 +- src/Cryptol/Eval/Generic.hs | 10 +++++----- src/Cryptol/Eval/Value.hs | 2 +- 5 files changed, 12 insertions(+), 8 deletions(-) diff --git a/src/Cryptol/Backend.hs b/src/Cryptol/Backend.hs index 2b8d5925c..023a3b2e5 100644 --- a/src/Cryptol/Backend.hs +++ b/src/Cryptol/Backend.hs @@ -242,6 +242,10 @@ class MonadIO (SEval sym) => Backend sym where sPushFrame :: sym -> Name -> Range -> SEval sym a -> SEval sym a sPushFrame sym nm rng m = sModifyCallStack sym (pushCallFrame nm rng) m + -- | Use the given call stack while evaluating the given action + sWithCallStack :: sym -> CallStack -> SEval sym a -> SEval sym a + sWithCallStack sym stk m = sModifyCallStack sym (\_ -> stk) m + -- | Apply the given function to the current call stack while evaluating the given action sModifyCallStack :: sym -> (CallStack -> CallStack) -> SEval sym a -> SEval sym a diff --git a/src/Cryptol/Backend/Concrete.hs b/src/Cryptol/Backend/Concrete.hs index b1ae62e67..b653a0d25 100644 --- a/src/Cryptol/Backend/Concrete.hs +++ b/src/Cryptol/Backend/Concrete.hs @@ -159,7 +159,7 @@ instance Backend Concrete where y <- my f c x y - sDeclareHole _ rng = blackhole rng + sDeclareHole _ = blackhole sDelayFill _ = delayFill sSpark _ = evalSpark sModifyCallStack _ f m = modifyCallStack f m diff --git a/src/Cryptol/Eval.hs b/src/Cryptol/Eval.hs index 6d6c68539..67718a09c 100644 --- a/src/Cryptol/Eval.hs +++ b/src/Cryptol/Eval.hs @@ -480,7 +480,7 @@ etaDelay sym env0 Forall{ sVars = vs0, sType = tp0 } = goTpVars env0 vs0 VNumPoly{} -> evalPanic "type mismatch during eta-expansion" ["Encountered numeric polymorphic value"] - go stk tp v = sModifyCallStack sym (\_ -> stk) $ + go stk tp v = sWithCallStack sym stk $ case tp of TVBit -> v TVInteger -> v diff --git a/src/Cryptol/Eval/Generic.hs b/src/Cryptol/Eval/Generic.hs index 9d1b981ca..750ef4643 100644 --- a/src/Cryptol/Eval/Generic.hs +++ b/src/Cryptol/Eval/Generic.hs @@ -216,7 +216,7 @@ ringBinary sym opw opi opz opq opfp = loop lw <- fromVWord sym "ringLeft" l rw <- fromVWord sym "ringRight" r stk <- sGetCallStack sym - return $ VWord w (WordVal <$> (sModifyCallStack sym (\_ -> stk) (opw w lw rw))) + return $ VWord w (WordVal <$> (sWithCallStack sym stk (opw w lw rw))) | otherwise -> VSeq w <$> (join (zipSeqMap sym (loop a) <$> (fromSeq "ringBinary left" l) <*> (fromSeq "ringBinary right" r))) @@ -299,7 +299,7 @@ ringUnary sym opw opi opz opq opfp = loop | isTBit a -> do wx <- fromVWord sym "ringUnary" v stk <- sGetCallStack sym - return $ VWord w (WordVal <$> sModifyCallStack sym (\_ -> stk) (opw w wx)) + return $ VWord w (WordVal <$> sWithCallStack sym stk (opw w wx)) | otherwise -> VSeq w <$> (mapSeqMap sym (loop a) =<< fromSeq "ringUnary" v) TVStream a -> @@ -365,7 +365,7 @@ ringNullary sym opw opi opz opq opfp = loop -- words and finite sequences | isTBit a -> do stk <- sGetCallStack sym - pure $ VWord w $ (WordVal <$> sModifyCallStack sym (\_ -> stk) (opw w)) + pure $ VWord w $ (WordVal <$> sWithCallStack sym stk (opw w)) | otherwise -> do v <- sDelay sym (loop a) pure $ VSeq w $ IndexSeqMap \_i -> v @@ -410,7 +410,7 @@ integralBinary sym opw opi ty l r = case ty of do wl <- fromVWord sym "integralBinary left" l wr <- fromVWord sym "integralBinary right" r stk <- sGetCallStack sym - return $ VWord w (WordVal <$> sModifyCallStack sym (\_ -> stk) (opw w wl wr)) + return $ VWord w (WordVal <$> sWithCallStack sym stk (opw w wl wr)) _ -> evalPanic "integralBinary" [show ty ++ " not int class `Integral`"] @@ -1830,7 +1830,7 @@ errorV sym ty0 msg = do stk <- sGetCallStack sym loop stk ty0 where - err stk = sModifyCallStack sym (\_ -> stk) (cryUserError sym msg) + err stk = sWithCallStack sym stk (cryUserError sym msg) loop stk = \case TVBit -> err stk diff --git a/src/Cryptol/Eval/Value.hs b/src/Cryptol/Eval/Value.hs index e2c46fa73..a488034d5 100644 --- a/src/Cryptol/Eval/Value.hs +++ b/src/Cryptol/Eval/Value.hs @@ -204,7 +204,7 @@ memoMap sym x = do mz <- liftIO (Map.lookup i <$> readIORef cache) case mz of Just z -> return z - Nothing -> sModifyCallStack sym (\_ -> stk) (doEval cache i) + Nothing -> sWithCallStack sym stk (doEval cache i) doEval cache i = do v <- lookupSeqMap x i From b273e6d1f03f90ca9ee994a87e65f118965ce91d Mon Sep 17 00:00:00 2001 From: Rob Dockins Date: Wed, 9 Dec 2020 12:47:27 -0800 Subject: [PATCH 27/27] Minor improvements to range tracking --- src/Cryptol/Parser/AST.hs | 4 ++-- src/Cryptol/REPL/Command.hs | 20 ++++++++++++++++---- tests/issues/issue103.icry.stdout | 2 +- tests/regression/safety.icry.stdout | 6 +++--- 4 files changed, 22 insertions(+), 10 deletions(-) diff --git a/src/Cryptol/Parser/AST.hs b/src/Cryptol/Parser/AST.hs index 00af9ee4d..070eead35 100644 --- a/src/Cryptol/Parser/AST.hs +++ b/src/Cryptol/Parser/AST.hs @@ -394,8 +394,8 @@ newtype Prop n = CType (Type n) instance AddLoc (Expr n) where - addLoc (ELocated x _) r = addLoc x r - addLoc x r = ELocated x r + addLoc x@ELocated{} _ = x + addLoc x r = ELocated x r dropLoc (ELocated e _) = dropLoc e dropLoc e = e diff --git a/src/Cryptol/REPL/Command.hs b/src/Cryptol/REPL/Command.hs index 0c8039afe..1d3f3e2a1 100644 --- a/src/Cryptol/REPL/Command.hs +++ b/src/Cryptol/REPL/Command.hs @@ -74,7 +74,7 @@ import qualified Cryptol.Testing.Random as TestR import Cryptol.Parser (parseExprWith,parseReplWith,ParseError(),Config(..),defaultConfig ,parseModName,parseHelpName) -import Cryptol.Parser.Position (Position(..),Range,emptyRange,HasLoc(..)) +import Cryptol.Parser.Position (Position(..),Range(..),HasLoc(..)) import qualified Cryptol.TypeCheck.AST as T import qualified Cryptol.TypeCheck.Error as T import qualified Cryptol.TypeCheck.Parseable as T @@ -639,7 +639,7 @@ safeCmd str pos fnm = do fileName <- getKnownUser "smtfile" let mfile = if fileName == "-" then Nothing else Just fileName pexpr <- replParseExpr str pos fnm - let rng = fromMaybe emptyRange (getLoc pexpr) + let rng = fromMaybe (mkInteractiveRange pos fnm) (getLoc pexpr) if proverName `elem` ["offline","sbv-offline","w4-offline"] then offlineProveSat proverName SafetyQuery pexpr mfile @@ -697,7 +697,7 @@ cmdProveSat isSat str pos fnm = do fileName <- getKnownUser "smtfile" let mfile = if fileName == "-" then Nothing else Just fileName pexpr <- replParseExpr str pos fnm - let rng = fromMaybe emptyRange (getLoc pexpr) + let rng = fromMaybe (mkInteractiveRange pos fnm) (getLoc pexpr) if proverName `elem` ["offline","sbv-offline","w4-offline"] then offlineProveSat proverName qtype pexpr mfile @@ -1601,6 +1601,14 @@ replParseExpr str (l,c) fnm = replParse (parseExprWith cfg. T.pack) str , cfgStart = Position l c } +mkInteractiveRange :: (Int,Int) -> Maybe FilePath -> Range +mkInteractiveRange (l,c) mb = Range p p src + where + p = Position l c + src = case mb of + Nothing -> "" + Just b -> b + interactiveConfig :: Config interactiveConfig = defaultConfig { cfgSource = "" } @@ -1709,8 +1717,12 @@ replEvalExpr expr = -- add "it" to the namespace via a new declaration itVar <- bindItVariable ty def1 + let itExpr = case getLoc def of + Nothing -> T.EVar itVar + Just rng -> T.ELocated rng (T.EVar itVar) + -- evaluate the it variable - val <- liftModuleCmd (rethrowEvalError . M.evalExpr (T.EVar itVar)) + val <- liftModuleCmd (rethrowEvalError . M.evalExpr itExpr) return (val,ty) where warnDefaults ts = diff --git a/tests/issues/issue103.icry.stdout b/tests/issues/issue103.icry.stdout index 9e5c83480..3ce0b6a33 100644 --- a/tests/issues/issue103.icry.stdout +++ b/tests/issues/issue103.icry.stdout @@ -11,4 +11,4 @@ invalid sequence index: 1 -- Backtrace -- (Cryptol::@) called at issue103.icry:2:11--2:21 ::f called at issue103.icry:3:9--3:10 -::it +::it called at issue103.icry:3:8--3:23 diff --git a/tests/regression/safety.icry.stdout b/tests/regression/safety.icry.stdout index 7332ee27e..800bcc608 100644 --- a/tests/regression/safety.icry.stdout +++ b/tests/regression/safety.icry.stdout @@ -5,20 +5,20 @@ Run-time error: asdf -- Backtrace -- Cryptol::error called at Cryptol:959:41--959:46 Cryptol::assert called at safety.icry:3:14--3:20 -::it +::it called at safety.icry:3:7--3:37 Counterexample (\(x : [4]) -> [0 .. 14] @ x == x) 0xf ~> ERROR invalid sequence index: 15 -- Backtrace -- (Cryptol::@) called at safety.icry:4:20--4:34 (Cryptol::==) called at safety.icry:4:20--4:34 -::it +::it called at safety.icry:4:7--4:35 Counterexample (\y -> (10 : Integer) / y) 0 ~> ERROR division by 0 -- Backtrace -- (Cryptol::/) called at safety.icry:5:14--5:30 -::it +::it called at safety.icry:5:7--5:31 Safe Safe Safe