From 91973099751b08a1a1028c72031bac4ceb07c920 Mon Sep 17 00:00:00 2001 From: Rob Dockins Date: Fri, 11 Feb 2022 09:58:28 -0800 Subject: [PATCH 001/105] Add a new `llvm_union` command that uses DWARF debug information to resolve union branches, similiar to `llvm_field`. At the same time, clean up some of the code involved in setup value resolution and improve error reporting. --- .../src/Mir/Compositional/Builder.hs | 1 + .../src/Mir/Compositional/MethodSpec.hs | 1 + deps/llvm-pretty | 2 +- src/SAWScript/Crucible/Common/MethodSpec.hs | 4 + src/SAWScript/Crucible/JVM/MethodSpecIR.hs | 1 + src/SAWScript/Crucible/JVM/Override.hs | 1 + .../Crucible/JVM/ResolveSetupValue.hs | 2 + src/SAWScript/Crucible/LLVM/Builtins.hs | 18 +- src/SAWScript/Crucible/LLVM/MethodSpecIR.hs | 5 + src/SAWScript/Crucible/LLVM/Override.hs | 40 +- .../Crucible/LLVM/ResolveSetupValue.hs | 608 +++++++++++------- src/SAWScript/Crucible/LLVM/X86.hs | 4 +- src/SAWScript/Interpreter.hs | 13 +- 13 files changed, 451 insertions(+), 249 deletions(-) diff --git a/crux-mir-comp/src/Mir/Compositional/Builder.hs b/crux-mir-comp/src/Mir/Compositional/Builder.hs index cf37cc5d88..faf09ae025 100644 --- a/crux-mir-comp/src/Mir/Compositional/Builder.hs +++ b/crux-mir-comp/src/Mir/Compositional/Builder.hs @@ -613,6 +613,7 @@ substMethodSpec sc sm ms = do MS.SetupElem b sv idx -> MS.SetupElem b <$> goSetupValue sv <*> pure idx MS.SetupField b sv name -> MS.SetupField b <$> goSetupValue sv <*> pure name MS.SetupCast v _ _ -> case v of {} + MS.SetupUnion v _ _ -> case v of {} MS.SetupGlobal _ _ -> return sv MS.SetupGlobalInitializer _ _ -> return sv diff --git a/crux-mir-comp/src/Mir/Compositional/MethodSpec.hs b/crux-mir-comp/src/Mir/Compositional/MethodSpec.hs index 28404f136e..9c5c2c275a 100644 --- a/crux-mir-comp/src/Mir/Compositional/MethodSpec.hs +++ b/crux-mir-comp/src/Mir/Compositional/MethodSpec.hs @@ -30,6 +30,7 @@ type instance MS.HasSetupArray MIR = 'True type instance MS.HasSetupElem MIR = 'True type instance MS.HasSetupField MIR = 'True type instance MS.HasSetupCast MIR = 'False +type instance MS.HasSetupUnion MIR = 'False type instance MS.HasSetupGlobalInitializer MIR = 'False type instance MS.HasGhostState MIR = 'False diff --git a/deps/llvm-pretty b/deps/llvm-pretty index ed904c679d..30e0af37af 160000 --- a/deps/llvm-pretty +++ b/deps/llvm-pretty @@ -1 +1 @@ -Subproject commit ed904c679d1a10ff98d1968da3407ff56cfa06a2 +Subproject commit 30e0af37af977b987eae58daad0a1a1e4a9f2d3b diff --git a/src/SAWScript/Crucible/Common/MethodSpec.hs b/src/SAWScript/Crucible/Common/MethodSpec.hs index 680fff2c48..5d9249a824 100644 --- a/src/SAWScript/Crucible/Common/MethodSpec.hs +++ b/src/SAWScript/Crucible/Common/MethodSpec.hs @@ -112,6 +112,7 @@ type family HasSetupElem ext :: Bool type family HasSetupField ext :: Bool type family HasSetupGlobal ext :: Bool type family HasSetupCast ext :: Bool +type family HasSetupUnion ext :: Bool type family HasSetupGlobalInitializer ext :: Bool -- | From the manual: \"The SetupValue type corresponds to values that can occur @@ -127,6 +128,7 @@ data SetupValue ext where SetupElem :: B (HasSetupElem ext) -> SetupValue ext -> Int -> SetupValue ext SetupField :: B (HasSetupField ext) -> SetupValue ext -> String -> SetupValue ext SetupCast :: B (HasSetupCast ext) -> SetupValue ext -> CastType ext -> SetupValue ext + SetupUnion :: B (HasSetupUnion ext) -> SetupValue ext -> String -> SetupValue ext -- | A pointer to a global variable SetupGlobal :: B (HasSetupGlobal ext) -> String -> SetupValue ext @@ -144,6 +146,7 @@ type SetupValueHas (c :: Type -> Constraint) ext = , c (B (HasSetupElem ext)) , c (B (HasSetupField ext)) , c (B (HasSetupCast ext)) + , c (B (HasSetupUnion ext)) , c (B (HasSetupGlobal ext)) , c (B (HasSetupGlobalInitializer ext)) , c (CastType ext) @@ -170,6 +173,7 @@ ppSetupValue setupval = case setupval of SetupArray _ vs -> PP.brackets (commaList (map ppSetupValue vs)) SetupElem _ v i -> PP.parens (ppSetupValue v) PP.<> PP.pretty ("." ++ show i) SetupField _ v f -> PP.parens (ppSetupValue v) PP.<> PP.pretty ("." ++ f) + SetupUnion _ v u -> PP.parens (ppSetupValue v) PP.<> PP.pretty ("." ++ u) SetupCast _ v tp -> PP.parens (ppSetupValue v) PP.<> PP.pretty (" AS " ++ show tp) SetupGlobal _ nm -> PP.pretty ("global(" ++ nm ++ ")") SetupGlobalInitializer _ nm -> PP.pretty ("global_initializer(" ++ nm ++ ")") diff --git a/src/SAWScript/Crucible/JVM/MethodSpecIR.hs b/src/SAWScript/Crucible/JVM/MethodSpecIR.hs index 957452f383..136d66156f 100644 --- a/src/SAWScript/Crucible/JVM/MethodSpecIR.hs +++ b/src/SAWScript/Crucible/JVM/MethodSpecIR.hs @@ -59,6 +59,7 @@ type instance MS.HasSetupArray CJ.JVM = 'False type instance MS.HasSetupElem CJ.JVM = 'False type instance MS.HasSetupField CJ.JVM = 'False type instance MS.HasSetupCast CJ.JVM = 'False +type instance MS.HasSetupUnion CJ.JVM = 'False type instance MS.HasSetupGlobalInitializer CJ.JVM = 'False type instance MS.HasGhostState CJ.JVM = 'False diff --git a/src/SAWScript/Crucible/JVM/Override.hs b/src/SAWScript/Crucible/JVM/Override.hs index ce464d92aa..da0cff4cdf 100644 --- a/src/SAWScript/Crucible/JVM/Override.hs +++ b/src/SAWScript/Crucible/JVM/Override.hs @@ -964,6 +964,7 @@ instantiateSetupValue sc s v = MS.SetupElem empty _ _ -> absurd empty MS.SetupField empty _ _ -> absurd empty MS.SetupCast empty _ _ -> absurd empty + MS.SetupUnion empty _ _ -> absurd empty MS.SetupGlobalInitializer empty _ -> absurd empty where doTerm (TypedTerm schema t) = TypedTerm schema <$> scInstantiateExt sc s t diff --git a/src/SAWScript/Crucible/JVM/ResolveSetupValue.hs b/src/SAWScript/Crucible/JVM/ResolveSetupValue.hs index ddf904b0a5..33e4311225 100644 --- a/src/SAWScript/Crucible/JVM/ResolveSetupValue.hs +++ b/src/SAWScript/Crucible/JVM/ResolveSetupValue.hs @@ -145,6 +145,7 @@ typeOfSetupValue _cc env _nameEnv val = MS.SetupElem empty _ _ -> absurd empty MS.SetupField empty _ _ -> absurd empty MS.SetupCast empty _ _ -> absurd empty + MS.SetupUnion empty _ _ -> absurd empty MS.SetupGlobalInitializer empty _ -> absurd empty lookupAllocIndex :: Map AllocIndex a -> AllocIndex -> a @@ -175,6 +176,7 @@ resolveSetupVal cc env _tyenv _nameEnv val = MS.SetupElem empty _ _ -> absurd empty MS.SetupField empty _ _ -> absurd empty MS.SetupCast empty _ _ -> absurd empty + MS.SetupUnion empty _ _ -> absurd empty MS.SetupGlobalInitializer empty _ -> absurd empty where sym = cc^.jccSym diff --git a/src/SAWScript/Crucible/LLVM/Builtins.hs b/src/SAWScript/Crucible/LLVM/Builtins.hs index f31cfab88b..ba1ad5e1a1 100644 --- a/src/SAWScript/Crucible/LLVM/Builtins.hs +++ b/src/SAWScript/Crucible/LLVM/Builtins.hs @@ -697,7 +697,7 @@ checkSpecArgumentTypes cc mspec = mapM_ resolveArg [0..(nArgs-1)] resolveArg i = case Map.lookup i (mspec ^. MS.csArgBindings) of Just (mt, sv) -> do - mt' <- typeOfSetupValue cc tyenv nameEnv sv + mt' <- exceptToFail (typeOfSetupValue cc tyenv nameEnv sv) checkArgTy i mt mt' Nothing -> throwMethodSpec mspec $ unwords ["Argument", show i, "unspecified when verifying", show nm] @@ -721,7 +721,7 @@ checkSpecReturnType cc mspec = " has void return type" ] (Just sv, Just retTy) -> - do retTy' <- + do retTy' <- exceptToFail $ typeOfSetupValue cc (MS.csAllocations mspec) -- map allocation indices to allocations (mspec ^. MS.csPreState . MS.csVarTypeNames) -- map alloc indices to var names @@ -2206,7 +2206,7 @@ llvm_points_to_internal mbCheckType cond (getAllLLVM -> ptr) (getAllLLVM -> val) let path = [] lhsTy <- llvm_points_to_check_lhs_validity ptr loc path - valTy <- typeOfSetupValue cc env nameEnv val + valTy <- exceptToFail $ typeOfSetupValue cc env nameEnv val case mbCheckType of Nothing -> pure () Just CheckAgainstPointerType -> checkMemTypeCompatibility loc lhsTy valTy @@ -2243,9 +2243,9 @@ llvm_points_to_bitfield (getAllLLVM -> ptr) fieldName (getAllLLVM -> val) = let path = [ResolvedField fieldName] _ <- llvm_points_to_check_lhs_validity ptr loc path - bfIndex <- resolveSetupBitfieldIndexOrFail cc env nameEnv ptr fieldName + bfIndex <- exceptToFail $ resolveSetupBitfield cc env nameEnv ptr fieldName let lhsFieldTy = Crucible.IntType $ fromIntegral $ biFieldSize bfIndex - valTy <- typeOfSetupValue cc env nameEnv val + valTy <- exceptToFail $ typeOfSetupValue cc env nameEnv val -- Currently, we require the type of the RHS value to precisely match -- the type of the field within the bitfield. One could imagine -- having finer-grained control over this (e.g., @@ -2279,7 +2279,7 @@ llvm_points_to_check_lhs_validity ptr loc path = else Setup.csResolvedState %= markResolved ptr path let env = MS.csAllocations (st ^. Setup.csMethodSpec) nameEnv = MS.csTypeNames (st ^. Setup.csMethodSpec) - ptrTy <- typeOfSetupValue cc env nameEnv ptr + ptrTy <- exceptToFail $ typeOfSetupValue cc env nameEnv ptr case ptrTy of Crucible.PtrType symTy -> case Crucible.asMemType symTy of @@ -2326,7 +2326,7 @@ llvm_points_to_array_prefix (getAllLLVM -> ptr) arr sz = else Setup.csResolvedState %= markResolved ptr [] let env = MS.csAllocations (st ^. Setup.csMethodSpec) nameEnv = MS.csTypeNames (st ^. Setup.csMethodSpec) - ptrTy <- typeOfSetupValue cc env nameEnv ptr + ptrTy <- exceptToFail $ typeOfSetupValue cc env nameEnv ptr _ <- case ptrTy of Crucible.PtrType symTy -> case Crucible.asMemType symTy of @@ -2351,8 +2351,8 @@ llvm_equal (getAllLLVM -> val1) (getAllLLVM -> val2) = st <- get let env = MS.csAllocations (st ^. Setup.csMethodSpec) nameEnv = MS.csTypeNames (st ^. Setup.csMethodSpec) - ty1 <- typeOfSetupValue cc env nameEnv val1 - ty2 <- typeOfSetupValue cc env nameEnv val2 + ty1 <- exceptToFail $ typeOfSetupValue cc env nameEnv val1 + ty2 <- exceptToFail $ typeOfSetupValue cc env nameEnv val2 b <- liftIO $ checkRegisterCompatibility ty1 ty2 unless b $ throwCrucibleSetup loc $ unlines diff --git a/src/SAWScript/Crucible/LLVM/MethodSpecIR.hs b/src/SAWScript/Crucible/LLVM/MethodSpecIR.hs index f7a64dbf0c..66b3598ce5 100644 --- a/src/SAWScript/Crucible/LLVM/MethodSpecIR.hs +++ b/src/SAWScript/Crucible/LLVM/MethodSpecIR.hs @@ -98,6 +98,7 @@ module SAWScript.Crucible.LLVM.MethodSpecIR , anySetupStruct , anySetupElem , anySetupField + , anySetupUnion , anySetupNull , anySetupGlobal , anySetupGlobalInitializer @@ -173,6 +174,7 @@ type instance MS.HasSetupArray (LLVM _) = 'True type instance MS.HasSetupElem (LLVM _) = 'True type instance MS.HasSetupField (LLVM _) = 'True type instance MS.HasSetupCast (LLVM _) = 'True +type instance MS.HasSetupUnion (LLVM _) = 'True type instance MS.HasSetupGlobal (LLVM _) = 'True type instance MS.HasSetupGlobalInitializer (LLVM _) = 'True @@ -582,6 +584,9 @@ anySetupCast val ty = mkAllLLVM (MS.SetupCast () (getAllLLVM val) ty) anySetupField :: AllLLVM MS.SetupValue -> String -> AllLLVM MS.SetupValue anySetupField val field = mkAllLLVM (MS.SetupField () (getAllLLVM val) field) +anySetupUnion :: AllLLVM MS.SetupValue -> String -> AllLLVM MS.SetupValue +anySetupUnion val uname = mkAllLLVM (MS.SetupUnion () (getAllLLVM val) uname) + anySetupNull :: AllLLVM MS.SetupValue anySetupNull = mkAllLLVM (MS.SetupNull ()) diff --git a/src/SAWScript/Crucible/LLVM/Override.hs b/src/SAWScript/Crucible/LLVM/Override.hs index 694f8bccc1..f29bf1731a 100644 --- a/src/SAWScript/Crucible/LLVM/Override.hs +++ b/src/SAWScript/Crucible/LLVM/Override.hs @@ -64,8 +64,8 @@ import Control.Lens.Lens import Control.Lens.Setter import Control.Lens.TH import Control.Exception as X -import Control.Monad.IO.Class (liftIO) import Control.Monad +import Control.Monad.Except import Data.Either (partitionEithers) import Data.Foldable (for_, traverse_, toList) import Data.List @@ -192,11 +192,11 @@ mkStructuralMismatch :: mkStructuralMismatch _opts cc _sc spec llvmval setupval memTy = let tyEnv = MS.csAllocations spec nameEnv = MS.csTypeNames spec - maybeTy = typeOfSetupValue cc tyEnv nameEnv setupval + maybeMsgTy = either (const Nothing) Just $ runExcept (typeOfSetupValue cc tyEnv nameEnv setupval) in pure $ StructuralMismatch (PP.pretty llvmval) (MS.ppSetupValue setupval) - maybeTy + maybeMsgTy memTy -- | Instead of using 'ppPointsTo', which prints 'SetupValue', translate @@ -1023,6 +1023,7 @@ matchPointsTos opts sc cc spec prepost = go False [] SetupElem _ x _ -> setupVars x SetupField _ x _ -> setupVars x SetupCast _ x _ -> setupVars x + SetupUnion _ x _ -> setupVars x SetupTerm _ -> Set.empty SetupNull _ -> Set.empty SetupGlobal _ _ -> Set.empty @@ -1194,15 +1195,21 @@ matchArg opts sc cc cs prepost actual expectedTy expected = (Crucible.LLVMValInt blk off, Crucible.PtrType _, SetupElem () v i) -> do let tyenv = MS.csAllocations cs nameEnv = MS.csTypeNames cs - i' <- resolveSetupElemIndexOrFail cc tyenv nameEnv v i + delta <- exceptToFail $ resolveSetupElemOffset cc tyenv nameEnv v i off' <- liftIO $ W4.bvSub sym off - =<< W4.bvLit sym (W4.bvWidth off) (Crucible.bytesToBV (W4.bvWidth off) i') + =<< W4.bvLit sym (W4.bvWidth off) (Crucible.bytesToBV (W4.bvWidth off) delta) matchArg opts sc cc cs prepost (Crucible.LLVMValInt blk off') expectedTy v - (_, Crucible.PtrType _, SetupField () v n) -> + + (Crucible.LLVMValInt blk off, Crucible.PtrType _, SetupField () v n) -> do let tyenv = MS.csAllocations cs nameEnv = MS.csTypeNames cs - i <- resolveSetupFieldIndexOrFail cc tyenv nameEnv v n - matchArg opts sc cc cs prepost actual expectedTy (SetupElem () v i) + fld <- exceptToFail $ + do info <- resolveSetupValueInfo cc tyenv nameEnv v + recoverStructFieldInfo cc tyenv nameEnv v info n + let delta = fromIntegral $ Crucible.fiOffset fld + off' <- liftIO $ W4.bvSub sym off + =<< W4.bvLit sym (W4.bvWidth off) (Crucible.bytesToBV (W4.bvWidth off) delta) + matchArg opts sc cc cs prepost (Crucible.LLVMValInt blk off') expectedTy v (_, _, SetupGlobalInitializer () _) -> resolveAndMatch @@ -1478,7 +1485,7 @@ matchPointsToValue opts sc cc spec prepost loc maybe_cond ptr val = case val of ConcreteSizeValue val' -> - do memTy <- liftIO $ typeOfSetupValue cc tyenv nameEnv val' + do memTy <- exceptToFail $ typeOfSetupValue cc tyenv nameEnv val' -- In case the types are different (from llvm_points_to_untyped) -- then the load type should be determined by the rhs. storTy <- Crucible.toStorableType memTy @@ -1840,14 +1847,14 @@ invalidateMutableAllocs opts sc cc cs = _ -> pure Nothing -- set of (concrete base pointer, size) for each postcondition memory write - postPtrs <- Set.fromList <$> catMaybes <$> mapM + postPtrs <- Set.fromList <$> catMaybes <$> traverse (\case LLVMPointsTo _loc _cond ptr val -> case val of ConcreteSizeValue val' -> do (_, Crucible.LLVMPointer blk _) <- resolveSetupValue opts cc sc cs Crucible.PtrRepr ptr - sz <- (return . Crucible.storageTypeSize) - =<< Crucible.toStorableType - =<< typeOfSetupValue cc (MS.csAllocations cs) (MS.csTypeNames cs) val' + memTy <- exceptToFail $ + typeOfSetupValue cc (MS.csAllocations cs) (MS.csTypeNames cs) val' + sz <- Crucible.storageTypeSize <$> Crucible.toStorableType memTy return $ Just (W4.asNat blk, sz) SymbolicSizeValue{} -> return Nothing LLVMPointsToBitfield _loc ptr fieldName _val -> do @@ -2063,7 +2070,7 @@ storePointsToValue opts cc env tyenv nameEnv base_mem maybe_cond ptr val maybe_i let store_op = \mem -> case val of ConcreteSizeValue val' -> do - memTy <- typeOfSetupValue cc tyenv nameEnv val' + memTy <- exceptToFail $ typeOfSetupValue cc tyenv nameEnv val' storTy <- Crucible.toStorableType memTy case val' of SetupTerm tm @@ -2103,7 +2110,7 @@ storePointsToValue opts cc env tyenv nameEnv base_mem maybe_cond ptr val maybe_i let invalidate_op = \mem -> do sz <- case val of ConcreteSizeValue val' -> do - memTy <- typeOfSetupValue cc tyenv nameEnv val' + memTy <- exceptToFail $ typeOfSetupValue cc tyenv nameEnv val' storTy <- Crucible.toStorableType memTy W4.bvLit sym @@ -2353,6 +2360,7 @@ instantiateSetupValue sc s v = SetupElem{} -> return v SetupField{} -> return v SetupCast{} -> return v + SetupUnion{} -> return v SetupNull{} -> return v SetupGlobal{} -> return v SetupGlobalInitializer{} -> return v @@ -2375,7 +2383,7 @@ resolveSetupValueLLVM opts cc sc spec sval = mem <- readGlobal (Crucible.llvmMemVar (ccLLVMContext cc)) let tyenv = MS.csAllocations spec nameEnv = MS.csTypeNames spec - memTy <- liftIO $ typeOfSetupValue cc tyenv nameEnv sval + memTy <- exceptToFail $ typeOfSetupValue cc tyenv nameEnv sval sval' <- liftIO $ instantiateSetupValue sc s sval lval <- liftIO $ resolveSetupVal cc mem m tyenv nameEnv sval' `X.catch` handleException opts return (memTy, lval) diff --git a/src/SAWScript/Crucible/LLVM/ResolveSetupValue.hs b/src/SAWScript/Crucible/LLVM/ResolveSetupValue.hs index db16fb3b00..e659af8691 100644 --- a/src/SAWScript/Crucible/LLVM/ResolveSetupValue.hs +++ b/src/SAWScript/Crucible/LLVM/ResolveSetupValue.hs @@ -20,15 +20,15 @@ module SAWScript.Crucible.LLVM.ResolveSetupValue , resolveSetupVal , resolveSetupValBitfield , typeOfSetupValue + , exceptToFail , resolveTypedTerm , resolveSAWPred , resolveSAWSymBV - , resolveSetupFieldIndex - , resolveSetupFieldIndexOrFail + , recoverStructFieldInfo + , resolveSetupValueInfo , BitfieldIndex(..) - , resolveSetupBitfieldIndex - , resolveSetupBitfieldIndexOrFail - , resolveSetupElemIndexOrFail + , resolveSetupBitfield + , resolveSetupElemOffset , equalValsPred , memArrayToSawCoreTerm , scPtrWidthBvNat @@ -37,10 +37,10 @@ module SAWScript.Crucible.LLVM.ResolveSetupValue import Control.Lens ((^.)) import Control.Monad -import qualified Control.Monad.Fail as Fail +import Control.Monad.Except import Control.Monad.State import qualified Data.BitVector.Sized as BV -import Data.Maybe (fromMaybe, listToMaybe, fromJust) +import Data.Maybe (fromMaybe, fromJust) import Data.Map (Map) import qualified Data.Map as Map @@ -85,90 +85,241 @@ import SAWScript.Crucible.Common.MethodSpec (AllocIndex(..), SetupValu import SAWScript.Crucible.LLVM.MethodSpecIR import qualified SAWScript.Proof as SP ---import qualified SAWScript.LLVMBuiltins as LB type LLVMVal = Crucible.LLVMVal Sym type LLVMPtr wptr = Crucible.LLVMPtr Sym wptr --- | Use the LLVM metadata to determine the struct field index --- corresponding to the given field name. + + +exceptToFail :: MonadFail m => Except String a -> m a +exceptToFail m = either fail pure $ runExcept m + +-- | Attempt to look up LLVM debug metadata regarding the type of the +-- given setup value. This is a best-effort procedure, as the +-- necessary debug information may not be avaliable. Even if this +-- procedure succeeds, the returned information may be partial, in +-- the sense that it may contain `Unknown` nodes. resolveSetupValueInfo :: - LLVMCrucibleContext wptr {- ^ crucible context -} -> - Map AllocIndex LLVMAllocSpec {- ^ allocation types -} -> + LLVMCrucibleContext wptr {- ^ crucible context -} -> + Map AllocIndex LLVMAllocSpec {- ^ allocation types -} -> Map AllocIndex Crucible.Ident {- ^ allocation type names -} -> - SetupValue (LLVM arch) {- ^ pointer to struct -} -> - L.Info {- ^ field index -} + SetupValue (LLVM arch) {- ^ pointer value -} -> + Except String L.Info {- ^ debug type info of pointed-to type -} resolveSetupValueInfo cc env nameEnv v = case v of SetupGlobal _ name -> case lookup (L.Symbol name) globalTys of - Just (L.Alias alias) -> L.Pointer (L.guessAliasInfo mdMap alias) - _ -> L.Unknown + Just (L.Alias alias) -> pure (L.guessAliasInfo mdMap alias) + _ -> throwError $ "Debug info for global name '"++name++"' not found." - SetupVar i - | Just alias <- Map.lookup i nameEnv - -> L.Pointer (L.guessAliasInfo mdMap alias) + SetupVar i -> + case Map.lookup i nameEnv of + Just alias -> pure (L.guessAliasInfo mdMap alias) + Nothing -> + -- TODO? is this a panic situation? + throwError $ "Type information for local allocation value not found: " ++ show i - SetupCast () _ (L.Alias alias) - -> L.Pointer (L.guessAliasInfo mdMap alias) + SetupCast () _ (L.Alias alias) -> pure (L.guessAliasInfo mdMap alias) SetupField () a n -> - fromMaybe L.Unknown $ - do L.Pointer (L.Structure xs) <- return (resolveSetupValueInfo cc env nameEnv a) - listToMaybe [L.Pointer i | L.StructFieldInfo{L.sfiName = n', L.sfiInfo = i} <- xs, n == n' ] + do i <- resolveSetupValueInfo cc env nameEnv a + case findStruct i of + Nothing -> + throwError $ unlines $ + [ "Unable to resolve struct field name: '" ++ n ++ "'" + , "Could not resolve setup value debug information into a struct type." + , case i of + L.Unknown -> "Perhaps you need to compile with debug symbols enabled." + _ -> show i + ] + Just (snm, xs) -> + case [ i' | L.StructFieldInfo{L.sfiName = n', L.sfiInfo = i' } <- xs, n == n' ] of + [] -> throwError $ unlines $ + [ "Unable to resolve struct field name: '" ++ n ++ "'"] ++ + [ "Struct with name '" ++ str ++ "' found." | Just str <- [snm] ] ++ + [ "The following field names were found for this struct:" ] ++ + map ("- "++) [n' | L.StructFieldInfo{L.sfiName = n'} <- xs] + i':_ -> pure i' + + SetupUnion () a u -> + do i <- resolveSetupValueInfo cc env nameEnv a + case findUnion i of + Nothing -> + throwError $ unlines $ + [ "Unable to resolve union field name: '" ++ u ++ "'" + , "Could not resolve setup value debug information into a union type." + , case i of + L.Unknown -> "Perhaps you need to compile with debug symbols enabled." + _ -> show i + ] + Just (unm, xs) -> + case [ i' | L.UnionFieldInfo{L.ufiName = n', L.ufiInfo = i'} <- xs, u == n' ] of + [] -> throwError $ unlines $ + [ "Unable to resolve union field name: '" ++ u ++ "'"] ++ + [ "Union with name '" ++ str ++ "' found." | Just str <- [unm] ] ++ + [ "The following field names were found for this union:" ] ++ + map ("- "++) [n' | L.UnionFieldInfo{L.ufiName = n'} <- xs] + i':_ -> pure i' + + _ -> pure L.Unknown - _ -> L.Unknown where globalTys = [ (L.globalSym g, L.globalType g) | g <- L.modGlobals (ccLLVMModuleAST cc) ] mdMap = Crucible.llvmMetadataMap (ccTypeCtx cc) --- | Use the LLVM metadata to determine the struct field index --- corresponding to the given field name. -resolveSetupFieldIndex :: - LLVMCrucibleContext arch {- ^ crucible context -} -> - Map AllocIndex LLVMAllocSpec {- ^ allocation types -} -> - Map AllocIndex Crucible.Ident {- ^ allocation type names -} -> - SetupValue (LLVM arch) {- ^ pointer to struct -} -> - String {- ^ field name -} -> - Maybe Int {- ^ field index -} -resolveSetupFieldIndex cc env nameEnv v n = - case resolveSetupValueInfo cc env nameEnv v of - L.Pointer (L.Structure xs) -> +-- | Given DWARF type information that is expected to describe a +-- struct, find it's name (if any) and information about its fields. +-- This procedure handles the common case where a typedef is used to +-- give a name to an anonymous struct. If a struct both has a direct +-- name and is included in a typedef, the direct name will be preferred. +findStruct :: L.Info -> Maybe (Maybe String, [L.StructFieldInfo]) +findStruct = loop Nothing + where loop _ (L.Typedef nm i) = loop (Just nm) i + loop nm (L.Structure nm' xs) = Just (nm' <> nm, xs) + loop _ _ = Nothing + +-- | Given DWARF type information that is expected to describe a +-- union, find it's name (if any) and information about its fields. +-- This procedure handles the common case where a typedef is used to +-- give a name to an anonymous union. If a union both has a direct +-- name and is included in a typedef, the direct name will be preferred. +findUnion :: L.Info -> Maybe (Maybe String, [L.UnionFieldInfo]) +findUnion = loop Nothing + where loop _ (L.Typedef nm i) = loop (Just nm) i + loop nm (L.Union nm' xs) = Just (nm' <> nm, xs) + loop _ _ = Nothing + +-- | Given LLVM debug information about a setup value, attempt to +-- find the corresponding @FieldInfo@ structure for the named +-- field. +recoverStructFieldInfo :: + LLVMCrucibleContext arch {- ^ crucible context -} -> + Map AllocIndex LLVMAllocSpec {- ^ allocation types -} -> + Map AllocIndex Crucible.Ident {- ^ allocation type names -} -> + SetupValue (LLVM arch) {- ^ the value to examine -} -> + L.Info {- ^ extracted LLVM debug information about the type of the value -} -> + String {- ^ the name of the field -} -> + Except String Crucible.FieldInfo +recoverStructFieldInfo cc env nameEnv v info n = + case findStruct info of + Nothing -> + throwError $ unlines $ + [ "Unable to resolve struct field name: '" ++ show n ++ "'" + , "Could not resolve setup value debug information into a struct type." + , case info of + L.Unknown -> "Perhaps you need to compile with debug symbols enabled." + _ -> show info + ] + Just (snm,xs) -> case [o | L.StructFieldInfo{L.sfiName = n', L.sfiOffset = o} <- xs, n == n' ] of - [] -> Nothing + [] -> throwError $ unlines $ + [ "Unable to resolve struct field name: '" ++ n ++ "'"] ++ + [ "Struct with name '" ++ str ++ "' found." | Just str <- [snm] ] ++ + [ "The following field names were found for this struct:" ] ++ + map ("- "++) [n' | L.StructFieldInfo{L.sfiName = n'} <- xs] o:_ -> - do Crucible.PtrType symTy <- typeOfSetupValue cc env nameEnv v - Crucible.StructType si <- - let ?lc = lc - in either (\_ -> Nothing) Just $ Crucible.asMemType symTy - V.findIndex (\fi -> Crucible.bytesToBits (Crucible.fiOffset fi) == fromIntegral o) (Crucible.siFields si) - - _ -> Nothing + do vty <- typeOfSetupValue cc env nameEnv v + case do Crucible.PtrType symTy <- pure vty + Crucible.StructType si <- let ?lc = ccTypeCtx cc + in either (\_ -> Nothing) Just $ Crucible.asMemType symTy + V.find (\fi -> Crucible.bytesToBits (Crucible.fiOffset fi) == fromIntegral o) + (Crucible.siFields si) + of + Nothing -> + throwError $ unlines $ + [ "Found struct field name: '" ++ n ++ "'"] ++ + [ "in struct with name '" ++ str ++ "'." | Just str <- [snm] ] ++ + [ "However, the offset of this field found in the debug information could not" + , "be correlated with the computed LLVM type of the setup value:" + , show vty + ] + Just fld -> return fld + +-- | Attempt to turn type information from DWARF debug data back into +-- the corresponding LLVM type. This is a best-effort procedure, as +-- we may have to make educated guesses about names, and there might +-- not be enough data to succeed. +reverseDebugInfoType :: L.Info -> Maybe L.Type +reverseDebugInfoType = loop Nothing where - lc = ccTypeCtx cc + loop n i = case i of + L.Unknown -> + case n of + Just nm -> Just (L.Alias (L.Ident nm)) + Nothing -> Nothing + + L.Pointer i' -> L.PtrTo <$> loop Nothing i' + + L.Union n' _ -> + case n' <> n of + Just nm -> Just (L.Alias (L.Ident ("union."++ nm))) + Nothing -> Nothing + + L.Structure n' xs -> + case n' <> n of + Just nm -> Just (L.Alias (L.Ident ("struct." ++ nm))) + Nothing -> L.Struct <$> mapM (reverseDebugInfoType . L.sfiInfo) xs + + L.Typedef nm x -> loop (Just nm) x + + L.ArrInfo x -> L.Array 0 <$> loop Nothing x + + L.BaseType _nm bt -> reverseBaseTypeInfo bt + +-- | Attempt to turn DWARF basic type information back into +-- LLVM type syntax. This process is currently rather +-- ad-hoc, and may miss cases. +reverseBaseTypeInfo :: L.DIBasicType -> Maybe L.Type +reverseBaseTypeInfo dibt = +-- TODO, find a nicer API than using these magic numbers, taken from: + -- https://github.com/llvm-mirror/llvm/blob/release_38/include/llvm/Support/Dwarf.def + -- DWARF attribute type encodings. + -- HANDLE_DW_ATE(0x01, address) + -- HANDLE_DW_ATE(0x02, boolean) + -- HANDLE_DW_ATE(0x03, complex_float) + -- HANDLE_DW_ATE(0x04, float) + -- HANDLE_DW_ATE(0x05, signed) + -- HANDLE_DW_ATE(0x06, signed_char) + -- HANDLE_DW_ATE(0x07, unsigned) + -- HANDLE_DW_ATE(0x08, unsigned_char) + -- HANDLE_DW_ATE(0x09, imaginary_float) + -- HANDLE_DW_ATE(0x0a, packed_decimal) + -- HANDLE_DW_ATE(0x0b, numeric_string) + -- HANDLE_DW_ATE(0x0c, edited) + -- HANDLE_DW_ATE(0x0d, signed_fixed) + -- HANDLE_DW_ATE(0x0e, unsigned_fixed) + -- HANDLE_DW_ATE(0x0f, decimal_float) + -- HANDLE_DW_ATE(0x10, UTF) + + case L.dibtEncoding dibt of + -- boolean + 0x02 -> Just $ L.PrimType $ L.Integer 1 + + -- floats + -- TODO? is this doing the right thing? + 0x04 -> case L.dibtSize dibt of + 16 -> Just $ L.PrimType $ L.FloatType $ L.Half + 32 -> Just $ L.PrimType $ L.FloatType $ L.Float + 64 -> Just $ L.PrimType $ L.FloatType $ L.Double + 80 -> Just $ L.PrimType $ L.FloatType $ L.X86_fp80 + 128 -> Just $ L.PrimType $ L.FloatType $ L.Fp128 + _ -> Nothing + + -- signed int + 0x05 -> Just $ L.PrimType $ L.Integer (fromIntegral (L.dibtSize dibt)) + + -- signed_char + 0x06 -> Just $ L.PrimType $ L.Integer 8 + + -- unsigned int + 0x07 -> Just $ L.PrimType $ L.Integer (fromIntegral (L.dibtSize dibt)) + + -- unsigned_char + 0x08 -> Just $ L.PrimType $ L.Integer 8 + + _ -> Nothing + -resolveSetupFieldIndexOrFail :: - Fail.MonadFail m => - LLVMCrucibleContext arch {- ^ crucible context -} -> - Map AllocIndex LLVMAllocSpec {- ^ allocation types -} -> - Map AllocIndex Crucible.Ident {- ^ allocation type names -} -> - SetupValue (LLVM arch) {- ^ pointer to struct -} -> - String {- ^ field name -} -> - m Int {- ^ field index -} -resolveSetupFieldIndexOrFail cc env nameEnv v n = - case resolveSetupFieldIndex cc env nameEnv v n of - Just i -> pure i - Nothing -> - let msg = "Unable to resolve field name: " ++ show n - in - fail $ - -- Show the user what fields were available (if any) - case resolveSetupValueInfo cc env nameEnv v of - L.Pointer (L.Structure xs) -> unlines $ - [ msg - , "The following field names were found for this struct:" - ] ++ map ("- "++) [n' | L.StructFieldInfo{L.sfiName = n'} <- xs] - _ -> unlines [msg, "No field names were found for this struct"] -- | Information about a field within a bitfield in a struct. For example, -- given the following C struct: @@ -190,7 +341,7 @@ resolveSetupFieldIndexOrFail cc env nameEnv v n = -- 'BitfieldIndex' -- { 'biFieldSize' = 1 -- , 'biFieldOffset' = 0 --- , 'biBitfieldIndex' = 4 +-- , 'biBitfieldByteOffset' = 4 -- , 'biBitfieldType' = i8 -- } -- @@ -198,7 +349,7 @@ resolveSetupFieldIndexOrFail cc env nameEnv v n = -- 'BitfieldIndex' -- { 'biFieldSize' = 2 -- , 'biFieldOffset' = 1 --- , 'biBitfieldIndex' = 4 +-- , 'biBitfieldByteOffset' = 4 -- , 'biBitfieldType' = i8 -- } -- @@ -206,7 +357,7 @@ resolveSetupFieldIndexOrFail cc env nameEnv v n = -- 'BitfieldIndex' -- { 'biFieldSize' = 1 -- , 'biFieldOffset' = 3 --- , 'biBitfieldIndex' = 4 +-- , 'biBitfieldByteOffset' = 4 -- , 'biBitfieldType' = i8 -- } -- @ @@ -220,147 +371,145 @@ data BitfieldIndex = BitfieldIndex , biFieldOffset :: Word64 -- ^ The offset (in bits) of the field from the start of the bitfield, -- counting from the least significant bit. - , biBitfieldIndex :: Int - -- ^ The struct field index corresponding to the overall bitfield, where - -- the index represents the number of bytes the bitfield is from the - -- start of the struct. + , biFieldByteOffset :: Crucible.Bytes + -- ^ The offset (in bytes) of the struct member in which this bitfield resides. , biBitfieldType :: Crucible.MemType -- ^ The 'Crucible.MemType' of the overall bitfield. } deriving Show --- | Returns @'Just' bi@ if SAW is able to find a field within a bitfield with --- the supplied name in the LLVM debug metadata. Returns 'Nothing' otherwise. -resolveSetupBitfieldIndex :: +-- | Given a pointer setup value and the name of a bitfield, attempt to +-- determine were in the struct that bitfield resides by examining +-- DWARF type metadata. +resolveSetupBitfield :: LLVMCrucibleContext arch {- ^ crucible context -} -> Map AllocIndex LLVMAllocSpec {- ^ allocation types -} -> Map AllocIndex Crucible.Ident {- ^ allocation type names -} -> SetupValue (LLVM arch) {- ^ pointer to struct -} -> String {- ^ field name -} -> - Maybe BitfieldIndex {- ^ information about bitfield -} -resolveSetupBitfieldIndex cc env nameEnv v n = - case resolveSetupValueInfo cc env nameEnv v of - L.Pointer (L.Structure xs) - | (fieldOffsetStartingFromStruct, bfInfo):_ <- - [ (fieldOffsetStartingFromStruct, bfInfo) - | L.StructFieldInfo - { L.sfiName = n' - , L.sfiOffset = fieldOffsetStartingFromStruct - , L.sfiBitfield = Just bfInfo - } <- xs - , n == n' + Except String BitfieldIndex {- ^ information about bitfield -} +resolveSetupBitfield cc env nameEnv v n = + do info <- resolveSetupValueInfo cc env nameEnv v + case findStruct info of + Nothing -> + throwError $ unlines $ + [ "Unable to resolve struct bitfield name: '" ++ show n ++ "'" + , "Could not resolve setup value debug information into a struct type." + , case info of + L.Unknown -> "Perhaps you need to compile with debug symbols enabled." + _ -> show info ] - -> do Crucible.PtrType symTy <- typeOfSetupValue cc env nameEnv v - Crucible.StructType si <- - let ?lc = lc - in either (\_ -> Nothing) Just $ Crucible.asMemType symTy - bfIndex <- - V.findIndex (\fi -> Crucible.bytesToBits (Crucible.fiOffset fi) - == fromIntegral (L.biBitfieldOffset bfInfo)) - (Crucible.siFields si) - let bfType = Crucible.fiType $ Crucible.siFields si V.! bfIndex - fieldOffsetStartingFromBitfield = - fieldOffsetStartingFromStruct - L.biBitfieldOffset bfInfo - pure $ BitfieldIndex { biFieldSize = L.biFieldSize bfInfo - , biFieldOffset = fieldOffsetStartingFromBitfield - , biBitfieldIndex = bfIndex - , biBitfieldType = bfType - } - - _ -> Nothing - where - lc = ccTypeCtx cc - --- | Like 'resolveSetupBitfieldIndex', but if SAW cannot find the supplied --- name, fail instead of returning 'Nothing'. -resolveSetupBitfieldIndexOrFail :: - Fail.MonadFail m => - LLVMCrucibleContext arch {- ^ crucible context -} -> - Map AllocIndex LLVMAllocSpec {- ^ allocation types -} -> + Just (snm, xs) -> + case [ (fieldOffsetStartingFromStruct, bfInfo) | L.StructFieldInfo + { L.sfiName = n' + , L.sfiOffset = fieldOffsetStartingFromStruct + , L.sfiBitfield = Just bfInfo + } <- xs, n == n' ] of + + [] -> throwError $ unlines $ + [ "Unable to resolve struct bitfield name: '" ++ n ++ "'"] ++ + [ "Struct with name '" ++ str ++ "' found." | Just str <- [snm] ] ++ + [ "The following bitfield names were found for this struct:" ] ++ + map ("- "++) [n' | L.StructFieldInfo{L.sfiName = n', L.sfiBitfield = Just{}} <- xs] + + ((fieldOffsetStartingFromStruct, bfInfo):_) -> + do memTy <- typeOfSetupValue cc env nameEnv v + case do Crucible.PtrType symTy <- pure memTy + Crucible.StructType si <- let ?lc = ccTypeCtx cc + in either (\_ -> Nothing) Just $ Crucible.asMemType symTy + fi <- V.find (\fi -> Crucible.bytesToBits (Crucible.fiOffset fi) + == fromIntegral (L.biBitfieldOffset bfInfo)) + (Crucible.siFields si) + let fieldOffsetStartingFromBitfield = + fieldOffsetStartingFromStruct - L.biBitfieldOffset bfInfo + pure $ BitfieldIndex { biFieldSize = L.biFieldSize bfInfo + , biFieldOffset = fieldOffsetStartingFromBitfield + , biBitfieldType = Crucible.fiType fi + , biFieldByteOffset = Crucible.fiOffset fi + } + of + Nothing -> + throwError $ unlines $ + [ "Found struct field name: '" ++ n ++ "'"] ++ + [ "in struct with name '" ++ str ++ "'." | Just str <- [snm] ] ++ + [ "However, the offset of this field found in the debug information could not" + , "be correlated with the computed LLVM type of the setup value, or the field" + , "is not a bitfield." + , show memTy + ] + + Just bfi -> return bfi + +-- | Attempt to compute the @MemType@ of a setup value. +typeOfSetupValue :: forall arch. + LLVMCrucibleContext arch {- ^ crucible context -} -> + Map AllocIndex LLVMAllocSpec {- ^ allocation types -} -> Map AllocIndex Crucible.Ident {- ^ allocation type names -} -> - SetupValue (LLVM arch) {- ^ pointer to struct -} -> - String {- ^ field name -} -> - m BitfieldIndex {- ^ field index -} -resolveSetupBitfieldIndexOrFail cc env nameEnv v n = - case resolveSetupBitfieldIndex cc env nameEnv v n of - Just i -> pure i - Nothing -> - let msg = "Unable to resolve field name: " ++ show n - in - fail $ - -- Show the user what fields were available (if any) - case resolveSetupValueInfo cc env nameEnv v of - L.Pointer (L.Structure xs) -> unlines $ - [ msg - , "The following bitfield names were found for this struct:" - ] ++ map ("- "++) [n' | L.StructFieldInfo{ L.sfiName = n' - , L.sfiBitfield = Just{} - } <- xs] - _ -> unlines [msg, "No field names were found for this struct"] - -typeOfSetupValue :: - Fail.MonadFail m => - LLVMCrucibleContext arch -> - Map AllocIndex LLVMAllocSpec -> - Map AllocIndex Crucible.Ident -> - SetupValue (LLVM arch) -> - m Crucible.MemType + SetupValue (LLVM arch) {- ^ value to compute the type of -} -> + Except String Crucible.MemType typeOfSetupValue cc env nameEnv val = - do let ?lc = ccTypeCtx cc - typeOfSetupValue' cc env nameEnv val - -typeOfSetupValue' :: forall m arch. - Fail.MonadFail m => - LLVMCrucibleContext arch -> - Map AllocIndex LLVMAllocSpec -> - Map AllocIndex Crucible.Ident -> - SetupValue (LLVM arch) -> - m Crucible.MemType -typeOfSetupValue' cc env nameEnv val = case val of SetupVar i -> case Map.lookup i env of - Nothing -> fail ("typeOfSetupValue: Unresolved prestate variable:" ++ show i) + Nothing -> throwError ("typeOfSetupValue: Unresolved prestate variable:" ++ show i) Just spec -> return (Crucible.PtrType (Crucible.MemType (spec ^. allocSpecType))) + SetupTerm tt -> case ttType tt of TypedTermSchema (Cryptol.Forall [] [] ty) -> case toLLVMType dl (Cryptol.evalValType mempty ty) of - Left err -> fail (toLLVMTypeErrToString err) + Left err -> throwError (toLLVMTypeErrToString err) Right memTy -> return memTy - tp -> fail $ unlines [ "typeOfSetupValue: expected monomorphic term" - , "instead got:" - , show (ppTypedTermType tp) - ] - SetupCast () v ltp -> - do memTy <- typeOfSetupValue cc env nameEnv v - case memTy of - Crucible.PtrType _symTy -> - case let ?lc = lc in Crucible.liftMemType (L.PtrTo ltp) of - Left err -> fail $ unlines [ "typeOfSetupValue: invalid type " ++ show ltp - , "Details:" - , err - ] - Right mt -> return mt + tp -> throwError $ unlines + [ "typeOfSetupValue: expected monomorphic term" + , "instead got:" + , show (ppTypedTermType tp) + ] - _ -> fail $ unwords $ - [ "typeOfSetupValue: tried to cast the type of a non-pointer value" - , "actual type of value: " ++ show memTy - ] SetupStruct () packed vs -> do memTys <- traverse (typeOfSetupValue cc env nameEnv) vs let si = Crucible.mkStructInfo dl packed memTys return (Crucible.StructType si) - SetupArray () [] -> fail "typeOfSetupValue: invalid empty llvm_array_value" + + SetupArray () [] -> throwError "typeOfSetupValue: invalid empty llvm_array_value" SetupArray () (v : vs) -> do memTy <- typeOfSetupValue cc env nameEnv v _memTys <- traverse (typeOfSetupValue cc env nameEnv) vs -- TODO: check that all memTys are compatible with memTy return (Crucible.ArrayType (fromIntegral (length (v:vs))) memTy) - SetupField () v n -> do - i <- resolveSetupFieldIndexOrFail cc env nameEnv v n - typeOfSetupValue' cc env nameEnv (SetupElem () v i) - SetupElem () v i -> + + SetupField () v n -> + do info <- resolveSetupValueInfo cc env nameEnv v + fld <- recoverStructFieldInfo cc env nameEnv v info n + pure $ Crucible.PtrType $ Crucible.MemType $ Crucible.fiType fld + + SetupUnion () v n -> + do info <- resolveSetupValueInfo cc env nameEnv (SetupUnion () v n) + case reverseDebugInfoType info of + Nothing -> throwError $ unlines + [ "Could not determine LLVM type from computed debug type information:" + , show info + ] + Just ltp -> typeOfSetupValue cc env nameEnv (SetupCast () v ltp) + + SetupCast () v ltp -> + do memTy <- typeOfSetupValue cc env nameEnv v + case memTy of + Crucible.PtrType _symTy -> + case let ?lc = lc in Crucible.liftMemType (L.PtrTo ltp) of + Left err -> throwError $ unlines + [ "typeOfSetupValue: invalid type " ++ show ltp + , "Details:" + , err + ] + Right mt -> pure mt + + _ -> throwError $ unwords $ + [ "typeOfSetupValue: tried to cast the type of a non-pointer value" + , "actual type of value: " ++ show memTy + ] + + SetupElem () v i -> do do memTy <- typeOfSetupValue cc env nameEnv v let msg = "typeOfSetupValue: llvm_elem requires pointer to struct or array, found " ++ show memTy case memTy of @@ -370,7 +519,7 @@ typeOfSetupValue' cc env nameEnv val = case memTy' of Crucible.ArrayType n memTy'' | fromIntegral i <= n -> return (Crucible.PtrType (Crucible.MemType memTy'')) - | otherwise -> fail $ unwords $ + | otherwise -> throwError $ unwords $ [ "typeOfSetupValue: array type index out of bounds" , "(index: " ++ show i ++ ")" , "(array length: " ++ show n ++ ")" @@ -378,16 +527,18 @@ typeOfSetupValue' cc env nameEnv val = Crucible.StructType si -> case Crucible.siFieldInfo si i of Just fi -> return (Crucible.PtrType (Crucible.MemType (Crucible.fiType fi))) - Nothing -> fail $ "typeOfSetupValue: struct type index out of bounds: " ++ show i - _ -> fail msg - Left err -> fail (unlines [msg, "Details:", err]) - _ -> fail msg + Nothing -> throwError $ "typeOfSetupValue: struct type index out of bounds: " ++ show i + _ -> throwError msg + Left err -> throwError (unlines [msg, "Details:", err]) + _ -> throwError msg + SetupNull () -> -- We arbitrarily set the type of NULL to void*, because a) it -- is memory-compatible with any type that NULL can be used at, -- and b) it prevents us from doing a type-safe dereference -- operation. return (Crucible.PtrType Crucible.VoidType) + -- A global and its initializer have the same type. SetupGlobal () name -> do let m = ccLLVMModuleAST cc @@ -395,37 +546,42 @@ typeOfSetupValue' cc env nameEnv val = [ (L.decName d, L.decFunType d) | d <- L.modDeclares m ] ++ [ (L.defName d, L.defFunType d) | d <- L.modDefines m ] case lookup (L.Symbol name) tys of - Nothing -> fail $ "typeOfSetupValue: unknown global " ++ show name + Nothing -> throwError $ "typeOfSetupValue: unknown global " ++ show name Just ty -> case let ?lc = lc in Crucible.liftType ty of - Left err -> fail $ unlines [ "typeOfSetupValue: invalid type " ++ show ty - , "Details:" - , err - ] + Left err -> throwError $ unlines + [ "typeOfSetupValue: invalid type " ++ show ty + , "Details:" + , err + ] Right symTy -> return (Crucible.PtrType symTy) + SetupGlobalInitializer () name -> do case Map.lookup (L.Symbol name) (Crucible.globalInitMap $ ccLLVMModuleTrans cc) of Just (g, _) -> case let ?lc = lc in Crucible.liftMemType (L.globalType g) of - Left err -> fail $ unlines [ "typeOfSetupValue: invalid type " ++ show (L.globalType g) - , "Details:" - , err - ] + Left err -> throwError $ unlines + [ "typeOfSetupValue: invalid type " ++ show (L.globalType g) + , "Details:" + , err + ] Right memTy -> return memTy - Nothing -> fail $ "resolveSetupVal: global not found: " ++ name + Nothing -> throwError $ "resolveSetupVal: global not found: " ++ name where lc = ccTypeCtx cc dl = Crucible.llvmDataLayout lc -resolveSetupElemIndexOrFail :: - Fail.MonadFail m => - LLVMCrucibleContext arch {- ^ crucible context -} -> - Map AllocIndex LLVMAllocSpec {- ^ allocation types -} -> +-- | Given a pointer setup value that points to an aggregate +-- type (struct or array), attempt to compute the byte offset of +-- the nth element of that aggregate structure. +resolveSetupElemOffset :: + LLVMCrucibleContext arch {- ^ crucible context -} -> + Map AllocIndex LLVMAllocSpec {- ^ allocation types -} -> Map AllocIndex Crucible.Ident {- ^ allocation type names -} -> - SetupValue (LLVM arch) {- ^ base pointer -} -> + SetupValue (LLVM arch) {- ^ base pointer -} -> Int {- ^ element index -} -> - m Crucible.Bytes {- ^ element offset -} -resolveSetupElemIndexOrFail cc env nameEnv v i = do + Except String Crucible.Bytes {- ^ element offset -} +resolveSetupElemOffset cc env nameEnv v i = do do memTy <- typeOfSetupValue cc env nameEnv v let msg = "resolveSetupVal: llvm_elem requires pointer to struct or array, found " ++ show memTy case memTy of @@ -438,10 +594,10 @@ resolveSetupElemIndexOrFail cc env nameEnv v i = do Crucible.StructType si -> case Crucible.siFieldOffset si i of Just d -> return d - Nothing -> fail $ "resolveSetupVal: struct type index out of bounds: " ++ show (i, memTy') - _ -> fail msg - Left err -> fail $ unlines [msg, "Details:", err] - _ -> fail msg + Nothing -> throwError $ "resolveSetupVal: struct type index out of bounds: " ++ show (i, memTy') + _ -> throwError msg + Left err -> throwError $ unlines [msg, "Details:", err] + _ -> throwError msg where lc = ccTypeCtx cc dl = Crucible.llvmDataLayout lc @@ -455,7 +611,7 @@ newtype W4EvalTactic = W4EvalTactic { doW4Eval :: Bool } deriving (Eq, Ord, Show) -- | Translate a SetupValue into a Crucible LLVM value, resolving --- references +-- references. resolveSetupVal :: forall arch. (?w4EvalTactic :: W4EvalTactic, Crucible.HasPtrWidth (Crucible.ArchWidth arch)) => LLVMCrucibleContext arch -> @@ -479,6 +635,9 @@ resolveSetupVal cc mem env tyenv nameEnv val = -- NB, SetupCast values should always be pointers. Pointer casts have no -- effect on the actual computed LLVMVal. SetupCast () v _lty -> resolveSetupVal cc mem env tyenv nameEnv v + -- NB, SetupUnion values should always be pointers. Pointer casts have no + -- effect on the actual computed LLVMVal. + SetupUnion () v _n -> resolveSetupVal cc mem env tyenv nameEnv v SetupStruct () packed vs -> do vals <- mapM (resolveSetupVal cc mem env tyenv nameEnv) vs let tps = map Crucible.llvmValStorableType vals @@ -493,10 +652,19 @@ resolveSetupVal cc mem env tyenv nameEnv val = let tp = Crucible.llvmValStorableType (V.head vals) return $ Crucible.LLVMValArray tp vals SetupField () v n -> do - i <- resolveSetupFieldIndexOrFail cc tyenv nameEnv v n - resolveSetupVal cc mem env tyenv nameEnv (SetupElem () v i) + do fld <- exceptToFail $ + do info <- resolveSetupValueInfo cc tyenv nameEnv v + recoverStructFieldInfo cc tyenv nameEnv v info n + ptr <- resolveSetupVal cc mem env tyenv nameEnv v + case ptr of + Crucible.LLVMValInt blk off -> + do delta <- W4.bvLit sym (W4.bvWidth off) (Crucible.bytesToBV (W4.bvWidth off) (Crucible.fiOffset fld)) + off' <- W4.bvAdd sym off delta + return (Crucible.LLVMValInt blk off') + _ -> fail "resolveSetupVal: llvm_field requires pointer value" + SetupElem () v i -> - do delta <- resolveSetupElemIndexOrFail cc tyenv nameEnv v i + do delta <- exceptToFail (resolveSetupElemOffset cc tyenv nameEnv v i) ptr <- resolveSetupVal cc mem env tyenv nameEnv v case ptr of Crucible.LLVMValInt blk off -> @@ -547,21 +715,21 @@ resolveSetupValBitfield :: IO (BitfieldIndex, LLVMVal) resolveSetupValBitfield cc mem env tyenv nameEnv val fieldName = do let sym = cc^.ccSym - lval <- resolveSetupVal cc mem env tyenv nameEnv val - bfIndex <- resolveSetupBitfieldIndexOrFail cc tyenv nameEnv val fieldName - delta <- resolveSetupElemIndexOrFail cc tyenv nameEnv val (biBitfieldIndex bfIndex) + lval <- resolveSetupVal cc mem env tyenv nameEnv val + bfIndex <- exceptToFail (resolveSetupBitfield cc tyenv nameEnv val fieldName) + let delta = biFieldByteOffset bfIndex offsetLval <- case lval of - Crucible.LLVMValInt blk off -> - do deltaBV <- W4.bvLit sym (W4.bvWidth off) (Crucible.bytesToBV (W4.bvWidth off) delta) - off' <- W4.bvAdd sym off deltaBV - return (Crucible.LLVMValInt blk off') - _ -> fail "resolveSetupValBitfield: expected a pointer value" - pure (bfIndex, offsetLval) + Crucible.LLVMValInt blk off -> + do deltaBV <- W4.bvLit sym (W4.bvWidth off) (Crucible.bytesToBV (W4.bvWidth off) delta) + off' <- W4.bvAdd sym off deltaBV + return (Crucible.LLVMValInt blk off') + _ -> fail "resolveSetupValBitfield: expected a pointer value" + return (bfIndex, offsetLval) resolveTypedTerm :: (?w4EvalTactic :: W4EvalTactic, Crucible.HasPtrWidth (Crucible.ArchWidth arch)) => LLVMCrucibleContext arch -> - TypedTerm -> + TypedTerm -> IO LLVMVal resolveTypedTerm cc tm = case ttType tm of diff --git a/src/SAWScript/Crucible/LLVM/X86.hs b/src/SAWScript/Crucible/LLVM/X86.hs index 0d0a02c3be..24770eda78 100644 --- a/src/SAWScript/Crucible/LLVM/X86.hs +++ b/src/SAWScript/Crucible/LLVM/X86.hs @@ -863,8 +863,8 @@ setArgs env tyenv nameEnv args cc <- use x86CrucibleContext mem <- use x86Mem let - setRegSetupValue rs (reg, sval) = typeOfSetupValue cc tyenv nameEnv sval >>= \ty -> - case ty of + setRegSetupValue rs (reg, sval) = + exceptToFail (typeOfSetupValue cc tyenv nameEnv sval) >>= \case C.LLVM.PtrType _ -> do val <- C.LLVM.unpackMemValue sym (C.LLVM.LLVMPointerRepr $ knownNat @64) =<< resolveSetupVal cc mem env tyenv nameEnv sval diff --git a/src/SAWScript/Interpreter.hs b/src/SAWScript/Interpreter.hs index 7df26f6d31..aba99d5e22 100644 --- a/src/SAWScript/Interpreter.hs +++ b/src/SAWScript/Interpreter.hs @@ -2815,12 +2815,23 @@ primitives = Map.fromList Current [ "Legacy alternative name for `llvm_elem`." ] + , prim "llvm_union" + "SetupValue -> String -> SetupValue" + (pureVal CIR.anySetupUnion) + Current + [ "Turn a SetupValue representing a union pointer into" + , "a pointer to one of the branches of the union by field name." + , "Requires debug symbols to resolve union field names." + ] + , prim "llvm_field" "SetupValue -> String -> SetupValue" (pureVal CIR.anySetupField) Current [ "Turn a SetupValue representing a struct pointer into" - , "a pointer to an element of the struct by field name." ] + , "a pointer to an element of the struct by field name." + , "Requires debug symbols to resolve struct field names." + ] , prim "crucible_field" "SetupValue -> String -> SetupValue" (pureVal CIR.anySetupField) From ef3a2de090d8419f1e5a35f819e35a7c9d7066be Mon Sep 17 00:00:00 2001 From: Rob Dockins Date: Fri, 11 Feb 2022 14:57:18 -0800 Subject: [PATCH 002/105] Add a unit test for the new `llvm_union` function. --- intTests/test_llvm_union2/Makefile | 2 ++ intTests/test_llvm_union2/README | 4 +++ intTests/test_llvm_union2/test.bc | Bin 0 -> 3488 bytes intTests/test_llvm_union2/test.c | 35 +++++++++++++++++++ intTests/test_llvm_union2/test.saw | 52 +++++++++++++++++++++++++++++ intTests/test_llvm_union2/test.sh | 1 + 6 files changed, 94 insertions(+) create mode 100644 intTests/test_llvm_union2/Makefile create mode 100644 intTests/test_llvm_union2/README create mode 100644 intTests/test_llvm_union2/test.bc create mode 100644 intTests/test_llvm_union2/test.c create mode 100644 intTests/test_llvm_union2/test.saw create mode 100644 intTests/test_llvm_union2/test.sh diff --git a/intTests/test_llvm_union2/Makefile b/intTests/test_llvm_union2/Makefile new file mode 100644 index 0000000000..35b13c7b81 --- /dev/null +++ b/intTests/test_llvm_union2/Makefile @@ -0,0 +1,2 @@ +test.bc : test.c + clang -O0 -c -g -emit-llvm -o test.bc test.c diff --git a/intTests/test_llvm_union2/README b/intTests/test_llvm_union2/README new file mode 100644 index 0000000000..08b8b08efd --- /dev/null +++ b/intTests/test_llvm_union2/README @@ -0,0 +1,4 @@ +This example is derived from an older union example +from `examples/llvm/union`. It is intended to demonstrate +the use of the `llvm_union` operation for selecting +the branches of unions. diff --git a/intTests/test_llvm_union2/test.bc b/intTests/test_llvm_union2/test.bc new file mode 100644 index 0000000000000000000000000000000000000000..faa00acb8fa00f3c554c1db556c8ebd7d75917bd GIT binary patch literal 3488 zcmZ`*eM}qY8Gny6J`-$X60b4kd_6-Nxh=8JHX%@8voWNw(iYmRq8b%vunDw$7~Am& z$+|N~b0oDklV+(`^pbvm6yNx=$B7^@YW;W zeDTRg-#n7v$~9vM>EsCQ#SzNS(V-mRy#qQCE*-bcN}8l9bJZDaRDO4^tca34*U70H za_Y|H*G;I*>PngB!CmG@#~R(2bfxvXg^0>_CdWA|dqYjz50BA*!OV}2YVOtF8#SGn zY#*mD&w|`m4MOk2TzpCY<#*69H_FrFRy@sVgg}%C>4l*<;hz;MqC(&z5ugPREmY8g zZ&L8Vx`z*q5uvzH!4Sb7-Y+ADtwfSchqdbok_(e*8+A*kT}~+0!_-v=Iq%RevDAi* zT1jcIBovGA$)QCfFe3*=k@N>$&f0%o1RRL{PqU-6h#a&?W7H}bWR3hUFdPvI5<{SVj2M;) zLv6(B-e=bK&S2WB4r;@pedc?|VKg`{?I5p$1;A@zYR*A!tZBgrml9MaMb3e3S!%&{ z*Bq9_InXOAc=g0^4?n~S!)P@@F59S2Q{ZCoFLfnBZh&?P2oLIp4Mb7gK@D+Y46kPS zgA8#ZMucF|BlwdDNCPe8ts%0dcjS9A~_JHf`{CAY;?K#eH(Lr6!|1UVw+;hqt;j)wUZ z3?$6vlEysR`K;vml8I3mu8k(5>fOz!Bl)8f&8lXvgmwSAyx}bKRb%Px&y5c?qE+>4 zw(~Q@oxii$rs`iT`DyG#Z(WY6{4|pNrjQGBb>yh(Wi^tFHDl4K2eRKM3cvmOh5c$Y zB9;-fr~E_`ul_Q(I?h+fh#)5hQALm7hD?o#hO7i*T*MD?yu#I@?4MT-Zz}tvO23sD zW(nWCbe$vIabk!jg7eZ_95D<*7$>~+_SZkE2oFcxsgw6MkCuOxj^=50ZD}puj5yr~ z=x!^LWjErmyI6AC4|U2JMp>$vim8eUo1>Au{SVAY>^TkAr^{?1nYym%thEaG-vApP zhuI?I$V+Qvw;HP*vsaEzN9wZC=#34@*HOVID&=RK(ju>;AQvEDx|!T88(*BkYiI4X z5xh1NjQHHdaTx*W;C2(kZrmRf+_X@XDOBE!D%Y5T0jA*ErgF1IX;EDgJqvXv?V!4u zQ`PVA)${hMxA2;G_?l6?I5!{Vl^Nko?%>ekWdFMg|%}I>D8#cYSvyA%Z^jim1pgh5aVa3 zjd1Dhk?Ife>d9&OyS;+DP4KvRUk?#v1s~M3xKMQEv4UHu;L{f6^{DciwP1}_-UKaZ zJrou(gBEn;a+q3PC9kh(Z(vlnrnPd?e*byCI@7XmTMb z#A5XfMu~uR+D(V_$g_N9X1aRPUJC}fovyiVuO5T#bma0bArun=fCq}Xp76xN?blSw zn@Q#0T9p4}N>d9q>iXK=#Wn2;0B9_#p5$xa;)_S8Dd~UkE`^~8k4#1S5e(dQ_SzN2TSicHBJmB)wu{gR{tRV zxXa`19UQ0+I6U3oZ(N1LPT)#r10eTFXM&%7YO z=y48qJ>5ItHFga;T}H1XaKPK;>2>>zy#u}@!00uK>>Yi5{{D_*18|?&=63hF=&nA; zz){-2g@HDi42*%H^;zlxlZkTLFZB#$BazM zOJ&G3g4D2siL^h2@jCbz7GD4eQ)L*&W|>aPuE=pqjYY0n%P{r1mKIDypo|weqa6H= zugP=b5sNHs=HvaP4LKN#N5fE*#QMY7=igJ&=H0P)WO4E4Qv1@%?2W~__RM1X%KG7Z zCQiNfdV7{Wd+AF1%#Fi&7mj4N3$t^}8;A31(5sM>;v*%0mq!n=P7JrXWA<7I*-3lV z{Pf5=IkWX6f!~r&yOE6{^u7uqDV!lPH4}XGc?fL0HqO^TkVmJ*TIrw>`WWUtlEY=d znys6X!`U!E|6mXb0IlSK*=Xy%ktSFozKl+@bfd_MdI!3U&Apu-hbLsL7kxSCc6p5U z!Tx^7fU~)Gz;$GBu+M9R@bDTRa&$fNSewD?eA;-->j8gu^&JBjclbhXm)F>F4E$j+ zclZoFJ1eix(RUQsI=nt{G;Pmjn1dmNp1dqwQ-;!R91Zi`22 zH~0p{d>nh_qKy>w72&;Dp1kAW7|x(1)P6Q7R%VE0Zr~8iMXlgZ_hqH^EW(12ds5@`0h_Aa3m>YG@ znfU7ILx}tF$>gbS`7T2UN3+&j5nIXz7u3oz$$J`g`{!9C7HRIE{*0mameeQ)D#=r* zS%V~n=B^gsc>wvT3BL zpii=Bznps_r*kI0DPnNoAA>Dt;)wrPf!K3#fO=9fc3&|EXysC1cw(e8jpF$rr&FE- zdj%Zlw%;T_muy9m&V-QY-uydgl{8(sYai^zHbigH%}Q0tD0*9xCBoo>m@I{PH-45D zeJ=Jr(8b)Y-`-~v0oLLyzJECAVk?4vCv*#Rk^f=nJ5A&hoA}S)xlF_bF8>bg1KYy7 z5V}ZHZPR6Cuz>a?VA=~aVETi&7n2$)v%%SU)ZlbM_4T;6N^!8VqNAexfJ3a+2l^dd agWjNtF_;b-n62vHA!hi09u+12(Ebg;4R|B~ literal 0 HcmV?d00001 diff --git a/intTests/test_llvm_union2/test.c b/intTests/test_llvm_union2/test.c new file mode 100644 index 0000000000..3a0d213e9d --- /dev/null +++ b/intTests/test_llvm_union2/test.c @@ -0,0 +1,35 @@ +#include + +typedef enum { INC_1 , INC_2 } alg; + +typedef struct { + uint32_t x; +} inc_1_st; + +typedef struct { + uint32_t x; + uint32_t y; +} inc_2_st; + +typedef struct { + alg alg; + union { + inc_1_st inc_1_st; + inc_2_st inc_2_st; + } inc_st; +} st; + +uint32_t inc(st *st) { + switch (st->alg) { + case INC_1: + st->inc_st.inc_1_st.x += 1; + break; + case INC_2: + st->inc_st.inc_2_st.x += 1; + st->inc_st.inc_2_st.y += 1; + break; + default: + return 1/0; + } + return 0; +} diff --git a/intTests/test_llvm_union2/test.saw b/intTests/test_llvm_union2/test.saw new file mode 100644 index 0000000000..612835067d --- /dev/null +++ b/intTests/test_llvm_union2/test.saw @@ -0,0 +1,52 @@ +m <- llvm_load_module "test.bc"; + +let {{ +INC_1 = 0 : [32] +INC_2 = 1 : [32] +}}; + + +// The argument 'INC' specifies which 'alg' enum to test. +let inc_spec INC = do { + + stp <- llvm_alloc (llvm_alias "struct.st"); + llvm_points_to (llvm_field stp "alg") (llvm_term {{ INC }}); + + if eval_bool {{ INC == INC_1 }} then + do { + let p = llvm_union (llvm_field stp "inc_st") "inc_1_st"; + + x0 <- llvm_fresh_var "x0" (llvm_int 32); + llvm_points_to (llvm_field p "x") (llvm_term x0); + + llvm_execute_func [stp]; + + llvm_points_to (llvm_field p "x") (llvm_term {{ x0 + 1 }}); + } + else if eval_bool {{ INC == INC_2 }} then + do { + let p = llvm_union (llvm_field stp "inc_st") "inc_2_st"; + + x0 <- llvm_fresh_var "x0" (llvm_int 32); + y0 <- llvm_fresh_var "y0" (llvm_int 32); + + llvm_points_to (llvm_field p "x") (llvm_term x0); + llvm_points_to (llvm_field p "y") (llvm_term y0); + + llvm_execute_func [stp]; + + llvm_points_to (llvm_field p "x") (llvm_term {{ x0 + 1 }}); + llvm_points_to (llvm_field p "y") (llvm_term {{ y0 + 1 }}); + } + else return (); // Unknown INC value + + llvm_return (llvm_term {{ 0 : [32] }}); +}; + +print "Verifying 'inc_1' using 'llvm_verify':"; +llvm_verify m "inc" [] true (inc_spec {{ INC_1 }}) abc; +print ""; + +print "Verifying 'inc_2' using 'llvm_verify':"; +llvm_verify m "inc" [] true (inc_spec {{ INC_2 }}) abc; +print ""; diff --git a/intTests/test_llvm_union2/test.sh b/intTests/test_llvm_union2/test.sh new file mode 100644 index 0000000000..0b864017cd --- /dev/null +++ b/intTests/test_llvm_union2/test.sh @@ -0,0 +1 @@ +$SAW test.saw From 2171c308b0f4f59608efdc53be18650f71e087d4 Mon Sep 17 00:00:00 2001 From: Rob Dockins Date: Fri, 11 Feb 2022 15:06:10 -0800 Subject: [PATCH 003/105] Add remote API hooks for the `llvm_union` setup function. --- saw-remote-api/src/SAWServer.hs | 1 + saw-remote-api/src/SAWServer/Data/SetupValue.hs | 3 +++ saw-remote-api/src/SAWServer/JVMCrucibleSetup.hs | 2 ++ saw-remote-api/src/SAWServer/LLVMCrucibleSetup.hs | 3 +++ 4 files changed, 9 insertions(+) diff --git a/saw-remote-api/src/SAWServer.hs b/saw-remote-api/src/SAWServer.hs index cbc72e3845..776abea42e 100644 --- a/saw-remote-api/src/SAWServer.hs +++ b/saw-remote-api/src/SAWServer.hs @@ -94,6 +94,7 @@ data CrucibleSetupVal ty e -- | RecordValue [(String, CrucibleSetupVal e)] | FieldLValue (CrucibleSetupVal ty e) String | CastLValue (CrucibleSetupVal ty e) ty + | UnionLValue (CrucibleSetupVal ty e) String | ElementLValue (CrucibleSetupVal ty e) Int | GlobalInitializer String | GlobalLValue String diff --git a/saw-remote-api/src/SAWServer/Data/SetupValue.hs b/saw-remote-api/src/SAWServer/Data/SetupValue.hs index 18fb6836fd..ff973feb34 100644 --- a/saw-remote-api/src/SAWServer/Data/SetupValue.hs +++ b/saw-remote-api/src/SAWServer/Data/SetupValue.hs @@ -16,6 +16,7 @@ data SetupValTag | TagTupleValue | TagFieldLValue | TagCastLValue + | TagUnionLValue | TagElemLValue | TagGlobalInit | TagGlobalLValue @@ -31,6 +32,7 @@ instance FromJSON SetupValTag where "tuple" -> pure TagTupleValue "field" -> pure TagFieldLValue "cast" -> pure TagCastLValue + "union" -> pure TagUnionLValue "element lvalue" -> pure TagElemLValue "global initializer" -> pure TagGlobalInit "global lvalue" -> pure TagGlobalLValue @@ -49,6 +51,7 @@ instance (FromJSON ty, FromJSON cryptolExpr) => FromJSON (CrucibleSetupVal ty cr TagTupleValue -> TupleValue <$> o .: "elements" TagFieldLValue -> FieldLValue <$> o .: "base" <*> o .: "field" TagCastLValue -> CastLValue <$> o .: "base" <*> o .: "type" + TagUnionLValue -> UnionLValue <$> o .: "base" <*> o .: "field" TagElemLValue -> ElementLValue <$> o .: "base" <*> o .: "index" TagGlobalInit -> GlobalInitializer <$> o .: "name" TagGlobalLValue -> GlobalLValue <$> o .: "name" diff --git a/saw-remote-api/src/SAWServer/JVMCrucibleSetup.hs b/saw-remote-api/src/SAWServer/JVMCrucibleSetup.hs index d2e571e943..8811524901 100644 --- a/saw-remote-api/src/SAWServer/JVMCrucibleSetup.hs +++ b/saw-remote-api/src/SAWServer/JVMCrucibleSetup.hs @@ -188,6 +188,8 @@ compileJVMContract fileReader bic cenv0 c = JVMSetupM $ fail "Field l-values unsupported in JVM API." getSetupVal _ (CastLValue _ _) = JVMSetupM $ fail "Cast l-values unsupported in JVM API." + getSetupVal _ (UnionLValue _ _) = + JVMSetupM $ fail "Union l-values unsupported in JVM API." getSetupVal _ (ElementLValue _ _) = JVMSetupM $ fail "Element l-values unsupported in JVM API." getSetupVal _ (GlobalInitializer _) = diff --git a/saw-remote-api/src/SAWServer/LLVMCrucibleSetup.hs b/saw-remote-api/src/SAWServer/LLVMCrucibleSetup.hs index ab25b88d8d..8eab0dd225 100644 --- a/saw-remote-api/src/SAWServer/LLVMCrucibleSetup.hs +++ b/saw-remote-api/src/SAWServer/LLVMCrucibleSetup.hs @@ -188,6 +188,9 @@ compileLLVMContract fileReader bic ghostEnv cenv0 c = getSetupVal env (CastLValue base ty) = do base' <- getSetupVal env base LLVMCrucibleSetupM $ return $ CMS.anySetupCast base' (llvmType ty) + getSetupVal env (UnionLValue base fld) = + do base' <- getSetupVal env base + LLVMCrucibleSetupM $ return $ CMS.anySetupUnion base' fld getSetupVal env (ElementLValue base idx) = do base' <- getSetupVal env base LLVMCrucibleSetupM $ return $ CMS.anySetupElem base' idx From e3343b00c39e77fe8f4ec43fd1a6c69ae0d64d89 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Fri, 11 Feb 2022 16:56:30 -0800 Subject: [PATCH 004/105] added parse_core_mod command; made ensureMonadicTerm a bit smarter by making it normalize the input type before deciding if it is already computational --- src/SAWScript/Builtins.hs | 27 ++++++++++++++++++++------- src/SAWScript/Interpreter.hs | 7 +++++++ 2 files changed, 27 insertions(+), 7 deletions(-) diff --git a/src/SAWScript/Builtins.hs b/src/SAWScript/Builtins.hs index d9c2244a42..8ddfbbd47d 100644 --- a/src/SAWScript/Builtins.hs +++ b/src/SAWScript/Builtins.hs @@ -1385,8 +1385,8 @@ tailPrim :: [a] -> TopLevel [a] tailPrim [] = fail "tail: empty list" tailPrim (_ : xs) = return xs -parseCore :: String -> TopLevel Term -parseCore input = +parseCoreMod :: String -> String -> TopLevel Term +parseCoreMod mnm_str input = do sc <- getSharedContext let base = "" path = "" @@ -1397,18 +1397,29 @@ parseCore input = do let msg = show err printOutLnTop Opts.Error msg fail msg - let mnm = Just $ mkModuleName ["Cryptol"] - err_or_t <- io $ runTCM (typeInferComplete uterm) sc mnm [] + let mnm = + mkModuleName $ Text.splitOn (Text.pack ".") $ Text.pack mnm_str + _ <- io $ scFindModule sc mnm -- Check that mnm exists + err_or_t <- io $ runTCM (typeInferComplete uterm) sc (Just mnm) [] case err_or_t of Left err -> fail (show err) Right (TC.TypedTerm x _) -> return x +parseCore :: String -> TopLevel Term +parseCore = parseCoreMod "Cryptol" + parse_core :: String -> TopLevel TypedTerm parse_core input = do t <- parseCore input sc <- getSharedContext io $ mkTypedTerm sc t +parse_core_mod :: String -> String -> TopLevel TypedTerm +parse_core_mod mnm input = do + t <- parseCoreMod mnm input + sc <- getSharedContext + io $ mkTypedTerm sc t + prove_core :: ProofScript () -> String -> TopLevel Theorem prove_core script input = do sc <- getSharedContext @@ -1532,9 +1543,11 @@ monadifyTypedTerm sc t = -- | Ensure that a 'TypedTerm' has been monadified ensureMonadicTerm :: SharedContext -> TypedTerm -> TopLevel TypedTerm -ensureMonadicTerm _ t - | TypedTermOther tp <- ttType t - , Prover.isCompFunType tp = return t +ensureMonadicTerm sc t + | TypedTermOther tp <- ttType t = + io (Prover.isCompFunType sc tp) >>= \case + True -> return t + False -> monadifyTypedTerm sc t ensureMonadicTerm sc t = monadifyTypedTerm sc t mrSolver :: SharedContext -> Int -> TypedTerm -> TypedTerm -> TopLevel Bool diff --git a/src/SAWScript/Interpreter.hs b/src/SAWScript/Interpreter.hs index 7df26f6d31..48b53b4fdc 100644 --- a/src/SAWScript/Interpreter.hs +++ b/src/SAWScript/Interpreter.hs @@ -2225,6 +2225,13 @@ primitives = Map.fromList [ "Parse a Term from a String in SAWCore syntax." ] + , prim "parse_core_mod" "String -> String -> Term" + (funVal2 parse_core_mod) + Current + [ "Parse a Term from the second supplied String in SAWCore syntax," + , "relative to the module specified by the first String" + ] + , prim "prove_core" "ProofScript () -> String -> TopLevel Theorem" (pureVal prove_core) Current From 61e3b58e1a072c1e84bb8c49ee9586f057ec0761 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Fri, 11 Feb 2022 16:59:16 -0800 Subject: [PATCH 005/105] fixed mrFunOutType, isCompFunType, and askMRSolver to normalize types --- src/SAWScript/Prover/MRSolver.hs | 36 +++++++++++++++++++------------- 1 file changed, 21 insertions(+), 15 deletions(-) diff --git a/src/SAWScript/Prover/MRSolver.hs b/src/SAWScript/Prover/MRSolver.hs index d29bfa0617..5e268aec85 100644 --- a/src/SAWScript/Prover/MRSolver.hs +++ b/src/SAWScript/Prover/MRSolver.hs @@ -671,13 +671,18 @@ mrConvertible = liftSC4 scConvertibleEval scTypeCheckWHNF True -- compute the type @CompM [args/vars]a@ of @f@ applied to @args@. Return the -- type @[args/vars]a@ that @CompM@ is applied to. mrFunOutType :: FunName -> [Term] -> MRM Term -mrFunOutType ((asPiList . funNameType) -> (vars, asCompM -> Just tp)) args - | length vars == length args = - substTermLike 0 args tp -mrFunOutType _ _ = - -- NOTE: this is an error because we should only ever call mrFunOutType with a - -- well-formed application at a CompM type - error "mrFunOutType" +mrFunOutType fname args = + liftSC1 scWhnf (funNameType fname) >>= \case + (asPiList -> (vars, asCompM -> Just tp)) + | length vars == length args -> substTermLike 0 args tp + ftype@(asPiList -> (vars, _)) -> + do pp_ftype <- mrPPInCtx ftype + pp_fname <- mrPPInCtx fname + debugPrint 0 "mrFunOutType: function applied to the wrong number of args" + debugPrint 0 ("Expected: " ++ show (length vars) ++ + ", found: " ++ show (length args)) + debugPretty 0 ("For function: " <> pp_fname <> " with type: " <> pp_ftype) + error"mrFunOutType" -- | Turn a 'LocalName' into one not in a list, adding a suffix if necessary uniquifyName :: LocalName -> [LocalName] -> LocalName @@ -984,8 +989,8 @@ _debugPrettyInCtx i a = (mrUVars <$> get) >>= \ctx -> debugPrint i (showInCtx (map fst ctx) a) -- | Pretty-print an object relative to the current context -_mrPPInCtx :: PrettyInCtx a => a -> MRM SawDoc -_mrPPInCtx a = +mrPPInCtx :: PrettyInCtx a => a -> MRM SawDoc +mrPPInCtx a = runReader (prettyInCtx a) <$> map fst <$> mrUVars <$> get -- | Pretty-print the result of 'ppWithPrefixSep' relative to the current uvar @@ -1121,10 +1126,11 @@ asCompM (asApp -> Just (isGlobalDef "Prelude.CompM" -> Just (), tp)) = return tp asCompM _ = fail "not a CompM type!" --- | Test if a type is a monadic function type of 0 or more arguments -isCompFunType :: Term -> Bool -isCompFunType (asPiList -> (_, asCompM -> Just _)) = True -isCompFunType _ = False +-- | Test if a type normalizes to a monadic function type of 0 or more arguments +isCompFunType :: SharedContext -> Term -> IO Bool +isCompFunType sc t = scWhnf sc t >>= \case + (asPiList -> (_, asCompM -> Just _)) -> return True + _ -> return False -- | Pattern-match on a @LetRecTypes@ list in normal form and return a list of -- the types it specifies, each in normal form and with uvars abstracted out @@ -1531,8 +1537,8 @@ askMRSolver :: Term -> Term -> IO (Maybe MRFailure) askMRSolver sc dlvl smt_conf timeout t1 t2 = - do tp1 <- scTypeOf sc t1 - tp2 <- scTypeOf sc t2 + do tp1 <- scTypeOf sc t1 >>= scWhnf sc + tp2 <- scTypeOf sc t2 >>= scWhnf sc init_st <- mkMRState sc Map.empty smt_conf timeout dlvl case asPiList tp1 of (uvar_ctx, asCompM -> Just _) -> From 9655e0fa8f481e9fea58800324e3b304c11d7534 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Mon, 14 Feb 2022 11:55:28 -0800 Subject: [PATCH 006/105] expanded the notion of a "function name" for MR Solver to include not just globals but also (tuple and record) projections of globals --- src/SAWScript/Prover/MRSolver.hs | 82 ++++++++++++++++++++++++++------ 1 file changed, 67 insertions(+), 15 deletions(-) diff --git a/src/SAWScript/Prover/MRSolver.hs b/src/SAWScript/Prover/MRSolver.hs index 5e268aec85..0c888e8589 100644 --- a/src/SAWScript/Prover/MRSolver.hs +++ b/src/SAWScript/Prover/MRSolver.hs @@ -193,18 +193,61 @@ newtype MRVar = MRVar { unMRVar :: ExtCns Term } deriving (Eq, Show, Ord) mrVarType :: MRVar -> Term mrVarType = ecType . unMRVar +-- | A tuple or record projection of a 'Term' +data TermProj = TermProjLeft | TermProjRight | TermProjRecord FieldName + deriving (Eq, Ord, Show) + +-- | Apply a 'TermProj' to perform a projection on a 'Term' +doTermProj :: Term -> TermProj -> MRM Term +doTermProj t TermProjLeft = liftSC1 scPairLeft t +doTermProj t TermProjRight = liftSC1 scPairRight t +doTermProj t (TermProjRecord fld) = liftSC2 scRecordSelect t fld + +-- | Apply a 'TermProj' to a type to get the output type of the projection, +-- assuming that the type is already normalized +doTypeProj :: Term -> TermProj -> MRM Term +doTypeProj (asPairType -> Just (tp1, _)) TermProjLeft = return tp1 +doTypeProj (asPairType -> Just (_, tp2)) TermProjRight = return tp2 +doTypeProj (asRecordType -> Just tp_map) (TermProjRecord fld) + | Just tp <- Map.lookup fld tp_map + = return tp +doTypeProj _ _ = + -- FIXME: better error message? This is an error and not an MRFailure because + -- we should only be projecting types for terms that we have already seen... + error "doTypeProj" + -- | Names of functions to be used in computations, which are either names bound -- by letrec to for recursive calls to fixed-points, existential variables, or --- global named constants +-- (possibly projections of) of global named constants data FunName - = LetRecName MRVar | EVarFunName MRVar | GlobalName GlobalDef + = LetRecName MRVar | EVarFunName MRVar | GlobalName GlobalDef [TermProj] deriving (Eq, Ord, Show) --- | Get the type of a 'FunName' -funNameType :: FunName -> Term -funNameType (LetRecName var) = mrVarType var -funNameType (EVarFunName var) = mrVarType var -funNameType (GlobalName gd) = globalDefType gd +-- | Get and normalize the type of a 'FunName' +funNameType :: FunName -> MRM Term +funNameType (LetRecName var) = liftSC1 scWhnf $ mrVarType var +funNameType (EVarFunName var) = liftSC1 scWhnf $ mrVarType var +funNameType (GlobalName gd projs) = + liftSC1 scWhnf (globalDefType gd) >>= \gd_tp -> + foldM doTypeProj gd_tp projs + +-- | Recognize a 'Term' as (possibly a projection of) a global name +asTypedGlobalProj :: Recognizer Term (GlobalDef, [TermProj]) +asTypedGlobalProj (asRecordSelector -> + Just ((asTypedGlobalProj -> Just (d, projs)), fld)) = + return (d, TermProjRecord fld:projs) +asTypedGlobalProj (asPairSelector -> + Just ((asTypedGlobalProj -> Just (d, projs)), isRight)) + | isRight = return (d, TermProjRight:projs) + | not isRight = return (d, TermProjLeft:projs) +asTypedGlobalProj (asTypedGlobalDef -> Just glob) = Just (glob, []) +asTypedGlobalProj _ = Nothing + +-- | Recognize a 'Term' as (possibly a projection of) a global name +asGlobalFunName :: Recognizer Term FunName +asGlobalFunName (asTypedGlobalProj -> Just (glob, projs)) = + Just $ GlobalName glob projs +asGlobalFunName _ = Nothing -- | A term specifically known to be of type @sort i@ for some @i@ newtype Type = Type Term deriving Show @@ -287,10 +330,16 @@ instance PrettyInCtx Type where instance PrettyInCtx MRVar where prettyInCtx (MRVar ec) = return $ ppName $ ecName ec +instance PrettyInCtx TermProj where + prettyInCtx TermProjLeft = return (pretty '.' <> "1") + prettyInCtx TermProjRight = return (pretty '.' <> "2") + prettyInCtx (TermProjRecord fld) = return (pretty '.' <> pretty fld) + instance PrettyInCtx FunName where prettyInCtx (LetRecName var) = prettyInCtx var prettyInCtx (EVarFunName var) = prettyInCtx var - prettyInCtx (GlobalName i) = return $ viaShow i + prettyInCtx (GlobalName g projs) = + foldM (\pp proj -> (pp <>) <$> prettyInCtx proj) (viaShow g) projs instance PrettyInCtx Comp where prettyInCtx (CompTerm t) = prettyInCtx t @@ -672,7 +721,7 @@ mrConvertible = liftSC4 scConvertibleEval scTypeCheckWHNF True -- type @[args/vars]a@ that @CompM@ is applied to. mrFunOutType :: FunName -> [Term] -> MRM Term mrFunOutType fname args = - liftSC1 scWhnf (funNameType fname) >>= \case + funNameType fname >>= \case (asPiList -> (vars, asCompM -> Just tp)) | length vars == length args -> substTermLike 0 args tp ftype@(asPiList -> (vars, _)) -> @@ -760,7 +809,7 @@ extCnsToFunName ec = let var = MRVar ec in mrVarInfo var >>= \case Just (FunVarInfo _) -> return $ LetRecName var Nothing | Just glob <- asTypedGlobalDef (Unshared $ FTermF $ ExtCns ec) -> - return $ GlobalName glob + return $ GlobalName glob [] _ -> error "extCnsToFunName: unreachable" -- | Get the body of a function @f@ if it has one @@ -769,7 +818,10 @@ mrFunNameBody (LetRecName var) = mrVarInfo var >>= \case Just (FunVarInfo body) -> return $ Just body _ -> error "mrFunBody: unknown letrec var" -mrFunNameBody (GlobalName glob) = return $ globalDefBody glob +mrFunNameBody (GlobalName glob projs) + | Just body <- globalDefBody glob + = Just <$> foldM doTermProj body projs +mrFunNameBody (GlobalName _ _) = return Nothing mrFunNameBody (EVarFunName _) = return Nothing -- | Get the body of a function @f@ applied to some arguments, if possible @@ -798,9 +850,9 @@ mrCallsFun f = memoFixTermFun $ \recurse t -> case t of _ | f == g -> return True Just body -> recurse body Nothing -> return False - (asTypedGlobalDef -> Just gdef) -> + (asTypedGlobalProj -> Just (gdef, projs)) -> case globalDefBody gdef of - _ | f == GlobalName gdef -> return True + _ | f == GlobalName gdef projs -> return True Just body -> recurse body Nothing -> return False (unwrapTermF -> tf) -> @@ -1226,8 +1278,8 @@ normComp (CompTerm t) = do fun_name <- extCnsToFunName ec return $ FunBind fun_name args CompFunReturn - ((asTypedGlobalDef -> Just gdef), args) -> - return $ FunBind (GlobalName gdef) args CompFunReturn + ((asGlobalFunName -> Just f), args) -> + return $ FunBind f args CompFunReturn _ -> throwError (MalformedComp t) From e3d1d0167cd1f043c209e1412dbf2eaa6258f8e5 Mon Sep 17 00:00:00 2001 From: Rob Dockins Date: Mon, 14 Feb 2022 14:46:59 -0800 Subject: [PATCH 007/105] Address code review comments, and use the `galois-dwarf` package instead of referring directly to magic numbers to decode DWARF metadata. --- saw-script.cabal | 1 + .../Crucible/LLVM/ResolveSetupValue.hs | 75 +++++++------------ 2 files changed, 28 insertions(+), 48 deletions(-) diff --git a/saw-script.cabal b/saw-script.cabal index d59f8546ab..e3cddc58b6 100644 --- a/saw-script.cabal +++ b/saw-script.cabal @@ -48,6 +48,7 @@ library , haskeline , heapster-saw , hobbits >= 1.3.1 + , galois-dwarf >= 0.2.2 , IfElse , jvm-parser , lens diff --git a/src/SAWScript/Crucible/LLVM/ResolveSetupValue.hs b/src/SAWScript/Crucible/LLVM/ResolveSetupValue.hs index e659af8691..fb37eae978 100644 --- a/src/SAWScript/Crucible/LLVM/ResolveSetupValue.hs +++ b/src/SAWScript/Crucible/LLVM/ResolveSetupValue.hs @@ -42,6 +42,7 @@ import Control.Monad.State import qualified Data.BitVector.Sized as BV import Data.Maybe (fromMaybe, fromJust) +import qualified Data.Dwarf as Dwarf import Data.Map (Map) import qualified Data.Map as Map import qualified Data.Set as Set @@ -168,7 +169,7 @@ resolveSetupValueInfo cc env nameEnv v = mdMap = Crucible.llvmMetadataMap (ccTypeCtx cc) -- | Given DWARF type information that is expected to describe a --- struct, find it's name (if any) and information about its fields. +-- struct, find its name (if any) and information about its fields. -- This procedure handles the common case where a typedef is used to -- give a name to an anonymous struct. If a struct both has a direct -- name and is included in a typedef, the direct name will be preferred. @@ -179,7 +180,7 @@ findStruct = loop Nothing loop _ _ = Nothing -- | Given DWARF type information that is expected to describe a --- union, find it's name (if any) and information about its fields. +-- union, find its name (if any) and information about its fields. -- This procedure handles the common case where a typedef is used to -- give a name to an anonymous union. If a union both has a direct -- name and is included in a typedef, the direct name will be preferred. @@ -271,51 +272,29 @@ reverseDebugInfoType = loop Nothing -- ad-hoc, and may miss cases. reverseBaseTypeInfo :: L.DIBasicType -> Maybe L.Type reverseBaseTypeInfo dibt = --- TODO, find a nicer API than using these magic numbers, taken from: - -- https://github.com/llvm-mirror/llvm/blob/release_38/include/llvm/Support/Dwarf.def - -- DWARF attribute type encodings. - -- HANDLE_DW_ATE(0x01, address) - -- HANDLE_DW_ATE(0x02, boolean) - -- HANDLE_DW_ATE(0x03, complex_float) - -- HANDLE_DW_ATE(0x04, float) - -- HANDLE_DW_ATE(0x05, signed) - -- HANDLE_DW_ATE(0x06, signed_char) - -- HANDLE_DW_ATE(0x07, unsigned) - -- HANDLE_DW_ATE(0x08, unsigned_char) - -- HANDLE_DW_ATE(0x09, imaginary_float) - -- HANDLE_DW_ATE(0x0a, packed_decimal) - -- HANDLE_DW_ATE(0x0b, numeric_string) - -- HANDLE_DW_ATE(0x0c, edited) - -- HANDLE_DW_ATE(0x0d, signed_fixed) - -- HANDLE_DW_ATE(0x0e, unsigned_fixed) - -- HANDLE_DW_ATE(0x0f, decimal_float) - -- HANDLE_DW_ATE(0x10, UTF) - - case L.dibtEncoding dibt of - -- boolean - 0x02 -> Just $ L.PrimType $ L.Integer 1 - - -- floats - -- TODO? is this doing the right thing? - 0x04 -> case L.dibtSize dibt of - 16 -> Just $ L.PrimType $ L.FloatType $ L.Half - 32 -> Just $ L.PrimType $ L.FloatType $ L.Float - 64 -> Just $ L.PrimType $ L.FloatType $ L.Double - 80 -> Just $ L.PrimType $ L.FloatType $ L.X86_fp80 - 128 -> Just $ L.PrimType $ L.FloatType $ L.Fp128 - _ -> Nothing - - -- signed int - 0x05 -> Just $ L.PrimType $ L.Integer (fromIntegral (L.dibtSize dibt)) - - -- signed_char - 0x06 -> Just $ L.PrimType $ L.Integer 8 - - -- unsigned int - 0x07 -> Just $ L.PrimType $ L.Integer (fromIntegral (L.dibtSize dibt)) - - -- unsigned_char - 0x08 -> Just $ L.PrimType $ L.Integer 8 + case Dwarf.DW_ATE (fromIntegral (L.dibtEncoding dibt)) of + Dwarf.DW_ATE_boolean -> Just $ L.PrimType $ L.Integer 1 + + Dwarf.DW_ATE_float -> + case L.dibtSize dibt of + 16 -> Just $ L.PrimType $ L.FloatType $ L.Half + 32 -> Just $ L.PrimType $ L.FloatType $ L.Float + 64 -> Just $ L.PrimType $ L.FloatType $ L.Double + 80 -> Just $ L.PrimType $ L.FloatType $ L.X86_fp80 + 128 -> Just $ L.PrimType $ L.FloatType $ L.Fp128 + _ -> Nothing + + Dwarf.DW_ATE_signed -> + Just $ L.PrimType $ L.Integer (fromIntegral (L.dibtSize dibt)) + + Dwarf.DW_ATE_signed_char -> + Just $ L.PrimType $ L.Integer 8 + + Dwarf.DW_ATE_unsigned -> + Just $ L.PrimType $ L.Integer (fromIntegral (L.dibtSize dibt)) + + Dwarf.DW_ATE_unsigned_char -> + Just $ L.PrimType $ L.Integer 8 _ -> Nothing @@ -363,7 +342,7 @@ reverseBaseTypeInfo dibt = -- @ -- -- Note that the 'biFieldSize's and 'biFieldOffset's are specific to each --- individual field, while the 'biBitfieldIndex'es and 'biBitfieldType's are +-- individual field, while the 'biBitfieldByteOffest's and 'biBitfieldType's are -- all the same, as the latter two all describe the same bitfield. data BitfieldIndex = BitfieldIndex { biFieldSize :: Word64 From d0a8fc6aa6a2dcb5ec8210576fdd99c760ee25a5 Mon Sep 17 00:00:00 2001 From: Rob Dockins Date: Mon, 14 Feb 2022 15:07:59 -0800 Subject: [PATCH 008/105] Update CHANGES and the manual with information about `llvm_union`. --- CHANGES.md | 7 +++++++ doc/manual/manual.md | 12 ++++++++++++ doc/manual/manual.pdf | Bin 475702 -> 475947 bytes 3 files changed, 19 insertions(+) diff --git a/CHANGES.md b/CHANGES.md index 61b4130864..323fad615f 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -33,6 +33,13 @@ dealing with C `union` types, as the type information provided by LLVM is imprecise in these cases. +* A new `llvm_union` function has been added that uses debug + information to allow users to select fields from `union` types by + name. This automates the process of manally applying + `llvm_cast_pointer` with the type of the selected union field. Just + as with `llvm_field`, debug symbols are required for `llvm_union` to + work correctly. + # Version 0.9 ## New Features diff --git a/doc/manual/manual.md b/doc/manual/manual.md index 088742583b..ad5ddc8bd4 100644 --- a/doc/manual/manual.md +++ b/doc/manual/manual.md @@ -2256,6 +2256,18 @@ flows into. This is especially useful for dealing with C `union` types, as the type information provided by LLVM is imprecise in these cases. +We can automate the process of apply pointer casts if we have debug +information avaliable: + +* `llvm_union : SetupValue -> String -> SetupValue` + +Given a pointer setup value, this attempts to select the named union +branch and cast the type of the pointer. For this to work, debug +symbols must be included; moreover, the process of correlating LLVM +type information with information contained in debug symbols is a bit +heuristic. If `llvm_union` cannot figure out how to cast a pointer, +one can fall back on the more manual `llvm_cast_pointer` instead. + In the experimental Java verification implementation, the following functions can be used to state the equivalent of a combination of diff --git a/doc/manual/manual.pdf b/doc/manual/manual.pdf index 6d4671cbded701b1aeed7c7100f291a55b046466..5d121e0738788f15de32538da0ccf7a4682d7f9b 100644 GIT binary patch delta 64200 zcmV)XK&`*FgdMAf9kAgilks~hf9+dabJI!^e$TJ)qg)jWX=ZeLgtH+F1qBCZ;Q`Kr zB2Qu!l4W#B$o~56p6-#yjyGX}oPv!jRgvaC^Yu4<8IOX=K*(RLv~|~yt?Vi zj;emZqQ;beKA+CusaM64YJLi$VE%L(hN1TX-oxo%XD^Qe2I0x`SUGc>i6k(SgBL%A zA~U%^TAlYazf^kjn|dmRe+R?B|E4Mn%6>o1A}?>t{JhdQt59XJCn6jTMw$s&bQn>8 z^R;QKi}F(-RRMiBtJ$->(~GgI*wd|33QNi|Av}>_e@~u^$eDDg{7k9IEQBEGayyWe?r-02iu~U_w7*h zgC#DI+7$?L0SLauh3PDPum$|qBH4?6dMEnM-UZN~Phoqtx?|Pw9+S?Vh14VE^|wE6 z%OJW>24_p={#^INnn14x&dXN|dU^T&^-j?lDzTe2>GKX1Rs481z+RlQJ8?ews*8ch z9%ad|LYPOg1@0Eje>-4)yK=P-u)ITN%U^79zqPo&Lo!d(&?X1@oyP+pv zb4o;sdaR89F$u`vZWGGR=WJn%^5O=mPtKC^ z{;BgdN#d0Wy>3j9HNY-OVs!xhyCf0*pd?(|k;U-=@CT5>e+R_4X+Muq!*$tnz_3wO zgLPYXozyG~5AM-z$i;TH5PlZ!oLM|8d(`u~S^$jk{aXIu?);!kGq`oFavE~@DV6TrEl=5__{=jXA|aD z!51!G>Za8-CDv_&R~D}DpKdX7i^9ZH;u|j$%!f6fdbI2hyeiMzyuF#uvgi=f{d{(a zdw$ZsS@#XcISt4Nuv*&>Z-H{wgYNQ zEK9szw`)kWx+fP-c^AV94I10CD0&R0YcJM!pK+X-yBhhbtHAUFUWU*BUscv+pYJ>Q zC~_7?;_1BqTaG<`E0=c{@O>`tJ6#NISCWM%SiyQ+wt0hQM5ZCPky$ zf{30Z(Lt3zxFAm2wrTkqs&0|;u@VOd=ch{{+HrqnJPAWTiz2b@|0dv}Z^+47S8sXhy=Nh+&lplmCt(q6GB%4@TTHEWVox#H1tZwx&vmOmD%(-^2V|RMn z*M#XE@0ebUFrc?9H%x>)zTDdOrRJO3`MJq5*9b6;5csqZn7gwU8Tny)0{y;M6mAoBU=(a75{61qjpCt)lvr#^Pg~3`WS20Mz)5aG^1we9a3N4BK!qNh{ zi8sv7%bpH2u*?at#V)gX`)xXa>hu^(#+?`u?}bY+NcGFSx62jIY7^lrp=hlrl4= zjHV=cTzIw`1MKZM2JJ>wbyhV(WcX%f3!0P9FCBl&28_nCrsTe#j=5`oTE^`d^iUqS=^P~dm>H1VKT=m>!IRLIuEvyH>{ml1hqigf=>ld@QDy`x!d?nvXtm!{1$%;1L@0D@ape%2ISV1Hn-=%{L?vdV$YEk zdB?_K09J#u?YfWFQ{8X2O^93rBNm;1OPLZq!Foj2vKn?O8Q{l1J-uQ7`0SUsa(r8m zi&PBtxUn!BH*ITMEp!L4krS)A-LfH1n!0P~X%q?dPc9F>BlJOr_R3Z@p~5i*HA#Q$ z9>nuvWEz8O6m6}h%dfWrs7)ZXeU`t0L_Az60Wy_v*TdONR*$cg8x!zW6tRxMKBkx5&y1^?OgFvK0 zg6pzkgLZy*>0qN#Tn~+Fst8*w;t^dJ=nS1WW%9v@Fr<3T19&b99%N0|O0% zbuzbgG64se0y#00(XlDFr^*4B41Y7wNd+}?-VB8>75E#LJ&GQ05qx&C`10Iqa^Uwl z_0V|`a=o$YDdMnEnD{c}-L~)-K}I3}^v&JW@HaS~zw+U)g$(GksL-VPZoqj%c}&^! zYg!g>zFEHccD%vD*GP!Q$b#H4u)hzQIt*NU^qVmWf30NZa))K-VaJDCK7Xj0@wL!U zu!E;+re7a0FunqW{7gh5C>B{SV~kW;QI#A9Gl+vKU->e}5aR%s_GQNd{ETgX-yZMj zT*6!i;BlnKTwk5%46D~s8YU2sM#L^Bd0JwvP@K(vMT&QvJb}rT8Pi$;2qjlwgUlC^ z`~|)-`LFIqx4K=~G>jvI_kXs3`XySdq4`^emrt(KZlT?EzH;&Y=7$?F4}*m8=WDv@ z9h-#(E@SO(@d6A~q18jAraLaL->PKP3o_1hxFRSWu)+%H*I8K?EyJj9s@2r*Os58U zLXxA6r}7U}`pgvqfRd84B89d82Ov$QmkMQWWOH2?aWtUs`#PP zq(}A@>3H#Grxt&2&VGcSeY65{D~I0K7k_6jUYT@}`B@Ssi;L?;q(eVWvvJak&ElQ+ z@2;$Gma8a=ynb6?Lwj$V>!tGgWoW$nWte(7UfP03eO2exLsxb@^k;n3(DM&h%N6_= z^?J)Ae+lB??N>{sl=m~V)$;wtcV~eJ;l-;kc6bZ?EZvJG$ueK-cyX}<4vV`bk$+u= znb!|_g=Ao5iSxFVfl`5=#Od_?+or7h?y_$t^M9HTl>~k|XQu1(zSs#fD1$Hrx#hiW zp^!oa!s>>qXURhUElCFWz?Jkx%Y%LiqL@T?FN8`a+xW|s*2cTomiB@C7adb7)@5E* z4@_q0itC}`0oRSt-V}K?PJdtaTYp^q!qL1WP5d+qc~##Wl4;<_DuLmoCPQ5|^(g`j zL0BfTul2aR2VuH9XT8X~nZ8X%@w2jqrR?$^XQhtYmPB<|Zi)@}T%mqGaQpl3NzH!x zLEe@b%H3@Xvg$^nGT*l7K*449b>0=7Px4vmz}J~stW@f!Va99td6`C*t$%ec?Bqk= z0DHx3CCKFp*jg8z7zmgWzi@k739|>Zfk=0~W&4`nCF7GRwq%5NxMu0u6j#H|6Vj5w zaqNK_OS(Df+kcNeLCcgMgpMvpux){6U4C7%kbo5pbaVc@rEMXZ8Ce&lzzWIuh(Zq*f7{bt0@i6?t%`NeZQ6cp)cFpz6PqFpY+ki_y~cUB zLa>%GxaBhn1iBB*t#qLV*)gc308yE&rFn52)Rn>mxo*0}!XP z#W?nMqEEA8(MjUNlv8qmYIP&*fm6~q13UZ7YleRAIN}UU-@3ys`!9jjW{+eRh7JPW zxjg0LXhH8?iG_k4}xKa7K2sEtUm_|YyW!iPhH5Eh)MDSuKSgO?N*01%uYKv;1Y z8B3z9yS~Ub>@lW56r0G;z-f|f-k|xjx4{PZkdI>5ZAlRXSOKt1W4^P1tqHK8N01&h z1-E1^>WPoQt5wBFp+~)JYJ{ys*~zqr5nNMM4Fz#zLex9dYb4Y$MoJxg{6!`TfB@Ej*@W8oNoXeX0o?CSnJNzaDAV@U<`8x8ona79s9%>w zwK<7==tsdAUirto`YM8b$#nV|e*ITj_$7jw3@dl6w?}w8tX$9L6!FDL+ zD;tjNvws!49idKmJ3`2B5dI-x;v3uye2SZa{|!P?=KYEgxb6>ag3eMuw!1(RR1C^5 zUPZ1LfgFurh2Z+YG)bCYm%Y5w@hj7X(MDykg*4bEu{IKyFrD!{9q~M6JjX}fa4Sx) z6<5fa8Di9P*2}v@JMwYSwJpx=?x(;+*+kRsr9Au){ z`%}`0;KBmqY zMVnd>AO4-h1S2gDJ)yrV|05&GNANmRp?@p!JY^p}Rt_MBkGyZ2aYW&yIy90&FdsT0 zDlya(!ipmedNf_%$5W&P0U&DNQ~@#AIWSk|1AU7W52sKED~?BJk4i* zkC4a0j$~7aI}d`GAJ0ded6Jn}R|(8BP?NNuY`4&8n~f$bWn0 zk9o9fZ=hEu5_j_TxLuguI=+IE*HNLyq_=B!#XXk+;rT$BB4x+}djtbv0wgRCJi0Az z+oH2BL*jAHoq6z>>7MV&OFHfp03}TpaT(9%^)1HWvJ1xJ2zgRq1z^??L4~QWQc2|Q z+meb|puXhoGbFa-C}+@${-a2@4UReXM+D9RTa<7Y-nb{E^iL0P8|%zprU%+En+ z2c##|K4Z@vK0}@QiJFlvJL?~IB>k@d!9?M{d5iCCI$r7bA}VOA7ut zo~{1j#LXJTry*aBf^Cbahx06hB)-oBzb6Xor$L&sKVD2|6xgk?soil$(^@+*YI7*cQya@+}SxVjGfJ- z^J?4*RYe(3cgdLLrHBJKUmfAba zx-d7yDSqcE0w#(HSrU5hC?ivpoxR6)N;w!`Gb>;SIKF(Y;|d{aP5^0*P02W5ipTTc z*q;B!j~tmC<2Yj=Ohcr+*%HjHwp^6NgQapKZ`>_oW6M?IaDR{GSO#MHWX5FhT(1XM z7iTjf=Mt9Hb^#oq#TG+Yrr6;e3*ot!yZoFNO$FbcF=pL!Oc;Cj+oqFoRZ-ti+5qiw zp5LUlKRf$Uz^x9&^V!p^@nlJoIOjxZeB|J6!cME6joAAvIYWChj<8|2tp5BI)Q&XB z6_Sey$0z#`OMfJW2m(^^36bei=xYt(&rQY>>^@b?GGhjF zYH43h%DqpVklVcKTG9$N7o%) zFX?(q*M_boU2D4bbnTpxy&Y*%b#VEIqVZ*!L22C}BgoclI@tYwWaosk%W6nPd0Q4qPd`24VFt3#X zpOZ}}5A_C1ZpaqdH?qBLB!fWX-kjt9gb4cdaDV6yA9Og#OL0f~N3-JT`L4ydS=|l` zlKgD}e(1An>_-agqQx&g?AKZHB}8QR2;vp_1mV%S&$=%*{-f$zxPTPT0FI7d0YJ_N zgh*)EL~z7^EHECaZA7u3LiXbl`;$r=apEh8BV5YoxT1hz8hH~BNuPmIM_zRf+q{nB zA%71Ugz)b*e^Hynixe12H0d2A zhU|>V*ysNOSyX z;9ppI&2I{(6h#N62W$Ty@y52wmuThzC;~Y)lYovXf2~?=Z`?K#{_bC~=$C47UPdA* zQfluGNPCx{hxFPazT`tw7_ydY3(?C~FLs>6{r8&}YFFB9Hg*yiphSus&J1Usnc+HI zTra}K^Ro!ra1kx6Tv%mA8b*t}I{WiXL^6r^Y>%LpAVi^Y)&Gv=6btU(Z&lCK~c(PL{(qw;pCJBX!;6nx5{?PO{NaBz; zKRt~_3Z!OB%JR0l+%`qscb9#0c~$hA!jNU#8F?0m@ywLOv{ zf0aZcN%a9oXh1Rr19`V)Lurf3)k~QMeOB_Pys0YKwL1p`3Qf>8JPd}}Ipkq6aUEk4 z5gO%*mpB)Vu62J7#b~Po8TW^Ju&IdCLwfn3VCOIJQk7>Em zG2#Mj19YL2!iiOmhXF!p1OXsSgV*17Jf3ykP;L97sr`}+m12Wt=y}3W7j@AWSy{Yy zWW$F(rwnk!j8v{_+WTb^2j{HQyPG0MFd_ts0!FDQs9o;5E^F_(+mo%xpvvB&fBBu# zu9Pqaa!+^tI$o<{B{cfrgfgLR)4pXkhkET=&oM)D6x@(Y1PvJym=CBd3Z9_`8b8&& z%c^bZ&PR91*4_v3SVKEeq|_K@c;`*qRIHS_{#j3~W_quiw#v%V_t2n#(X#KjU)21} z{L{59^R@p(5g`m-pL6#L&mCXxe~OdvsZuKxgtHmfUvB3+g~SkV;`D(2`3LR^YKtNf z+n6VGLyl1r%}s+T^8)}N3bHkK?uxSHx1#QPHx9S1AKH4hth=v}mUo8|44H;+mvIdE zHaIx!IF!LtoYeETEeMJb3Ipe-bf>KVk!GBKJ&4e$6rnbA@=Z-9f(k(Pf54`@k3e0V zrZ6VG1E3MC6xj6Zo2=KXtE?jTG`y%hSgCX0AYjH|y8O0(@l7kKOB^r2t`CdI1 z2`#`qkeQLgwBdVT$&9gvxGQ>o?xlJ8!>ccnMFUu*VLIQuySn{cVd4lt$Epv785u9j z!+0Af2JkB7sbD4G^b9eDe-Cc#^O}8L9PymkSYec>@b9K~?D##LG*cL3#fU9s;XJN1 z9z0&Wpc$`z<^^kaHGr@A{Izm@w$A!&jyFx~QB-=|$7Q{1tD^P{%z}mry1pH94@z%B zr2*Qz9oiLZw}-18+U>$rJdrj=^Yh6M#0XEyL-tc5Y039h;`MpXf1P^_O3lEX3OO6P zo_kwFmaaP)u#8Z#o^QXperRwS1&}%<7@Uy-{hio2mLf9od_`Vn_2c)3^wB^%KcjSa z<7(DH4mxP6ZBhEd1=B_jhmN}iC6%`nOUv8cto<2y-4~wV&O&Uk;b@g`lu~Spi5Gn4 z4OmN!`Oqw_Ls<0*e_+E7!SSGLynjp+9_&MGuLLVrnFWAo8po1!0@V-%CD02cn9s}R z3KL~zY;c<`A=I}8Zsx7wM46&f4PThopNF0~lxY}Tdy+DtIAb75_ateEJrgJTKrpW?p1gSWVzTw)wg43r!ZPvmVADBf7TOWngDC>`8|gT$J6*d zIs(undL}0&X-GQ1^in>+3Rem$1EjQqijq!YO|k5tKCbaRE8oFHck)$vrHX@kbynp9 z^#~+cMTtn%=aje~N=KEfFK=J=Em=Ljul~-@9|6<~INFzxcx=C{?&Y|xwH8*VV~Ikk zc4#55=n#@yf9Lxi-Qg{xL>@q+L6~+gQptTOSy0p~TWyG`Bx$N%7s&tl z7@Hkw5@t>U5%jLSTBwupBX3$bc2*eB0dk*kTVsT^@e%oV#nt1lWOM`ttM+-g^@+?o+SSTLvcyZTfy&prT$Dt7+?au30TBX4+sJFYKqbe+n z86Pbhe-q$dJ~0%g!)BfYJ$LKIQ{4K!{xF_wD?I4D<>V^E~$PzYbI3ate~TwWd7M5t8H=x|zXV@)=Kr&w|qun)2U)XEriEe&|KeO$C-T*Qw>wZp4K z;-yDoLb~gtujq0Ozmf$ZmEC<9(dMz7pcn^EW^|}o8w(3H^5;VnC?bu_7`OQJR(_D; zf1gbG)321T6&|Qtf4@AY?7Nr&?_3ejVg|RasbYP{R9Fq{;zc3+qU@AZj=Rr!B2u>19of8E`e;5mys`-w48+S8As4;*}P+ENyf2CI; zl%na}%`cXT3cOR(1t&z+dVR2c(RITpMK`o9a(YB+Juh0$M=onD)7t}@n+EX|7`^k9 zbnxT2z?YBT9ka$rL?J^}to(0g1%PLY@y$|VYE2ZpgNKTPzagy3AcRL4e9wUzf72ow zA6pCBjY3Yx;SH~?Kb&*Fn-lR)fB$7Ofv}ZIU#@uIn6Ls5-}?(Ae>7!GC;+$FQqUO` zT#nkF+JRagM~1ALQiO+Rj7cJ~RGK-_|M}gdi9V@{>j$Xf{nt^2{OYQB|1ed2vIvbr zp%YjswMa1b;>urYZ^n~Mkv+HACuk7K+M;*I4Il80vNCV`l#AMVF4~O?f7)ZwP(y|p z?SAgsJSg~s=(`a0k)I?}(7hbzJm{_n!h)K`)dP|%Y4As@*gGvxtk8H&@K;Egbg;tX zgWLhmGWG2(wH39O&?bJop*Ev-z5B{D6aSURhY2-MJse%|4cV=r_6b;rQFv~^fTOmf zwns}hI4hErrhr*OIEZvef9nrybm~AGvc*ekJ8HKRtId%IJ(1Y3OqNl?!|Ihy_wA6RoOVxCgCX5fBjx4wF4t~)-X)P z9@NKoG^v8R8NIMvygd8uEEG^c10j4o=l}UIG5B3-jHX|@?vmjQtR69h6hI5wB@RRSr08f$Od#__v;1(7e| zAwHV>;4bMl1=6%}9H4*$sqqKf5U4wz#D+&IB+s%`Qq#|585l9-ce@^CV0b! z${jCi{SKRp_%)1aOGjl?YC15(1EGCN?UBlgMtVPMt&Oi?x0LZ)=%w+Wkj`kCCaEkU z7*DcH?a48&MCg{F8-i{Kq9y2tPBKJ>A8+xboOt?BR5bz12!JM3q4RIT5z9=*0xFfo z-*9!!)ibDnj75&*I#yIlDv`WG#lK@kC7}Z_gp!_WnI+2PbFzP@BYCNXttA0CBLJ&# zcbbTzAQ&Qb5&)uE@O7v0K;7qHgv?0i|B%Saek&bBfMX z1WyyM6g?|Nw5JNi2QFFCg?m{M(`{>$-F+Z`g!g{)k@qgY(DyE9@BQY#{N5*9u(t^^ z3v7aa0FLfWWoC6EMHZcG;fNP-vkKngdDESh4ca2O(oXWjnw_wAET{8|mN-Gh8_UqBD>vzpHuXMJY$5-94yb~ zN!RnLx&@?%v20hBJGUOcc4xKSI70_U%?YE0%CP}uj`i3j@5OD*}=XBCcm^VzG0(oiWjJ9e+i-B5)iC{T9~H73zkc@Ue29GU|~)1hU%KE&`MQC9jj=Z}WE?Fi*{y}6$G zlghnPZi7H)aoN`>(}$1{78J_F(D#pj#sZ{}uZ#WDz5hBPMQ)sqzeAy31HRReIE`l%II5`f@+5aca|Q9F=H2#xlrQac zuQGdnOV7AE9(zIy+snVWv1;61{!%u(>LJ&Ly3Ff$rBgswMVS!b{qq~|0b1YE33t(7b`EaI}uc5yc9<}9` z?8jlr#+%+N>?OE!2t1UQ=QXQ;=hnlm0|~^y%bAr>7=}xyA?DV{Zv-3sfA8*esSJxp!a3W{gFu#L?*c#@2D)PTnC;k`}SQhz6+pL=xtkn^4E(vq4Fu% zL!(>_Qc*cjIid$Td*2M$2Clq+30!%5hfwkd3;O^t6mqcuTRO*3tZ$23vHs?B#QN8Nd(Dx3j#&TtGsXJK z%;~(XI;;zV_o~C*c~Pu7XdHuMN5OkmWpnLyF!}cXT;l&qF7YwB1&AxPh@=I-9%^#` zt}f~ohTrgnv=)KO0e<0dPp}H60{o0(4($CS5fYhAay^GJc8tjtgfEp#L^#|=tU+B5 z0j@sBfdhUkMn=?sM@I@9-*dIcHCy5@c@?{~?ADRsbU4eAW##^nz-KJ9QfIl<$AS24%y87D1{fe8F6 zA>&t5A_N?-DGTBvu^?A*5XpNo7MVz_%;$t|PKV2C_0YI~$g@l55bDG14Aib|s$uXc z7N1UOXE6=(8Dvo_7fh|IvFf*VTLn?@fy6>i_V$y5?_sPP7Y$vM&YQ2tA@JLSU}^8P zYtF-kDFb(<^*)eOF4of=+GFVK&jJZQkePu{GS%`?(a$V3lQ2-QTL7t`q%MA^Dr8cC z$(BGk`24hg@?~E^*txEKLmR~Us5_j%`PcWfTV1Cmvfex!YNK9T1 zaKsb7<2^sJ+=aKZ^C%$(BX{4Zuvua=mvbolvwG~y-esyT`)XZ-vT-k>9A?sg8OWS_ z9{ucp=?vp?TJXf@n5Ik;XGpGZMbQ4qI*7xnyWHo2RqQio(6!r;7yGQ?r!TMhh=JZd$ z{NoEj_hCGK1il}26T#aDt6K1jJztGP=Qb7r~xHLpKP$bu7*`#Pnumz z=NaJ~f1YB^ffM8u!Z@qGZn6NVP_358uzNTF3NZ)QH#dwkJ)`QkUD-U;ZL*$~(k2Ff z-0%>ZyAS8lji6Tt@8*^MwQS2~Khs{DGqKIdV*4dsnT9Iky~M5*RJe z{w^@_wqS2b(Q+Vv=a%8`C&B-i0Eo(e5|d{5Po>vy(`XID6e$!Yx}rtfNE^&uH_`FY z&qpaR2?1gCod4ToGH^Z%V>Gf9-6jQ5)AYTA-#55#Hds|8vY7JWGL;ZSDy`z@Wz+H3 z84%GI?P`wr{OCxdZ0YF>)k_Q>%JYgLsqEnW1MU9-QhV+|3T19&b98cLVQmVRfAIl7 z0Wy<;jwpZSSW9mkHxRz-SMb;#%H=%BAps*m9(7uvMT0npv_=k!vn|{@QXnfu`tSSA z+6g3E&awfL9D1;KNPQe~zIp6$OOud7X&N*IQVP{aIS~7h0~H^az{$rFSbdxVPq-Ge z)?kT3uClPip|Aj_p%lUV`#%k){>;Iu;aNfz!qb03HO!?N8o8bpTE>&GS4zAvA_xiu z;UuXx2vAP~U8E2U%E%AP&_)G9alrzK?+KkGihoc+;wPo%R@H?~<`v9fC1t2L#uhmj zSXJHXgc)p6lVhN{xgiYA%`IVIT6Lj;8cdsjlVr3o7{-J{nJ|QmGvm0-zFZW7FP97f zOyGYAfn{3mLh%`MjxobdHhwq37A5P#;2k!FLimNPx+xWoz*$UOaC1PtOhjR&P<7%h z2)ij*DO`M}2ATNr8Bu7?34(hjQxJ96WQO3r$r2=kHp|eQ-JG0*6u8#ulZz z0L{*Xdt1z)8UB#gTn}P};8;UoC>JcpQB;4Dvz{QR&twSIg%VWR1%rT*!8Xm)a_Gs< zhGA7kWSUXXg0M7W2yU`r3wIGt00GkmOSF=Mp}7_ZLvwQy44Rv|0L`r;HW1o5!FyH_ z*U3r1f=nKvaCrua5OT=sQ3tcLdeniwoTmt{5Zq000|>;| z{d(E4Cl*T6)c_7Bq}$biJq)g8@fd%*mJxUe!s~eiMww)sYYwH;U6OH{aNm&NdOyj;KCoQ;=L zxtXSZ9$%d=AFSVnQ^yo9NsV7%o8<;;L%CkMOKa;4qqavsQY03u^El(!a)*CDs*&4_ zzDltn^9!fwdC`SU&ZIXZ`*qU$xSl$>k7I8~ zqo(?C+_kIFsm9j&uyA!$&3)KfVr|@qHH{*z4_lC}waju*s6_9MyL93`pxS12<^r9q z1BbLiU7y9F3yylAMBKtjiAJ9-o4Oi}y_EZ6*`&9+4!%%g~B%OM_{vYU)ZkmN#I{M^3vsk^J_d&(W`8=xxR*Cz}C$O4I zpZVmp5`E=N+)ci{to(msnOOK%CYJP{GI6-STCJh#bovV7XSuQE^!s8sdHZrZjej~{ z{k0e#tT(U5&7?ZL7=9Rj93Gz1H1NZ~z*9kksAv!+N%XHwsuB|-R&Z~~oPoPPv2YTG z$LnY709Su=wtoF)eR;k;U$2%I-~Byq&VN5YTl(-@r)Vc8O5cB1ihUgWXOWmi=5g%R zWgf@YV&j>8-{%aTHMc%&L3f=>A2yeRmz#rFl!MOG;>uLi`moeuYTAcQXs{04g$`k< zNo=+DVewSSeb|EgSncD1z%D|0HWG+ZH0wMoF&gsD{ZoQneNj`91hp?{ETewQ|M4qV z)mtUA@~1X0Rr)o`&@OK7R(1e;=dJ7z_O4smA?#hZvP0OLx3Yf$G>pus3T19&b98cL zVQmU!Ze(v_Y6>_plc8c01Tr`|HIspkD1WsXYjfPT@wD&ysSOAN~VxPEl^>&r6zBv=nrYo^B za%GfB%2cfC-P!MFiI9ch!5K(HVTngP`EDmxf9=kGf?pVlfm}SJ_vOp8CtsUlRevUB zF7wsP%azhH$%=B?^yOytI{Jre_HWm*QYsp@76Bcdcb97s4Qpwl>$NPR3Y*^YtY`bG zJ-Wv6)Sq#vqw(L~tYi4veZA$Gzoc1u{%kFTh<*lGtbcv^{aNaT5WY{oF3gO_SY}0{ zg<8c5zFE#p{vt)XSPdu3XRCxvjDJEw(CoIo+FjV+$Esb&narZ6{5iM7cz9K{qvd}5 z#l!gL{a80|T1(@M!V^7k5}D0;O42kBH!YG}i&b8vNiJY?2VA~nX{XWXJOEM$y0?$! zNeG!HMIo0oW+(kXj)ch*UFJ)2b+u zDz6*6M{O8*mOJjS$C}Z#pjA!HBlgDDQH@vg$ts7VagO>8SR79d`2ApRE>D+++5EBVcU9X012Xy)s2Py=gBNcSqst|Y z7k1cooAZOMA9?YC8BwUj0Cqu*#FPs!_gsRlyRjV@2|_0v-l2)QVasUO?9e}qEs20} z)qcZs4}Hh8FPAj@2C!4rzqJD+Yo5EY2^g79qi@NbTqAXRMQ!iJ)PMMWP$@|h(xfcr z+K_@{(>f@#vkn&m$!6d$D>wk&RdELl@N#S!CbibVDD}fvBhxG~CR^_NVOKLhfy_ms zQ?(=)7(&HEmh0y7=rJe-K2}F#8{Zwal|Qd-K;k{a8=hp{{-ZE@(>M=yeiCT{e79A< zSqcQN6qa9MW0N5LQhzQzTvld@D#gOX!W){eRXRJalIhaCq&|fq`v- zZ?+!5fy8-19o!)(`P2LEKqN})RV=^@ipKT$odcKxXh@{qgMpKAovBr z9l;xdM}k{|fq!}-(kO@aHYYEe` zxbV_5FD}L6LY7Np+21L2YVI`DdBdHSI{toM%sT^hwtw8|sI%eDIdx9gN2DKN$FT<6 zRdB6RC#Lk*`Zv~V#ZdwDo3))`dvl#3k$hz1-jJBYyF*kd;u9lt*9PRH%XX zB#)RBWXm|9WeIUWOmQINI8Z_)wG2Q?i9m>2Wq$}TzEqg_zA~ho)6?vdi-*y!hCHTkKu4p;TkBbLBjD%v8u9dPrh?*~zm*GIz@5v@nS@ zKJe9D-^2EM>)cccP|Z;B=Xod>y0?9`^92fLK?>8O-C-O!VvAF8vFUt~62kpvtUZRw zqkpP%CR#+k+F|zVq3bENR1&KeE`Vl~Tf2Wtd9n&QF)htbSE)SH0#Bkc3Jy_KTcek&r170U40i<8(5BZ7!-7})`VgKHgHqVmOx0#pW>B|?g&MsT=qC`RuI<}^SN zMiP7x@W$kLdqR;TC^)K9;!seEBA|Zy>^{Bwpk0czpnON;0%+e+Yv<%+IDblp&yw>^ z{$LHdB8x}n>{_?aj=J}TmQI2gMW~fAl>8Ljc&j5Nd*B#`l8(jcD3LhtYcfbc%ox)ohU^!SxbSe-?F<6x$ScMk?!u(K-VZsPIqd!gVud0gjR#o+3CM%^+ z)w?N?FMPt@&+t6wf?7A5*-ynam*j*OSsEgWX0s;m3Z{I^tkLQ}Ce#fF$xlz7;Nc}0 zD37-z_{mwO`TxU>VSl*)oJ+VD7#gGRC?NjGk&{n+I!ip|6BrR4g~x{4chsU^EcwWS zZ12`0@YU~irhI0c`Db`-N+S$CJeZO=g_PiP&KbCh^v*j?guW$N&a66W`?(;54k3<< z+jrDjYA@y?u9?y=lgVj6+Pq=hUofRB-zN=2vw=dx+kZm5e19^}RcxJOa3=A)ro)MC z+qP|UVmq1Geq-CVZQHh;Ofs?UlmDKr-K|smrMs(sUHz%69^Lo#>~XSeGftvp&FIG1N2eZh*JN^uj9w{4M}14{QVADNb=7KD4U4f6iU)l`<1iKd2 z{ysJ2Ug2ba26)g1bEWS@3Z$Xif>3_)4|TL}AyjGJo4=b3@Cx`w;P;38g?9BX;7`Y) z$T!o1Y0BZNGGtnDOU~bs++#!b+g+>=w?T}DnvR%PyaT2!lRp0`;plbk+|9OM0}Bpt z8L6~o-j9w?v0Tfc@2_~2~ zfAaMPv^e}ptlQOrtXKk5U*~9;EO)0$JF&g2UxQ4Py*E=Pt-Fu5d$YdEQ~zS)^+@+2 zyb4{SEq4F;_U{bPSX-riC}mruxwS=?lp^)-&T>BU@nHHc)@OT5zcxvE(on@vj6uKE zZPkcNN2b%eE5%mRVE#An*<{HY{#(a!{;sjQ%;)v4ZtY&L)dXDZ2hsGxs=gi!QOd4} zu1;_F>*w#Y^qX~c=12>f#4Yfaupx_jMvokeY&u(4!J}zF^Q1v~@>Ju|VDnV!Z}nZg z7mqbUCXG$EOCR-%mwekB0`@@EvZH4PpZmV)*hkk%I!Sifv1!xIJu~;{lA06C8yF9e z6*T+fP}S3tgOGsl3D+$<9~Aqze>kC@Ffs$AIUAkzRH4}97B~uQ4W|w&shk#nDJ~5B za!-4#Dr(jMwg_WA!IH`zs04py4;;sNvER>ZgZQYbQ{8Mrldaonuz5#7IqWKodIL&4 z1#Bbz5%d(i&u`-r&XZkV?a5{Y$jLeOS9VSF3}zY+<7r7;@c@(d)KQ!PJn#Z_*WXO4U-^5zeEx>oEPkrn zWJ>pmFrW=3+ul!~EL5l~Ky8zYQbxoYF7+#SfaRvYpCRX;J(QImZUS`!h#(;N_)qv$ z0zGJo*P<2H^27G-|MXN#P!e;e0t||jO=|rX(aWer*GsJ0)Hu#Ncyk8ps6s5qZUM56 z2BT~Ejvy6xLOyyGx1OY?pdbJ=F>S)EnxjK3!>1IJRivVZ;deJtF@!OfWZo-HDRW#FJ0_Vxh=2v`WJt zy_XJt2{N+=cq9Xs(5vSdkhrD_QL^8jyTL)k%xfDS@s-r!j8`8h^!NsW{Ba>^-|Fz( zK0Ge?9Nn|UeF!RCEdGf2-2gNYG83h)J1P($T`Fu*5IgnSiy@ypbMaW><3V_Z^ETf4ag{a@} zkhyI>c=_rC(d7XHzZl&&w5O4UzV5edqM#a5ctvC;(EMh#YUiuA5rmxhq%DYfNQ_wH z<+SYf_a!pUB+OzFnfVo1huYzeZ%bilSp{ogK|ike%`ZGf1WU@2RC|We$WCppWNLRn za0y%*Y+^O~eElHz&;g9UO=A28AP25-H}gd26bAxFphA=x0{3TGxl^LxY3~E#&p?@~ z%t-S-A|iqU^Jly!GH1cV(lv> zb}>v0{jQV4&*_zlsJv_^Nl&={#S^jAFE+EOIb$$EV{i1AbsV^8>ga=)i7EBo=J3;@ zqTtw4F_G2s;Sdnz5-+0`;+ntA+%IsDLsIPw|BiQBRah11r*Qy&xk>_L{Zw!faMVVN z5&G?9i{~4l9X>U?f1pFBIAIqkEAmQIk-Ehv?x`de;f#R_0>QQqH$~dbrKPNF_S%m1~%s8wAI6K^E-Ini^IKdn5DJZ{<fc#TCFmDN{0GE;F}%J*s=efr`w<9HdNiQW5{}lQXD|+PYjo=1kIlP&a`Z;MG7C z04|yF3Sz^FdT69!>vs{d`n+bVt10Sf$f;oG-`7Ih zViO|~_f(y`*=EnPuTV#VIqPp|Rwef9>boGe??$Cv$P)eh%;%rv)+U)MM_>+up{4ij z9RW}*k(SpROpL|+Bj*@@ZL&3J=tnmzkteWY7*8Wd6_k0x`kC>_l#+MUl#mN+S5w2r z?nF0Yhd!iUrP{TVF*(FOb1Jz}r06fQYIlh^MoYr4bOzFrv*>M> zXQjNZ;)Yo91{@Y;&4rhJWT_eQjeiPCO$pG4x@jKV&qN6?wh8XGP>uixA-H9o@6>uA z1bUw7zHV|TPFX275Npa!O3OZFWk7@Aqf$_PX4V$s4r-!F2xAExmp6qXq5=K}3_s=qXLvC%X| zu@OPx&OmIhbz)L~Erw%)7iv%vE^8gep1tXPtq;(+zKxdjJ5HlFA8KH06o8-`Xw)t_ zPo!?~zPWedT)W4r$ysEr7xvk0FX_4JxGeA_Vpc-|K>^I>3w>cAzrBz^F5c_4ZGpmopKLN2 z`SeX;Er;FWFm?tN?%4D}{I5&&jXfb-jN00sZfTUvebJZa2mut9^@09@!q-WUPQ6Co&Ac`ze znk47{xNV|ZL<-W(x7eDFCm(KGI|zK4af)=Wuamp=5edpFd1KAM=6aYl^;@+vzhJnyY4lk6tfIcs`6y0x^yn2BJ=ba3@@N0?50+Q#pLBPu zuT^a9$A+1T(wYm46CUs7wdZHIbGVNT?%l<)T@bvjE*%)6F1I=K^If~%ZfFgttLHZt zWCfEg$?TVW#meXaeZ2U%UMZw0GyPsbiYGJ8&0^4UoVb09J6dr$L5Qb|m*462Q^~J* z!8YSRraqJ~+-yyqB;nbqz2MYSjXl<9F?u$cDcJu+e$?z7Zn=0-#VqxkP26gxD1aaTkKARDNlo^r%&_m^j z1*FLETsz<}_YI<-MG>mUp&PW-FqR(IQuq+Ie@|!gku-JkpReP*`K+i=VCmM6-BbWM zOs*XIJPu9%Th;d}c0j@W zX<{dpiXDY45Vka>t9nQp(|u6`INzkbE`Lv$oa1ccybs^A?_}puw99@hWv`Uftam$; zm0(~#qqOHU)e@l>yw)fos3Ib`_Di{L%8IKgGojKh69@oOttxlrV@=J(PeNfA_K33a*d`$OHSYaxB3( zI)`)!Zo1VmOYSH^=r$~kW9QA3L(qb6>h*^FVeuSMg~TfEQQenK*zP&?%;2~$TkleR zXR`8Up4}nun$P#ciB1hUnye-h#8t~kY~i|mQhN-nb9EmX9gipw6+Tq`jOwO%~LJ z+&@nn9Be74#zDu2$aO*d9(LLTT_ZUNtCR3S^)wi=h93AWSXg-m*uUvvd~(08w(B-u zwk+>vI5{q{tJYZC`3Us2%lxZ-??*9Q$}vO30Jd73IiUo>t>#NjyZ~HXue6sp<2mQ8 z@u%;hW$HxDWl5X$LB^0UDGYLN!DoE#SM3v4M!T z`0|_>rMpy&A^0CHfZp^#md$!)z0R&OMkoG7EIoGVPGc+l)76It_*f{{6Mexkz^3o()0dlBuhpiQ|Q44P8WDXUEBoI;|clvjr zQ-TWro-IqMiCg+>ktM=?j`}5)gk(F@=c%NwBvfvGz^q3lKozKxNb`8P+=h$Yf0S&Y zkw37{a-MeS350|&{vbcFTaw2ja0Txbq8%p_sC1(YI=a`KaQc$;A3~>A zTZy5Wnl=Inxf3U|R-6#C2 zbxSJ|5k@PUEQ)?9?(|F1<_H-TY3*HujopTrt1*At2kYBN-S-1I%SW$$lLx2FEM zyjttYRheNl1>=^5YX}{bLMRdp8)%U$Fba12kz+fTmY_fUIijoR`m`FSDVmj_6ZY8s zc?hz|`(7KB5}KSL{#{B(IR|1JzO;-?Q=7e)`(jmRZlu59CeSlM6a9y7zm`jVqOhZ5k-Sdk6i#MYyFflgIrP%=qN zDoNg#gw(dZlXDcyzGV^tS+2gV8?LHez_-B$AasHED>!m8SsFw@wd=G^bmD?fs#>9V z%=(ALqKHGMi9dd{UvIxvyPu~&C;JD_ogq+A<$R`iaPEt`QbqF zcordWtdqy^O68HYV*gR2fFwcBi8=#)O?t3^>ju-n+jE8TDKUr(2D@4@$9gi#+mCgY87!Hx+sWW7>3e^ISBBou;NyzL>P?7NZli6}I_Dk~1*dD9i zUhb5_utV98oqG=wMXzq-filhtL|yv$xZZ&hi%k;ba#F;cdM1+Td0gY59$h3}$}4;S zFu)ND)3Kv+;sXSmQqsJ?cl|h1M2)!`Koi=vY&yA}L?PV+B}r5L-j%oWZ!I zX9~Ew>K>Y%iWBHk_vpwtITU!T#In7U0M;8LPBvQdS0-i=GQ9)rF_R?lS`j@M;F3!w ziv-NNpUe199jCubRF*7E=38j8tA)Ux;JMCrG!F zCqs6bc0wq=ezU@8Px+Q*DF-TXyRz@3oF~F(l8x&z#W~WZmFP9p(&9?19whnQLG?(w&h=m zx$gEV3NmaOmqG*}-<0HRaZ>FN8MP;+U8I|K+&rFjdHrN>?FGoD`XtyvI< zifBtq&Gn{-fmg!S*kvI4S;l11S1Ht43fk}qm)qLT*{MCz08+B7+V=p(oP3#B+G0|^ zfoO0!KYnPK%5sq$drB@xfQ#;_6LG0|as?8#hy+)1PGhILj#dBFudg7eD(HH|hCW*? zAej~X^Cbr4_6^y?aDP}EMcQKl=rk^rTkii6@@slI7vVMq5pYOl+13W)^0SQvh zV6b+QcMS0zZ~=lvf5BS^sWUZv$zLlU$iPMj!O=yxOEE>EMbfX*0Fnj=yhbH*3%3~O zC)S1*=7@$Y^5qN}D>Vz-g|$T*<}S@Zso@ffQ`(?5Wz%tvi`HKUVw^B|alu!zq4A_C zlpXd?4!bGPW_5A>60Ml42l?Ps&ri-&BV&R>%nTH?bp#RW`!61rYB7Sj5U{oiT&cx% zB}|Gaa8O)en&-0HfCELZ8dhi7=v0D^60%rdN_ifaHfromQ<*=}xopDJXG#1iL}Sjz zk6h`Aknz9b8d(+rqCHG7e}POduMP#5=KVwT94IKh8BE|Dfo?Wi(JUC!0y&k7IkH|_Omq5NQ^ zb1){(+z#u!hZHM-gE-zN5->r+H;Tyh+*1E=T4WR8#VPc`a~9QAWBSFR4f18CWb}R# z2zbG6bO?hvVB4x{+dZbb9a||AaaRA;`gxv_6B_|(fV~ac&K$A#m!@=hKl%)Ak)IZB zg`e_p4$qxLQn0@I{z;@quKFkv@L_`#r@qOUJ!7}CzIaX}HoCtkvwjiaO-D)Ce$>4_ z;(MzlF0@pNH<$74*6Sk>RNMZWm+K~0kX12sy&?GBpbHWkZ;oyzaXNGhciU}D%9E25 zuHbPAV9BWmgmBnv2}vs;(D{o`2S-)}Y=|Wc5Wd#N5bNAkF!fQgtt*i7eDpZY@;G`# zl>9_eH+B$Zi4A8CTWG?mzc-4FF_6pQydhbOT<3v$Kokc{rR{sbp!#45IiSFcl`L$V z!pWQLKg5mc>pW9Ya?uuWFPA-A&9du>Hi5|*=34oIa*YXB<40hUYizf%HgTOc0~E z1ecL)%=pL!CwkPdltI*TIJvs8z4BlMm?L$Bx#T2xVcS@glCEq>B)w8!nodN>Bt1aL z3@WZXsJ=s|fF@+Wqadu=TRmHc7LE+rfL;5 zIW8kr7qx5*vIr5S#5k*Qzf`Hsa!l3JFLJ^HMoCIn>MlXDO)#(D%>HWyA&1r_vT?lGAjCt~rX?6&&4=T?bv!fVoHG?Bk~Q|*3B#6*=Y5RWQz(0N(*IoI zicLnqPr30R05l3C;Azus5v#*`3>x9ol^_ugkX`UcOKnuaInADxqLnP~GaG zCJ&~?GV1bRI0~U?nqOegGU~`YO4w)YZMwi~$!TB6tnL}X2nle80{}aS8&l+Y80uAU zGX1N9kvn71_bUxiDBxEe?LRnid*%yxh1JX*-9G)Q(fVB*yj+2=7fWwX&YIDk`KG$F z9N5iyJlwV`DBR(Jw;-WI%x=z! zza}ljE76B9Pm0@db$VlE&v?-tJNhmMaBSFl8eISCbm+#4<#>M=pTYR6oqjX?LTPOD zloDafJ??_bvqfg-VUL7CSG6LhBl=R=;MZyYlD25Akv&WW&3K$owh+b|5C#w8HCNKT3OOYPf(2t zvDvU%Im{;K=P~G;{!wR=@jD~5N9t^Tvs_|RSz&w;Fr!|+Jd#(_8t9o0v*Nj_N|mpe zNmXW6KM&1jIaq;aWuqvR&F+TsuP(@$OGR-dncjHOo`XJvHN6o#aD>qm`$}-+pI|DSf~0yo&vMJGidhi^cD%uu3s_`}OL&c)1Dy zwC-NSD2%@Ab2soDxPRjF_>e=^jGNIm@v zAn%CGGVfgffdv{4xpuEs@?GFziMX6%F$vq3UZT|5KQNh#-uQi;$0YgJPtO4OAOFr> zwwhn>=00qHHSNAEx?NxE+cnAcWj8l7_>)BS~(j!#Q3w>l$(WKU#AL88+uedP^lnd#@19rY z?$zdI0JpD)?d;an>h%EFT@ywA03yNS{zx*;Asl#lj;-RJP&bO006;gmKGB zTco(tr4)@T(n$b_k>j!t<_6^9W?Sn~8XfshDH~2!7$j;Qa&k7v60Rmv)JJ4Qf+XC$ z=p0)5JBsbaj`Bw_KSTC}iHM1q3D>5Eb9HQ*Q+h%mRvc9bebU>i9Yrr5Nw)lMDr(RT zIe?roEPZmoiKHzYG#Y!?FPwz)X{d?Mu|8_{I$c4qDIq{43fadW6L$BoTeU=f1GX12 zU^#!5o(ZQU5La}a>2_+%3T$o-m%)gv3k;qZ8U;5lat(0v{Q9HU!IaX`l+v7rt|(dt zvPl+4XM!r*whd&Kd%ylthMl>k?mvdVV@(~qQcUMRc0GG{JVRGsU!*IYKcr=_CSlhE z0}(@>douxAcpk@!@ic8mGYdXHfdE&T-{Y#0cIFN&#z5sP!$W;mJ^D|-OA&SS*VyuA z4bgSb<+^_R*VlV4ppE}Rhx4ssonb-&=Xu5D9Soba1H+wF54*JEjse$P$053y_^#&q%A#NLIAB z-Jl-WDp#@fEW=ugLREAM@epT4em6bN&f^J_sjP`U>?o*m`ZMT0q0u}LPEblFvn3et z%u7R_-yT6_z&n0&?R)!~mR1D?R4{Y@NYthGq}de)2e0Y7g$ourrS9USXB|UZyw{j2 zJOEM2QzPPKabrgv@>LNinZYIzR#?;-ZRL~D9_L%e(h$69htxBuDjT{Jv1m8qq`=WN zX7m&EzJ~^WGW84lGiOGVsZ!QeaA8e)7?H>X=*I%UA=Ptb5!L6R5i#090&HDM){f_% zy|*CSt-iOH8^871;3m+rNVKj8pBKv`ssV7tUiC+(OUOOAC?2w9+%m?=#re__2-95- z!wog;shQcpLvVw}1CtrxKGgf@q#psi<7;DmilRT5r&6EM*zeoq0QvrYkc!#5TWm(X zFedCA!p;Df%NmU~eoP{?fy06_1JmE{R}{ntB*~j47u?DOw&k@+f+py2T(%|1r7NN(TWqE zO(AY*pA-JSeb8C>@Jw{jpC2x-NXG>0x1y0E!kXvxft@g2HAR+^V)PiXH~D}{=!I?( zhJCqI2yWa__SCVH_*xzVE9a%x0|A>Um5&z1-iRx)7CWPleuMHZ5gxz`0-7q@L!yVmE3AwY2j9LzGk2 zMI)N4FZ%CO%x#;5aLs-&<RL$hN}-^*g_daU zBo1?RL}xA{5-$E=5_VI334r1-hvbS$fLUtKa8{W5!;}aERz$SPWwV3J9_Ii{m_{s| zaOhYXE9Oslzcjj`?06w6mqma1;@}KPvV>svlrdZj`ptdUn4ve_3%7B6W*n>pygLr+ zLl5Yn4WHW|jGgIv=*>hKcQE!b(41g*ZW&}O-C79U%J>Qv5yVG}VL(aifmr`Y8HzoK z%{ewVEikBdpaxdeG2cuRuyF`hpi<1F-@MDI8$yI|0}Zp9bq7!D+B3vIL|M;w>PeyVs)HBDm@puzeb;e&S0C{;)ndaZB7%nk?*WYEf$B5?= zLwK52eYkX#!^3k%3-LX&?Z+4<_O9162xg}d&8Gaw!&v*81F-8gj`xNI5Fx$5jN6ek zLuWG#eWdmYLtaS>%eOP|Ed?C=fHhx;Dax2D2-1BA^myC+{H_TO>?UIS^;UaQf6n;2 z4x7|+ixg2TA*R5YK|*u~ui@zg9x(=0qD%8wz~=IOa-d$*i;2Va42vaRfFbNkaUK6o z*+^;1^(*nL06vu2$-XSy_wrrl-`Hj!f}k4_pMuIWJ9L=qtdi4WkNivO7%Jr}Jw|E1 z>=F4>J-F%h-RUBtVj!2?J2dzNMFlX7CPYW1!68{BTOS4>GRIW7kb72K+tv9@Yh$|6aKic0Ul8X*Tra`yk1z29@^x}YJ*|B z>zp?$lgOH0>&Ud%wcZc0?a?k*4pN(Fxp@1Kmkjh%>-V?j4JEk}b9IM8M$jW^;D!<{ z5rdO_p%|QtIq_h$SbstN2|L_rJ8AalJe|$J0<^-vMY`7Y=US@h&skgMMV5ES4V|V%^)9 zp{DO&`VhaIfEuQIil=rG-fJ@kYbrUqDz>iJZO`Zb-6+Zhe20b+^*{pA8ek#lPw;0- z0xi%DithUbKY09+_amFgMx;WRRvRwhX{C^r0f6kg3QAEdERa|Z`(u6l^?ZoMvFCuR z#|OKJyj*^dHEIYlRHjZ_p`+V4K!8%TBe$#d?Le-Vibqtld&%Vj0@bJ^zd^)w1U*|a z0O1$>%zNf25`PpZTK|G*@ao3ot4eGdnBO|3=&B+HH>AZubhGOe%>D*$cGE z?63(ktjgG5${^hC<0tgxk!_IE#zRZ3t3|wDXUFPVQBAro+>_ZVL2AsvyP3P0nVXr1 zNRuBYn%uof3TDa<4NZjqW}iV}O0SLK#~l_n3()^X*nOvh`@=4!VS3eedSLnZsKkoP z1b@)OCjjsPOdF-}kHs^_Z`VaFu}U@hX+68rx}tqgE8e`hRiwo}#lrn!c390-kRDYm z3(w1^3P3Vj4wZIShaES6;~{*a>9ak2-8pjynrqH7xF2?s%I$aypb3lig3y*+$A0@J zaT4|I$kw%{%ieP?_61BBWn=GbIdV68s48zNm;*Eu#0W|nd1KiZ(Ks)1f#ARqNf;{3I7Fc(VH?FN!oD zq5$Dl;gAPK4>FiIpWugOg;=hRxQRF$IQOPf#4A4xJ16ug!x(O>{VKYwnOu9U;P*CnbW~GMH2@w@3By3 zA6H6$P~&EgOAHV4yf!*d7y_7F&3M9E@+dg@nZ5DvmGW{_4oLc(%WMH(nGp_Zk#^$;^r_8 zzjb8K0GS^Ll)9uG#4*gmizM@D8Q_zqxeXRmfpQIkcZ^`H@r9W;vUI5NgPC{o=k~_T zTN&yh9$Vhf&3V_FZH{+vubWjP?$9A=Wb6kUR2Y7A`m^K1GkhI*E2|f1kUAV)Y}OJy zPfyP9QI7ArvgFD>`nc8vI}X)>*+i6>T}#%P-k5}9l!nk(Rw_IwvP6>}fFmtcf!%;I zp_yO?ZjKCRqF8T0D;Tq%yGMwB9jfWmRE?_4R=h^lf@J* z9y^;ddkne-uJddX{MZ;AKw%M`_>1u~DzU8w3t2Gt=(p~t-0U7SS)I@;;htmXj@)U4 z5UHnzfyg>ZzTY7=KWP|g%f>)SBWGQ&LxZ_a#jv=WoK4s|m{}VnY#q)*4XtG78affZ zNB=A8n*UlN_HnpN8eGlbRs&q(h;B%m3A{c#OrII$oG0BO&d0pA2*0-|6D zq7c6jF!CCfvKL?wMV3c0RtE>ck1(8;VNpRivg8ea7lXN2T1_2Qj(QnbfaF(O4#$+~ z_ZCoo{qY;!lZrRHd(5SZU}dyK4sp>js{>jg;SaFfjb|C~1$-F{@g_g!88wiCilyzB zMAC>N(Qw;MhFdQd;AuL)#lg!azH(`x_hgo z_NCv5uin_SSUb8}C6=dIrBVutkagfAHO*W@stDU(;_{4Enwzj^LP>36`*FqIxNnof zEB5H$cmmQRzfSEQ#Jx!G}VKO7i=^R2>O>d{e8RFtYkd0ix z<>avSujw2n2BXqwTvC0`?bd0ziC>l$m+Ost552vnL&>^KH)>tYTzfi7!_4e4%oMaWu&Fg-=0GK( zm2{@j;f#hEMJDle3qzn$s*tL9s0jMv2`BU}{7+hQN58eQhx26!x~+I~MT%G?9%Dnn z_2kMlKrphHLX*AcSFgR>Qw6F!RvVH;=B0__ouNvTV6zST;{nU-D)J%3hCl&S1w@l}_sF}{4^2y3wk)>M>nrwKN$+N5HJiFQETjw%QgoXs zLFL1^x>-<6ifBK*KyHlv?H}1r{3^IRLEpFWf@h2p54+MjZ~cWkPj!T(MFpBRU3O{P z8)-EC(NOt?kuHvD-`b5deI8Uirg?%W08ViHLs6}YU2(aTE&edcK>W?d+_UbWs~F2Q z_~hd9f>Ket@>ITo>Zz!|Y+k`vutFJQ7%|zMHTp%r#nOZ{^!PuR$Y<{bJ1|)fc1hLV zmwSYq7uq?hKIqzqC<3(ui%!wI)YJC#Rc%LU&>8q2eR0_7R6v~@n6g<2RG>jY0QaUM zN2V+LVi6J0DgkuH!>)Q^bPuK56gV`X&?=YD73 z3!oL>VW6H-#LE=8b9>AHUihzFh#cKw`_-Zsgr3&x#Bq?hi;wBUj9=A^0PBEb$Gd+g z$AzRVRLBFPf4*jOr6{mC@e8Sr68HN0^>n57vJZz2UujGOl{{$gi5QZ?QQhk+Ph9G) zbp#0ubI&|@pI!@#iTqmks8ke=a?|`!kI7UP#{17f+`l=nefZ!0KS?OZ|LI}E|36Jk zP8Qbx<(FE<){Wh4yY&GC$5XU((j0_}R;=FR|hd@K!hQ|5Kre+7%JG(?e2^SZVG@1 zB!_z?tND97`{R~!@_MBCc+E%4(*}R}a`t(ADF@U?^3JfN)75am6q{ykcyB#;cDrMJ z7S?9APA2~l3T$btPfk2KH6tuEq*1!{rE$<8J0i^aEF&)KYrS&bKti>!dpk92_O#iK z=w`i>i^lIMWQar`KsJnC-`-LyhnRpZCP6mTluy^ntm~E8S1d<{E>md|e}*bvLCkN1 zjsR1arT~KU=$6UfImlB5URKv-pCKFI&81vah!K2bwCpKk+BHF6+^l%bJXRP>{KP_< zN&OVztbM96oF3X@iYW48oM`(?N^+MWdw%ZDCQt~smSjZ_)uhqBq9b$(8syk7Nh8D# z7eW{9fzM!WZN&L8&M-gyKfjDS8Eb}$6q@>`lHw0W5lu)}!jq)?3v z1!+>hu?8{R9z}q>16a1Y@abhHxCHh3D6XQX?s&-yhN1H9h&GDjPHlPTeznrSUaG8!#A z)8W)C#QCTmyqqj1PSyDymR*=d|R(FJrCxdyXR7-%s_{X$hciyMZri9@9E=_J?CLyT8Dl->4p zrK`xF?1A{j)X3rh|5d2xe z7shG6n;KUtGp0snl8D@Lcak17fB!inoH{-+bt#giO|TAyn5$s{S_KI4JNJaJ$eF92 zBE}%=kFGuW%ILH8Yrt?G>{n+0%y-Hjw7EnNRU?dCq5JC?D92-OJoGS}JTcX?i zhi7#>B)=MG%eQRB*6Msb=?XuqEG3qM4f6q zlySC#QoQcMsEL+yYPY2p&1aI(9>T4mA%nbsI9s^vn`iw^CDgG*t~rGf-9e^=2HB&? z-XLo!(h}h{l}6|CS_rKaL_;N%5bz8JlA^;eg;xy2sJd*p+-a*1_id(>A%WV8 zEk#1-6Y)%%^wEF~`hsm=FK2=0D(hkvVMz=XLH~uakYxygc{uc`Xg@S+Q1gE^OZl{w zJ-K(2EN6We9^l7}2{8+~bs;lnGd{htMB|(I)Bp$hf84sKp~w%#IWOSay)G(*`mR;g z@&SB%Quf&gGFmA^;+Y<}t_iT~q%Z{}I6<02J{C?7{9*v<6k@W!2Om_*4PpHn(9(?E z_ODABAMTL?s72J2KvBsGPSCkUMVPdv(9gdhd7$zVl?67C21a-SaODp;HI#A((g=e& zkdKX9xNb@ZWBUrhvoF(@4$KEtxW9himLAVuTEBWr_Zy#M&4dVO;}1sRU#*dlYILxU zLIj~^@)`kZrfDEFPA)VU+H-@k7cu6vnv2u*vXO?Jfla9n47ZpFEn(}reE9 z$^mQWJ2VygJ^9RW{|t^|Q4PO?(d4C%IZ^>&)#jMKkQkTZnjSlmxmH@6h8OhfvJHs_G<;+MKfEL`=KT@bx`~=rZEA~ zQtH>cHuDUJVzSYzc`rQUP}f`|kz zA_$kj@u12!pVN84Txx}xr74nPTwM!LS0sjp~l;E zRKw^ty?vYCIjU))L)b#Qwbb)f{bQ-8Ob_I8LiSt@e)S85%UE}s% zR-K2ra%1b{wZfV3&98KM)mMjIw&bU&Q!7$dKeh6vuXO&K1B-fhV55GaLmUGLIsCNg zb_tw~w9y|MlFGM-G~@YIjHNmw7~;|>zzIyOZA75Y&r3Btx`vmY6JT(;3qQx7pU$l5 zESIk)6PLU3C4FfHJN>gcZQZ*aq$hTGPKJ+GZ1_x_-fUgU@ip5ys;i}tW;(l33!;!W z5$|$i)PkfX0uS{Fn~IB9h?5i$EprxMBY{ksnpZy+c6Ama|69IYl36^<+~vfLRd$tk z{`h*2{6nqzfx@@bk*1YrSJK_T ze@7lMI6Q}x{m%6%1TA4EzcL!oQcCP9wmZ{N(odxm^Y2ZgvLu3ZSH=No9eB<-RsE;yJ-H4gUE>150EnOM-OcJ#*N%~ zY5MXwtLRY}wdiXwd;dOXq$`MdOvS(~y%`Cp5l`tX((xXY8k&nwQqbZlD#Yr@ zj7Are8V}Z!Ry@6FqA3j0RGasuDmV|vE2Q<_Nh*xHKuz%4ld2(VOT|OVO4MQU>}HQ) z|NXEFQAbz@lTqkEh?sEH)#Z~SphP6+srH1!u^3z{EiJ_c=NuIkWypeFlZuRh9+M=o z4I!G;1Lg~bCnvC{N`PVnD-26#3~N!~8CSy?v8KZEbNg-4=Y`R&p(enm;5XPt?~o=! zQ5SS!r;H;nuW-v8^maSPuY^=!wrY>DUjGG z2u{3YG-pN;zx}x~PMksoy(G!A;Kas!`D3!rb0V~USM|6*$Zk_rK^>9-{km{d=u-f6 zFUOdas5}wlhH^B}Cb2sRa}mBjfgM709E@$^bJ*WeS6m^AL4WO)>LjyBUnhhjR?ESN zmoy?bM7C&@d}EWXRSBc?*(U0&7Dx>3iD(NIs;GPy{M@W#t*si+>Iu36*Aqx2jw^uA z8p3cc1{%ovAQ@E`%ca9VV7}BXEUEy{ldkJ`rR3f6mu&*QgVI6=bfoX+FNf39pUcsh zqz&|6$BO~hlwe9y4bARj!>3Ywo)5>7+Rls8NeTeJWh0>KG> zOZ#O^#3wzm)YZHHo+b&iFGV;7{$g|a{avli3jO^zZ|4E z`PeiEhqw30-rVL}In48F@$c@~_3!H3*}6?X`&UND(fiN;dHRJ|Pn-98rbMHFVP1Cw>?6&)5ycT=;>3m8L@{fs1nx9BrfCKbgSsmDS5ji5nX?#* zvijRo81BfJ?l+5xuklY%x~DCGQ(~|AE%j>#k%{0_4=<)?>h=JR=g>pJ$)xw^MYQk1 zcQtnVXDx8otpT+6(ijrpzdDTYw>J9vQxB8-u9Mz<@BcmVbHMoZ!d7y&s=;wO^oY#f zw6I$Pk+vBYU(*tkr+$v!-LO#as!!NwEs@T>0aWM87_xP3_@$;6HWY4>nUbNlN-H|A z8f+`j#aEXz^zcCIWCf!LrhPh;%lVkz9k4g?b2&9%A-eo%;iOU8)bXf8b^bS3?Inxm zX|)TRC4xd@oyqg)i@)vXcl`3Eg~sMv#AB$sgNw!{WxEQ7{iDVTy}Ri?JHYJPSmJ*^ z4fkK39JQefU)bL*+CcCebXX_o}8x~yM9wN z+IAZA7ummn?V3@3k!px%GDZ(ot{HT9z=X##Ndu;I`JWzGW~M2U%0>1rwACxl55v z+QY<>#_r0rL{bLt1&(fxLyBJlGT@+A0{P1O!0>8LQlcvI1g9JzQ)2nmm_jcH9qY=( zqP(f7qx=bo+Q`$Ex!$|xt>$nVzycx_bfkcX5mXxAgB3P<#6lP@Ly;iCJE4k;8DdgW zor6=+Q^}{^Q0dL&O4f6vFad`CBXs_)CMaycII5Sm4~;D5>TzO}=9PiG({3dWzoD`8 z@`F!;BwPSaoLqR7yvA#IKqP8;kR=KEq80jVP>u$m6!RpKwUEK*HIQ|(NZ~yCfNAMZ zoVh1m(55R8NfI}a8}nVKEr~-Br}l8NP>#7cHIgo39D*WB%h^G`)266`QFD(*bNs0CxXbW>LGr8QR84Ej>yjJYl zOKiYTnfibnysYIhZ4O6XW75u&{2~60OA>?wZk?s@?cfwS?vnxKa>ZDt2?n(6`oc?3 z?Nlqr8Hy5BES?7}gx^Bi(qv1Lsp|;!%zYZ~;yWodo*yAl_h$0`*q1+eAlMY3d|#$l z%|&J1Lmb;kIVB}n>J<5w`LLD=z%!451vHFij^c^Nx>#p@1PId{m7u(ZS@M$K!Owe2 z7wndSZHTyosClmV7XJ&}*q8n56qSHPBrTwRt6__rJd9&Upa!Wqm$HWpNbG*-{>yi6 zchTIOfiF;$&n;(Olsm6L8aoA1OJz-+2}YbvN&7yi_~Azq|Bd!uhU)b<9LejU3@|2; zJC=-y@s5^giV`)39t$}^%{@U)bHTAh$Vptxy8vc@5=qxGEm}Lr{06J{h~2VCCq=bL zzWrS|brLNm9Z3}KcKFVZ<1Ub#2zrSeevd)tHnHuVR*|B!Wxs5iOj;cK|N&?#u; z16gomt54wNqV+ty_S))d)8>noPq1TbLfjI6NY&>77I7!=SfRI*Z2Fr~2C#@)K_eqF z7_t!#+AHq5yu<#+&qU-eEu_pt;8}AGk<))A(--i$D5U9%NXqRwkB=y#^9b>q(Bj-m z^OZa|&Zw*3KKf#qBIfKYGkRZZXseut&L z9lX2<8kJOYCk|99MQGko9pFSJ5-KwmafA$hzn%t#ezEq}1$*yA1Y_^smllQHtxBDG zp*UpE(G6x+pWI=ajS?EkB1-9tKNxGm>6ypZ1iSJgnGP+Ef)In~Sf(KGr`mwDWUsvQ zG>$A(r!%cz8wtGummRUwckj5SGnZ|G;65wO6ms+C)Q)m^Kq-*}0btQLxSH%jA!<~4 zkjhLWOVmInUNFz-tXQ%U?h7ba@`HQ z!?asmGtP)_SQWfm;SY#w2ao050F@A;`kq0q?rgF4{DvJlfuBXmH*&wa-qvI($*X2d zz?Y$5s%x{;fah5;1^Dkb?X&ax2!I6+4;f_8j=8rRXte3=;1ezz)rb@Y78PPZe@cEu zoQx2oIqpd*bS9YWhkAmYH5WiCP~+Wj@GLBGa;-{a0FV5R?Qk=O@-2f@^u8R7oLPAn z+<*@jF@xPKstNeBg>=psUF`9-XSaXj>M@fai5mT>X`MIb3(zfvMcA9`+irC6UE(yu zxF9q6Em1#G%im}$NXF~MOxyos)n?fYU`?icOz$rNKG0i^<5PHp%Mk)ag!RGN!mtRR z+g$(X>)x!TX>-?Zi#E9eGVGd0L{(C{QX+?w@GPF-V?{i3JPX{=Ua}otp(SZF$KukU zGlz^`2#N_W0fe&E(`{JIlF^cDYAW)c@QSWpd+Y5yx!oMF%QI%e;IH@R;+UUFV0yy9 zxbZtn(cD_24akH0L?dX>&!6hJ9$;A*zdR zAi%#0) z$ZKK+gInEzo`9=$c&+7dMZZ6Oo*xd!6S*$RlNFYgY|7AL)XEAvD)fNb2Tv*DT=UTD zJk3jQ=tsx9k-jYC45x&7o3qM>E|tOZbR6p+1{^;R0U21>NnJz$KxK}bzk4b#GlO4- zY@gV8L2Seb>f;4qTbcVSg*dyzH5czQE4iZUQ`k!~*!eI%jT!MPk{C0McVi0Y>HEP! zq5~;&q!*GjQnC2T=#Wmg5STIFlH^;qZ8(fI4A)-vT+%i08)7hIJXomyuDFfk#k{Z} z1B!B^g%V%J@Rw>>58-fGU0+L%<_!n zD36~GZ#ev6N%ebxK66A>5(u5Jp3ee-v>q2D3}LTbD8Z0g#CF4y z(MXDn4VsNnBc{cJASsml#uNa_4U)MX1FmJ1h2V&6EUAJ6VeUUK(!#jV!$v*Gz9?s) zl0#^g%PJMc%9qHkbdP)mWUn7rLulehcHAWW?{azXPx<08alj5q1diI&^o)Yy4$u^x zIS?Rtq>PDTF{NFwXjQ%#rV>wZj&f=C96uo;MsX*CCZ5GueO^Xe~nkOvTm;P+{Gf1ZD;D3_TOKr zj}BTXFs05Gr*Xe|$Ih}|ouQmM=n-BL^D3+3YkEvtJD#YDq3oMLSfH4OCU$PTskJie zg0`4QXeIU^LDv0FqCj87UR#dS1T@KY`dUN-{EIe1ZwwhwbIW!aT~J8jGF-$x{WJDr zhAhvLSX?!evl#p(8MOd8mQ+E9;N5=yy@9^t!jC67|9TIfPyRBAyfg=Y;^4>WX(@1W-uq2!!6`OY0&mppRJ^i_**b5MHEiYFk)WACwbI<@&4 zoUzehok1PUE)03)UW%_c;i-96~#7qgLvVHo6>KZ{6 zL^e*V@b&ihWHY{4L{hR<^iPP00tn69%SrfcgXyZKK%#%l6H4Us53)9)!TsO8>fYr~ z*3Gp5hUF=NiLXhqHK;cwTTuTBdn-@3^43AASzxpck>O&`o(? zo2`0LDxk%}*xb6ky#UXs-@Nie-l-v(Orj!{15nJTtiak^b%!Y5H8d=5MO?liC_fSb zTG`M~n?8i5S|iRUfS!Y>BRsp8UOVL9dh0(lh__oJUk@X(py1`>$5pF54k@=?PSG6{ zLkainV7*S=bz#$m{yx+3PPnfKuNhRcnb4`haY-)b#wV;yELtn)Q)5)D&>#b|98>DK z)yhw(Ob2mR?J$d+F1Kz;04OM}+Ix4i!s4ft7s)*VnrN7w@yk{c4-6ToieY8gG!2m{ z#=^K{=!y6-IQl1GW!hb_PXMr=!JWZ>USGhB=|bEfXke_2Y+V1n2A;}Is5hc@=ZJkO6dB+DP`#?Ro;PBCRB`K6UUnbPk*@RBrq^$McO zU@FXwCYs$MU|q@lI?Y--jg^#Rzh)|R@!jx15i zpp5i+Cro6o`8tVIYlR8PtboJu%COAq>E1f=x;s2(mpRybP1h+Aye!ZFtJ}{E);9X& z@$M-(H4vh$&lC`(gwgNEt>;^_s}zcP^94eZ1s$RR#05u{K0o1|L07AUmO9l~b`{+7 zwo52ZapvPQVK;U#MwCekPRaNb{8)6xgIE9JbnAgR0Hw|AqH*yfKINRPFE*8&wm^EZ zw5b$R#820WrvQ^IwL^h{yzB{Rka*P>U8fA?#^tdI5tQ@IH5Hz+Hc^qE&-tQFI*{eY zloSB~zs`Nn@9fmjO3%%4vl-)=)Aj&5jPvoc2GxT@Xg4|k{%v2r?sk7&66!ZbNC~G} zzn&O6TsxW@m`8)1K-HM5$;<6BjeYr)qM#qK%Dc}(TpERAcp;UsC@J6}dB<{ke%In; z4U##4#7U=RL;PaF^_0?83WdF<{qiFl)PW@jj8b=P1qndcI>FcXlz(qFLlw!^DD;ag zw#LB2-DYaw*}_8bNd-5GTqQUCnL$q+75PQ=#Fz|6>^bmePBHbMMeh){Xmqi8Nf2`v zUG0D)?scu9$&llQ3*(sSCQXXEwJ5YqlL zu&_PZ4EI1D*q`Nz_BHMkezM|pCj|fDldspED%|QX1UhKwR(x829vrd!8e6sc79C_} z^RLbiBg@ipcMaa5T7Rr~(pkfp0T6~}fRx}(tSR~G0c7N_n+vkCnkm0mmRLj)c>cCj2NTCBXPp(rdw2Vve8lc+4kgx9FB zSMVmt5XAwh!*4L*`P#u?kz8<2I4qL5-$#0}Bd`_2^BjEF2ma!U>w~O8Ln@A`4m>0A zG@GiUt$1K;%#gUWZ)H<4NDf4AfGF6e9pE>Rt+UR`uFwP&(CNGMbS%PnYALvIEpnSK zShj2`TIYBGcS*tgDPg6JF6X=ntQaAtu@|!AqO0WA86s#io>@-ZOXT{**_zn?8ZNuj zD@bI?WVOGjguX z?^!6sYWuA6=U*o8^U!v#be#g}4=9eI?$zk5LrTM zc1z~r?CL3~+|+fddoL)rxY8=GpCKcs^I%*U51zH5YgG545zq4`j^pDmMEDRPR%K%L zyCo0%!qP)v_8lNi&%8tpp!B=05wb)Cx4fFycXaIrcT0-tfh{r80ffD-aTSaRsiZ#V zL9o$86d>EU&VOqY0MAtgxT|V(Bqlhb8Ba$P? z9?9NWrNss84CxH<70WMeK}!a-wJuzIBj)tFxiy7WZh4d;0CGR<{b0i-f1Ny%TEMqH zv8ar8|Gy;8OgS>%o8DX@mqYY22&8Y4BsKFrtY@RA->{y?O2l`Q-Z&BoSEl15Sd7LQ z*UDX7PZ{DP6&ZxKPvLZ>mQ;0VLTF<2E{)`4q<1+g!kzXI&MA~PQCkk{g1`Zj(X{p> zRF{iN0&Vf!02uVKY)L&~BxYA*L>nGq_g`!(4SwVv6?qdQ^f|ft4yVR&XR75UktqNC zGY^^iD~*pT7+fdZQzj_zR3__@5n7&MWm|} z9o`C08`%raqYSX((IH59Zc-0V(H8o8NV<1+areHy0X@70&ehCX7#K8qhbT$Xt`Lp= zN#|il1lxipTzNTM2DHx0VhH}KBy`I3x!`on7QGhze`sNFR2}t?p`b#s2G`?NlT_}Y zbqlHHOd8~*XCGmO`NlHBMWYrrs5?ej8ROhrc?*<6LZJUdLAHN5598DHdY;>bt+>vX zOSgFe0JmN^BNM~&7|zIzS8pVqVRmY9?&72&TtNg9KCs*C7rv(ccM-f&ze6e4Rd}7q zqhs)q*^d;bo0lzI)w&GnSc>xuFCSIlw2U&i34cLYL@Ele80Xpxc1Mv#N`0{haLGQn zs;%ssddGjp27R18*wrNnmFKm5qHG4VKo<$m0vckg#HY+6mF)2#xaZC$IIF62ZA?(K@l}=QwC?YQ z0PW4Cdy4jK*Yd`yfdUekAxy@V8HA%9Tm}7*m1|Jvld>45)UjvSXxl)I~ps{%@c#Fr#7~_gPfb_EvMFO z!sRp|OALV>y&5!`iWNt{I4q-Rm)5bRkXi}j7B$j^Q1n8as#n?vMgzNH9U${mf~Hf7ApOl8^qdjb5(s^zQ`s-dZ1}$(Yg?u9?^yF%)ETTmsdlI-aXf3Yq+ddq~5UGk;Ic#_v6D3Zku?*|p zK0uMYGlt@xoD&~qR3^kCa|~`P0by#RVjriQAX=0aTM&~HP@d>mVy={s0M9~=0NoxgHY2NJ*?w=g0NGlZ7jig%WU#}qujs{JVW=`{@hZHHNT0NC{yT$V z0G~n!z*@FGhxbpa$jYNZr?W69OcA zY)3{khYLz;lsfZ?! z3@Ppz27f1S9Z?PNEmT=c_`)~LYjE0h0M|E+(3E`rP8^KWWHE3*Td^L zE0bC%f!WEMTMYi4JAA3#gHC?*8+0!0Ecv}^tcSQ9Ja4um$6`+{$lP23)TiQ8qwHmyU z>c5o-;TOK^Aa%m9`tS&GI!mLRUSHyZlsv4Tw=wsK(5FUT%O*670 zVYuk7hNX~(GTF9OHcORHDf-(-p$8nS;ARt~11HfzL|2jjO2%Weu0q>um@YwdQ?<)5 zMB~Ic!rk4~s5b|r59IyK$_KI2l$2<1{o{wQCgR<&&L)9PI9au9W6 zrCideBHCTu*9}}9%cnsJ?#yWqYUG1Mk<{!EaG_l?rKIXk%fZ(W_|W>Z79h2={Iej$ zg+6rHmXOPMS}ORnz5URSq@Gl45&p$_dO2x5vfa)*wp^&i|98#XAa##J?2&S4a(LU9 z=AY{|z;8R|IW{Dz#~N_II6GeoQO|>c$ZFNgMD4xp{&;gR8cj8YA{qkNeZ-u#Y8>BB zD1ku4HfP3}5+x?A7@;Sf&*Xre(q;lkqd&d}-o1V{UgOf_3ub(_R;`58rSD{5CH-On zAbf(F?RcayVSg2i1$2MI8s^5D{g1RIJp&XJF5SZw1Ot?X<-ZBJx&KATDG}BwryC-bh3w%FMqn9PuzLvb*TPuZ?r@kHa!!L((eNn3 zk+;cUDOb8K_YrX0Y`Ecx)#>phS5bf^i8=BG(n9XHAHL`b-PVt<=Vb`SDPCRT4V3ko zv(Xb^Ef45|8p#VI2=_j!jq=tPHxJio9w*OPRLk&sc>+Q^k>SA2GVl`t$%WLp$Oq>dOIDB#iRMK)|3Y65UAo&z`u#3U5*X!C$-}2!oQ!jlJeAkwgf>BD;uU`d zx!&sWbdpIt2K(`NLoclue}&fe#Yi=6U$O~kcm%gc&+@3ElVH_RK-B)?qBf3eYZM>1 zowKw2P?=nGwY+X|RgPdxHcky3loORt+G0Cw$VZUqftBbf%_Hk*L3@z_-Az=gGIwCm z81$&S9DR@KxYSDAbmb?81aB_0Qg!D#C)X)QwUi}wQ^4O$#=p-swxx&Gp^7+`r=t27>~pW?*1VZcbSGkdlk+#1#i651?}o%3wd07C+#*`*2}^3wTz!RkcEhSQlR|< z)yn4F?dA{l=k-f)(HFV8sbeP}!HrQBt;s0m8C?Jom=!}~fMdGjYZm**4?cVU)I+eS z8A2kH{v;U2;1ZC{{W)*l;#GKhJW_68D7tpW!i*Y#es?|wOJnJtCSKH|zi;yqw}1Kw3W>OunmXE;$$ zqeL$5efQf8Vu+=H<9d?y?;7c)@w(*BQx_xr4j`k07aQtW?>`K*9CtV-o(>|Mmbv|M z81o6tBhr&Q95&BCyXWw($6%b*br3z`=AX|V=Q2uOyCQ!e@{YqEP-gUCB+LvEOIdvJ z@Okm?>DbmUnTA}(rsNOD(_8}Zn?Yeqt81zV@P^aXXR5BDuUwAw&xZ^@ZcwnT?i;Zx zC4Vibh<6}ki*wkdiRQCq`JOhI-@B~tWBAG@v;xAN_%{pk=5En}0$miM;O-<)O3!W- zkzZ}LLLZ={y8@;mk`+(a3xj>p3zF^J)R*7TF7A>gB8H*cZ4yJIhU@{){(8leen4|; z%~EeO;?6|q(ZOkkP+5O|d1v(Twb)2fGu5X6uh;GIN*SVUsIi+db`ZMKiv=S<(9K!H z3r#!dC!}WxAy~d^SK(7$zPeHyY9Y$lavvPeN|6naptA!`Jj?#-+ROVfkuI=zlZGvr zO^6LrOCe&fEwQG*t0Mr^ny{DLahk*N`xq;47}X$Qz$)Om5~!VPt-P1ZOuiK3S(#;X zC|YHO;Y9@Qb~9LY#i5}G%p7p+m#Eiw&&jis$q_`EO@+$8}sf1TSZ<8hR zxOlUKLCmIut-wRc9AH}yBK5(En3O+_4UViCmj4bX2=C!xO_y6mv|C>KCLix_KOz!5Xr6TIT^VCae=c zfuW=^_AIavLB(NX5lKV?9;cO$;482|!3>`l^XgM%G_XX@#=$3@9Refn@hDDLHNo%r zL}v&{vW;Nt8S7b!vh($Lnx-fcGUq9kdMrV^w8MBdlxqMZzdr8b%wXms>(0H#tIs?B z?juokqYQO%O6qx+VVf07Vk-kqDlmYFelJ#NyTFRxsmx+hJ4bK{55=UWnoHDy>eghb zVg@2wtnRqj8RMz>;H2k5xZGQBw@pEuu(+KThqnwGS@XHl#KZ~orZmP3(rOEyRWn|= zHY$UFb`t=+OA+{hIo4bAUdORQ_K6&WUmAMnI=ja;J*jEWg8s!lyy{ezxOI7_@f{Y0 z%(QMaP;bh)yR)p7Lw1*0N!1fi>LEun2WI9O-9P?Gq!nbzu)t2|GZ;?VGCa@qmnt*h zW^j_JD=o!=ygi#f2`cF?Qr%yB5T8JFRGwn#v+rVg(98p>d7C4o0O?GwJVSrx*2=6}NUI?ich z+WsM=f&V>^QM5j8cS^uI+mrLmvr#kH7K!dG_h1-Sh)OQpt7%&c)m0RcjCJ=lLczE@nmSGXQNzF z1fG50l(&2TxbECrt2UA`b79XTDP7W($SvuMCx>5wz(9K3D`11TOf!p`Os(Liw{SuT zf9O#pb#Uv&-{&ICG&s<8LeihkiTr?dlFs4c;_dsni>u1&z(M5rGlnJ9CW-z5-q0a4r94xN&1!U?Ss$I?3xXJe2}$X!-r= z5=O+R#5&Mk^G#a5MvxLrQM&F@H^f;N=$wQ}KpffPQl5aZx05RsL^H;g$Q{8ZVP_wH zOxq!!OB(k!+CXm%X{z@KRlD4J*UPypNRhoty3l=$6Lk>-TK<{vk#3w$EkSZ8v0s9f z2G4_=ogNIILSHc+yu5%*CNh8$R@tN+ZIqk|lnGjA)VpPYo=tWYTeZ~;#k`$&WJ^N9 zxbB8zRoj;?BHmdv$!4}y=OJ@G)!vXjbvz(r3KFn*a*I|n{40Qlwy!V3Vc*e@;)#I? zZLX0nYltq!Y4|XE4CZksK(IUZ@1= zjXa2Wx#)56?Y+W2L(*taIuZf7D2;AMTQBg_m_eTfxb7+}U;x=YWsB*6gK#g=SPZ#q zM`d@|mnPq`@uKz1RG?8y_^EqhXbKYUtg`zVUGFU_uNPPE*pMV@kk@2v_-6Slre7_~ zcyCX$BWV)Td68=000@vFd)i5FO)Y}mne=LV(J%?#Mq%0+FmUX?fCX=!I9ih&1RvM+->dl(0eHTBb(B$p&cqxZ=@?VBqhNsO;T0QhW z{vW<@%2JrvKz{O$%m){2aYzS8wDnH{IN2Up|8sifxsA&*3JG@CO{>gEx=tNRX7Crc zS#ST?5P31DWD=zteB(Ew5vYXee>SPgnm!3?NaXlq)^N2G+cxf9ZxD?Wd0jZqtDNJ0gT) zN;~F>f$oH&dcAz8mQv4K7~fR$btHwicjA`~26)mS+?xexgLXd0?A~TqWpii|peYe& z!m)1#0Lo}lyqNU~!@V;LZtGE>kK< zc?fEe7kq_Bm3YwXH(xWAke4hZ&*oc;4Qlu(F@J8ytXY;=?ti&($9%aeNMsi}ESKvX z&mk6IQ{k_SN+S>9;XkebqggtHS+>Y~Vc5S|D_W!(h7iR?@d}J4rJSh?(fkm2UGu_q z0E=zSDh7zLwNH{|m9{vS!z6eWSeVqc9G;sBt%84PfqZ5>|MJ^C{bNDWvBa+yG#QDr+@-_z1hD%moAM;P_}H zVOZn|alj+5KJtB$$luET0R~H0Hqu`(3$4F&3jX;AkTpaAH5R;|zh!J^-;qft1EMGU z4Vh;KU(1ycaI&bzA zzn)Z=cU9M4Wrm{ew^(jXCKk|mWo_(66>b#7-G2qYxzpSVgj~Ry@fLDo1Tf_W>iT`= zTfA6cbKDMh!_Lj_jfX3iHM10wBcpt(4+W~azu!E;MHYh??&TnxEO^9xz^JF073*QB zquptkQw7tq>+$EeJ#=PKUh}PrJDKAr=`)$2dh#a3=<#SbnF(_Iv2xn0%F&l@sce+f zNZ%^v7DnJDH)V(kDE;SjB;W$)r9dYgQ47i-6`R4^+uYAF6HflonUmwKf*~KDjQPyX zAElyjPOuB_xxVZ#jcpUY0B1i53 zyH*w|zQx5}gTT#;JA$)n+{aGzI8pQD;hKqep@0zvCvr*%vLOFr-zJ~yug z-^{3tF>mW=z_(yCm-`)e8P-hA5qr1?SB@O#m!*EYankW(pD;KQ5M++PR=Y5ZGK6*t zV(Sz_h>FtrtnRO%RNC}+c2L|)VM6|01_s{b6?|ALKuecwEFi-yF~NB}=I?%v5oB-% zw`!Wg_8}NP@WaTlMB;Sym?xR9MxGe&j5X_)RMg}SFA~~`RLlk|;%?1~RC~Ly^(vu~U3N7@jVxgZ@WYpm; zqB)t?n#RTe9H93ouY(Ufx?k%&Nhj3pU!ztO*m*mmzJ`bH!+d9iNWNb^Mhkx6p|2a` z+lzKFL4H!^Y#1!3XO$sfwI^%nNRCi}V0K6E=S%$G#c0QpGX)3J@yt`e1#k*|q zkvH229l7aw`=CC9oXBNju+41I#-=wV@Vl~PZ?eh`N6M3*n;u})Pv;TES#ls&7ku*# zl!$5w{h#gz%E-j}zm0CNh+J$;|JUip&XybyM-5ok*tEyxK=NDFxMR8jO>f%=X9O9N zN&&M>>|@_(jw8e~JN)C+9M&bD+k1;Gt#9L|vmy!qB($YT&Jl79flY%lrh0)Bo(_k2)mI(ff78@g{K2jV>k~7;ALb}L|7>YSCl#0p{ zBMESq6;evYyI;|a!fz%NZP;We3RNwxgB*)rvM2g9CEm0>23p0)U3A}%Qe~b;4`A~o zAEbeUQa0Ry@a>v$@qAv#1O*ooQ{mK;$BOxzC=tNQjJlRj&dV z1G`n$SW$VycM}4?9_v< z8`yslGgLR>QNkoVtQdnfd|{^(d7U6Q)U4v^muEXLVCm$qVLU-hVys#3jd@{3cmWi! z38@Z9V#(lfX5j^Ylbf{$#A-rTj^0BN}Szkk%p*+5lUNAb6Lz z&ntXhg|>0N^I)F@RCHPV1toRT(EEM6{ysY zNJeY-MihJg_bMQ|#2i?^sAR2r^K|m?;QI7*PEY%yMibHubr~!>wnajl=(<)&Qq96F zt{2uKt!=7!>f_8cy))A(iA@ZfFpio?6iOXNQ)PP=p{YEbHe=!W!=1fk zN#ix#+0#n)y$U^%&Cn!{k;Lgn>*yE+qZxrP(? z7Slutf3>aV48-a0SEYIQ%q22jZtHV%_enBq9idwIvzrS`_L3L<)Tw`kfL;zhYuiCc zhbRBrBYnpgu+x&Itv;yCVDXCFCr(0q1xom}CcFevrEcpu+(13R!-vaa zbG^FE#^K#xB!ZFOlb-xwNWaIxQUfbVMZzkYntr-y{-+K z)*!v8BK2^4QfVx_KPr}&H3$2foS})?*4my%jtiAlGR*tI zY%Li&Y%@x;wH^RS6s$cJ9%LTR(Gi2wR0>$L{%a&@3A|_THfxC(4%8`VynP|d-xS+{ zr^uW9%hT-Y%NyJ0^^W;PRdXayeZupL`Qsb$^NUE-&F$a2wfjG%99MZ&h6@MGSBzPA5#s&JV&ke>qmDX^acZt}^-j5RCv(PT%Uu*pZIIbL7Oce-)!23<<&=Is z`_L0XOBb8+NorcT{OC1&{tu+W!|1u6z!WV6JY*B8{ z2yup}Rie7x#|eRfrWT|;=Q|TEgrAosAuA~3LxBSZ_()DuUtt&iF3uY!NV=1^EP;RN znq!}jB64+pLOY`%G=$6#X+U0upsp@16N0`ZtA*EIBXhE=AJ7sp>9Ya?nTsC4jqIih z^+3Rm)qa!A5&sqR0R0l74+aY)$Pk4Dw;-boR7BvTEsE+W1`-n_Omjy>49rRNlrxeS z4ykMnID&Fg)7Mew00A{kP>-06jSdavY0qkx;JD-o0D(ExK6DBlvj2Te>wE?E3-4JQg=Y@F z7}Zk~mDk>Ce`m;0hyvoALc+qaJWf*M@Se^PMi0JIOYToGpSzT(Cyou?%&=eeGN%Tx z)1_mmIFpWouqsTaRKI;W89ULC_JRF8F-?2CoGHF1d-mNOOzHr&Dt9WJ`#dk&S+sLG zpoSdUM_yPu@AHzVCd1t_fCn5R-mH;s|d{ZR*f3NOaRRRBi%#50>b=)}ELBjocZ_ zf@kMfdAbyj1w$(t#vnqFyOkC3^Lc7ooW%*vZ$2?&JHf3u@J`MVt?)|V;v8^H(q`eA zXF)W0#M+}|hn&f8?!6VL0P=TI&u{&ILo@*%pqsgQDUVT9q` znP<46WqqB5bEuL!GYlLFCILq&#aMC0m_poR4mmU~8vX#_f>T&SAj)QEB{QdQYOnLM zB$znh7kJI!m@VK4i28V*+y?u73bn`i$2x5tJscXpD4V4nTtdwj%{VKX98v5KL^x{| zSSQ2M98nc_?+qbp9TA-0gl<#~w4|91eg4*|Fdqaz-|IBhi4F^w{8DgDp0*j3rnkem zQg+g&r%kc~eh^I0mL(>$u=TQ)cQnO1WZ+6NMa9BoktAbN2&VhnoPAGv`=J$8oW#v(;nGJ%2kG6lVys!s2w6AEl{Kp1W;+B--|iJ~ zOFh}86_#^*9shPB?+mdIcHyieW~t=IyY(kNSC*EkddtF;{+c+^zI!Z4kqI7T6FBZH zQiWVO01K6n96~!~_gGv8A!#Z}Ewnq8C~~|s1`CX_!!qfP=(&X58>0w@y?9?h3}=u> zSWqg0rGKCKQYQC(2yxbQ1Y5JC=&*N4Ldq7oZF8CgD-qjq?%u9vl9=A&ME^n3w_4}9 zIOA5c2=u!xNIZkfeX%#@Lp_#=BK@$kwyXWPrNXl*rBNqhjI-$YDKbpgHub=b5|f!MjzSv5|u5?FyJlfQB4O+^+A;q?a;>bna0n|`vI#}rvj z0vhz&&66bF@}o}8NTH`?<}CRT#=rhhL9uAv4bu3~FNC^ehipn}$IPonxY7(DH$lblaAl*9}lQJn# z*MAuA{UHXCHc@>WS%*Z$R>rW9`DF_30x-Oigu-NVm*>vbzQKbpgddQEALGd}%sYip z>%6f9_ZE~bQOuqu!+e2?7V}!xvdh<@0~6->x*nAXe#GT|I8geP{yDIt|Cylxpi)p-}!&p#eymTsLNcIOhRKoh%ut@7IR^dL0FrX=< zk-bFBM4x&NncqDrB$pEw`5FfQupd4WYHOA4d-&tpw_C6z*lVQUO$C{21AWc~c`GoP zsAAqVCfT~tMy_!yU?Jit>Gh#?Ex!^Z2Y1Y z`VJk17mEh2>-vnG!*IDGL0|PSN&_Cs7%L4e3?=qm5|R0ww~1pdx`SZ{oP2x4G#rl6 zpZKz3g?cKIuPN{RJ4;gQm6P2QPDIB)lY{S##8URttuC+O?c|pdOXWY(!U*1-5sYk{ zd*9CM-CjkHYN?o~6!ImOLLlUv8IzA;#Wfr&J z*~=%&!!7m3nU0U^o+`CeMlCggfa1}kVoTLZe){89tyli)s4 zNcf&{@SB!R@Ws12M%%olspt+ZZ6R(pR@F%ZA%_ z4Idt^zO_{A(r15#?s+}89OO8|B3S(7?jlRU3p zj8AhuTuJ5KI?$N~T9X~UErb3TVaLy7tkh2E8~qyne`3*nDxHqGgW11I^rg9`fWt=moILCVOgkX?;G z3-GF#8<#j6-S~{cO;tp`>;&KYyc{W>=5+`O>$67uOHxVXpmp9z`OX&g^{BwoD^_fqnJJ>&(F<<=Wyq_2 zcic{7#?>xtHIaaT)s5-*r(If&T@=X+Y_bur&KVkIh@%~Af0xM}uC*u%A*1btU4TY= z@0LKVU6I1=?x|Q}v+LBr=gEfS^{i~e?`O}Zn8p+Pud{JS{i6lJS**-{uBq-2k~)sJ zm6T&tbch94vZH$e2&$#*wIjO9>ya@BcQM?0%T|5=o{@KrR@vo^ml{)YKJAobQPfhTF>t!3DUYVG z;>N&EJec4q%f!s${oV=Fk})T9S%0NnMwP3|xEp}1GALK-v}-AkGh3oS zHz1E6@F8+6P|9SUy@aT;6Nvv-Q)Qa?{WHZETKMESL`+}R9|=iw$#VhdP-^zlq-i@< z)08thYH#9g+OALoF03N^pIgj4GfT15XyWJ+8_LB;W5(lj?-TKl>@D6SIdkMT^kjA- znZFqM^H#CC%ZfW#ps<@A&onfp-$CMe-r9&Yalw^&0Cg3Y!w(3BS-|pTwXULidGKt% zLtq*s+n#^|)uXsY&Xc7_>r>4h@$AgrZ}XS(d7;&ffz_lYR{YaP=evYIwZ$@bGnqA< zZ+-^;ZOs#za?q|5SYs`A)MJs0S0`g)?vTT+ZLz0rLhU`78$G%THBa)*_)PMg&8s!= zvZ_4i33SZ}#~@K9K*pJJ&65&N>3Aidf?qnxp%KnG)ndn~L|ARH&?1A6Ww_s5eeDXl zreRUrld-`#&+m8#QdF1&CB+P9F&9of?Yg?@Q{Qj` z7X-4hg!2Xfo}7q1x&waU%jd5@fEgimImFJ6d8`*#l}Rz5O`5u3baCj;C$CA&xigO1 zurV}C+)?%9Kiopy`roGJX`P?tbbhA*8c6EB)Q(Zx4!Hb-=^G9oeUM1ojhowt)f<^# zC^b5ZRsmadjU2L+KK1lJnr)&(bz#S*e$o3>EFU9T^jnNEXnT_$=osiNcB^#94jHA> zVuqV5`s2K>)jaqbmGwt7byXKi=yfvpNlbzmPgf`+&(R*~aD)J=M*lG9GsSugZN!Bn zz7DPN96Vi92|vL--RZ=OP5)_zk7|v&{JM&Ae*g#Bw%}LZCcYoz^2f`0Z$m()+Lz2A zzhj!EpP7E+pWJl-txNq*B-Ed^B!?1k92hW~b^W;&n)y>CGc^V95;`?0m!tHiFL&bu zYOPDsHk%`TM1Nc^Zm680`E`<*OTd}Jr}jF-7v%vL>-}?%(Nqj$3=Em2ZK!FUVe(;+#Iaz= zdy)OT{T2OT$PxTwUFd}7A0A}CBCkZ#p8^t9%L*cf-cn|;pZW=TANWzKs)dy9*(C2E zesyZCY8HMyJ#{%o^gsUHg#)GM-Iqrz8Y zbSG$`dVhmSa}`8?C}$zNw&@boXQIN$ti3oR~)%R=**yPXFs5b zq@?lVO{u~Z5<0!?NOY=-h!Be6MWBUS6FKsoNcc2gzRGt^t&ie(`H1-1*y4M)QI*f) zd$5s1AUxyZS5=+oGZms^C~C7Ff(MV(Ba}(6r1+9;iKslp+bqOtADGJ3^7^&WmP+pq zdT!5~KF736ToBLojTnjHml|mHZgK)7Bx-UcI;=5h{V^T4gLhY#aP$f6cuWOKT=%yh zVtypxequ3u3`?-O`tDUVjr)?V^{nsws`GISrP0gFu)UT1y8TZin!)p#tWBy~`(t&M z%kRmmYR{u{>V<4wQ<#P4*gx~mCzZ79Z-ZrYLmzqr)h%mu_f*GUC=b@u8p79yi<-;y z6I5M+v*koeXZlBP2f5*Za6ZGF+`@Q$Ttk(UDc}GIpWec z$ud)SM||amA750vK9$D_XQ$bwo^eaNR5#-qV_`THCb+2<%rm)Amd{W;^C9>_4^|(C zE%lw2RZ4!pFYnA-(2;4J3TU~z38T$oZPKU%qLYRp573LkJTF=3`FB_v>2yETM#u71 zp=+&3m$gDuQFXK?#i^y0YgDKVBV_Xi$kPD6M-8p;vp@SQ@1~O|VpP&o(p{V%=>3 zymz8W(Ftq;e2|noziA~2+8#+PaxhkBn&YK-ywQ@Jh=(9#Yx zaA(Sd{#Y*l7(OV8_~|&_kGHt+wmAYrlkx0x1=IOEMfb4y$9LU%mP=C4Ytp_1$8-LG z6naNl}2@B^~)xg6_9xs_VAc|W=lOO8kG$^%~lF`C=D3}HVOk(m;*^{ z>XPd4*Ok9qk<0?;a)WMif2{bybg-9_1gcbHjQ9z+DuysnbSi0JVH9Zx!ejnM2`r4p zO!6p?iTO2Cg>mdB+^L$9Biy1Si2#2c`K!L?9)2|O7n@qjYNfC^{Pq0Ikh9SC*$j=H z#a?+~?BmBkGbG%qK(7WY2O>s*ktv^(_0ej(>lAr#HnIP`lUq;jCi~suy*HuKF%8MP zA!KHq%!BxZAQI}pxK)c?3X5&6Dh*0q4uok@Fu!y(g9`U@!E!t4)ow00N^$E^D1?RX zbh2v#k@4}y=8{|J096OQuRiwCa<7j0Y8=bq@>Fko5GziLn6AR196%i?YM={r)gEdK zs{b|c)nCUV2O5dfGiX-4phkyQ)+n%H{ZjzeLNp)w{8Q+!@E}C?!$cT8IL{U&&(=&K z?C@e-rw={FtR*w^LkQ{N8}!BDX7}*bN%4&e7?dX0ng?=Rcg_t7WsU#yXf zgXcvd)qsb^;@7vERzScS7(t;+^=j?Zez9rmlJRNU+}wxVt>1sE;!WXG7JDm)w!N?8 zSzmUzzR>>@`3A<$Hq6%DmD$K-!&>a)+&i{!@ttpzq${=BDbiB2`Ywt~1Pu#Yf@c!ZagBM-=+EYE*vnSp(30h6M9G3WHmEjFs z-6nC|@5+mp?@v@#Q})90IIlL~D6ss}BKwNpO(87>MuV&Zwsfu;0@jT@)RFJ{dp$g2 zz4nVDj%G134OkgC8JIbYIgB7@4g?T3s1$q-4E1&lO=a$A9-7lk3d5>lv-+Xev}$0{ z_zz)>LgWTu+2=&R*gv0}3?OUbg~Y5U!Jr#A7520-Id;zoVvc=vWaDHm9F8dDAB#?R zWn#Sv_T#}|*06(vf=U)N)h5E(|Ir6tAWdja9(?Eno;tQfIts}ergzPNx@_&f1%GM^ zOhPW9a6L9If^Y4yTux;_F~{RR^~&>okR^7x3negd0h0=WB!RGUNBtRCqe+)0j@;sX z|Jf)wZPCQo)fH^%Y_7%sC1hXdBl-|Bm_&cXJnvmG-Xn`Nzr5;3I zq#+Mvw>m1gVrGdbB(^FZch8!bOOE>s=bnm0nM>W zXgj+(s+z_2PeZje4pi(;72*+?DVx8%7*H>b?8Z?YO5qFFEGPq-XYG=^8XQ3im12D= zQ@-0j$@*5&wa|9h#PEglSf%$@+R#=!AJ? z8%RMQIKFnW5hWSG<5nvgVQr$|xJ5(^<>Om)KO9vlf8rH4DO1%&+nGLb-coIG{S*)+ zzaQddYt9?(^#|@!O(Cs%1Rdt3sp!mQmWxDeU!`K zE`yXU;Vz?;Aq>Od#oSf;|Iwi#OGUtAPIC!BMG-dz0^FEC!zp8Ue!?ZS5yHKU8XifV zo2oT{SAj#qk&_UYbRx`s%o@#uyVOYvL!C6iO+5HV1GLv+vu>!Cg70dg0fi_uDG?$W zC@C;|x-XhJR*x6$MTg38k zN%Z>%yMoWtTEcS_<_zF^8h#7tTY;1S7x6skM%WOl{p0|7?%M9t^jk#F*{5`4P!$d- zF8T%4S58zz3w=Z`I`o9GzA#XA1c{2@x=_5v##=;PObx|7L$YJ>9hWq#Q4Mv+B7K7Z z_`Pa;AZyjbsi1AdmRDTagW*WQv*}y=-ZqHud)j1Dv`OCRm$RL!Q1~{_g7P-M@G%SK{~X>1y?WPO%+hUhMqSQ zv$=P3n11z~Y#E2mupkEDwcKZ-E3&Pe}OWG4>j#A;9DUmn5fM>rDM&sxQQoub966S1u*~@nI?MxJT`vGgNV?PCc zp5Jk4bqs*2iZ7dr5N~(3Kt!8&HYe9S#Hb}BG8Z!H0V0by>H>x!-I^J z5F(TcG4eN(oF}_ES#Vn`F3UC*^Uecw49KVjzd5ww?7yuH!U&0Z%l(Jc1Ik~?o-n?) zrv~J4OG}t+Ba{k5c7YAgUc)oXV&7`N!*C=m88%SBwW#zcz1icrdH(t81sI8=UR95c zl*o^sQjSqHZs~b_f~~YS`ph<94bJBsDkmYNp#N=lx&rPpdc%RxQw{XMAw)e=JGSJ4 zw~=3u3w}#hwgZdjx}f9om1=+bdNCZ>SB^qRH2#mR+35)N%TFaGGMbuAUMj#;q5lA1 znDb4l-R7&EdAu8K9xp(q9-qhxy3|W?G2FC2Q9r^cK}e`S&MiMLC*3OKfOzh6=&NLK zgVjF|f(t8jH5P>jIDA=#D3f4Mu3R2=&eoKvq?fuD>W*RDbP`j2wScf?4@)%5VXX{? z1+5UY+8ytqUNtjO$A?K6830%+&TMj!w}jbu9Mt6fC`S3MogDLR2j zkEXnz5e=7&42A(AQ6cr;b`>NztdX%pgq9TsK?8J<8l4k2zXl8|xpYmV;lMGUenMd~ z270h9^tweT)(^k)pQ7P{_@sUQ(>aesh*RiE=4gjC)b#aOKj<6aD3CYd(`M0smibiy zWuoLcej<_oa)@t*AEkC{^<8DGN_$E^_IzYc16m-Wg3_p5d4zXZuLDqBv12$RA+5*B zT?9@TgQlj+xe(R6Q`wMvF+tvTH?+W6XLui>mC$9YA%2(kBplaF^MM{Nyf0YBH4rmp zY^gJ-=tWKe%^ZS;Y+TCF7#QOIU+1=|i~p(xyVG~DJ-jdF|IAUxA%~rSV_{=qXXaqz zOg<-v#s4?dga&eB4-Rom)x<~%iv|JM#!@)snO}^yp#WL})zL*s;}!ZFuP@hf-z>g< zZiKidVb%^Aqh(MsM%JDc_6TxdBOM#Dh)O$LmQUYT6P-+8h_w^^jN1)fswEka)DcKQ zG9mmKRba3JXY7ja8}ulQi~;nwJ`2pny>Dc8a?Vr%n)B(X723VLO;-l8>6C*2`BsLd zgYS?I1C*n*EvcP3%WzLFr6wGK))hg6(75Rep(R}Kw?R?tjFO3Aj@y20|-bwlVB6%Xuv*EiTWNRwg}C;tPpyj|1RP{ zFE08V(xSycAw0SvjE-tXiW`y*nEfVR(R2;Lq{pZKfhqY6W(o_L=k^(uYaG9?ee7~W z*jPS=nqyhWc!9o_8IDbu4iN%Le}=hO3+{KohA?VGk0#tVmN5@{w%QQQ`o4lW8gaC^ z-5leesEVI8LugVNpoH+k0!bu$PeriszgZKA%$fAD#um+?sG>3ECq&h<{Ao=Pk(ST+OBS+^`WX zl+Jz@ge8FYOHP`UXp|`$B;XGH|21Zr* zwE)K=#w>capf!VlYwVZ2WJeqjS$&g7!M%IzA`!!8~<2&c0fnG=6p{bWwc9Isf! z0>O%Ff=A9A&ve~Kg_%E=M)|vcK>Sv{K)PJ~5eh0+Y&w8B{8ZCGZaDxDOg9~VJZcn> zO*g^bGglcdfVK83MM_|?6cn$~VpjLZjr<&i7Vv32QQeF^-NLnmbZS@|9jzRL9;#M) zV3#)7*HY!X;FeWBKX`!V@T6n94Y`vmeyqPlWDoj>P0@I8FQd7rh;B~tvmv;DU~7HD zZjK4-2{KDFm6{AdqGP0zD29wVPty@b;9aKZfyw=(l7I8b;imKmx%P+y{f{-d14XI0 zI|9_Dvfl?oHBtl!_FcW&A)z8uThg2)vv{pEtbWS%;-Cu_8x&lj2OL+22okR_3uIA2 zmQYfNFdm1Qpk7Fhp#%M{JOXXMSJpM>$cx+by_+J-Z&(z=feO%^ z{(>;1nPicIAnoY;O%I@AC|{$V%pM;le*#=fUf<$&GS?GulF)(pMgF8XY> zi`FNnhjh-BoNB2cA|mt|b3|C1sXq3b8pu*_`ON^mAoegMutCZrP3OaH>qxe*KroTd zL}|p$&>?OlZOyml^U_0$yZ7+9Q5tO)-n?zCqCeY%-&3>BK1y)h^3n}_XW(6>wshya zLH#zL?(rDhB*Z!Q?WFHZT=#<1Yl8x>Hg%vPiZ-=H3^JcpCYu(lr^LB+!%nYBOr=`) zs+-)i2+Bsy)AvD`_Jo3Ioc4%-AnzcZs2~V8dwTUZNC*a&eEbY*> z>aFLcSH)TUDjh`RhRx&U({IznOR%7@dN6-SgJ1GW5}w=TnwV5I#>;!Y$TZkre0yav znkL;E?m-blD!aRT?xb_k_!e>Yb`^lK?`NaJJGnJ&Kq1pXfmVPPf z>eQmO_V%d^ml2*;3+j!U#8tfH;LEL5Jn}{M&ig9}vlZGuutk|%mGWnyIz<-8mCEN* zwq=N*WXx0s=EvuZ~P0!H|1w_5b_2-V8-&ps@t`rN$iV@1ah7;_Y<2}cbSRB(2$Fki< z6iAJ5&J$V4u@$o;$|(1u|HJU{qnNES@RAIcxR6{ic+MLaE)Ci48W+%9B9+_3m)Pac z@C+BZ8omeU?#@+#gtJ@WHHz&W!Gh`2hq(QQO8^(URe<5_Tn$=~oN})?4u>34crC=mnOt^2cJF7FQLYe4xlYo8M7I)s+pNGnM` z4d334QR)#5FP_;y(p48p1u8s*zh@?S5_N87HrK6pRNNhCvatQ5-m!055wH}hjD9!*BUR9E-qR&;OT@IypyKNEPpnlkB5*l0_4ewBs>}XK|Z_jm>Q^|g7|&)HlUWO67c&*DOuw2opo9t;Bm^pB$!lhGac>8e8T%++HMVCDjn0i+OApZDRvWi#EtJdiPYjR7Cwnt? za>98O?j}a5f6-$gP$^};5A+M4P3GFr)h93S%L(v9hnJ=)iS@U{{9U!*;l<2$ECu9q ze#4HHrlp}&k}hzeQVsvDhy46In8W8LPJ}W}iL6jmI&^NTKx=v}oqV(16YjACjav~{ z%mgD*QAI>z-tx{{aA@|vFQ9rtD|CeBQ+`QA-U@fAngyeiWT$T1d8p6LC?sZTf|8Q7 z6fGsYlTyQs&Z($?v$1RvdAyReG%Y|^SP?W)Hh=00%_2vb+J5V0Y?6?usP=5CN>%>Z zwGOj0wRv?=5et5lVUOUa&@P5D-=!AW7&~NT|zF3?^v)w@9`fx)jvS?=)M_e_!nQ~>u zFY5KMXjs_mzB6k1%;WCV8s7d6=|uC`^Uo_)Bpa-ek|;Neh>$p!2)7U$n}`sr5IdI` ztB5c+2e%kEix?|22R{k#|EG%Xze}oEKmYGtc`28qN+|zm4qkdpb~GKhXFcEWu4RFa z!L!$Po?dPEqSJvmc_HoLzF&bU8Z!IXzQCTt0XZzPKzPy|l{zK6ZSj~bmS(%%Ji)@b zXZJNP_iWFJ%I(*;je|LDRaMn@o)W6o=L;|*G_W5L`A>C8pNbtc#RL`2J98U zkA@oLgJUtk?t6%)}*hUU{3LUAM@aD^0=TnPIVhQE|Zm!P`(7 zfy)SKDSFWO20ZP4h}mX}pGFO6PyP7paO8V2n_)Of&aYV8W#?=4!^;8aYTXCJd{ALG zdSM^naQUS~D@vG3Te)0(ISlq2AY+ErsI*h9EUZlG690iFb-GY-OVZ!k#!SZKPt^q? z{k0U&MpXFTt7$4XT^fLD4eiR?Rjsc7KP=&=r}FKir#(k_bL2?--x-YW(8;q|BL?xtHl?H6%T4* ztH~q~XWyrwwb0D-F^7ccV9#J@eWbDBy0VpS@!v6$spQVEi3?O-w|J&$IC_oCd=9Yl zGyYrsqtORZ)?hfLd}_xE90!ls=u;Hb+$EpddB< zFlAc<=P|@Sg+a1x#&#;*_DKnXv_o~O+BTf(43gN!Aqf6xhyLxCd@n8+!oe1=j&Hc# zhnv}L%x3sSK_h|<-*h{fXgP6LrQ6r8$kkSa`z?M6`zzQBRPhTqqTY{g@RM8I=G!9U zt`G2fy@=)~y-hhy0Lo@BY)Ezh;?wH|Ylxt3A=~7P96RmpDayQlMw9~tl@N}lVM$;v zR*=^J1tj@vL0O`eh~;4Y0D;Ei+tR1>&8YfeAqLn6g1H@yXUwwy9rv#iTFI_@a#PxC zT8W2#+1vKy?!_#x1al5wNB_zHU+}U}t#tcGE<*>|lKaqTMWEogtL?$}6;z0a zw1*8?pu^yf2;HOA^Z$vycj?E@R7dX)skwH2DlF8_H}0bDq;4^**^HS95{Ojb{=@y} z=)B3^V!(6bDUt>uAeoo~J4;YRj;!2lpB-0dRP-)<^yG;8?p6zy2EQV$|PM&35` zUgwVfMqR1(sodU8%~Q=&*i-mfn~`&3z;g1xlZoy8U9=M3dX&G?s`B5Yz2gmXX6mVV zQhAis^X4r5hpF#9Opv&epJ=LXS}z6Gu}67S7Uv~yhUrzh5Ru}-iIo+c$lkPwt%&2MpTde#RG>Ux_plX7bMY< z=|qovGZ^+Zx=s+C9cERJb2B*SHpg0^ryVg-w+MjKL+*yCu*J$NbEGX0zUqO@v_;wO zx5x}>yT#D%e}4g9XExm;UO&;rxtW^=c7U`#t|I-4vTIw^oSHm?;)Agdva}SO|L^p| z@eg^ittvmA0HN{mYcU`S(W{3A9<2Y1kU!8#Ao-6^C-_`l+tc{q``~{{Q>K00ecxp2 zLh6!x!EZqNzf*Z6uB}bsO*McH+hAdyVk7xK$hgTJ=D#xk=V*II@Xckj_=b2hqCR$Q zDGy*X{BlPdH|uq2!V_@>1)1_cdyu~@h(Y$}j=wvsRG8;Zq5};CY6Ceu*%z+2Mo`Bk zz61sGtz;EQYUNK@^YJvW$kiWd`bKXF_Sp~*xm$<}>P~i6VvB~rf5~A`w=*c-qUHvB zr%e6_(!$N(Mg;iBiZJ>|F5Rfs;HP&YHyY1!Zey(l@z`O1`*R>S_>+@x7R3-MdW(hk z2gojF^&+?({o2*q=;m>=ZNh;u)4m-b9`N?^jYh3~fXYbT1B6@P8t3j3nM`! zKJ3H76!`kf$FQqLe~IZ7`wrpxKS4UR9^|HqAa)Yizz1Qk+FOSI5q}yL4u^q8L-tix zc{v{Dpc5aP5mpR2i~xh1#^LK;&X7>7KiS`cgk6%9eTsk6?~h3C<^z3y`Q?NC@s0w? zMlWm?{RbI@7*rTsLh_cbQ0)3=$X{Pm7||8U(8#`u=C~DuSYJ3a_uHm@XT>ql_(YJDSd$$Rm2_BEud5a4NTQ3rbOgJa9sZc@c{{Y}$k#0L@x^J@wOq;jG z#eVh9#eY+*-TaHhunii>%hJyv^q-r!dA5pJS4^h`qo98ZgUc06Q zVGlM7f98&x=VM+paGPv1T@?~pC}mwI6Is4HxiTfP#AmoxCjx3J5?=S>v}}aW>pX>t zi=l$|LbytMIin+}l!)tQCPV3ReS0O+{+k_IkE=?B;w*SH$vCN}(*+K-(->oljGwP4 zxYCMs%-M*sXs~hmH?e4U{kgi)3xg*WGptiTN7WIi(H!7Z2B?m36()=3vyVvSH`K`E zE;bQy(7=l08v^m4ZA@9M6xGDF4QU|kpItuYpN&k4^B5Fg#ZNPa%(*)eEsIC(JU-@6 z^DkB3gz#MzxjG3xZVat%D)RcYvtEh2VO0BW;t>WKjc|&8=KhkK!Sdxpaf04nB&ZAA zr^~OmlRt7bbRuG;(Z|sZkQq4;Pu>oj86BHeZ7#Y=0y$bIw4uqySr1sM<>hEaa!rVi zIRC}BKQwd_It{rmlJAQ$@Wv7LZkJ&1#e_`Eq(*3fvAFXzU_aG-@eu3SsJLd*{wsnm zgqB6lD48Sdk+pcYc`fC1X}39AF(ouoeofoFz~!_^A|tw-&GkYHXTa2mpeu4)M}Dx5 zCuyDK*$5CK9z9?3!wEm*()%ub>IMyW;)dBbI>uhZf%Ik|kzu5pmh$2fu}~bk`8%@u=;7pBTTIMW zfBVTd{`g!yDCs*$#vBD#BhVT5yXs|EV+Wr!X#g+{QLX)t(Kg^b{n1f_a@Wg7;OlP( zhun+C1wXjOmEjw22me2Y6pWxzAN=Chmo?CU0>P%2u=%f%1g~!}D$*mGD3cGwbWpaC z(-t=B_&uiRX66s`7F*KRGtUt5XSBRQA3yWzdY1H&dY08&4u;vRkLG3W5I3{D&{`H* z2(9K>D0t?2a2{rQh%2Ug@Lx>zkkd@`K0F!gA!!-wA+#Flq2L)MPYc1)C3g$K^8Uq8 n&|av<*IS$x_J=ns-caHT&`6Szgkg!{+1NkBQ&Ng4h{OLc2?;jX delta 63900 zcmZUaLzpF6ux8V?ZM)L8ZQHhW(zb2ewr$(CD^c0^b@%MecFguDz7_w9s1Cz#3&C$V zqy%B*N)Ma@rUKmR=(wzKqxjF)XGkchjcp|P`h+wO2n!7wH9Y{G4?a?1WA?%Ik(mO1 z+^cm6X34S}1my?KY1A6s()<3cV8-Ij%vlWH{8fVb4c6k68KFyz%m+WLsfh2x`&%d} zLgT70muNSH9k0J~ctd!*nEzlAjj^yhba_8Hxmau=#SNJLro(u=IkBZkeJEzlhTzkh z<@f%*nm+UGOHlS6);^AYO1s_UeF^K7?3wPA?8W0kMh zrtzu^g9r!<{IyfVNcr*46Vu;I{cBa~q+U2>tRTvX6Vrm!aKTjcFAaBD9rLtYunOeU zK6^B|XT7?zdSf|P1x99ynV2`x5D=diIg#mF@hw}qNfJU#A|=uzLN`{HsW=N=@&2rO z>w!Nx^L&U5w*RWQiOBW~PS{>EaXNQ%3?hl%tO#h^9IT^C6XC!Zwv2==aR(351q!-% zH0qPQw*&5Pm9!TX=tcLlxCgnIKWpga-fgz_jF+;Q7rqL7`rIa5H$&Pb4^C!t0aS)N zi4Ff6adNo{wq;IT6K6@m@&;@ef9ZBalYdHmes-hDo2+Styg)<sp~>mAyVntPYR?rQ%#xce@UJ+Xf~qA298-%_zjU_49o86h`zTKMyR z(jx6v9p$}!S!Aa^rg!yzbkRO0`yQ+#Bz6S!cJWtM;y58MsF4gA5*&co!6PujYtW8{BICey0veDPwm7)*k5_8vU-#hg zn6m%E?9~>8V*eh*NAHV*ce_N_Of^3yF!Aph2z>P&gR~!XvH>jtfRzZ8KhATC=g?Yn zIUfGK9rK@pkw*Kza6)9h_~l(GFcYYr{sS_Vq?zSo5083X5q{U=1?usWL%#r0f z8=k(fDxMPGnvuc5P77*YZ;E3rtWPbpNWEVU;Qo}KeGW`KZ-aL&Pyv}+v$KVGHBMBg z8wn{+p32)-mPB#SLeGI*cP`A#bdQ|wUa6Q$M3;|s?)Her!K|sW?2#k~lx*E?=JN3Y z0%5U9mJ`%I09r%rteoO8nW21ca5BR06v_G2TIMqPdt|zpT)8{6n2v*Zlm7zLJqFKu zhgiusk*w8fPXOEI$kNi5zQ8R!#+$iYd3@%prK8bYs}FwndUqd%?7ipwi*X2WuU>}{ z$;spCnmrZU{>q$!Tw14ifK|vqdFa4SZtKJZ;&RLyz*rDbko{oM-0*C(6n$ppej$Z5SsqJeh6yU;`h;RLzPy*fJsK|>vNK(e3odJ%4tL6w@;gJhUOyAM4}we@Of9hJq(yQ&!;4H7?!-i2)$Pp^9r`f^>lnOYWHwk3E5~g!!%2uoijVv52l8_ zO?XrONA@!UOak{!lnMq0%iESy1~%2H3k*Rkjq61*V(5qse@OgQV`Jk@`?uX^cko{( z9-ie<6i?Xz4iAXvK;%7DYqMcRX@3m)4}ta{0Jx8+?wF@J%29pEMN=GKYgmD-hx>Tf zmGsOI-6N^~g*go411Lxq%u- z_u$St1to})ns34KGZvWV1qec9qJQY2*WvQb=S+4(30*X^gE!uD3Zop{j{j^czG@~I zK)iB!6 z{P}I$9ccCPPpT}>ACf)Tbi)LkwZDexv^lF3LmI-1)=GAiI)<_Gi7*tOYV{a?e;w>v zku`(!UNf=t4f}}KW27B$R=fWSjjwRx0$k54Mpocn)m(T)?i$B3nQ%Lr)Y483*;S)I z?F~lR(_$YgGPZGfB+*)yJKPN*l@RcwaaRgy9-yho|c%%!pAq@Fq+Zdf5Ux}D&* zVymudtwSart?MUu9+-eUQgry^dLmhch9xbhQ1+jDp(tDiAq#=6Q*0CEEO zF6-YdG21K`h0?xO@ZOV$cX?;PUQK+K^dg%}UC9X*KQwwS(N-|d%8LL++H1-VvbXw5 z`llx0#7`PIJx1EZWE5K0eU-RJOJD zlhJ%vLwr{vS+5&8f7mkswvcERz{d@JL7%i)hzT(!S*hB+HjWJ>e|6qe6n3;NLTM^y5K@z~O+)8x9AA-Zk{F6bAbLOoeiluS?)7aS;r6n_6ov9BKk%owUIhaXvc13b9VL zr6reda0jNiEol8t2Y`))5f%X6zItwI%RPwbnp8QjZNrr7(`~Y zLGEK8w4%J*8;_k#rGZ|z$!qvFVR~OXH&<_HO5tEg>_r78_j)m; z@wd@npF&TUQ_exwH*lhV9aJ4s))M~0nA1*B-1Ft>Wl6KG2>xi!rbz$@!2MB-BtAS< z=s%`!x)Gzy*;gs^ofHkBzGi=H@y4;#XT%urX#0;pay#~w|g=JLuP<*a<%^l zl>=}9WNtoq@P@2R`!Jjg9BV^YpM&P)k@R!jQ`+Z#6^!zNuiYSZLXb2WTJel<`!a!F-eF@$6G<`|&J#AHOiGc-nCs z;D>Kv#b|%4crQlkbM*Qy&}_gwLb)=jSsZ@Nt#!#DWAx=+A^V zwn@lTRMp8ty3n`E->Gztunh>$7DgU|0}I=)uQyMDbCfk^plDLQv(Kw_Hx*E@WKjnMl#-HzPF?dO zz_?m`1!HD!>f-8bW@Pt2F9&05nDl`SV9a!2R}dP&DbBY2@!0FG0r3ertDzH@Mv{~g zQMP+Bd{WV1*Jk+aPyzXtaT*DFV#_-G=RIFKc2o&@EuKR@3~=$G?pzL+%N@(&jXTC{ z9}lXcILn{tQ#y603~}Q&&HNvK446!)J3Q6OX$2>EM*aHH8;94;`G;pc7a$J80Us}~ zw<9$`&dd^1>(U&9gSqtd0-06+#i{cf!-s~7YWulMsp>+VbIrwpoSzFr(3|eq;7_M) z5L~p~TybAz(^DZe4#6izxAoPpqaT0xZ;y73=Sh8HWx5r5GZ_&imQ{bShod0qv??IV+L%Nsx+w?x>EewYMu45iR z&NibY$>a5wKTEt286yle+f_|TqZ~;Qq|x}aytShjGThZ=&^M6{)gL$ZsIMrfwx$_F zqcm(bP0~$+?wPz@mlVM7_%luzIqUy-a@L&|?Rpl&a`i=U*Soq07{a5Pv5CS#xJ&_S z5;)QpMO^()r2eq(tV?52&^IXw9^_v@8A?uW+M!~iP>V$EGf|cAo-+UtXF)b4*9)GfCZ;5ygmg0O`7YC zKt0|4x|%G?+E%#8XJVde5{{RFM|S-f#EnoJBXNBy_^6V`tW=?VTfX*H0E;~}5mT^_ z=GDmy-2d6rK9;0C2(W7rta#0yB8r zN9_N8kx_T&0?htS{nl5z?=%1aSS@{%+xEi-6_12gpP<>0TG7Vi?lfwKk1sPcxLYGu z+LZdRNf|k0+Mc<{g|3+akAv=K6I2s4|K{3s4999Tkd=UR^5Z@ES`EREGgEPD=^4A+ zZT-LL@bvOM&_>A1b4Rn?Wte~adE){PmqFx32CYOXQZ64jlMbCE?fwEd$u_EBDtp}t zJ+U^T!vlZWXi8W=;L#6?c0Hgdz&|~4WnfdL6H4XaC!r23zje11%j4b{qu1oDJf}QO zT;-{Ah~VE4plM@M+r?^Tll8MHYi1j(FWKk(9dzuCXrr@Q&KI*Gc?-v{gv3eE)IWnA zw(Q2yK32S_kgH18;Sm5b%qJ~RYzfZox3J;z;b7u<2C?*ZN^*2}@VLn%*r;WKVQClD zeAyW?)PfB3N=sCW$0_2L$OSvfn@XJzw@x*ViZ!wikc8YH`4^=}{Z8TGE(3#wO+`(m z%z?^a8hzw(au1Kb41z5}szu*zM1%-|WZ3beSPuYzq2LIpJaT!U(&}2+ zl1&?+z#{lg#~6f{3*P!VLxpzGaO@Im>@tRRL^OjnCa_w(08hn=mnC7z=j{UVn3UA9 z>C{vKAM4@dY7$BcUcW4IyusUuqT~*_vWqtTyVJQ3o%Jlv9sPH`j?_p3mTKl!?$LoG zDF*DG#mTYrFbjaUfU!H!$xidpcPG(tVd8Tr(S$M6H3sa)umWt1T^bla_VwinlREG# zf`G?D#LeTgCM|;gPIGpMc0n{&)-Dd}T|D;?xW{ae^3dp8;@z_cOv9La|8b)39?pBmy~mmwC1AI_a`T`6ga1-2Pp;clW|E8)oZV2@j>zksEfTZnnSHq9 zbYobG>tahn%-*>Xc%Em(I_?K6QMVDw1V!NM=mFz2K=4GR4KZ6YXfE?Wo*J!o*DfX# zXgPHzpA6^>u5Uy(c-auf9M2OC>*{eSG+`#goD@gv5pEqdqOjcvt)M>0WJ7D`WQ=_S zCiMl30g!spVc`T4JP@K|A@bsiC)>sfhtLb$o66yna8L&lIsblGnXabpqdjauEZnrs zeRA01B6@`aX^y;M%O4ir!vBak-^srqA;$h-&;cZz^v>oz(D3gApMVj!LSxdaeG5z> zh4`-bP0SH=d4TwW-eO1z52)QxwEqC>vF`EKz%IDxXC`j|U^K|pur^I9_>o1x{TpN{ zka8y{1sI;>ct-0V=&@-R%`IXploL7nwkK6ZXdJ;~+9k1VFexv;17Y$(y#Kk1xPK0? z@c`(joG?4Sr_BOMPT9=bdT-r@QZQUD^9j`bEZ3Hcy#x`gL+wDcv_oy%1 zG}gyw8|4S^vM28d<#}uJe385a5AtFPVSf1nI37zfc#YG66A)ZyPtUL?L5PL%dN$1NmbpoJWl3E>!0a zM#(@Olx%f9!AlS}RR&6Y*FLqlDk^?~@_xcwaNpj1U?$KpTu@~N-r}!egT8@GC*{L< zg=#=G^d!M1p(&iGZ(=a$eW~%v0TweGK&hN^4}@i`7dEp1jh&9e`mBDKe^np#r+_hY zrb34riP-hxOZy3UK<8KvF23{tIrR6f{KP_=V>06RJGg{<-o|6VhPR-t+z7j3M`Ws?HfJHx?Nv_domcPDu?A7rL+ac?zm;O3KY?`4E`cA{`cr4Y+ zO-2cH<;%_ALxZzK3Gy5{*f=8h)P&x_uW#rR3&A?)0@oG(rOvEaO-}sA7J#8wQ<5@$ zj=VSR-rdhBW`NB;W*Q+JoNZE`fxX?zqbH( zE__x<1gcEyc4mv`@n1MIyUzI_t7 zsUgxVuu1q9ciT@;Qvpe9Exf#-oh50t@$b6uM}zc>apGUO$QL2cG$88-(mPmQiFy}@ zOzGQ#5f8F`Xb7sI(wt(T>`jC8ed71^4Rm2z7=8qb9G3!8CPfV#8GirnD3&j-V{`4= zWKAGen10-bmlTPh08kGuiYvtpv8yH{+eK_lb`-%mqKhY5;LFJP5J7h3cXgBXe;+I}XM_4as5U{oZW( zZ1zDlNI`9v2h;5XMMPgV5Miq+1|RvGVal6yphzK01coE@1(1bCFcAUX8-aQOx2G|- zi{0Q7kz(|zAg0X*KI%z6&O_v+S64`ztiI`*sh_$zR@1VWK7;AmuZGwe?D4wlHNgq@ z7S0#z)dw9o&g9@A{MMTpFsi^lbld-&r0yW~af0rc_I@_;Pfwqp&IXo|g8r8(@?K(AlZoN<7zwT6-$9|=(p|Qv&pjWeT>gF40z}3PJ{f9SJCYf zQ<10{-Y*=PB&DT)r-JJoc3x?-!qkM`m1z6=sCG<}X$(%}k{{*b9pf6{)-s&sf=yad zQMOWW0JWc9q8M%s5WslCXSCb5kmAdm&x1DDgKs%?JVs=pgW_=Z&W0mQAmUmRY4Skg zh;A2tSX2Qim=qFWmdq3a$(8+N$%Y}jsT_WGmw)v%mO!P+_1aXs$eO_Z?lEh3Gjxqd z1+`;-d+oOBJ}TfMYSA%K)5wcU3gl1vIAeh$1LU|N0DnN9-lqqz^`yJQ*_l81-*>+( z+d|CcLpC<~;I&0gVkPwE_HurFF+z!WfS`W+jxl@JW>5x3t(U}+&VtacSN1s?sl6Xz zifVT&QhfQ!ZB5Dk41zjMduVB4mM{@7dFj!QIpmGW%(uh{^}gKi{EGxh*gb=js_YF3 zhV1>tEQMPIPER=lrUK<)<@o>BMO(*VhaJQJy&mhuj7<}9I9rl>SC8n{J_zlyO|0iq z1O=-}ye-s{Ok-)IG5Y(R4^ujA40U`C!%rKlKr)J#H~n6>qER=8{^V#hFi4$YW#~GT zL%&3s{%Lm50aEx<^l@4$T_0X&Xe2ouxAnuqo~`hGcX1Gqe9o^`LgKbX zA19AFW{pgF>3Ol}{mA~Qps{8#o%)C3Y997xSM=cl|MhgS@0qEm}s! z$gYQT3n+Y-T|z#gLM{-1=?%m|GquLsK~o*&W48M`%Cw8|(^hM--E|GWBrNZ@qG~p` zoIcGN*JP~|aY~cM?Hv~F?eDROp{KMwLM#m=?WQsYx<2Mzn9Ox9mYb_O>XhooTbE_K zi*NDz*>R0qz_~n{?q;k)U*hKSB&Vkb2~OlA_Z2uX=UN%kY<&nop-fVJZmVvR&>J&M zeXeP*POhO{<6X4yGC0FWT<{I$M17a4RiiUay1_GyZ+FvrALlqrG`6k}UG|noD14@G zIFW6EHw3?%%FAzG>iKs!`%4xb3*RBeEzrZ$`K@had>Zn6R>uT-45ZDx4)(qWW1_4N zL$#^S*R8De%u)^5yp3wJ({>u)5+sfjtH~JX&(8Bz54NxfMEWe29kjFRqpxbZ=-6NR z_I-^~@A;d^Q4^g^-=PhKoLw}(rj`G=#B6J|<+d1>oMohA(30JR0H>Q9TrK1Xl~{Pa zZMXMa?Xk2`r0oGJq1Q>k9%vO#%ABMY#TrRDBrGUnGQR}KOYtKDm$wxfoR27>T<4Hd zJSRr1OXrTwqDN$(*lfG@at#bDy}kqObsrjW_y4}SA%4h!DX1M`5}*YA>^?uxggrg_ z8`m>+HJ+aEeV3~=MB>uMER@WY0R zgL+)FT7ClHl|l?F$_5>w@F5T}--c4J zae^%sJkv~;#}LFwDmpg(D6*DkmL;E)NZ(wlsGxsr2ngf3>M>)NZ;_OB>>+IDYpzhi z&IQlnF62EfvMrEOxykBavKfw}n~#n=!eS6aU!nsD$hWhNv{K00FTjE6;T7I(8!=hO zuxp^>GR=FF$if=lv%R}$Dl*6Ljd%Vq*t`6a%WvcI^JD^{4 zdQSo3*ZpJ$#{XRret#1jX+w|s!IzGMD;QmMs{HI67d_A5<4#1-n1&R)&~%rCPZbSU z>|hw-f$+XC(}WhVINFwEA0V)+d2rZGHM@w4V5PAUQSS+pYrxUMQn*I*b63OPv%q0_ zHP`+jLK<*P1W-&S{vG7c6 z8PSUtFZ%>kvmP0Sk7)pV3?-{4RG9S)V_l_wC$bun!A5zTZAjBmNU6MbiT*3hFK6yPWvJu?l4_iDViD?Vtf- zg1FqSieO>bA$u9W=}| z3UJJ3ke668h@MVS3z+c3yii_wYqAAjU3Jvfcf^P+FdZGJ#Id$?8ttrwh>2D5!*#Jh zZn<`o7^aDPohGF1*WvqII9ISsO8NkX<!PqJ^7Mug3yMcgO8%KR~CHK%3 zpxvzQV`@x#*`ru;#xviOgavF?$-o-nLtuR+0>-V#zPHr0HJ-w-iCTzqn#V(MrZsW!tZY|f z<|vxp+U>od9|dMFz1;HUIA{WZ5*tIv&fn8Ose#*>WIYH)Gw$o6@HAu-R2#tku6q#l zO#Xoo6^uwFe(a|aC}>wA!6Jc)5rN9gOzK-X@IYMZ9D68v>~oo~6&@2VH+Mgv2O*s9 z6n81{7r#y5;&K>clpZCYTqcM^aTDr@VK)6q&kHxxGq$92fN*N^FAD*X`A$>+7jK>w zREo?5pZCr4G5yG2dA_#+FM=7O*$e9}z8_mO{tzJV0N0IR(`NXRG7SgQr!}Cpdg-q5 zh|vMGr-m&n{xjZVVBC>QXU$69i6 z@eA($He7faHIGGmcMAYsJEk;{e2u`Q*git`5ZIGtKSfnxDFl^azk-mCOk?+F)im$& zqWA|Urx%Zy3htzbgvIupvO^q9)X4c;@Lih8QO=hG<93VL*ADSVseTqoB8yUQf1S(* zka(s~T1Y=OGg+(%o95aA<_<^nmA4i9%G3YmqHJn0Pq48JG8BMJYc}c+n*6f7pAxzS zqT=W*VKK~4c=gelQPsy0zN(bb;adNaI@!|mT>e$SkyP%4zs_EoMZ(Bd6XV-4K@sk% zDe$Li~jXYt>yU@!Yp2GBdr+PHk`fxVHPfalD!5QT%gvnI* zN=GT)=S}#aaWMcO*m_c&mX$CC-f)_=C4I%df-j66`We0zyY>2!zFu}nCvRWABJgU^ zb&(@PN9Yz+Fr3Ab!?2*Bt+-91gh#iORgDTrMiOF5daFNpu@W>F1tY%lwxTzqfL(&% zM$~wm*~=PV>P8Ylg4H*Jy27rK-s)e<=XwPz3f|y9_+S9vNSy=cT`#%+zR0w*(6(|n ze#zS$;$AHq4Z<47O~TC>khg=o?_<`xoGqnP7}}5vKO(yDYB5#fFKo_Qct5`mP{j&!#P49YZ=U28+GCGc&I4J z0ZI}CzXgm-37m_?^!PsoapWL$jEKE93{%3um(qa}=Ru(@d!@CFi!xCJnTq>g_fq}@ zyzVJ1Ku79dz0`5qgRlz#55*{W!yg3JDq-{Bmz^BF%+@-q!1io0lf6f%%-m`zdzIy-pyNvIT zuYA`RPXd4r)W|X9$3Ad>x8I!`!>m3PQ@cjd>9^==hH;9td-y+21z`wDiG6zxeqn&{ z$>kF!b4O(nz*>h7NcvdrMply@q25Y|3d!# zy9is|>&Q+}@f~B3)7%_HjosZ&2fXQ;tE0y7}b<(La>U(!?V!taB~lSEtCB96Nt+luu=xRZ5 zC?j2kfTN^C=aFIm4g`&`m7b}urpldByE`VqY~YHBQo~eN>Et$mBC~Np+R*TXFuO&dmZG^lZuk{~UNjzDuj)}>D>aZ;=9K4OIIqUE5e?^g;@{C>olg4K~B z5o8Jj<31P}ArWMg2*K=_gXhRN$wC)R{y{1vz`u!7rySVSJ6gnGaTMn*A?}8Yn+O5I zMIlu%3Zl_U>J|tDO!TP;s#3C^-24fZH~_^9x9jwzL-Umuvd5A~H!Z^k7erz-L9%ZW z3JITpBk|ofl&U*1bga8FbhMuYfSjl00-dY7nMvLz?Z8whqhx5EDkj(wfrZc_{s}Gj zWgz0EQWIj$WbTRJ><9v43GPYKQip`BK9u5I6R+sRH1d1}OxH_Fy&Kd_8T}l7f4^Q0 z27BT8ycC@w;H661VUJUfgK^Lw4$w+#pGoKzb=x3Ipd{-0bTIMmtTv8H9ub$yT*b}H>25qrBXNDunw^o zjL{5vBuZaNKn}neX3ExxiB9?_I+(m#(C{W<1A`GGm^iO8v7Mnv@#1=Q zIlbU9{mES|wo@IIa09HqhO82YtBrBuEXxys%cK)(SkW`>(0bI;>%fheEhF=6xJmE4 z(4T$#fWOhWhIh6Bf5m}~@7g=X-B2w&-^&p2%E+_={Ibj+vQ9E5Eik6pwq{OPqQwM? z|EJ1kDxHz#=a?0qkM+ZInv9kDtU=LCwb4(ROPE`;;Oo|?RL}_XrGL$Xee}M)MF*Vb zq8B~Y3a`BM!#H_%=sOHtd4572b?qQ={q*6)@%L=XT@%i)0qVjevTwJYcpByF!wJJI zhL26MFzVpocrj+ev7ZZBqq3N2Eh3>ObDhu=$_DsydK}Th%Cpn60~7%+U0(10E>3Mc z+cgSv{a-dac|Y#%-bd38yJG9k!hkP+<(p%sKaxW$Dd|oXBQ;GCsI8mTs|0r{vsC&7 zxr!Ob`H0;O*y~Jlewv3FF`o?~Hdw3tw#vLRm}$6oq$7Tsyf#*TnjM(lFGkUG`j8fl z5BJW-$o8IDJZy5%lUtOzj-)Al0g0&>ggo61G>Iw(ONvq#t-0Kiv6Zjnu{?kT+D=BR z2rQ0_z7paN4jBU~nl16$X>3o869V!6Zk&Z*;P#=O-T&>4Ik?h^5rNTx+0z3N|Lfzc z+PnXy6exgqgT@J&R!j9nN$C>jbWrbJn=BB>l7?+wvOr>+*0wtB$<&s(T#?`RImk-# z+gOuxePueqD1+fcN6znA$K=t!Bw9VZ(!_EYm%`DZY1|A+u1a?C{sK`dM#}at{FRgN zjp+0GcFUvvpT+ry=UM;76sL<{=aYcN=Ks=8G^fO9U#BK5N%Er^wC57a>(T9t^v27% zbXsaNR=t&v!lGmUX4zsZYS$MdYFSld=9Qi6?mAnCG4qo;hla}XxBa;^+KKDBu7kY$ zBs#8t_L*f?FA#mpr(enWaVWH42lVfrI?$Czbm3-_sMT~9XIrOL6L#L3vdg?4LmF(h+%>8%g9J_)*~NIpfUiQJT=+NixPS#H^%l zYbLLiACd2C%H1z{qG_0H6i6YRJySG=w?Z$j{W*7OU$`z_38Yk1&Qt-rU# zS%AIctSL5~7X0&N7-gk|utQ@Rc==e>UCr*?uFT;^S5E-E258o~MOF^80k)w-M`8*a zB9*d{Cd#oEmlyLq!xtdR*KD0>x)_Z)twtf){^u)=6 zIJMbOt^mJj9vud=8)+W16YX8qPHd||FpQhW5^sEJTHMGPaWanPBCpkEEh2PJL@7qy z{NLhAdmm%3U0ZvQV7goCQwPNhI+}0@w@)P0N{C=)*q6^m-2ec_lY3*}z5x)6itAZn zCC(>u2|V}o>15Iu9!7}gy_ zasK+m0N4H?reS~ikF#d8W6>wL7bPmR9dUQSHX+k3)A-6)N?v;1 znd*bHJq38>iN~SaCFAxM7NjkE!QKh)9APnp!W8CK<|YQ2Zq%Tem;qK7Q7uEk$=5VZ z9|=0BiF>ZeIIJn_Boga#++`2ZdKtR#R%aiqi7ZBVCyy}xwFC?Y<@p=HLnI|b13i}>OkWy*q;6tBBD^RXGShxcVR zycPJ~33>Th6ox>;{se@U0R`l^G*X%7V79NBX$7>lM>s0ap_qcm=*-D?KJ8ow0VUDQ zcc?m7zCx5x!PeaLC`;pjq|O#PwLOt)tm)!725y#PWJvgUn)imWP9Do%h}Z`&_n`%1 zc>*vORx|6>5)*n*w;Dp&Q$499gXM~Pp3?yK^BrY*dJO7@a?d9b7z=KjP0=qQo%@b& zA?VNakJ0id`81M{(jI*n+drs~=-3R9^k!6H*}bO|8_s0;N_X(3prx(l3z+(Z1ZrJ* zTV(c19A9FC(z#>J>@xHFDXisW-chFHmjI;3SShluxPt>|X2dxK+4CP&X2f-`ZCA@{ zuzR`iK9`~mS4BSVad+@_+bQAe)QF?Hzz!2XrAUQb=+Kv~uey%R+nW=%hk)4Tp*NsM zs1_Ut!m9=g(S(&Soz}G$!UFpH-qjlZ#+-VZwgiaA(CmIiTjE$3a3od*lT_`SzktJ{ z%7vdW(h}7xA%ua@W4<{WUGxB!sDzDIQfz4!d|dRU4DYiO&<@5{cu~zgikU&(c!GL{ zu|RZtDsORBaiUPdeHZmtG;huAEoYc6@;Q#u1gHrhA%Qm1r?H**C?={{tzLPgh0cP| zEl7H@i3y^z0k_bOwDIkOK|Jn*1^@*5n6t?-Brc|V2X4-R_dzw(U++1gXcJAauvgI+ zbA%9}hpb|vHRNYwbjZveO5?=RMhptwi!;}rn(FXRF?n4WUlj0K;7Yyqwc`t6I)q>$)ISn8EhrofL!mqdJ+i2d4Sedu=}VJ zr+}$pd&?$|^U|kxl%CH^&aQ63AtVV4H6ArN!RZfJVP;0;P%n52%nLZxf=)z70Iklz zP;4kgeK^j}oZB%kbA#sv_n-tpufBB0%lPEApy_?2D~t&g#=;o>`?j}r8{5*VYp@KH zr+$s_c5#tXIJGaN0iKcNHej_&JoR?MAoNqOeJo;pptOphED3}{b0DGkII$=zNW_O} z@Pb7tz^QzJyxmTQZqw^sNmdS6h$>)j^;orDi*Gpe3J*{9+L07D^FQa6AT08a$qJtR zQ+X~1_H1C?YuG(P1{49;4)~Vv%mpY-;g3d=>s?a(p8_RA-({FU3P3f!6r6q>)2Pbc zaW5~k$?moxKTL$s>@G{xU(lVD1Z`i>_ z%(C^}!%AqznIMXUq`ke@!rg>+l*y{W-SGgkb7J$~lp^_&d}y&!ZbTC^1ElDtXm}7s zO2he~hvoO-I_tTuEWnVWZYa|E-1e*1}2l8!jD1N^)J8XlEBYretpPp z_~Zxjw?77DnPF}qGu`+#M(Ud=VZjpl$}{`nzTN6L63 zwW#zWa=t8A&V3tOwn@t^3}LFG^~e^u9yA*fO*aOU(Tid5KH%EBCd|C;T3S;##O|AO z)EyKT3PqR?_dnJ0YboD~LRIIphIq!bs#U{cgK&wo+J8UwR#+j$BLxGm-U>Cj`O^?# z57N!eouSb+UilZewm)2*^YeBWlobF3noqG6eso+iS%02BV`){ zWyO0(_kkA}Vxo3J%vDVdjkni$&PaG9)L1K{jO|X?2r%D9O!Es#@mgK+u|+VvHjgI% zvR*6tr@EtTu)Z4CV*x>PF}&vfIT=YYz%4HrI5aqi8Jf{ZGABE*M1lbsN9Rne#D;2u zM_R0i`0ID{LkZ4TN;j7b_v`lb=GUYt!p2og)QY%b)vd_IU)&OXT$~?|!dWH>)tvq< zkje`xpj$EF61pUzNjVspe~3_x?1{2IOM{}Y0(S~@P<|5peu z=v1;7MZ!We@48aVvRg6BdGNfkBT9{ls3eTSi&;xewKXmO_ML+$me^Y4?A}>IaC3qo z1O&VM1rlwp)?)Q>BPob6H#R?+p+YrJ%s|gh2IPhamjwyLNq(MmbBLNEU0&nv*?2e4Yw!Z44NH9xP;Tw;z{w#9n!w)Vg!!m8g4@(^6AsGF4 z{F#F?QDx{-CUqtRs+lv5von+xdDgygNpT!{{?2RtmYsKS1OT>+@vnFQ<1}3IlH`86 z>`w9OQU*I7gJwvQz%{1?8A{gT92e=sX4(F!YHMBvn-|!MB4{-cEIEd}<4!nh;lh^Y zxb}8^_Q}>JdNK-u*2j{WM6D3`P87$A8Cm`-5=_jayUK#X7VJ^6mBR9qt-0GdIJ>!8 z5`1R*n!J6t4FKP+FK5;PY*^CM+r-BLYv0{+=!<+!^^y7Z1W~$eL!(n(wiLU}h8umI zCuWouC(9+ZP-U#In&{Cs97oi2^S6J(h9W1|(QJKlwa&Q90fGS4U<(I(wD8ZP>rVZ4 z)+3B5i7VW={{nT2v;T|fOlB7KXFtyKcq ziqZ3*yix%TN~#>d(_7TPxkAAB;5FkhqURH6u#K{1^pd|nBI6KA_y z?tERr6MR8b{|SL-3;%3>4@_X0!_$BX1T6mVrH>D(Fv+_O$qI`WA?N^~1mznu5LwY~ z7=Ssm<5YX5J>Hu0t3K0GjBvNTu=I1AaVe@(2hfwvvZWj{e223mHfXIm;|CF z$#@^rLD-KZWgU?vl^liz^2Kyf4N;w zDS#0s6@WO7{4+~hCMRk&)Q3P}HB@EJamrqyP}#AxWQtsarmEw|i>K~IRm-Kca4Lz` zLY2#wFw#E+myxxjF32vGTb6YA`5QO8^{52sY<6s}rFU0ZzR~UyR9^qFoTI~Ouu|m5^eH9d;_)j`OG@t)k6D&Bo%p< zs1zG3OGvu3P#mo+P#<*{sh8|?#wYiA>_td~Pdve}vJn`la+uSp3NSbEXp!xJ2@n9G zB92J`6WBeo4170~7y)}^g}-10-Jl3(MRLKJAWGDx08%13OjbX8hL!#Ak^(Ce*u$#3 zh`v3AdSWM`(>i-ri88+_bGOh2J;tpQ-wZQd+cDz54b2c%3exl3YE%PowsdOL|>34lBv7vjHOLxz&uYW97m`9Px33(Mx+*PI5vF|~+r z@3Rlv{vGtV;iJVB?1-|O+X=b;i|n+7(xgFnszCy&I$J+6CM_>XS-oR0cB}K?6f6v* zXJdvx#ssB+;IF(3CS>U9LndyChMw2MI)*2DdrD)VCdQcX99OZX3kFI% zg@CDYo4MQxH4pix-?D!U^VWZxBUQ(7{I|NS>ce)C56Gv4d08?3P*B-20ga9f99-&9 zfs?-_Py}d1pYwBUu%Gx23lR0IeE5jqg?4;=fLP}ggBpbrG|3bp49yp#ejGQs3laIy zr0WajG@tPZy1wTUJ2G)VI=b{uxBMzf5RxyVnYyfRy(1&jO_e5nXO|-uM~Z zuY=PnVkSQ5Uoirs5kY$|3C}~rG4tOw-m|1ihKwPiF2iJyL!~PY3*Zuz^l<847nwIi zvZpo%c@isEVIZ`B>j4uZIFTDnW%FP5+`b0YuKSPS%f$+RgEgTM8f4jzJLd>UbTRaq z;1djQgJ6nxP44sFjRcSB&z|YfB5lY>(!(Gc_)P^J?>-i|e!v*fv7+Q5o$!-n&YjHE zBHJPyD4G-5B4(b0EFh?x5)C{krI{NzJcTGK;CT7{eREeMHc6cN5I+{b;9Is7KiXhG z*|@MQ_O$DIoayJ-!zr!`v6Wv{2x!@iZV_N!Q&%siG(l$(x>< zQ3CAn0aQm^<;jAX@L)-a0C!b)emkvh^=*a%7NjjHdU`3=5Ri*5l2sN1`8AIn`$Nzj zn=O*Wl5s+(G3~8&gpOV6ZQ13{!SjO51U z5fB1I1_uHpJ2C|A8GZpxN%iF(38{W)PI2plo0-T^mnb(&cz~uR!tX{nAqgw0 zNkZPR0dezf`IRlI`Y|lJTm_7%(?+~FJ*ImGNQ-8OR>O)m35rh-`-{4LxFYD9a}(?{ zuHfOV<#1*lE}|?TjqN>w$GK7j(nVt;olih-f?!7!MxOD%xKf}%d?$*jCF5KvB5ll9 zbDt2S@1z-v|M}VBbyX8`D9!}@u_cObi<){*0IgG|CKY-XC-$zD4c7R+NqZVW<=f0C zQS~KV1T`*~M}207!a1HTH?NqX+3F2buk!d-bdx~`Ww;@%wA!+icAxfzeD#&L3k)?} zT*ovl|4OLAmvKomr)&}_8LglQU84X30sWo?7!9U&OjYd;o?)UihU@LKMBn=V*hk z*+II;U1*M+++x}ma>g^J3vUjXH6eQdMWMN3e2ba%yuWDkuoY?1Ql83TJzZ^+ry-c| zV;1O-(5<;27^I}(bUM7G!RA)m%avp&0Pw_}Y3?YESyMEulL28;qCpI~Ix&{mI~Gl6 zn5yILOjJ+=+3J?_jLAJ4lun*wb^#rCfIihBYN&{q>pa5a8OQkjf7m*w;LM_STgSF- z+qUfvI!VXYmvpQzcE`5av2EM7ZR_;^?{l?lSFQV1>tfX$@0epe?>;0OtdX?iwXGRQ|)TSvAUG_gYx0p0eh3l_70YrC?Hl+Ol@>;^Lq=0fqnpa(A2F zS5SEmHxnEU!h$})nogmyUG z)Vnhf1n1}c-VuHQndbA-=HiB{&KXy!=E|{>n*6h zIR?Ei;pKHL1EL@gRLE0@YZ^qZ%L#XZm+3PY76aO3jTA+=gGt}nQrsf`i2~=2YP>e( zBq$aIv!9RtvIXrle}3t+(#(fRrc3`kp-|S*u&?%Qlf&VT;tQm6eWk71&A4u2c(e0* z1pj!gqGV`BSbBeaT;%QsE>n#q=s9BQZ%c{YQLw+ZoIcWd;(wP_XS5Hh!Js0ak7=5I zv~}v&xN8Flx0zeQ;dPxc|9GxqWSAH{b3FXHw66W$4;@7Ftti%;A91rv?(%Ilj2d*v zox-}V{stuRQGwXe<=Tzb3$UU^lPHj}OAgp!$!85?Cifd#slhe?8SW=s58%cTT$>-! z&bhU#Yqtz_OvVjUMsBG8#Hg5)3H8K`>=~>w6IIt#6jdoFFNDeG(nKaBtR%zcTS9{; zMgw67M%-nIGyDp{mzuS^dp%KOh*joh&eLH-WUOD8B6Zw*eWTBh+Ku`$!a6h9P#dt1%J zXmT+Lb}Hp--&I)Y7-KO*qndPn+(f4}{pqiH`$|TNT4?m|ubgvOYjM#k{s1H-1qRXkg+pzv^y*j?rl(vXbXsgeuQIYXO zKl{o^8@r$9z?qu2#>7YquuU4)~M>B zFN>KHq$!qfB;*Orep2E7*76B?$2HEB`j`z9z(bvEZV(-}V=3;dlU~u+T_EoP>&QtB zC|UIjZAJ8xjRAjPOeReJ0Wx-Oh%ia_F%qZYI4i*u@p4=_H;+(Mjm%zQx@w#R#+8y+ zl;B?kOqiNO)UK}CGV-xWD`4#Z>nK7@!h&u^*6;$SEB=7H01PuYl4} zWz0z%T7q^vx=3(7O-BS^LhXV1v>eS*3V;3Z!0LB)QW<_<_;HfhZsboQOH`MxY z{pWT1=5oJh(}|tdBT@d*8y8p+9;WtCNOGEy)ct@Ur0d$xN3gm_;(VY0 zvYNC1a0^xv^UbA1{0+^M1sEjKvX}{jKG*{t2OCGMT`q6hmC?K!15egvaHwejBFK%- z9JwzMOxi^YiCwKZSfWfa1w2|>O5*!ZSsOyl6a?vOsmhef;;^BDAb)fSr){^&=<^)h z3SYzymk^`%Tl-u|6`!>AhJ(4V_@BEbv*FCcB`&8P^Y|r}W#$}H7CUvpdJB(fJTyct zQiS6Pwi)a1#3prR$)Zv}LAP4`E5!e){e*H^GMw`lrMX3zK1TsT@=|r}b<#_Y-2din zju!5(3_3mrI96e4jyZHFh`*vN$e(RNd#XZ4IGO6zb3l95K;nkKPLcHHqd0vX{DvzFSKe zv+=G$DqWEycVMya2_grgn|1N=_|H&a&PN6Kxl0}onPH^Q;zR2$Jc#cGJhJll1PVY6 za(Ex%1z!7(afGcPJH5jAdonUq_C~35shCe>Ne>OP*q3=8huE1%DofeaiHhphYlZ4fP$@9CY)AvE+QBArgdmlA` zR0v-qM5DkUaC{-*-I8^l060a=gQ8Eo4Lm+oO*f}(KtfOJb%SNp?tF+OFk z>;~@h3(3l1z0(3H=L5IQ9J0m&9}kshy5vN2TL04Aqo>g9Sc@cPShA$d8XpV`BvDtyVp|VTm8QsAcfsAIE7U4`^kn?77QM&;AqgbF3`*jYu#FsWTbtoN?(A z6sJ`b_li=#trlT|u?S6bzO8Yko5W!+$43tAbYbG}Ma+pnEWcwYlfj_p8AW zn3vB2cFE8BIe2I`d0vN75C8Dp|rZ#f05UxP>X8<&(0wI@S9CVHc;a4 zTfW4F&x~%%Z3<(&3aYz0Z`Yu^|E_OoE0T*$z?YGt_QqR>J|w#S6xNLu5D}K^c}a9|0PzMU z*nBSu$D{lz=dVyg&*uFW+NvoFf0LG(aM*)bXY7Yme@Xt$X;V7_>2CWha-|tb9Zx-8FO45uGw5+`S_L=VAG&hp;0}@gLp4fIks63 z6ogNj!syQAJWa|WBg8hiS~!cmT5Z0$ujUf5XD@huU91O2YFRan^$X07o}HOv;uEeh zvat(!fJY*eFjhqr6|Iy|eeh=b|fX8vV%8a4c%K<3Sm8+UvTue>WcPv|}ZD%eNwW*)#%xchj^Kh2Kl{!jMXErd)Nb9F60 z=^cobsXR39XwtJ{okIV%X9pe96|0g85^)Dj0B~r34|v9#8YK=)+;B6-FY($o@VcW) z^sYEEv#{}8fq58!TN(Q7AO#S`>_+#KG>B-`Tn*C4j-lfJW^#@X<>Qjqv~S*Ixf_5i z#X|oF4k)I1cpU&OJn4HJ!ok$D^B?}n!yt>>6FV|_zfNf1Oz|16kN0aNB%-`r6+^Or zx>?ap(GEx4#-mJXRH1w+L{pK5B+P180@CeK#eh4SxGmYSTxVj2oNPfp_^F|U#~m?% zlwU+V72JAjc|REzW5ZFG-9OoD-I$tO2WNpb6XX9dCKHKG4`*2t7KzV}e`crA5TP3J5Ac6Hk)zFVm7V97F3vV{Wh zh*s%Q0VWR7CA$_Sb%+Ye&+}3A-ri18<-w)**m`HHeBWz*7U7Q+D2d>b@z%~_lZbwe zSW5|s4O#WGr0|m2ZyHZuBGnIMW1SomVup3ikN7yzD3?wZa&>7&KD?5LQBqVvZDQ8+ zquz7eJNFM*8e62XTi+g^(on~~{z@5OC_;K8L;O%yYM-?R4Y%%4zd&}sfKGVNXbc{Z>REz~Z}6_JHVb&EfsB`cb#cAKZZGsZl#{0H)S8p#5}sz3YdV*?O&kY?jk6xB=OwIK_zZav6hNV zw&uiOdh#20UUnNc#G;-W0savm*rj}ITiawpr5sZMRT%ad|7Xit=)u%=Keq)}ABa}p zhFm2;kjKg>EIexbopVn+|q{9C4YAOF;r;>9d^-D*EU{E z>nD%I>VK!iw>&ujF_m_~hZ$izuVj}VaJgRE^7zY+zrzax#(c6dX~MGRnSCG3&*yA9Q^{Zo$8Dbjm+KMT$7+c|pA|J&dd5vZNMczxkWU&FVkT7!)lIKhN zPSOGVef-wGw)qV;V5G{!pO)P7AVZe&A~+7K&MVc_S>Oz}RyyhloQ@409)kvE@q9*D z#JlcvMw5+K+DO4ScGIk-?@3w$G4Ge(4(Jl9^1qh zA5kiu`_j3I5-@WvIYac+shtu@GeGN^YXb&zedpaQpSXm{61KgEWl7p5u(v;DekDM; z8b^8ZNySUmG1iL$|8g%k7RESRw|C)bL(5rIV2~6j<(BnNfJBkCSnL^2;8spHgPoe= zP`^3}AB5BuK&0i_b>i!hx3V4y1p^RH@$THT>Q#gC0uwF*e&gaewb-BCMRA6a7AYnT zdpFZt!=9hfx;*0Ev&5h`WNv&#AwXHG)-QQNW(={%IdNj_ z6nSZ#F*=>20B1eu$ff~vJDBO@#Voo`S|aF7F0yfVqq~vn=;abf2Aj!%B%SQ2m23Uv7LaQdoOhKaRwWie8?z?NbgYTdN+d#t5K z$AT9AhY6X3M@*hb6!TYE8j>D?vYIU6xKpXS7?l;(ofBNd(s@fl z>{p}3r{0dmu-D$jm^rU7w^g{;o^XA6hx%ptF9Olgju0IkyLc)dvAz2I)k}uG(4-JI zrRI{cI)l*Z%&(d`6~dOGsf8iW`dphmy`EURd1jpIZ}5Z@2ChLU zk3yP2$grU!*a#`eP^pkC#K7DfE@*JonNsn@M`GwJFK?Ja1Dtq0{QJ4KypD&7FOpTQ ztx>0tTZz*6L8IitaoCc$G0Dg2bLEL0jpSe`h>qO%%*l>aCNBha>tu2Q?O2GB0mI^hE3g1!X`A$(vV7>8&-kZD#Ap!`y@U4)hq)S4du@mrN} zU|1)0<$O&egjJsd;Svm} zXG==^sI!Qcv@2*#IV@ID4f&!VkY=%kwHLCaNXtE)jErk*kq2HkqsyI3F3VY0^`WQN zd>ny`;`DM7E-Om(GuCOFV5${|5MSnKk^zCBIv6DsS@EaF6~g5l5;8+TSfra^jJO0 zhCOsUHhex_*e4i1SdR&z5Xv_|thOIn#RF;~gf@}{GQs!7dOffa6II0)iJ z&{N(Mg zj5<|!l$rCC_i_Df#FvfERQ-!xgT%|m%3^I&bI2N#Ha8fHX~_#v$q=qxm+Gsx7uhHZj(FLhN-+UR8efcT6U4kfw7los zan#qCyWY4R3l&pw;jxg(%;=Rs2I9r&-mndaAn<)H%^5aTy`(SQ7MRTc-laybQA8h% zpuIpO4?whZ8%%x?1%8);l3Ou;fgY6@+Z9Ay6P=0=p;OM={L7T%GY(8t zMM(g^m`{8_UR47^s3^{{ETuo29xXNr40ca%{8cFZ3uYIT7GLQwYZkpvR3MM32V&1m za1;d>fE?_k+57G}4fuOTcJa0z`TpkPMe?_R+6S8Y*QgUg*5dTed{{MklcWNvC zD=eUNo@?E#5QxRGf8bzAfl!yBgEQi-(8ey^7}dw2H&2bNB+VXdKmXx!+-oG54SlO2 zDe@se+D14QZ*|{SV6v4PK#8&-EVykoR0s)UH5ZqaX1!n=GUo9lpTdRG%;ff$Cy!P@ z8Dh_n!8KuFrDsY%03R|{!-$Fng8t=U<)w&fOJU!;HQ5nZGPM$Tq9JluR#BExpnXI5 zgz2lppivNcxAm4W_NMsAG=3lzfkjrpP#D3@S>XAcK-Hzm@ zkxxzTq&@l}jFS41hUJo!#es~X?oo<3O~|1gP?%90k`d|p$=NvU>Jx0*|8-( zH!x(xC_#6~$7hA8*7TBPb8M%}!0GUmAD}qP2#{4JhM=O`y;;QpvU7U&l^;xY??bi+%7t7w%-rVeeE{Ue>g=weWPpQ*U8)ZV{1pR6}LR)shYnn-~@0 zL{75k|Cva2esEa<`hDtWRmCOz(5mWFtGPIPiP)jvH(oRZe-WE0?U$>A&DIH?>}`|7 z6k*62XcDn~#M3kqWmeBxMd7HFisN+~C~D3e6NrXs@pyiknZ0aD z?p^FUSsqS_G_!Dr2R7n_*mtru_Azz0|q zN7kVM{<$4lkw>|AhoJtryoUUtbF)4^F+C|myc{;$A74+`_N|+THw992=iR?5-wz$R zQ_(HoK6)Ce+m!=bg`Q0p&~jW0lFbX>B`RHkjc251rW5<+<5S7|--=$|kFGd5KtY4g z`3B|p$98+5V1#SQ<@i&LkL%tr^baU#f!h`l8G%yH5vT)*F=O%-xo}30MN^>Z?n(pm z+j6JB8Su@$OUD%(JMzb}fgKTYFj8uC=8tUj5X$RU4*;*JX66sKNDTE#kAqsAx38Py{H8^V^kGOn#Tv)IPGtT*p905ew=E*C)yMwm-5Xj_ z4Cn%_C;&h3;`Cf23|>8}T3@`up=<5iQak)JXyZ$2+%QKIv=10)|9!yhu-;is>04c) z4pP3vd6^Pbo7K5mdB4~)52jynjT;9@!itJReLJ3?K9ZPJXRLUV0%J$Q!X+`9PUp`b z+L`onS;UqBzmvGctE1}|R~6_TKIc>eC53_Z)aenjrEM+M1Ll=FX9~S%dtFm@I1g_$ z^;IIGfq*OzT9$M_KI`zTKUL8`?^cufs!6dKQ~0cXNGq-@YW5f~h2>ME3mGXV_QA;5 z1ijl2;shFU+Ot3%IMk4n9}irY65h=^9VQce>(ulgA{SjB45Z#f)j1a>d2i0E+e?A5 zh6vYu8k9cE1?|6i_!hR6i9>ds?tia$ z2@?zHbvBNFnYkXLCK@K*#X(!yLnw zQO^g`dR_}9t*+nR+k}tI{_6f49qa>~q2ov%6?#0>*+yQes^5LTddQAq-3#_zS=0=O z6-^~8onx*EirTxD#>LUCx;&QWf4DSvadCB>ZOjbEa2IF`8xE^-UIb-aN#wyiOa3=(gH^UDw)I$J_VfpE*V z{^yx9GqoKWLCtkmRvO{dhpV&kog*2Q!xTlLF&VX{;@>7mssqz5-gjp#`9lh2D8=-% z<`@5zZM%bme*jkGn`PxmzYT`m=jF)ylxkpQhN)w6xwBJkre(q2fLVVYcI0UL$+n%2 zPv%s^l4>(ujZyx+CvTD}_YbbNG&<}_aphAEZka=1AwAcF)gU?kj9nleU9Mu}V(6g6q!Cxr>yw|{USbB{O!W5Ql8 zL&h$xN*}G#&LF6wKYQ00+X9&DkseUr>BpP~r*q9&2qw!Spk!xkUOxz;Vphk?H1MTn zLzaUM0rMO28H*#>Exz=G9kxi}Vj^zFUDpcl6Bj}*AGcf%>dw$*axo;em4Nl7Wd~7l z6BWLKZ(&rFVYu9=wot7<7{}0K;O%vgub0io zJ&R&`Wa3{jL_CXSl#7f>|Dsgf=U@jwWT-9cxjr7&(f+(q375;SZsohia|&3={tQ09 z?*6{b!G8Z|vidAu933vU@i4b-CWqcoF-4f)_s#dE5#K*nwd~(r#c7t1x$3O_#?6T} zF;5Kk0)=MQzj*N3)6jEyF98zJ?@c_`iWgI9n#WTB9GKGdY;V>?V~fSO9Ztr3tTR$3 zVV^wN%Bm}6Y8yV%~SbyoEl z>7Xfjh`Et#Pb!iRxea8_Q}UyBE8Mln$WhW`I7Cef#i*F4(6n-LuJ!M3wT?k69MOi%Lpdx+KW5kMwqY5Q|v%)H~?df5?$$DRJ##&YsX0~vp%`P)IFT0X5;lQR8-_BhxEGh6F5hCAGKhzrXgT_0TQ4GCzTT8gHcjl z-f=;#kl|4JxqdBcOz2k?up#zw(g4&_e3o@#hLA9 zs_;f69hlucQKMZ~5r8|l!=mQ~IclS0;kayy?4V~#X$M+=1@HWGi4%6d65@Qos>QMd z0xs%T=tf6=nIT6ygS==k=ivExQ832yB!w$OoW93Kk6{cOCY_E@yJ#kYw=tcE9HVyZ zIZx@E*3zGsZ%6fFl(c_POYkbVX#b%tap}Ee+;@rzi3q{YPj(oyAGC2I`Zocj3Q}Ae zy-N&x$leJBwTbHb$@v#vMA=G-9^kVAe;^Z?>OA8f zh+0t-8pHX6L70LtUMt!~8=Hw{feZ0bFz|Y{?oTE2MUp-^1>A}3fMmE&@A~l?!?>W? zF?Ul`ye95=1^I7I`*LV|a;#jC(qLq8v;s2*C%io}t<6Zl5A9~2{4AHx-BNcD$8V&{ zeW8oFwrd}BHAh21h)p!r%D3fRG5K=BU#H38Nek&=In25qXy7xw{OUI9Rg#s6MRm3U zySx!WziZS+c?i)8cK+f4tQ0%Jm6dEBRk0RjxO*69P+9aiF5E0%9b0hpIJ3dxSb*S; zQOca8!u1lVCzzUien>p-?1#%-QyYniD;OV!!|8%%>U-1bUPM0+D-G@kcuHBoccW9= zs>UHr$~D8sRfsL&+Uw35+AiD&iJ$vQ*kgtd;enB4MdVV;?j72j;u6A``f}tZMN&IX ziPon{F{kqykYmehh(Eu@$3I!&1b_n=Vak%hZu&35(Ab6;%=zA!D8JB-_pSAcKzkh)NZs|^_}O*0!y-f@l)=CvE{pb)uG*UvSMt~ zRo_-%k0A30OfkvCz$j`2qzG`IRbkZv9aa)6(lH+ZBJtKBi@y`@L@hD4UvDOKt#pZ7 zLg^3S7bzllITg`2NcVM~En$H=CjE8RcOij3wcxh@L^hyp7gpFtz7o81YBSZ}fmahw z9<@UgYT=XEmH*@^bG33JVCmM+^cKzN%%dUh_mF$K3QI$L4(dKr!3XS9+JlLsbXFFT zV3FbrABS;sioZSHtE2Nn# z26n57b!KPgd;*}lXzWGBv^#f!G6BoM;1-Z8==bi{U_>jpIgg&zI4>X{4ZY7?k-%nDqh&cSZ2xn^efe`UX8j+)VY|DpC1osB8&#M>ZW$ghsgK_9JV&PcKnjac z$ygoSNGTofw#@qgy!MVoYdrsyX@_+R4fJP~jT4^&gnUfO%pQ27DgMfV$(@x@h|0t< z>tjGm7<@YDm!&bKd&$!(l(rAEbN}ksRQURl^MN4zYzcK?PSl+OETNt@NOO)4)*(w6 zJ+;nnK-lLvrxw&#+JfqCFmn;gqAd!r*EbY}b~szqfY{VX-?65fCy}1R_(yP{+a_46 zJFM#7D@e~a$W*krG0=$QeD=m3oXxl{77N?aqKQ0xpC?u(tANnf-K(^tN0YT}J@7(i9c z(_r!Pf9G$gc`?#gD~mQz!u8=KKmvQMFse*a(bu9PHtAf@Yz>3R$^+%;9Kxr{iVB@1 zF^-hUgQFDiWOCDzL}*aGBh%9*@|28K6bK?l&cJysl7Hm`jmgqU3SilOx?<^h9YVUT zsTbW7-S}b73c8hVz$8TMFjf#QKu1WO8jD+NRVgCq8m&`|%{s(9G)YVMdX?80*3%@$ zby23}HRAp(0j=~dBxSsQgg<&EwibuuzxRK#Q091ct-gP%xwX7}tPW%HaM(uTI)dkK z2q(95vTU~kV$;}?1#HXU6>r}uOqb!SvCLxPT8lSOwMkaU1aQ~zh?2>!*~%8v*hNyv zVU+};{Hp_2kJnbKQ7qDnaS%v(w}sEaMKq1+4jTB=G+-x9r{Pt466DmE2L8XhV@Z^a{Z@N)xVv% zz6n+B+QJJ2_5Xpva39SI%F&tLckymLo8+>%M=)(Lx?)1xR~pJrrqGZ&;K!y0S=<77 zRRRH|rP$zjG*?H@rJ?V^3gXE(l+4VFo+vYm(-I)rwr#1QdTNl5a@K4fUOxz7zfH`er4 zyuXL_qedFis8_6h3d!pJ7j;{Xq4G{ly5Av}Kyf$?2VPIQjQBM8CqBV-?a=Rb`h4H< zt=|Jh#{n17!N<{F#{*#szhdcgsl)JpR>1aXM496pU9|L#larf-uNPB%w++$ct=hn{WK9Dn(C3 zTK4lHh}MF(>mK@U9r6YxvwGh#I6%b!Cr~rL$%^ggbMu<4mByt{_2sU@PE;LB3D@#3~ zfKjT1aX51H5sf=f711(R=>}24Vn)zlz`9&#v^ZCeBy+))HZDfd1&Ob+Imc-(GTLl%c6umEg$ zj~Zn4HJ%hsV9kLXCUFjw71uCZ`7H9oz12beA|*^ugA}a_9Kne=>i+A#CK-A=XVR5T z>|PpJdaG5fgsS%Aioh*HNNYdP)OV+ZY>nZ6xTPK!ib z1j~=pRMsN}4&V;@h9jbotWpH!G)wMMz^Z++UU6AjgV}GLy)5^bKr5AMjC~L02=R4) zl67SaF|!>t9RYJJB?~<7bFmO8^%yjJgxcAsG zof~hG<3Juzq0`jqF;KZUzdpSw72d2y_sIObfacpDJjuP?&r)F6I~j&*8T~MWYf2+t zSz5v7^g~;I;U;Rz?_^b+w&hWA>Mf>tsgFM+L1)qM*B-tx6I1wll%N3?a82 zPPwnhx1LET^B1>GXuy`A^+3_ZZ@ew`amh#aRA2*8r>zjB)b$nxG99JxDfmJH2acGI#|{2*LEJ?=uY>(TP1MSf~Jd03-n*CJFE>|hU> zLPRgh(_*1K#LZ9{r;$!8;E~9udC@_|#Wb+|dk(Q&Xc$URGUQAZAEG1|rzFDF8AlJr z4#<1H;}aJDGhDk(9{WjTRXGL0$2ep1=S>NU$)mu)QH-fR(dQyu*Qh|Y3vSu*$TQ*B zzcq9F#CKXb=i^C{rxox5xKd zWA2@GD&{^f%;dBvePuf?U1f|93BAaRWCYt+1!bga>;USa=y7En%cEn+-*dC7h9Gs{ zNV~&5Q~!tRcjx!;{E@Qr*6#tzgT6Cfzg31ld)un3|af7cm$Q`T)t(^{8hhs z?c&H?G)o;v+(DX4#OJjjwpzaJG}pZ1KOO?XEQO0qHh%YSj?uGCIvtuM)W zo7%Q26O$dSFB(oBT_5@0hEKN1a zRgeW9F_Bz2eBJ7|dg`smb+cc^2&Q9 z!(GyEkJ2BhnpGv8A*}C!r6t5}5=O`#RQbYvGNSme`LBHv-nrZ6|E!{>5G-l$QyN@{$03^ zsApO0(CjKj9=lQ}TK%0E1r?4(?9kR;vvssKawH39ui-8;;eqU~Iyfp0Q7mJK`BEdS zjgvHJGy`@JpHH0v^@>4LAYM{eWX2J?s(Sg;_t#>pW?)DBGtUK{9#8cC?qu&~`xO5L z$|ORS(8K=>JGyA|-A#q_8FvWwy+*R*{VpHQvv&2}TyK+rcI|T4MTo|}IzCB01jof( z1EAsash8^om5yNP=0oSd!-rH#WU3A1yUl1jIn`%wFi-~rkE?(bKNT(!UX=$&2N{GnO&@7aQO!e9eU4y-p@|UqW!J+6~X!e4zWMmS% z^wAlaOJ(SR5j9sn;#GG;lJJ!#2wfJTY|b>%J`qSomV}CInuWNWUcc>S&3Ns>ajA32 zN<@&k3;n?dQ#TVbb6R!CG1#E22*a+zxFqQF8ReaN( zMx8o;%a^#|d4?uA=55RNroY+k4XTdDN=hiz+;}KM6^*i;N<(}0f}t~!UUHN@pdc{t zn&O|p3B)3husS`)R`01=8YMK&z)=hY4$!h$gc5yRL=yu{FE{aq^|R08jcGngWIvle zeHPekjq?*vPcKK&$!7GH>z?WNeCDS`?Z-!DTPC_Y^$kktCg&A$7uPRUMX^-&J_hCa zFM_<_y%||3hjq%7SL=Zc*ET{k4Obt7)&f`HrE4n11L`4_2Lh;dYtN+7vc~k5O}Q<@ zocAc*6JBzCKx1QV6RmP;Zpgv!q6DetAG0k9OZ%6wK`WStBR60n5*iA^XS-;{Cl$9d z{T;5_d&#vp$XCI2_gGUr@l$M>BOyrVNMAKd^QD$ZNza)Hty9_|wGe@2 z7XH0+*Bclk`I)vA=nc?fuphKtrslGl=iaabN_C_Orl10Bpi^YG;u*W|2uTQ{MH`@> zxOBJ&vG`(?sRk`U*7DdMp~4skbfus`i18BH;Au5A3Hh|XM*luJu&3~6CnsC~7}!kjA+>v1WNK}l*auV5xdc>gc|zyI!cZ>&;fWfM!ex~1 zMxdS~PHjLPRawd4ho3vjYHV>lPpxYiZHPBhT>P1soXald78uAvC@-|)=$HR8xJAvk z!OsPRZeIUM{r1A9!0ql_sb1}g`1N~d+1R)IJsL8xfmrG<9!!v_P%8Z^<`bvy1}64) znd&#QY;)SUG*8#wOuCVCdsRGO@+XbNL-N8Gt?z+ZcdX|-yu5yPt328{LlIw)%uzs6 zW3*7s=jG|JZa(JhvuOK)Ec6>I6!=G9^obFhr7t-*7~23fI6W>@sUZ8SM?3`CZPmL5 zo>|sN&X304{B=El@B%sa+UqD5PbnT{muOJ{0#Hk;=F{>-~>T4ca+h-w;JIRg!9r8 z$ja}$=yKD)psDlc-+F;Kq~t*^`I~XVEQXYid1o=PRz27Ea%XIdabzY1!pbhrRVAjP z=ZO{MsSQFZ7Rs%VUm`RkhHv#EnT$#fz&-Md9qP>H2`5SbnpQ%<*53CjSmkOqvevbJ4 z+}Pq#S(Wetp57(#ru0+fV(&&`CPISUc@Ds-4_>}!3o!^n=x53q6|`@2U?OvFU{X~r z5fZjRX9oL20?c-cksg&7Z~E#@Pj!;X9&C~4$ply`|IH?z51c5TDfL=mzhAQCC97Mu zF)wTv8WZ2dw2qy+yKpMzO*IdwmSQg*(<&Z4{?1hb-+$$*U|qi%U)KQ;$o_2)*@rT~ znp7DXu*wA>V9`Ul;Brie0A0L*fHCpf0U})?VbaOU!fS2~N*0ZfLu6>23>Jw)9cM+B z3i7e-)i1eA>j1O0MtmgwD$i?2oGq1UdF9#%vq3U;StUoj8I)qqc~0w1$wove4=RH? z-I!@0l|80`Qldqn^D68fsg<5ujI&@ojXpGUSwIS1`o}kuegxWL3F}C z7bzGIfVx?)Vp4mybz2sj7(BuzJJgJ`QitvhMOm)TeXt!i_EU^MM8s(yQte+y!A}Zq z;qJ$}K}aE!$}ZO&N)anKo6porjKn<71)>e01zO6!oYAx?8~KryIMeir<4MQCK5XxbB}rD1{UGnSDq zt+Xjiu+AHlapf=+bj@i+I#h1$D|dEPH5v*yGNH`CPUqC#Y$9NC|wmZ)Cp ztU7|>^Mu6szSqV~LUPR>oe`<4aC+9X$ zr%x+^z=E)F|0kkgM03DFj}xx@TJr?9xkxIK%;;dgjKPNrhm5;~-Nk83e1W6|)DpA= z@Nc&+d$n#E9fXaaZupt6r~+H&UQS+B`Y44gEQ=08LCrKpOrNP$E!y~^l0zs)b%d9Z zoE|x6RAcNeaYQtVotgVSstn9+<%TgI_AonOcpWaU8KrNU zIZ3sN?MMbd3HqX;2N6MnE)BBpMu@Uu{S91aD@o5FwaVVFBu3pYRYCvKtOhUAPSmv9 z!fA#O*hB2Pe6Cg2DbXJZ+Y-wujI>0Is46$Moq@1~E<6wW)M28CfTt;r-9u)xv>h6j7H-iii#poMjM0xx+!Tmj&Z2WDr=6i{PiwVk|Y-M+&&(kpUNHH#N;XS$8t^ z%lZKFTI>Bkpeey8wXdvN&z~K)ySMqgSw_%jq`Xih^;iqX0VCLlN|9PDR60W%lM4^B zt9zNw$TdbimiCBksjY_px;r}jZlCUK(qFjt*AD&rx_T5IUtVUyKie3e(%2xB1cXJ7S7&^bR_ho0sBwBt zeUydP&fQl>V)1w;cE;~#;rW1n`uJ0?SBP#6fRCl7jqGa7F2BzHw7k5Zow2QOzqj#) zDZzhNCiQ(+96LKceO=pqL+akE`xfuM&sRsEmn&CWyDZ$@Z~o6yj_HP5zEYUV(#-%` zglStkSMTVKiHC@HGU3gQ{PoZzj+wCJcdaVOcHYVqrcQd}u3s2>>atqr+!vP6)k&Ft z@Eg?CkL)#GbthTmbkCcZ))h&`;c34M+D@S-od$JlGrQ;x?X>cza9ZHct80{L6Fl9f z;2ILzeh%6-T(#+d&p7_D*J#Dj`U9Y0-9xS6b-AZLW%@oJQHiM3nUCuqo2)0WVd6Q&gQZoo6MYn8=II#$@LDx~7BlhAAa z(nV|5?rZ${o<=8p+49ruzV>_J7{t6u=iqG}v%n;D$+z~Xv9<6d^qjnaSOrwB#r|e( z!Zo(E;2fNtb_mJM+=Aj|?m~96@F2aI{<#6+Bg-$Wja9s-+t|9)o*5YTClC7sikEdB z*u$pa=ZcWzYGhzs0jnyWv1J+8;H;c;KrYS}6f6!+?PaX7OwV(2Z9jZjO}X()cp1F` zUJOG(r|fDaW&CeeMFL|=K;DOy?y_!cV;PNmC}Dl2Os#oi%TI*9>oL1cq%1?H#O3mk z5uauJ=o@4lSRy z3$FfMyfYJ7%LtFLlxQ-paizr~d)=Vf`-um>G5oj3LvL6pG5a1nhFyH3!X3Gdwi|u9 z)`b7Ri*Jy2V$9tCaLKWmSeS{Ji2etN&Bq7BC}-|q>1IX5%JHL9{AXME^8fsw8As$e z{l)0gkts<<0q1Oy(O~jt^dAXeVIIS|%C(6W?hX9lZ~uNVl!RsJ^KzVF&?C{Mkx&~T z^tqN(XkThfoMlUbOq!8vNYur!I44G|Jl&jJDbtxTyqGJMYWhc=xBGY?Ro8b)3J&H2 zS^^I_27CbB{s6bfmI+O9J*!I1ziqUslU!5L-b?2;kE#!Cg$|zQu_`n;<4U58Yk* z(N=o0s6EFWziW?5ke0RrWvU!5qKSBkj66U#K z-S-ETGZBzIPk}wDI?l05EeB2fk{qk^ijQeh#n@pI8{qBJC%Jq9;?0eK{aoI-VtK)q z22riI#Q&;6?Mdy=GC=kbmChI@$4CvsuXQ^@PRyx*B%UlqJVoh~JQe-XO)bB|U-U8T zEbZ)bB!kbUvV5=98M3tLgwl&byIJ3nCDK(aO)`F$xN?LNT}8Z)$PXGN8y5(WyyT!n zSmA&?4oH*eXk0>Kegdo53->QLp(9y0Iv+bb1vDu)LXM*`4e-wWKD~+2gi{Tzk$)k z$zO$y8olEw7^U8Z=@bE`uV+IypI~%~-;`Q;pQCr*1XE3j79G!0EYae7dt0O?^ue@pwooc-BSrClUCmwSsl?EN}Ss_t>fa>2ztYcbnfO<405CZ2obRsRog30FBBt zw6tilKUqO8^zd`vOB)T0ZKhiT+b|2)H)#f=RKEy<}WS-$M7pxdRqCD zoF3T&oMu760$dd01ERDnU(eov-UWg`Re%T7)K|KH(Rg`Ylx{Ty@ey7WZWEzST3;X> zYB_p4t!eOCZQwH{uq$)U>zEIH0>*mxuXOXAPN>Q&FLp4jd~`J^3G`NmJa8a%J3Kl0 z(3i^oYH3AWF0n;2LH{=ESb0s2MFoSe~z-p{0Pm2d@T0+_aF1dXTJ za&7)J-XR`#I9#jE*!q2l@5vg(O)Q0rkU$$}9{nCO?KEz$NiiE^6vqqKSQ5}Z0E9%t zp~8f;21XCk)&5f?gEA3$;w=E4+Z7>es)e+d!CN~kkjh5Q2xO=u%JV1MQi=(j2CTuJg zK9I7}q@ax6pG%!KzAtK3*Rh@u)(3^)o?ILO>wa4%KkKU32=k`%H=oTWx_kK0SkK#$ zPe>*@a^FH%+4Z5vvfk6FuZIFOTYTKyIw8DJ)}uGzHF?wVz5bj$Nn(>*{wJsen+6qd z1U9+%$2>Cj8HPh-9{`ZnGRt!wP+)mqzi_q~evkcRVhJwJ*t)}IKqttai@apG0iTax z%m7l|TaT>27a7Jo^Iwp((B>ETIHSe>gT_E#DQhWnMiQZ&E2&$V*-VB zpj2(hlG|1~Uw8?4sOxhFoOV($Cj%U&&Gr40FfRU(^=%HxI>6S0drQ+-kG`BKDA1+8 z_d~eM;*J_mJnL>vRu>iS!p=N+b_>;7REsuQ$;`aVsLnJ6MhCbtqAM(_ao6Ps)*Kyq zhIWE*+NRk4rH$Vjg8Zp3r^gL5I!-=td25L%#{rg<#Kn z_GUkM^KUQXx|Nu)bRU4~md9*ZFzZI#Or&A)u}SoN`}}0>aWgz-n0>9Gxq-t8LLJ8w z`|jP@0l-%*^6JUhmf}v!2l2c`UKog(E652nN_BI+&Chd32dQlUVz zRHv^D7N^~rZeTh!7Lq7MS2vMskKdo+^M%uWX&P#sb=AtT9ULbb>vwLSQ#;Ls$v!^A zTXx>@@?~gx={)t={3-EwI))3mD?aA-_Y4}&C16mGYscdNfimfVW?UgAPZaaU-2to; zmQT8@^DEW1ft#u3*G)V9c^*-5dg=x?nE!EA34%oULd3%CG?6T%7^FEZBUfCQP}IT3 zjO9QO%oMd6#T$leU^!btoHxL0Nh_Me#dHm|FavCtGa{aTtkSYCuWX?yv0*!XNSo<~ z1OPnT;%;{WK`DvE@BNA$IM8~xCp6wazf&^rvd+b2SyaRqW~DcZ_hdvs-G5@4B1w@D z8AS4ecE=q_#FNO5hBhKp_M-16I+KJlyu>T=4TNoNl9-z;npz;IN#+#E`aSPXWr$q5 znFXOq{4}tHyEg~vzz7DlzHz6uy(}Ng4B&B56*}AMWM7p)@t@}zQ{aMUneJ?eOX;$FiPHtPEClyh)eknyoQwnpSdjbR1v{%6D^hKnhwKsY4JIv^a0FN|M3%>lr=AX?4wH1+>-0 zQ6noDma=!;xEiT(8gCy- zhK^$N4Jm(#{Q8|L%^>P@!hMg71DA^&h+pPTA%at728X{wb`%|7Xz;!yH%8<*1&Vl> z4G$)d5!FTe0vO|;J*T0gy;0japF>(u~LT<%9wt8@9W_LZUpqX1u7nlTMIFzHUVJmj}*GbpnIPC1m z^@-#m(=jsU!3Tm%QSvUC1}Fa{hUEAo7QNg<)}~W}h_Cw-6|olRjH0M?j_~9aC8;97 zu@c+$-HsiT4SMzT4QmBg1LkriK_yoJ0^P@WB+>zi7To9Ilz;#EA8?0+Sjiqtxt|ya ziT^VIeB&Qo;v`cg#YZxbF`v3Hu&m4qGT}O$8b3&}IjiJ@!P;UjSYsVBcG}T_t zX`*ws@1FLAp*-;SaDh-yP$X+N6C%z?1|^Y`aGZhYVP==VP4@+O1B68DN;nqd?&OqmDmI4`DH{vx(La16(uxXu1{D<1yQ1Z)R^GxY&OAp6usLc3GbgjSP<< z7}Evee|gW&8@D%I^0)N^!zG9mPTo;n)#)WD$kyQ>h9Tdb z$g7Xww+}_Jqfu|)p0(x&^UdkU;XK$sir9CKwHZNH<^}ipd$&5<5{mTGz8)kV7?`Yd z!~U;tE)h?rD^HdzuA);<7BAMu58*hEotS|+cO8o<%Dp(_s|v-D++XX@<>xz?@kV4f zBJBw;*`xXX(f|!~H&dJvB6MHTU<9NkAquUXP}3%#uM^3y%VMcVnrK*4DNa}MXdxE* z8=iq~=6SuXDt6Lk2hPiN%7pdtR5v#Xtfq2q0ORP4LdEwND*-5+TWXo{m0 zf@!s5)&yxg7Ck7!e@rzzx`$YTrBb{WrZlrZehZ0-zPpfze_+K?S}NNLrbL+oiei;N zl3sRQ8582iP?HBPBjWE>920A%%2T@#fDqFQ1e%7-Vb|;zBjLFP!+&~GP$o9!^nTNy zX*tsmWb1!CtED=Zj+=Zg-&cJm3yhSY2I3^*%AIK7i+a}`XjZqIBlb#s&qN6=db+V1 zI2cV#jBE}qk^+4N~}`Sq$us%{*eHqZ4nTjEVwUH&SrE~~z$ zXHU`d>1+OTp6jEeczwBIkzYDN?JiI6GyHxRClR@s;{<3>>^N83iO4y)BU@5fQhe_j zd0@fA0w#lJWyUCI1L54?j^nQdK2L}KeI2qdnNcXXUP>Z3T!$%#%-4q$7Ppq0udFOT z;A_4flhS{&Ia&MSQFba5I;uRZX8)ugh}>g^4R9y42eue^e@><+hc5)Y^OgD?K_`soPYTNzO#BJ?zyO8 z1Ust{9QZU^x=aKJu0R?lqu)8;f4@~d>86N}3AfI~Ha1MXZMBg$uZ^#uM$4KPxLP-) z0n#l`ZrV zwqsy6)&xBzpE-u*we{?~3~emCS`Q9_=KaYF$FDZV`Ht`j{IwY$R~<~RMl=@I5*58d zlzUa>@XW-vbkIrb@Fv5GxNm(xAg4@L0Km{q3-+dtJzP=rM6Y9O6TvoAPz402s%hH4 zkE^%Uxr(xP;8Qg)YnVa617qqn+z=!k+_HA~t-yWxIjz)nT7Paf2k$Cb5x&Ry@HL_3 z4rALf(1&`C*&v}q?YUL(FmP;fog-hY>Q>Oh(;SkvUE@_E%v!3uos31E545Ym1F9L3 z2Ya%G>c^nBmrl~o<74OlkrY~+h}yScGRz0GJe!qCIwUqx#5P-1h-W9KSXJ9U^b+Rj zJKO9JR@XUg?=%K5Nd>vl%gU)e>xUnQ!N?v0i4EvPCVBEU>yOj7_Fh|~KeGm|$OG|KzgR0~TLJKcnG0=~FuNvAEXk*isB>w)xu86HgaFQ5IoKqp2F4NZT6 z6k?h0ld;=&!g6MlF+>abM*=fMrG6;stDm+J{Bt^2rw+rUb;v@<#2vDzsFkoTFa8`i zF?YEr{C&x<+y1MvM~(cMu8@*oi_9GU2DO(?1pbPt>Cgw6Wbiv|>ni+q3jp;;ciWJ1 zQb<5M5k!j_OP@i^J zXXM*HW@lW{l^@CGO%yvul5y-{N6U@Hc5R^JMKOh7z{=z!=*kCzeS5cS=07sZ$Q=or zYcH2LY+czsn|Z*S4LQpJ33$|l$F2^impPw7=6kn3-u{@J!@{v)2C82ZoJ#`%U(oK& z14}(OZ&k}1(QY76ZgO9ry%?CnW!CxQw>lJq_212zY8J$PA6!qddwS z2%U&(hZ+Fa5?HiVG84(JnbP7tcS(zy8q&G8?8JX=vgi4W52_~|efwSA7ZL>3o2PiP5(f)DU%68#>xXgLv5m5lwbd$8w%|y*@%;9v%QD<{vIBy`s;m(KWvrev4PZ1Hw+-GD z(o_doh-1f1E^|Ip9`!$Aj#KNvBJw?r*Ns_ln$oEw!RvTvfSoQr7M;Iff(WvOj38wgNLh$L|2HdKVqIK-60NDK%Nt@Up#0~4O`NzKm4G=54 zD_CszS!Vt=hm^v62GadD=_T%zRGjCMNNGBlGBO;vuT=YuL7m>J96iX5=Vj`L2hPa* zz*S8JYzu7eg_+E?ibl>u&msHj9U@!;X$|}1UffI7GbO4>;?=}oU=kSz8%e?C z`g9oq2Tb;X0oRE~`xvRD8v3?-fKt)?HR;6@BQ@J{Ch`im*N=6eAdT@3%iHS-b?oB# zp@qj&p(fL@G|Wv5AJftClKLi!vfsDz?pGf{doGHyz&Jb~pouo;)m_ejD4S@Q0x;qG0&wApgBCm_I0f*TkI5w{y`gyK zPNunPHocEWaia64Y8z=P|5dTQLCFMmr6$AE8uvIcTOcyZNQW^(U0D}d;%3*yS1fs`0TOl2L`$fU7eF-&07VjxiO4T%1U*&Lok z1-R{r9NLmY<)R}h#vt0sNVrxzv<0b@ev$W5Jq#}aqRT)f5cBZC;>5h)hPXhpfSOOc zV_4~Vq$Nvl$5*@1r6YiXF3-Y-^lIl8jZ=j@oGfeM^i+_vbf9mg8RR70S7u(7rQ5;F z6(ZYmK5??e(D4;7^{`#QYH}PTJOLuffXMBm3o@JJvC!ON6KL?a{Q>4gW`6~7H)P68 z#1%!!NLwmLBXkSUDXHyi8agj-6Zz11wpHN@+~bqwV2Qf1kMrk!KK$bmY*9J7Ft2M$ zR&XAAqBoj9%UsdUtu#LQODkHU-pD)tz{k5f)Yc*sN%?w48tYmctZ6`mj^D>Y@tG_pEqY43x${pvGkJ$FNR1=6r;nNs3{JSdO zfj7XM)R55~MWnFaF55tp>6tHY08%EOoZ+|!m*o4F%7ZeoSw|<$p{o7Fuh&MSdU=Ea zkQZrsOgo|zHtC``LZJq_g&d>8!|;a}IeC?r(fIvM&@2cBwhyilc@e)X%G-n3sO_j% zsl|I-;)^tvwdLg8_Jfz(OhR@+pDUMdy=*0KxEBTfhCISco17a)dtUz>fChgcG_20I zqS7SVc4+D{;g{lr;5P5Sj`TSWaMRn*e)3z7D~-U^Li*%D1{(X7FP+uNy~{gnt?x4dKE4j> z&PIYtkwh>-JZ)etby_!}sy_qS-V>e*j~+kFEw8>4MM-@}y4QMZV6NwQ-Klii!h6Y24ui_}{O&{7n$rOH{yM$|+1 zyfzv(C>OC?z58_VDfri^><*kY3kQmBSF3(}_cQZd@A)~O{QB*69`)#zJHM2upDvkI zV-1wtY+{wtRCo~i$fFwAa;as$kjI4@Dz#9IvuiWg12!*r=v}85lYFlT^akN1`7k@l zZ>S2xOkm6@gLY2QCC{ul6ly?@Dr1P zbm)KAX0&WlSTXvVl%%;n@ptPy7rw1R>Nr;Z*CKyx3h2lLpWB@HD(m+(89Iz$Aa?WOYyiRIK{w+w!Gn1@keJEI6@q~2Pdm|ky?Z+sId62)=R*Z|YS_d6;tvRh8 zbf5R=+C0o$d|?H#smgXwk|96juqSIUt~Ilo^DY}!-?~VH=pF*o(g&G zlbZ0|u^ZJWtnk&@Bd*+->v@XX`GGLoYj!v{m1u3dbY%8UMHIX{0bGR&A`8?y2omQ+ z`Dh3cQu}WHrqp%sajr(SR(g+uInEryZFMZ{`*YI)gup=-$1eHllH~)`=2|I5H&opX zEB@uo0!6H>px`(AwcHOKJXIVg#aGm8{B&!>6u|i>OXVGHk++VJ^3Vs1os^Qi>a(08wA$vcG!6QX|A|MS?n{j{X-cKLyQoF;9ehqrY91 z*RF%8jkG1&R^Sq~|2(!Tg-K%@&IOi;jk@4B-X5?Lr+~kmC!$ z`HcF^IGrM|?ZOGV-yO3TZIOW!O`U^>f0`1{gYSR8OTN~Vqr(W@3XD}lj|-AqnSW2Sh?Kko5;K~&kN>(XK%8z_eYLo307 zpjhc|eF|Y;kVV}9*>J_s9=^1l@0{z%jE-nmG^DC7PQA{bDTpsO@ z7&0cU;*f>J8@@zuY}&!hH}Hw#lZJ>Qaupl|e|sJ_L99dc$h=WWbeEbCLK2@bs&8?tGCajHy3i%nf_Ise-n5^PxZhFvN@gpu86A+<^? z-x^sq0fv@rqgW!ExIhWzIv(f3Q8+H}cX90MflKn3cLhm9<$AU!XJJBULAt?GuZyhL zPPS(4>PK~4gxvRDrHsIlB!)zhF;m4jsU-UyLksWMy6ur;{XYq3z~YMO zmgn@C@rka@q) zt33A^|KrAXm60GjUm=Zmc_%Ar^X{S6kgwXvXnNcDponzZ^KjMnc@;Gz2>~Qy*p&AL zZW<5q~2Y@XPfEJ$tuu zV+n>d@fT%UnK8{~pf)Rrd$vE;f`?L3a_>A5HZUCjD(S* z%?u-%jCd>_16@cmoD$6f|F@=a{pmRF9+*djS9WXDg!u4+%dZ8CHP*_DJOfHtVQGqE zhqBQlMj$rFEUJYAz%Y8`%?uGwS$gt>^ziHL*fIz`EWWCNG~9!yv&m-(fg`8QsU*xF z!dR7~*@QWE+21iU-P=$59F=S^ZYECdSyYwiK-ET@JeZ`@E}h8d`%CA4#j_bSM?Li& z<1VmKl&9pBV;=(KnJVLXBb{jP;fzv-y|ML);Yo}JEQufk0O!d5$zEJ*7y{z1rVCcO ztC(6y$kRNA^z6GKaSqzX$)Ojmc(+fiYl|F-$qc!+Ba>8a;IV=ZGqP$g36EV@?Mj^t zLq|{egn^I-F`e&q^D4Bna-zqEiz#<0(XfTax$;IffH?FQEI7n1eva5tLEc;{4KU}Y zbJi-+0ufIFU>Fy1DPc)41wRGqMQKjmB!C9R6}rW?ow&;^f_`LW9W`!F7TS3P*Od({ zHzW7hOkQ!NO2Yh%pSXcgv8~pXKX=sxmq~lDDMlmcljn!#5xbvz!}yUhIMcOFT5`PO zEb~eVgQhG>{cB_w4b?efci-3ViSr*UL24s_{j2Q&^0SS1c$$0n>OU|i$gJ@|M0V?>dwPk?aliCTTIpxMVjdafpunl=bApW2=HGE>T1SGmH z7)HiMmJ*zTT^<&hpb42Pl*+wW+3qbl=U9?0c=acuge4-mFIfg@bXgwW3ausi%cUQ8 zdv+WuQ`VyaP%xNq0(WZFKu8OxDYZS|BrlS4nABNIhfquA^9#!tmAw5cRnqRrFHS!u z2>!<@=jBUpJ;e2pXwB?ia}K1r~bKMMfI;7bdB7m8ZaZH zW!YToez|^mjg=_@>~f2FF1?CthdaYU-S!mNQQpC8uR@oNrsC)eY(jFl*26sc zHTy=->;Vb>6MlL0Qh4l6=xQ4X5LkY|6iGNR<5l2H2zI-n%i5H>+5tqW=UbG5;f%pv zT4$>TDx_n@@$Z7hHL6rj8Uv{n_?XWMn?`>ua-n&}^Vok9EFjO|IJVGz>ot9$#=9PG zzE7E>81?mJAI|eL&3|_bziy`I58P6tz&^ZsDI|f#I&MyQhp}9f$%?%x^GPkLWv&_Sr6Q>W{}a`Ypmx}_9H!y0QvxU+HsiUn6(@i1dr z!B+kvJu63Eo(Yvi4Q;At(Q%jn=J2|*Q2xSCaZenv>NYVkYL{}dLIix`bGRvAn}+Xd zBI+E6U*3pX3$d-6H1obeHQ2>{0$Kdqn*m5rHJ^f%>Fz+Ug{x7SgAJ;2Ao($~CYX>W zlca=JFSzq(ObH$T4q-b>CZ_SIT26+$}g<3mz;2U@CfjUjH)K z;xr=w?ORg>6~`mv_tR{_HJa1ja2O(<*MZhUb) zvxhAsh>oaR+<@CY*&q~|Cj~n;r3tvkuOUdOZjzz$Y1Z~>nmFC3lwRmypqMi>Ig7M< z`>H*k`cU|knZKOZs+G)0Fs2&qWKvspe33Pit3)lUm())Zn(41Kz-9#>U>b2Gvt_76 zjQnT0KjUxOq(!H@b|X2{uZjrRxTsmtfWG}*ZRYu}ST{J_3}}QM-_~A+q8PMoR^J|_ zxn-?@4?U*X0dS}mjAuhrZ9j7;DIhHv=h9Z>*k%$1DKRO7T0(L^psHUok0R*CDRb=Z z3Nx^CcR6d+lb;Wk0N2%KC|ICR+A6Q`$GKc;#J5>2s1ZZzx{w2=$@+*vZT~Fz$QCZ= zmLT~f$+)=n?u+oho{k0&!CwT|UN0{#V+mpjyEUB7nRYm$XvOpDbdsQ#>s;M`ewSe@ z7yW(cZ=q751%cF2eUz1-e-k;pm}x!UZzQDN8Fql45|n!?1{B%fr^6h&V2so0B?SWi zD;<6$RR)^Cp7Y1)6I_8urPk9@K0#u(>Hw)*LT_h$+G9t(k#WpWn+~y*xo6(f zB-}|f5l8Ok0nD$C_^0JsHC|QuyBMzF5x<$3iyncFx^8X1MKSn_GaAO#5n=uDKpn8g z?9w!~X)X7nhIT7=Vd(M&$&r92yShKl6m(Zkg)`?%@4-}!x1`cqOW=n@W9VpV#p;s} z!>*Mn&L1@6Ep%C>G7xRLh6Ezi%G_C=1wWt^2r#$h0#Fd4Dl`9E=T&K+iJy2H$m_<^ zin{{SueP8Q=6>DzQ52gyJb| z50FbOdi(rakz@(s%S>EV;?=yCS&VR>mDg9+Z`Pv8h>CA~5s4!m$T3T*<9y44Ihv-& zbITA-0yGspID0%bxc8X||>?`NQCe zSwoS2C0XKzw^c`kJ^}>r=QS|UA5c+0MA$BBv#GVv!HGS!u{jQ!)Z!~CJ^3qjn=pW1R3#;s!ckQSr zcNt_+B7WJ<;NOQEYN&Tq$jvS2=OV0{8yF$_g8F~^ zJBh%b{*IaZzrglX4dwU^DkT58`kP{Ud#xDwR(Hjoo(=o!Q-$m*M0-N5@L>(RWbnr7 zk9SbKGFk|a& z6!7Q#QNCBv`mex$-OUiL=b=6SIIG{ssuXY*p(v7O7^nd<5?)(+2wQf^^{18_itl#% zXyRu)hmhuPHJ;jeoiXaCzedm0-UN%4&WFgtn=a|A{BLD>Y6uM)*?m`*Jt|&fUEV&3 zr|$VaLH7CHdtYtEO_8n$u?>x;pv}KS#o6GgW%KMLguK|^%#}!256ssUzovv&73~3d zXcK?<92Wucz(ZZ(HQR%I9iZ}w<+TJ5D?AS<9+TG5WpRt^(aY`w#ZH3?*~*;;ic|>_ z`A&$6me^r1V2C(5b&HxgYyQgDaDl*N3N7284rc&e?gFdo?KcjZFyGPJ2^zJNl*l5W z4c$`^EusW13ThE!bW(8izghzFxxS~l>jtH-$EUqq8cY&muBP+}*S>HAv8y^e2SD8K z^djyrEuUU^vrxDism>UfdX)NTk^{B!H+mB0)sk|Es6hxm#e|A9(NyWe`t)j zA6fn1XUf@VDjW7yj`BZ&Gkh&nDP{3w&*j+sdnW@q@d}8Zf-cydVnehKYd$`I;dWmK zN`Sgjk7AZWdHt&t-x**NNA;bbr{I!-n+^dJ)`kWGxh`0xF4n*W5)DV~yGk}MC*!aIP2cA&=P zrOeNguS0i2`9e5smCI8tw(D-A6Yqo8oTPT;^7B2@i%`UFaGU$q^)2dUHINyGTbQRM z<-!yVMM0PN$6ueghGK!-QO}DjF_Zx%IZPE9Mm7U4MLQ?H#0lx^cuG}@g`6qwZ_K*K zr|hohUh07ceM8rv5bx;r`p7hT$oT#Uw?|>1d!s#BDT##vAI;*th0pzNl)cjLkE)vArhb=9C+Fm!Nk~m}3?z49mJxu_&p;JJ; zq5vplcuWvC=;Anuwd_S&h7mnF0!*gN;=Su<|Et0qpx?K%R`@VXo9U3M4RqKp=z)Tq z(POw=%1$78Z^vtYui4guuujR7o(tGSy!;pmk}SQ}l~tS_#{qda!jxVrqD11SpwJN7 z!e@;G<(r&gjy3ONMLJgO#J`!)+_B8LjToXIq!Bt1Z)vd)>U$vk{oJTXfd}F>zMkMU zuh4a9UJ;uRdcR?V%Z6qDyM4mU@e`U(fym9q{eOlCW)9Z>h23h(I-*G;^X&;{=sdDK2;WB~H(ZT_0ZKd%svr{lGjmmgPG)mK$l{gNd% zSEE)A4Ukmf-cL+@M3^hGi<-nSO>qsQ)aW?z-b>+(q%`nu=afXxTo#&JMj<5yHoX3WAb`eL1 zl%%JDc3n*HcyftfPnh?SB*f+*Kw$-p(lT=?#g-$@0K;@q#Ym57e?iE`o2mz#``2s& zI>!YhE`%HJkk3$VA;2qS$p^#&I`PD$2kAteL*l>J?x zETjG=%Z~7cx>pmD6Gg*JJSW!Hh#iLI{=KWll*~6hufkO=7gkA$=h*x1|3THQWwXtYs_kv@{iG@n3cN z6Ss~@HkFS=j|}YofS=OueFesVG4D+B$N>@2m<7&obYSy0MbiUK-p@xvhL>Ir_m7xv z*NXrj-t0KUbp`yu=X?GYyw<;PtBhAzVG0%r8r<|wij>LJDflyp-eshge2Q0@mECN?Ae<(ye0-oDbZ~-n@J*f4<&a??q4poh4+oTtK;6W-sVwQNfB0KZqylW;B~~zg!;h5Ety2B$)&G<>Wp8yn zg(iTiH-ok{;2Qx$bytze7eG0_5m=}7Q5%8YuLe|evyL*!r3}tg5VQ1M7GtW%u#eT- z7vuQlW=FLT8F_>lzjIlj=IZ=*YU1%GjQ=>CeSG=1$+_#>GFY2ZAc{GEQ&-bwK(D+YZ-lHu*(4c;S(bjinsN^r};jU}FGC&~b?uNh;OAyh^ zYjVgD7cSIXlw|es2TqUmY^(Vh{#3_acyAs1`Q^R|3wsK?&>4tdYy4d6sm+ypZlchvKh@F|SJ$C2?GM8OAz@S5R!9l(3N&yKk*#N-D#fVtP0M!a zy)AY1I7RYcj@#8uVb@3g0zgRq7#-Dk`{n0GF$C8o>4VzPD0ksBZv8v^a{kbrw`ZV$ zeF`K0QOD8Utq1WKo!a$JG#rW@prS+{CG+Fmr_Dot+(Ohp-H-p@R5JUPg{p5~HOWO( zStnqFH$1kaYwY6ogm93Zd+a}dqi~UUke>qmDX^acZxe}!P;v!k`L8=qPuCS!9OH-1 zm?61J-*w$a6IC@#Op(14LiWQp3N}&1qi-}P;|BBp%#)pyi)Z`UOon|5Bsn`h<@S4f z@T}ucQeHom(U9TQ#MY;_CSil&EmWD*U>;Bpr_u4UF+Vh^N?~;Z7rEYrnG+R3n3wiJ za@$(Lk-_%^`83=~m@rOG@`eXV=)X!ON$7$fqShe$ zq0<2Y^=O3#IGvEuA}yOLYA%4~Bmxx|B*5}XjRSE&@s~Fo?*al-aL7gUQtRnJ;8?D> zwS=W@(Tt!

@$p#)80EcIcCv(H~Ni0IsrpL)g)z z(dnlqW0H&jY*@Nekf&>Om3PGGV0|TmxID>$iA&5YX z#zu#R@^WCKPXIVAdx5}M*WPl8ns6?-V32!+pvU>pOXHnDG(vCIKog`lJ2{&CEQmWn>ts!r4Zc0G3rlVI0Xlu?7}k{+H^ST!4FvR1h5vzpfj;4A*A89x0BaSw z$W`58hd~3<(eI#%v0F~Y>7#>8jbi(9x(k)?_h;k;8p1!fADCjx#eDrZLzx?qp0 zQ##(RXntPNO!ZQZEPkExCMQrcq&rVuar3{e2X*YN>HYG#jy44P^%7!OlJd`}$tv4> z<6T@Q@-G0L!=2YRZsu;PC!ZfI?KstoOTVY*9=8-ht)&H=Cg22!1igj16Es`bayf9c z0;JhUbUtlAQ{|TxYb*=XtbG}E9*(81!^eZG&e0Hky-KS>RdB{Tk`5wKKM#D$4z-kM z7orZ~%OvG`Ix{4LYF5PlEDu&B&hrVsfV?nai5wuA8#R109>x+mtXsw)T?b0JigU*v zWDq50(-UEpNgk2L#7_ACHTD)zbu8P~FdAG#aF-C=HMqOGLvVM84Z+r@CALpF=?z`iC@0T(6SYuYz>guWRJ`(yJ7By>dA^@O?ZDr%t~Byq%jB0 zJ0k!^30tL^5!cw?A1uK5t&E58(VuebFyeBiO~S!CN^$j8Lxd>yU_p8L z?DgIW4Jut2jtbRnxr+vp$+>pq)1OIMOC?EVujw3i;$mCU2-uo} z?@UQWMJ5!($SFow>$S@dk5EeY&`BT{P zZSt+~BTfQLfh0{*JLbJ11Ln4S<9o@naSvn!ghK_kDIxOFN4Xvwe2#VvupOgl^V049SQ*5F#RpuI15AQhP%ooNX*Jjqo$5!R# zQQo(c5h?GibxC?EvF$>SGkshmmwZT<{9^gmE#Glkj9m*e_8c$H3kiXl$A%8Y#_m9| zhCZhvWL5x#V=51NH}HVE#oNA#ORDSC7Uh@o(FM=V-9KeIM3 zQS}=!d%k6T0VBaXSdFHHtaS*VlvT*l8FfZ;3;u&@?3B0-sc0GAk}MV)Trp!MO9^*` zH(OShS~tYRWdyH2vYCsT=u_4suY1gg=5W9u zAAiC-=!1`fid|uKLh!V`yaCIEx%qUgT`On%1LTySTZidlrNAvnmdVugVGAH;aj<$GB!b=puF`eHyysi7)v zAd!r4tx1tfy|%2L&X@*w{!Xn>mP%K_hG~L{v9o?%c_Nf-hVi6vN=LfKo(U^7A7c6aox6KqI7>_A-&+mm`!^7CdUh~?{R$(*PskaO*epHw#>JN3R!j=xS!)GWfYwiK(N^lgRu*a*JGlGT+I-3R!~QEOCA9Xf6MkW!1$e^>xk=DHC6T(eac@tI=?&1 zutp9wu{3H$_a16TQrTsx)}R)F93lK2-1I$&b^yf1)V#=U1_yq~MIXck#0tESMuZ6{ z3J6Y{ybD}~GW0|~QpGi>xRedR_2vP;-(bX0pVA>gVWCQcyndPX&<1yM+UOliT6?C` z)PI0Akwoy23ezp(ga+Zw{VQ2u9^M#tJ)i z=d@$lA6j9hJH?vYz0PRXxXqW1>QZ5FvC%{t`}OhE34TV_Jo&WiL~?|0$HeIKa{3}y zdvkQA@@v{O@tbj(L%(o^u$F*{-tnZ`YAe*kb1=Z3#hoUp-Pf!C?6jCM)qZ((WlJ+T z0DO{a;hI~|zM^<@&5L?f$0~{ym*0zMVQS#ZI24oId>GrB3P`~j|J~R05k!k;GmQU1 z>CLXBy;I+5X9zuFcDKr?wg(q~*tU{vT^3U%Xu*az(`spo*{7b5Qgkj$&NRVkcv2UZ zPg{m>9;U1Smtn%}){#pKB1+{bbWNgf9PoP=<1#;JLFzh=+j7SG)A6-)p0(%8)4{Wu z`0rcmiV`LEOo?#~+?ZpcAl>tC%C5;+rmN7rjpQmdDO>8q#omLa0ZM}b$MOus&ss1oSN`i|Tr%4!AUdZ;SzXQkx zcQ^i$tt^Q(FDlkyW?=7DX4gTYJedzZOhp-LH2NbXUBx=fFaPyX%wqG&(zE5M zdWUER-Jy={ZSE-B&Mv`bWF-yh@} zf8y%6N7Msytfh78focbaJ@TZI)Yo?+$GCci?aogtQYY*CX{14Bmp$5{|= zkq+7Mdr~u<3xwU>IHse%{KV_A;TAdI3S=PDec~T9EKKQ@p~~XGyYhHU5&Qh2oGirM zcASskM!IH(qerECBv@2Qu?nag(rgc`_4N%hyW?%vH%O8JL<(IK$;;;`Ycgvzi^&T*y*; zNwI@Ow4ud*LJLL;5sb60p|YCiWDR8{Eg?n4A~k)f4aMp7sjEq(PmW(nVXmQUC0K2j zBoO}W%ING9Y#E!wfW3?soF<%X|2u$+vzQNt%!DfbssqK0%m@%XbGNn1C{ET|;H>jm z?LN7O-x42HE#zmwN_Y2-Yt;;~ur}i?86qAskn{^-?mSOEG;Kt_5K*UCZ=^n^!z{k) z*7xCajnZ=|&&ec}EvexXgJMraRcvDo&dB%`oZ${&v0zAC5OAkjv ztiZ;^$C4QEMg~B5kF$E4vDe6&e)N}e2tn*%2sqY`o#jP{Zx5`lnpab!!l3#1FL3{2 z=1xPs^fPC@Tj37pNig{L_mbwd-ztbc!KR^xk3?m~Wtg1ahA}C5zD90l#youuD%7eU4b10}v5Xu71$Z z*-r}NdvD>cpAH7R&KfySP|ay2&F9DUQvv&@gFbt-|2XXU{3u9y74-Q}{qLOP^kO1s zQgzNaZMWQDVW9ow*9awy_aa;%el4Qyq^!=?S2^2_#M9QW6d!0d7b2Qs%__y%{-k#p zlGz>w_!RVH2=tVK&oIUS*%&e|$M*ZGNr&TXocK#YbPd|-YQsgp8b<4lNZ#Ty)tMf( zq~Ul^*S(GJq)MgniB+lV!g;EmINexip9K+*7?yj_41+L=VK5msGQqh~lt+*1~-WXS*C8SH~TS>VT zJixNXq;db-l3SleEYr6gIjYN2i8B3@gmS5blMPLDTCTT}%FwYANXr5726ljspW<@UA$|z@4PJ(8&+uiL$_y#`x0luF-t;d!=b9 zCzrxx8w!*xDb14J<{-6YC2x?b?4KoUQMHEH2e+2e6AH32T~!x)wO#HShPAJPSNr9? zW51V++AM|M@V}H9FKU%&qiBOvCuD69oi@1o8w^@7%`7bd=VMOt#2s7zziJ&c%DX?SZU2;llpSj^#5Y%=1Fbkb-3Bx0xfaM!p;_h#qv zQ4LyYX~o1Sl9m)x^?d$1I(%|KO)|>OOLKXhiVh*4p)+(fiVvJxq3Fv)%u?AcsaXBFI zanEkt6ttuIvJ-ohB&_+dXc(DE7(^3d(rwt{Qaow+X0P$IXjsyO497)#I-En#xuYEd z$DK$MQoqT#!O8Qv!%d?Szpw_lYD>WEm|B%AR*8UYmm>DDYpy@~pN!2_>7ZOAP6z4kl4yn5ujk5k*P1OE4!w-7GveOA0DOSFPk(Hp*bENYi3VTL1&Bl##dFsmYg*5CCezkzGU$>ufS&5X`IBl3u7{!1RQj%S z*vb0Voa6Le7%(CvUFrd+L*6~^W+sfVj?cMF=1>iYd{L)|`9U%tc zVP$3SmeWw`d~wG1`DN@=nYY}?_S>!vVD(SR*!9!G=@u{BodTcuyZhp@dU7iz!h0*) z_Y-#gEMA^=8PL6WbZ4jc8oxHNy8O`W_sRsnpV-`K1tceT6LHknfA~&pq|Wpf2F5lj z=u>L-Gd-68&uGeb&VUQhll^?vMA&2FcWWYfj_ez!lNF#LKqISB@hpS>&+1#F&&!q$ z9gHshhVIEi(d*NVPpj|hd)52Lr}6r2bOQj|;o>@b%?Q+jq}3UoEpD z4^zOkPwk^q+7pMLW@0>;0)8=A^;#V&xF136v%vYmT6!d~hEEZ@Mi~YJYz_G?P=F|pQ1xdXl&PUcr8Y-{dHP1U?`Fq> zJUA>6=&p?;foew+u+cFJP6MgRC`>oG+Lic~Oxj0-sOUo}GDPS*2BU^KEL32!Kz#*r z3;~Upc?%HEi3ff0M%+Jpl$+r~h)z6Rd4Qs4x0i&hr! z)i{;_%s)JCjwiZ^choxgGIUN5K_XLw07F%dmRJ-Ty(}P?`y+3PkhEXz*gnF^_nv** zuO$lr-IaL?gHoSj

#TJ4Vkh$fJc1Mk5hrP3M9w4@g}?+*T|T7CqJOqhJNu#Hk5l z&Vehy*wE)H6h2mk}#0NX&FU%-Ek%O!Qn?3{AXeudtN~ zi4!zve(?nVZd6C@EL2_rPY@RM)mI7MHQSZJWBKQf#Sx#NlJ+ebO{(2k?edh|R7+My zY^alDxNCSOsGKeOK=0-TdTPcg15dEOReCe9P_0OS4|D1`CZ%d6KoXP%f+ck#=28Mw zHvVxVx0b>gZ}nB<;}H8+UIqh#Qr_E6vSSNG^zy*Wk29e$ULNeP zI7yj_GWa>}8pP!uLWndlRM`6Q&WT|1?Q&q5V zpKLHvN2&MJfL+eH8&iIA`d#&<06`@T5;-MmA#eP8>SI(`m5|DRFEK0_bqvU)Dl}OBC;eKoXlJ_RA2f-j9}QnhDC%$$2O-)KRjXuqD->R7bE}2{ji?b}m=w6bD-z!?R^Aq`h?u$Hb+ML@L-w0mE^R>yz%8kLze4bzX}OYH8GL6;yN%*+A4z zOR2nDwwer0B*=(HNy$k+L47pPy=)0-FGGfsaOegnMQq`LLZY~?wGmex?kBOhA)QG- z2Mcl7OJifPP)agD0IO(SQ9K$5aah7l=I^cxQ7MqH8t8B{3xVd*rth^dMMD>ARRZ1V zMv8gm|Irvnophz}!~>C6%h9yvc8@yC@G$@gfk}&@s?17 z^_UeP;@UBE3Wyy*5{VWjY>wn!N;_V)CFv?g0T|=n`itc8#TL!%1fph@XP|)+l14b| zuNa%OU`NfkQQLwaM7dDgC@{z*1w)G@VM#K-`mgiIl5Te`16Mz;@;4@k+IiForr3ty z-j%@MSohyxkk_nKu(XL(ht={EH%1yrkm<&B;87}HHKiqf1(s7}BS;TwL9|o{?&bYL z1%QSsfYI}N$K`YxoYDtc5VdWAl?76;m(wa5e(rOS>;{)^72iYP_*KS zFrt3@OB8&l*@C|9z#uHb3Q1Kvhdx+2OfFg|L6!rDI6o67EHO4tq9f98f2)V0iR_v| ztUUZ+kQSm-rZ^Hb@N8Y&fa%E3BWZI&27GwkL3lxl2KHNGBox>>%t|-5pNxWY-B?gr zFxt~;Vjx?yqI@ja#kS3|1HUbkLNZBCwcwabW-i-93e;~s((alot%~p0hHZ~pVkGl# zCUkD2ZL5>O3B7G2Pude)Wx4rz(S*Ff5N?9Pg^}%vPNU39S?Yo=0N%fxCHjjbLv-4v zH-)B9tDLa{-3z)^^GG^~gVm${Xn~Kza(AkcBP^K!j6I(gck92AR-NWtJMyLNgwkcXaqWp z7(XZWkJ3IH`xk@^p;T{oeW3gL|yrzbx`CAGP3GmDO*)fH* z8CF$>+Y@?vw5e$5`vKj8gYmARZ3AlRyD>cntAU$w2ad#vBRsMJI*czg3}cu& z5xlP>$>ou7hi1u(V$yBaPi#(B0A$0HS5jc$(@>0`z~i8VKm78FY21UyqrR+)#%uVG!LQB5QN_Je*eb3xR$In`rs+XQcgtm z>@-$n;1~0+NNZaD%+ox5&{F79RS>%+If+LXxnBQRicvMhR4J>X1uPsj0m&JX1UAx` z3Wk5+6e@;3Z6mM&RE3I z*@XC;2sbk$^T+SMRGQ!@VDP{pEZLjBeuY7U0A!I$?ublnrnnKk)%)rZ$*L*V{?6l# z4-*(lHZGXesD*K+ns2JiFR~;rxN`0&LSlT40{O2yU`us8*+xR(3Tz~IPH7Yz#oWJL zLox&ZltlHGlps1EdLe`fWCW2DuM05)Vi_k!`DM)3NYtunH6dtXEf`H>&N$X6*f&{bCTntgop$L$iN`nmK4(On|u``0Y-VJS6i0U&&e^Gob z5Mv6D#fPED3kr=N5)v7*CV`z+poJ2|J;JZyB*8pCiQoZ4lWV6y6_g5&Dj=i=sL(?7 zGg32)86f77{($PormkJ-U9MnSyVgLL#@*FPUTYPpMJ={dG3G)!qC`NutqThMWD=cf z&XvX{Ed$>kk0^~Cq{l>E%!A=ckzOaj&4mDdxI+h(KXY=Y__bT(>`~^ZEq)L^^gw<} z2(?RWExiDOS`6t|feOvv5AeBwq7tvF$Xv{G|saVT@e?5XfF983-Et}8@^W3>p5tfj`&0qi6iu!&5TvSQU*j2^&9F`NNdp`^XxvbulF zadOBR#VAR}G*p#2b%-PzcMcbobEQ}w%uwy>dUe?*@XVIX@uHYXgLEt1oY~JVaybs| zp}&{_$Nz7t;nwJi|6wdG!ibe&a{zSM1#DH5IAKvXsVY+OEXzba(P+N8Z|&juK9()Q z| z1I4H~f)ChVNXbIM%7kRl!TW#f#6c<(&{Nrcgf<%RuJTNrQDdX$jL2xTEYZY-z*|@s zGAKNvg)%Mu#8eV~e8PM5w?Wiw;qQ5tmEs{AMaG4BbmxXacgKgt87%eY8q~?JW?wpk z2!37Yvn2(+mzI=1OsJ^5sMCtPsMC=nH2G$(%%+6VeoSGycD8xV=^t@rMy{|Kpv!j~ zlfrW)be5a{hTfqaLDh`y-B(E4Fyd^#O!08T{>t>bB)T_>V-9UWTh)m`$1ZWqg;Q7C zFC+Gvr|E_PBZ0)d`lb$H%cmVS3>xBQa_cHzhL;4)Z zqG^>8_4ab*EV>M6)TGNppS-fWcU%2Q%TzMFe{U3Ss!6bQKjqf6-3K&ZGzYr2?c}8G z6rANUaLeLnY13*uano1#QoMZOIg8d;d+r<9HGBm$KX@-QH>@Q)RGn{*KUlPL(a*2+ zIdrZPy1(vIe5$q0YQDdyjrUkUi0#P5$JBWB)HzKXZ1_Y5w;kl)DoNcwa^J7@87LT3 zb^K+*-jmf+ldoda<@WG`!>(RXKLL@Khdh4@8+kQ5%<8}pX8MN9=d&jcyP`E1C%t4= zOHK%&iEUbd!1Li_2iIw`JTun9uJEmvqFl4ucl~@lv8C`WG^7P)9~6GQksIqQ&f1cF zO(s37ttCFik>i{Y)Ux&25&kx$mK;oN%K12`M!BOZAJ7svRix)4w`73xf#Grf6!+qH zN4v5wMDzjH4G`=7R?9@57r}G--`O_{$fNoJnS!HTtp`x>8Qt9ICsJcAIdz>lVR#$_N@MhOacGow>KKORsO7!nb= zND{kLmbVdcMI-HPyQE^Bq%B)S zUmbP4wHUG*%S-ZGi^U;udRY0+}dkA2{<;kmU z6SYklcy3yBzWPMAgJbkFwp}#CCUuS)@z2KR=(Tw~kW(o3o&`>KA%H1m@u!Kh5ARH-6_t+W`mDo%ChV5n&t{s3X2V;>s736nGR8Zo?Tfa z#$k^Lb-X}oXx~Rfr{+ym@d|)^EHpuboZwgI9Xo1d8?ih)n&{becu`E3*(WTnVMV;> zc;XV5NVHY^CXKvh;+oq26c(8X0z1 zHaT$MbuGPo!U?&b87V3-o-M;I&?8NWX--jz*=Al~wz;GH@lC3gTT57~nxSlW#Hh}D z7akrzk5@oCvpl353+Mpw)&DFeUsz#DarYqCZyMOGYWwx|3*Q#Qo14~|$AhmMXxR0>b~(#zj*+W; zZQ9HBH=IW#uRYEaDPf%F6Tf~|2!C`HgRrKQ-IISf7$-)CkK3O_KO$qlmX!MHWRi4} zUUuSY@9&H}^qrN-19mx#d;_1MXbIiQUh^<#pF*>cQLk=-q}TiW)irba)1U_2s+rY( zVTTa3XcFmH{U|dhA&Uuxx(QFO8emYWY}MoMd~95K$2w@by^L5r3Z)$Hxn>=}tubI5L+xeE3^w zPM#&(GavEJ9WT>XSzU>U2}Y8likRYQhDsSL7B~4urS825|I@C2xQrAPRY87YJT7;M zmIb|Qt{nkR!tUTlhSIPURas7*B^%&bS5T&cETJhgraZEidDwEJeArmEaP&>9uQTfv zDO!qFD*szt?jBvKjG~FuQ_aSJh;lA7^>FdGywbgjQq^1jnztqOm93lO<%#tz_#=y^3; zYfI{vi)0-=S3&+z0;@;7^u7L6L&`gr;IPOw9hXV2W&*2K{C$(%<(L&uQm$q)>qxx% zE}Lq6q14sxce{;HM9I?jLUs5LAu)|1>Axp`w4v-$W-wOE+D`tIIejaBBm{3sE!&+> zmC6d8P-yULz96sVLhl!)62Qvhj$*7Me<_9adHN(Ie}>iWY)(WisSS+>(WhK{Np%$J+4ySeJ@mC>p{*=RZ6CPBjuaqc9 zd@sHpI<~Iz=X@_wL>rL4e;8KReIAYvLpjc2GN7JvtT;J`P!}=TRbTMuFO zz-=|SsR5bw&#`Lg#vZW7Zr4Td?}k_>!MxR2ciq06U@(T5(M9XC8+}QHvhC}&*aSa; zuj@PJn8*Sz188}?)p*fBNunENJMO-Bxh`^>rz(-6d8RhGo4QW6C;mtsCGEk}+YGRA6Ehy%PGtEbXLg*O%POD+=x=A=8 z7B-fYu|v&IBL-L}{y=*OdZ21EvcpW)rsxsDv!~9hwEJ!k3SN6~(*^Q6 z5N7Z~k<>`kN3K0WpG)9#_0=!FL1VInC>eHEcIKsjQRXGuPmg=M#|iZFzu4Km4|LA;6gcV*FlE;B?rUQ(YV*i|V|z&3qne=u*Q3`h{Q;Y`4{M0Y<9zgS2NQOOjoD=4@h`eS ztiSNz`|b``Wq@1{xb4Q9T!A^?T*W)t@c~lE)c-*qD)b81QQm3g=s%j}%yfFL zd=7Z0_4HK z0SK6j{(zh#w{+Wf?T?(+jOnDTC}7=k%`(~t)|~%1u&aIlPtboaYxGK;zVO6PT#o)5 zQF7_x0im&QFlGwsh{NOoD46Vr1)Q1cuk1?i_-tV zU4*i5KwsLK0hFJ{;~v&+HBzS;-Z-UD1f2dc*lK*WE~&q*wLHkBn(!}Mg+ftrN;gEX z4g$9hIIV_s?V)#v@KSoZ4RBEPG9>!jPI(H(2q0oCoi5AW{<74I2X;4fxo!(iNW#Ot z@otZ1FsvHcdv<^4<3En+4R;cpAo z1LCM)L z*%jrdkAPGO2|9oTodlf-y>^&~ipPHe1&&6XE#P)4vEx3$;hV3OuNC!?GS%yfelN^l zhhN&w&i~&ipU>JdmEwO0;w+XG9&?s;{7=xe-YRc4?foxk1bi|H)R;d7lLmxudT;RstA( z9Y(4~WA8RygwQqwTQPt+f%3{(S~C!4ZTnf(WxiT!=8JuQ`LP=v-UDowPt0MDvtbLPu8c_9{$N7M z`#};U28-ri(c2b(bo_&mH%SMoekemP76?K2GU)I0;#M*nvAqewpgu{*;uGc_!gJ7T zkFQ~8wf-W5>wqX!I4lO*H&O+W>`(zTe^Q7(ouq&gz?q{?Gd>2_H%En?>_Ne}07rb| z+6<_FADeoaQppEHoYKh$g9KnNJo7lxf8TG;!`jppj9X)d=}}0fM^_|8`>R&>q7Ts< z0nKH;efpEJzUSjrISpb3V|}s@jZ%flM(uw9edE6no#J!r?J9QqXpC|^*z12USqXtqh`Ux=dbvK&$LqQ32X zdr$d~8f?5Zp|t){qv+Ue+ihz9{j`hc@NImhW}}47p^UsKCXoqGrb#}LNjT>@ZCc8r z;^8hx2})~xMO})fl%m6@B67&I6W~*Z2u?cLp&pFEWnRZD0w??|iF4H-mWqF;^sepZ z_0}kpmR+S|Y3v%3Fiat)%qah7aWG-izQZwY3PPh;#~cHoT^@-70+UW6lweiC-*)S)wR_Y(K4yGHQ<9toH>7s%xZ~gSaeoInNp&Isuk8gNR}V+K-b5$g8TzQEi#n>*{=r@DBz%cEAS|ah$$;(8ZRX~FcOYvgZ3x+nH60mLL65cPwnU>=V zO$&e2v&p_5Z48*l7It)Ui>*wz4RoUAom#B(`?82Z@SyuEiuk=w?XtFCeXr@|5TcD5 zLoG9+K{UX#4*3{R06s<(i;(~2r%ks|@jt%N{?}+?3nL?##UAs2bI`KQ&`n#&t3h7& zM1%sYJ0Ym;4@@F>zVK82S;DLvDX2bf$ho^6{s)cc#JHz0p@h$9x$V(E*pmjBRvy0> z@={K!TtgicdBE3GPV*qOnCpSzn(IM%n(09-o9cbyHq`_FWugcDWUL3NWvmC&@?#w= z#X|_j1BF}mT!X{a1GM1z4l_B5kuuc|{u#^3+0fD1-O Date: Mon, 14 Feb 2022 15:08:50 -0800 Subject: [PATCH 009/105] Bump llvm-pretty submodule --- deps/llvm-pretty | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/deps/llvm-pretty b/deps/llvm-pretty index 30e0af37af..ca81abf2ec 160000 --- a/deps/llvm-pretty +++ b/deps/llvm-pretty @@ -1 +1 @@ -Subproject commit 30e0af37af977b987eae58daad0a1a1e4a9f2d3b +Subproject commit ca81abf2ecab957aff9e068777203a3af2a19088 From 68eba9fbcd73f34edefdaaa7adb2e46b54efd071 Mon Sep 17 00:00:00 2001 From: robdockins Date: Mon, 14 Feb 2022 15:45:26 -0800 Subject: [PATCH 010/105] Apply suggestions from code review typos Co-authored-by: Ryan Scott --- CHANGES.md | 2 +- doc/manual/manual.md | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/CHANGES.md b/CHANGES.md index 323fad615f..fdc01b341a 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -35,7 +35,7 @@ * A new `llvm_union` function has been added that uses debug information to allow users to select fields from `union` types by - name. This automates the process of manally applying + name. This automates the process of manually applying `llvm_cast_pointer` with the type of the selected union field. Just as with `llvm_field`, debug symbols are required for `llvm_union` to work correctly. diff --git a/doc/manual/manual.md b/doc/manual/manual.md index ad5ddc8bd4..2661c3cf9a 100644 --- a/doc/manual/manual.md +++ b/doc/manual/manual.md @@ -2256,7 +2256,7 @@ flows into. This is especially useful for dealing with C `union` types, as the type information provided by LLVM is imprecise in these cases. -We can automate the process of apply pointer casts if we have debug +We can automate the process of applying pointer casts if we have debug information avaliable: * `llvm_union : SetupValue -> String -> SetupValue` From be6beea5d0f2f8d98b6944cc1aa22bf4e9201710 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Mon, 14 Feb 2022 15:56:24 -0800 Subject: [PATCH 011/105] added support for recognizing multiFixM computations to normComp --- src/SAWScript/Prover/MRSolver.hs | 103 ++++++++++++++++++++++--------- 1 file changed, 73 insertions(+), 30 deletions(-) diff --git a/src/SAWScript/Prover/MRSolver.hs b/src/SAWScript/Prover/MRSolver.hs index 0c888e8589..3d826c72c7 100644 --- a/src/SAWScript/Prover/MRSolver.hs +++ b/src/SAWScript/Prover/MRSolver.hs @@ -216,6 +216,15 @@ doTypeProj _ _ = -- we should only be projecting types for terms that we have already seen... error "doTypeProj" +-- | Recognize a 'Term' as 0 or more projections +asProjAll :: Term -> (Term, [TermProj]) +asProjAll (asRecordSelector -> Just ((asProjAll -> (t, projs)), fld)) = + (t, TermProjRecord fld:projs) +asProjAll (asPairSelector -> Just ((asProjAll -> (t, projs)), isRight)) + | isRight = (t, TermProjRight:projs) + | not isRight = (t, TermProjLeft:projs) +asProjAll t = (t, []) + -- | Names of functions to be used in computations, which are either names bound -- by letrec to for recursive calls to fixed-points, existential variables, or -- (possibly projections of) of global named constants @@ -233,14 +242,8 @@ funNameType (GlobalName gd projs) = -- | Recognize a 'Term' as (possibly a projection of) a global name asTypedGlobalProj :: Recognizer Term (GlobalDef, [TermProj]) -asTypedGlobalProj (asRecordSelector -> - Just ((asTypedGlobalProj -> Just (d, projs)), fld)) = - return (d, TermProjRecord fld:projs) -asTypedGlobalProj (asPairSelector -> - Just ((asTypedGlobalProj -> Just (d, projs)), isRight)) - | isRight = return (d, TermProjRight:projs) - | not isRight = return (d, TermProjLeft:projs) -asTypedGlobalProj (asTypedGlobalDef -> Just glob) = Just (glob, []) +asTypedGlobalProj (asProjAll -> ((asTypedGlobalDef -> Just glob), projs)) = + Just (glob, projs) asTypedGlobalProj _ = Nothing -- | Recognize a 'Term' as (possibly a projection of) a global name @@ -1202,6 +1205,48 @@ asNestedPairs (asPairValue -> Just (x, asNestedPairs -> Just xs)) = Just (x:xs) asNestedPairs (asFTermF -> Just UnitValue) = Just [] asNestedPairs _ = Nothing +-- | Syntactically project then @i@th element of the body of a lambda. That is, +-- assuming the input 'Term' has the form +-- +-- > \ (x1:T1) ... (xn:Tn) -> (e1, (e2, ... (en, ()))) +-- +-- return the bindings @x1:T1,...,xn:Tn@ and @ei@ +synProjFunBody :: Int -> Term -> Maybe ([(LocalName, Term)], Term) +synProjFunBody i (asLambdaList -> (vars, asTupleValue -> Just es)) = + -- NOTE: we are doing 1-based indexing instead of 0-based, thus the -1 + Just $ (vars, es !! (i-1)) +synProjFunBody _ _ = Nothing + +-- | Bind fresh function variables for a @letRecM@ or @multiFixM@ with the given +-- @LetRecTypes@ and definitions for the function bodies as a lambda +mrFreshLetRecVars :: Term -> Term -> MRM [Term] +mrFreshLetRecVars lrts defs_f = + do + -- First, make fresh function constants for all the bound functions, using + -- the names bound by defs_f and just "F" if those run out + let fun_var_names = + map fst (fst $ asLambdaList defs_f) ++ repeat "F" + fun_tps <- asLRTList lrts + funs <- zipWithM mrFreshVar fun_var_names fun_tps + fun_tms <- mapM mrVarTerm funs + + -- Next, apply the definition function defs_f to our function vars, yielding + -- the definitions of the individual letrec-bound functions in terms of the + -- new function constants + defs_tm <- mrApplyAll defs_f fun_tms + defs <- case asNestedPairs defs_tm of + Just defs -> return defs + Nothing -> throwError (MalformedDefsFun defs_f) + + -- Remember the body associated with each fresh function constant + zipWithM_ (\f body -> + lambdaUVarsM body >>= \cl_body -> + mrSetVarInfo f (FunVarInfo cl_body)) funs defs + + -- Finally, return the terms for the fresh function variables + return fun_tms + + -- | Normalize a 'Term' of monadic type to monadic normal form normCompTerm :: Term -> MRM NormComp normCompTerm = normComp . CompTerm @@ -1236,28 +1281,9 @@ normComp (CompTerm t) = return $ ForallM (Type tp) (CompFunTerm body_tm) (isGlobalDef "Prelude.letRecM" -> Just (), [lrts, _, defs_f, body_f]) -> do - -- First, make fresh function constants for all the bound functions, - -- using the names bound by body_f and just "F" if those run out - let fun_var_names = - map fst (fst $ asLambdaList body_f) ++ repeat "F" - fun_tps <- asLRTList lrts - funs <- zipWithM mrFreshVar fun_var_names fun_tps - fun_tms <- mapM mrVarTerm funs - - -- Next, apply the definition function defs_f to our function vars, - -- yielding the definitions of the individual letrec-bound functions in - -- terms of the new function constants - defs_tm <- mrApplyAll defs_f fun_tms - defs <- case asNestedPairs defs_tm of - Just defs -> return defs - Nothing -> throwError (MalformedDefsFun defs_f) - - -- Remember the body associated with each fresh function constant - zipWithM_ (\f body -> - lambdaUVarsM body >>= \cl_body -> - mrSetVarInfo f (FunVarInfo cl_body)) funs defs - - -- Finally, apply the body function to our function vars and recursively + -- Bind fresh function vars for the letrec-bound functions + fun_tms <- mrFreshLetRecVars lrts defs_f + -- Apply the body function to our function vars and recursively -- normalize the resulting computation body_tm <- mrApplyAll body_f fun_tms normComp (CompTerm body_tm) @@ -1272,6 +1298,23 @@ normComp (CompTerm t) = mrApplyAll body args >>= normCompTerm -} + -- Recognize (multiFixM lrts (\ f1 ... fn -> (body1, ..., bodyn))).i args + (asTupleSelector -> + Just (asApplyAll -> (isGlobalDef "Prelude.multiFixM" -> Just (), + [lrts, defs_f]), + i), args) + -- Extract out the function \f1 ... fn -> bodyi + | Just (vars, body_i) <- synProjFunBody i defs_f -> + do + -- Bind fresh function variables for the functions f1 ... fn + fun_tms <- mrFreshLetRecVars lrts defs_f + -- Re-abstract the body + body_f <- liftSC2 scLambdaList vars body_i + -- Apply body_f to f1 ... fn and the top-level arguments + body_tm <- mrApplyAll body_f (fun_tms ++ args) + normComp (CompTerm body_tm) + + -- For an ExtCns, we have to check what sort of variable it is -- FIXME: substitute for evars if they have been instantiated ((asExtCns -> Just ec), args) -> From 968828ccdbab62c0ffeb7172593b659bd82e0080 Mon Sep 17 00:00:00 2001 From: Brian Huffman Date: Mon, 14 Feb 2022 15:43:34 -0800 Subject: [PATCH 012/105] Add `lt` field to `Cmp` dictionary. Also add similar `slt` field to `SignedCmp` dictionary. These fields are used to simplify the formulas generated by the cryptol-saw-core translator for Cryptol operators like `<` and `<$`, avoiding redundant logical connectives. Fixes #1565. --- cryptol-saw-core/saw/Cryptol.sawcore | 51 ++++++++++++++++++++++------ 1 file changed, 41 insertions(+), 10 deletions(-) diff --git a/cryptol-saw-core/saw/Cryptol.sawcore b/cryptol-saw-core/saw/Cryptol.sawcore index fe13215f39..d60f150f88 100644 --- a/cryptol-saw-core/saw/Cryptol.sawcore +++ b/cryptol-saw-core/saw/Cryptol.sawcore @@ -455,6 +455,9 @@ errorBinary s a _ _ = error a s; boolCmp : Bool -> Bool -> Bool -> Bool; boolCmp x y k = ite Bool x (and y k) (or y k); +boolLt : Bool -> Bool -> Bool; +boolLt x y = and (not x) y; + integerCmp : Integer -> Integer -> Bool -> Bool; integerCmp x y k = or (intLt x y) (and (intEq x y) k); @@ -473,14 +476,32 @@ vecCmp n a f xs ys k = foldr (Bool -> Bool) Bool n (\ (f : Bool -> Bool) -> f) k (zipWith a a (Bool -> Bool) f n xs ys); +vecLt : + (n : Nat) -> (a : isort 0) -> + (a -> a -> Bool -> Bool) -> + (a -> a -> Bool) -> + (Vec n a -> Vec n a -> Bool); +vecLt n a f g xs ys = + foldr (Bool -> Bool) Bool n (\ (f : Bool -> Bool) -> f) False + (zipWith a a (Bool -> Bool) f n xs ys); + unitCmp : #() -> #() -> Bool -> Bool; unitCmp _ _ _ = False; +unitLt : #() -> #() -> Bool; +unitLt _ _ = False; + pairCmp : (a b : sort 0) -> (a -> a -> Bool -> Bool) -> (b -> b -> Bool -> Bool) -> a * b -> a * b -> Bool -> Bool; pairCmp a b f g x12 y12 k = f (fst a b x12) (fst a b y12) (g (snd a b x12) (snd a b y12) k); +pairLt : + (a b : sort 0) -> (a -> a -> Bool -> Bool) -> (b -> b -> Bool) -> + a * b -> a * b -> Bool; +pairLt a b f g x y = + f (fst a b x) (fst a b y) (g (snd a b x) (snd a b y)); + -------------------------------------------------------------------------------- -- Dictionaries and overloading @@ -538,19 +559,24 @@ PCmp : sort 0 -> sort 1; PCmp a = #{ cmpEq : PEq a , cmp : a -> a -> Bool -> Bool + , lt : a -> a -> Bool }; PCmpBit : PCmp Bool; -PCmpBit = { cmpEq = PEqBit, cmp = boolCmp }; +PCmpBit = { cmpEq = PEqBit, cmp = boolCmp, lt = boolLt }; PCmpInteger : PCmp Integer; -PCmpInteger = { cmpEq = PEqInteger, cmp = integerCmp }; +PCmpInteger = { cmpEq = PEqInteger, cmp = integerCmp, lt = intLt }; PCmpRational : PCmp Rational; -PCmpRational = { cmpEq = PEqRational, cmp = rationalCmp }; +PCmpRational = { cmpEq = PEqRational, cmp = rationalCmp, lt = ltRational }; PCmpVec : (n : Nat) -> (a : isort 0) -> PCmp a -> PCmp (Vec n a); -PCmpVec n a pa = { cmpEq = PEqVec n a pa.cmpEq, cmp = vecCmp n a pa.cmp }; +PCmpVec n a pa = + { cmpEq = PEqVec n a pa.cmpEq + , cmp = vecCmp n a pa.cmp + , lt = \ (x : Vec n a) -> \ (y : Vec n a) -> vecCmp n a pa.cmp x y False + }; PCmpSeq : (n : Num) -> (a : isort 0) -> PCmp a -> PCmp (seq n a); PCmpSeq n = @@ -560,7 +586,7 @@ PCmpSeq n = n; PCmpWord : (n : Nat) -> PCmp (Vec n Bool); -PCmpWord n = { cmpEq = PEqWord n, cmp = bvCmp n }; +PCmpWord n = { cmpEq = PEqWord n, cmp = bvCmp n, lt = bvult n }; PCmpSeqBool : (n : Num) -> PCmp (seq n Bool); PCmpSeqBool n = @@ -570,12 +596,13 @@ PCmpSeqBool n = n; PCmpUnit : PCmp #(); -PCmpUnit = { cmpEq = PEqUnit, cmp = unitCmp }; +PCmpUnit = { cmpEq = PEqUnit, cmp = unitCmp, lt = unitLt }; PCmpPair : (a b : sort 0) -> PCmp a -> PCmp b -> PCmp (a * b); PCmpPair a b pa pb = { cmpEq = PEqPair a b pa.cmpEq pb.cmpEq , cmp = pairCmp a b pa.cmp pb.cmp + , lt = pairLt a b pa.cmp pb.lt }; -- SignedCmp class @@ -584,12 +611,14 @@ PSignedCmp : sort 0 -> sort 1; PSignedCmp a = #{ signedCmpEq : PEq a , scmp : a -> a -> Bool -> Bool + , slt : a -> a -> Bool }; PSignedCmpVec : (n : Nat) -> (a : isort 0) -> PSignedCmp a -> PSignedCmp (Vec n a); PSignedCmpVec n a pa = { signedCmpEq = PEqVec n a pa.signedCmpEq , scmp = vecCmp n a pa.scmp + , slt = \ (x : Vec n a) -> \ (y : Vec n a) -> vecCmp n a pa.scmp x y False }; PSignedCmpSeq : (n : Num) -> (a : isort 0) -> PSignedCmp a -> PSignedCmp (seq n a); @@ -600,7 +629,7 @@ PSignedCmpSeq n = n; PSignedCmpWord : (n : Nat) -> PSignedCmp (Vec n Bool); -PSignedCmpWord n = { signedCmpEq = PEqWord n, scmp = bvSCmp n }; +PSignedCmpWord n = { signedCmpEq = PEqWord n, scmp = bvSCmp n, slt = bvslt n }; PSignedCmpSeqBool : (n : Num) -> PSignedCmp (seq n Bool); PSignedCmpSeqBool n = @@ -610,12 +639,13 @@ PSignedCmpSeqBool n = n; PSignedCmpUnit : PSignedCmp #(); -PSignedCmpUnit = { signedCmpEq = PEqUnit, scmp = unitCmp }; +PSignedCmpUnit = { signedCmpEq = PEqUnit, scmp = unitCmp, slt = unitLt }; PSignedCmpPair : (a b : sort 0) -> PSignedCmp a -> PSignedCmp b -> PSignedCmp (a * b); PSignedCmpPair a b pa pb = { signedCmpEq = PEqPair a b pa.signedCmpEq pb.signedCmpEq , scmp = pairCmp a b pa.scmp pb.scmp + , slt = pairLt a b pa.scmp pb.slt }; @@ -1110,7 +1140,7 @@ ecNotEq a pa x y = not (ecEq a pa x y); -- Cmp ecLt : (a : sort 0) -> PCmp a -> a -> a -> Bool; -ecLt a pa x y = pa.cmp x y False; +ecLt a pa x y = pa.lt x y; ecGt : (a : sort 0) -> PCmp a -> a -> a -> Bool; ecGt a pa x y = ecLt a pa y x; @@ -1123,7 +1153,7 @@ ecGtEq a pa x y = not (ecLt a pa x y); -- SignedCmp ecSLt : (a : sort 0) -> PSignedCmp a -> a -> a -> Bool; -ecSLt a pa x y = pa.scmp x y False; +ecSLt a pa x y = pa.slt x y; -- Logic ecAnd : (a : sort 0) -> PLogic a -> a -> a -> a; @@ -1592,6 +1622,7 @@ PCmpFloat : (e p : Num) -> PCmp (TCFloat e p); PCmpFloat e p = { cmpEq = PEqFloat e p , cmp = \(x y : TCFloat e p) (k : Bool) -> error Bool "Unimplemented: Cmp Float" + , lt = \(x y : TCFloat e p) -> error Bool "Unimplemented: Cmp Float" }; PZeroFloat : (e p : Num) -> PZero (TCFloat e p); From 390d74b04ad8c11b8a8a5336bd80827c486e3cd3 Mon Sep 17 00:00:00 2001 From: Brian Huffman Date: Mon, 14 Feb 2022 15:54:01 -0800 Subject: [PATCH 013/105] Fix bug in `unitCmp` that caused `<` to return incorrect results. Fixes #1579. --- cryptol-saw-core/saw/Cryptol.sawcore | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cryptol-saw-core/saw/Cryptol.sawcore b/cryptol-saw-core/saw/Cryptol.sawcore index d60f150f88..ea38636eea 100644 --- a/cryptol-saw-core/saw/Cryptol.sawcore +++ b/cryptol-saw-core/saw/Cryptol.sawcore @@ -486,7 +486,7 @@ vecLt n a f g xs ys = (zipWith a a (Bool -> Bool) f n xs ys); unitCmp : #() -> #() -> Bool -> Bool; -unitCmp _ _ _ = False; +unitCmp _ _ k = k; unitLt : #() -> #() -> Bool; unitLt _ _ = False; From fc4c2a70d95c97ceab4e46a7b4222d0744fec271 Mon Sep 17 00:00:00 2001 From: Brian Huffman Date: Mon, 14 Feb 2022 16:56:31 -0800 Subject: [PATCH 014/105] Add `le` field to `Cmp` dictionary. This makes it so that `<=` can be translated to less-than-or-equal operators in saw-core (e.g. `bvsle` or `intLe`) instead of `not` combined with a strict less-than the other way around. --- cryptol-saw-core/saw/Cryptol.sawcore | 33 ++++++++++++++++++++-------- 1 file changed, 24 insertions(+), 9 deletions(-) diff --git a/cryptol-saw-core/saw/Cryptol.sawcore b/cryptol-saw-core/saw/Cryptol.sawcore index ea38636eea..f067fd2b7c 100644 --- a/cryptol-saw-core/saw/Cryptol.sawcore +++ b/cryptol-saw-core/saw/Cryptol.sawcore @@ -232,6 +232,9 @@ ecRatio x y = (); eqRational : Rational -> Rational -> Bool; eqRational x y = error Bool "Unimplemented: (==) Rational"; +leRational : Rational -> Rational -> Bool; +leRational x y = error Bool "Unimplemented: (<=) Rational"; + ltRational : Rational -> Rational -> Bool; ltRational x y = error Bool "Unimplemented: (<) Rational"; @@ -488,6 +491,9 @@ vecLt n a f g xs ys = unitCmp : #() -> #() -> Bool -> Bool; unitCmp _ _ k = k; +unitLe : #() -> #() -> Bool; +unitLe _ _ = True; + unitLt : #() -> #() -> Bool; unitLt _ _ = False; @@ -555,26 +561,29 @@ PEqPair a b pa pb = { eq = pairEq a b pa.eq pb.eq }; -- Cmp class +-- `cmp x y k` computes `if k then x <= y else x < y` PCmp : sort 0 -> sort 1; PCmp a = #{ cmpEq : PEq a , cmp : a -> a -> Bool -> Bool + , le : a -> a -> Bool , lt : a -> a -> Bool }; PCmpBit : PCmp Bool; -PCmpBit = { cmpEq = PEqBit, cmp = boolCmp, lt = boolLt }; +PCmpBit = { cmpEq = PEqBit, cmp = boolCmp, le = implies, lt = boolLt }; PCmpInteger : PCmp Integer; -PCmpInteger = { cmpEq = PEqInteger, cmp = integerCmp, lt = intLt }; +PCmpInteger = { cmpEq = PEqInteger, cmp = integerCmp, le = intLe, lt = intLt }; PCmpRational : PCmp Rational; -PCmpRational = { cmpEq = PEqRational, cmp = rationalCmp, lt = ltRational }; +PCmpRational = { cmpEq = PEqRational, cmp = rationalCmp, le = leRational, lt = ltRational }; PCmpVec : (n : Nat) -> (a : isort 0) -> PCmp a -> PCmp (Vec n a); PCmpVec n a pa = { cmpEq = PEqVec n a pa.cmpEq , cmp = vecCmp n a pa.cmp + , le = \ (x : Vec n a) -> \ (y : Vec n a) -> vecCmp n a pa.cmp x y True , lt = \ (x : Vec n a) -> \ (y : Vec n a) -> vecCmp n a pa.cmp x y False }; @@ -586,7 +595,7 @@ PCmpSeq n = n; PCmpWord : (n : Nat) -> PCmp (Vec n Bool); -PCmpWord n = { cmpEq = PEqWord n, cmp = bvCmp n, lt = bvult n }; +PCmpWord n = { cmpEq = PEqWord n, cmp = bvCmp n, le = bvule n, lt = bvult n }; PCmpSeqBool : (n : Num) -> PCmp (seq n Bool); PCmpSeqBool n = @@ -596,21 +605,24 @@ PCmpSeqBool n = n; PCmpUnit : PCmp #(); -PCmpUnit = { cmpEq = PEqUnit, cmp = unitCmp, lt = unitLt }; +PCmpUnit = { cmpEq = PEqUnit, cmp = unitCmp, le = unitLe, lt = unitLt }; PCmpPair : (a b : sort 0) -> PCmp a -> PCmp b -> PCmp (a * b); PCmpPair a b pa pb = { cmpEq = PEqPair a b pa.cmpEq pb.cmpEq , cmp = pairCmp a b pa.cmp pb.cmp + , le = pairLt a b pa.cmp pb.le , lt = pairLt a b pa.cmp pb.lt }; -- SignedCmp class +-- `scmp x y k` computes `if k then sle x y else slt x y` PSignedCmp : sort 0 -> sort 1; PSignedCmp a = #{ signedCmpEq : PEq a , scmp : a -> a -> Bool -> Bool + , sle : a -> a -> Bool , slt : a -> a -> Bool }; @@ -618,6 +630,7 @@ PSignedCmpVec : (n : Nat) -> (a : isort 0) -> PSignedCmp a -> PSignedCmp (Vec n PSignedCmpVec n a pa = { signedCmpEq = PEqVec n a pa.signedCmpEq , scmp = vecCmp n a pa.scmp + , sle = \ (x : Vec n a) -> \ (y : Vec n a) -> vecCmp n a pa.scmp x y True , slt = \ (x : Vec n a) -> \ (y : Vec n a) -> vecCmp n a pa.scmp x y False }; @@ -629,7 +642,7 @@ PSignedCmpSeq n = n; PSignedCmpWord : (n : Nat) -> PSignedCmp (Vec n Bool); -PSignedCmpWord n = { signedCmpEq = PEqWord n, scmp = bvSCmp n, slt = bvslt n }; +PSignedCmpWord n = { signedCmpEq = PEqWord n, scmp = bvSCmp n, sle = bvsle n, slt = bvslt n }; PSignedCmpSeqBool : (n : Num) -> PSignedCmp (seq n Bool); PSignedCmpSeqBool n = @@ -639,12 +652,13 @@ PSignedCmpSeqBool n = n; PSignedCmpUnit : PSignedCmp #(); -PSignedCmpUnit = { signedCmpEq = PEqUnit, scmp = unitCmp, slt = unitLt }; +PSignedCmpUnit = { signedCmpEq = PEqUnit, scmp = unitCmp, sle = unitLe, slt = unitLt }; PSignedCmpPair : (a b : sort 0) -> PSignedCmp a -> PSignedCmp b -> PSignedCmp (a * b); PSignedCmpPair a b pa pb = { signedCmpEq = PEqPair a b pa.signedCmpEq pb.signedCmpEq , scmp = pairCmp a b pa.scmp pb.scmp + , sle = pairLt a b pa.scmp pb.sle , slt = pairLt a b pa.scmp pb.slt }; @@ -1146,10 +1160,10 @@ ecGt : (a : sort 0) -> PCmp a -> a -> a -> Bool; ecGt a pa x y = ecLt a pa y x; ecLtEq : (a : sort 0) -> PCmp a -> a -> a -> Bool; -ecLtEq a pa x y = not (ecLt a pa y x); +ecLtEq a pa x y = pa.le x y; ecGtEq : (a : sort 0) -> PCmp a -> a -> a -> Bool; -ecGtEq a pa x y = not (ecLt a pa x y); +ecGtEq a pa x y = ecLtEq a pa y x; -- SignedCmp ecSLt : (a : sort 0) -> PSignedCmp a -> a -> a -> Bool; @@ -1622,6 +1636,7 @@ PCmpFloat : (e p : Num) -> PCmp (TCFloat e p); PCmpFloat e p = { cmpEq = PEqFloat e p , cmp = \(x y : TCFloat e p) (k : Bool) -> error Bool "Unimplemented: Cmp Float" + , le = \(x y : TCFloat e p) -> error Bool "Unimplemented: Cmp Float" , lt = \(x y : TCFloat e p) -> error Bool "Unimplemented: Cmp Float" }; From 004862a5a292c4f2470bb5d98fb15ddaa80b4210 Mon Sep 17 00:00:00 2001 From: Brian Huffman Date: Mon, 14 Feb 2022 16:57:30 -0800 Subject: [PATCH 015/105] Eta-contract some definitions in Cryptol.sawcore. This should make it possible for `cryptol_ss` to simplify things like `(<)` to `intLt` even when partially applied. --- cryptol-saw-core/saw/Cryptol.sawcore | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/cryptol-saw-core/saw/Cryptol.sawcore b/cryptol-saw-core/saw/Cryptol.sawcore index f067fd2b7c..3a387e57c4 100644 --- a/cryptol-saw-core/saw/Cryptol.sawcore +++ b/cryptol-saw-core/saw/Cryptol.sawcore @@ -1154,20 +1154,20 @@ ecNotEq a pa x y = not (ecEq a pa x y); -- Cmp ecLt : (a : sort 0) -> PCmp a -> a -> a -> Bool; -ecLt a pa x y = pa.lt x y; +ecLt a pa = pa.lt; ecGt : (a : sort 0) -> PCmp a -> a -> a -> Bool; ecGt a pa x y = ecLt a pa y x; ecLtEq : (a : sort 0) -> PCmp a -> a -> a -> Bool; -ecLtEq a pa x y = pa.le x y; +ecLtEq a pa = pa.le; ecGtEq : (a : sort 0) -> PCmp a -> a -> a -> Bool; ecGtEq a pa x y = ecLtEq a pa y x; -- SignedCmp ecSLt : (a : sort 0) -> PSignedCmp a -> a -> a -> Bool; -ecSLt a pa x y = pa.slt x y; +ecSLt a pa = pa.slt; -- Logic ecAnd : (a : sort 0) -> PLogic a -> a -> a -> a; From bf20290b91a8acb1950686a806e2efb5d449921d Mon Sep 17 00:00:00 2001 From: Brian Huffman Date: Tue, 15 Feb 2022 04:19:05 -0800 Subject: [PATCH 016/105] Update submodule versions. --- deps/argo | 2 +- deps/cryptol | 2 +- deps/cryptol-specs | 2 +- deps/macaw | 2 +- deps/parameterized-utils | 2 +- deps/what4 | 2 +- 6 files changed, 6 insertions(+), 6 deletions(-) diff --git a/deps/argo b/deps/argo index fd8529883c..afee6bb49c 160000 --- a/deps/argo +++ b/deps/argo @@ -1 +1 @@ -Subproject commit fd8529883cd462b5f666506ecce5802bbf6867df +Subproject commit afee6bb49c7831a38316221e7b9721fbc65e88d7 diff --git a/deps/cryptol b/deps/cryptol index 413788c578..7748a619e9 160000 --- a/deps/cryptol +++ b/deps/cryptol @@ -1 +1 @@ -Subproject commit 413788c57877aa58b6656eb7757e711e91d499fc +Subproject commit 7748a619e9e2167097ef680a20578c17803ccc0a diff --git a/deps/cryptol-specs b/deps/cryptol-specs index 031b6c4558..0365dca32d 160000 --- a/deps/cryptol-specs +++ b/deps/cryptol-specs @@ -1 +1 @@ -Subproject commit 031b6c45584150a33aa7c0b817703372b0189492 +Subproject commit 0365dca32d13d6fc12a93ded11b686e18e6490eb diff --git a/deps/macaw b/deps/macaw index d1d71fd973..ad51ae3c54 160000 --- a/deps/macaw +++ b/deps/macaw @@ -1 +1 @@ -Subproject commit d1d71fd973f802483e93dffc968dfbdde12fab59 +Subproject commit ad51ae3c54be97f4f7d15e8eaed9344341ce88e4 diff --git a/deps/parameterized-utils b/deps/parameterized-utils index b0a84444c5..8bb69110b5 160000 --- a/deps/parameterized-utils +++ b/deps/parameterized-utils @@ -1 +1 @@ -Subproject commit b0a84444c5ce096255a54e07179f242ad3d5e9dd +Subproject commit 8bb69110b5c9658c94ef8dcf9f3028d6e7ad32e6 diff --git a/deps/what4 b/deps/what4 index 629f9f1d6f..ac64bcd580 160000 --- a/deps/what4 +++ b/deps/what4 @@ -1 +1 @@ -Subproject commit 629f9f1d6fa586cef756e3cc65c130c14de34e17 +Subproject commit ac64bcd580f552bd22ec5a135fdbcc3d523723a1 From 80084759917cc116ef2cd36dd4c86b6d34de64a0 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Tue, 15 Feb 2022 06:43:54 -0800 Subject: [PATCH 017/105] fixed a bug in withUVars; added some debugging around calling into an SMT solver --- src/SAWScript/Prover/MRSolver.hs | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/src/SAWScript/Prover/MRSolver.hs b/src/SAWScript/Prover/MRSolver.hs index 3d826c72c7..1be18ee8c2 100644 --- a/src/SAWScript/Prover/MRSolver.hs +++ b/src/SAWScript/Prover/MRSolver.hs @@ -146,7 +146,7 @@ import Verifier.SAW.SharedTerm import Verifier.SAW.Recognizer import Verifier.SAW.Cryptol.Monadify -import SAWScript.Proof (termToProp) +import SAWScript.Proof (termToProp, prettyProp) import qualified SAWScript.Prover.SBV as SBV @@ -775,7 +775,7 @@ withUVars = helper [] where helper vars [] m = m $ reverse vars helper vars ((nm,tp):ctx) m = substTerm 0 vars tp >>= \tp' -> - withUVar nm (Type tp') $ \var -> helper (var:vars) ctx m + withUVarLift nm (Type tp') vars $ \var vars' -> helper (var:vars') ctx m -- | Build 'Term's for all the uvars currently in scope, ordered from least to -- most recently bound @@ -1071,7 +1071,10 @@ mrProvableRaw prop_term = do smt_conf <- mrSMTConfig <$> get timeout <- mrSMTTimeout <$> get prop <- liftSC1 termToProp prop_term + debugPrint 2 ("Calling SMT solver with proposition: " ++ + prettyProp defaultPPOpts prop) (smt_res, _) <- liftSC4 SBV.proveUnintSBVIO smt_conf mempty timeout prop + debugPrint 2 "Finished calling SMT solver" case smt_res of Just _ -> return False Nothing -> return True @@ -1083,7 +1086,8 @@ mrProvable bool_tm = do assumps <- mrAssumptions <$> get prop <- liftSC2 scImplies assumps bool_tm >>= liftSC1 scEqTrue forall_prop <- piUVarsM prop - mrProvableRaw forall_prop + forall_prop' <- liftSC2 scGeneralizeExts (getAllExts forall_prop) forall_prop + mrProvableRaw forall_prop' -- | Build a Boolean 'Term' stating that two 'Term's are equal. This is like -- 'scEq' except that it works on open terms. From 73d6468e7db95124637298b69cef40e32a848ac6 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Tue, 15 Feb 2022 11:01:28 -0800 Subject: [PATCH 018/105] changed mrProvable so now it instantiates all uvars with ExtCnss, so that we do not pass the SMT solver uvars that do not occur in the proposition we want to prove --- src/SAWScript/Prover/MRSolver.hs | 19 +++++++++++++------ 1 file changed, 13 insertions(+), 6 deletions(-) diff --git a/src/SAWScript/Prover/MRSolver.hs b/src/SAWScript/Prover/MRSolver.hs index 1be18ee8c2..e6ba22701b 100644 --- a/src/SAWScript/Prover/MRSolver.hs +++ b/src/SAWScript/Prover/MRSolver.hs @@ -794,6 +794,13 @@ lambdaUVarsM t = mrUVarCtx >>= \ctx -> liftSC2 scLambdaList ctx t piUVarsM :: Term -> MRM Term piUVarsM t = mrUVarCtx >>= \ctx -> liftSC2 scPiList ctx t +-- | Instantiate all uvars in a term with fresh 'ExtCns's +instantiateUVarsM :: TermLike a => a -> MRM a +instantiateUVarsM a = + do ctx <- mrUVarCtx + ecs <- mapM (\(nm,tp) -> liftSC2 scFreshEC nm tp >>= liftSC1 scExtCns) ctx + substTermLike 0 ecs a + -- | Convert an 'MRVar' to a 'Term', applying it to all the uvars in scope mrVarTerm :: MRVar -> MRM Term mrVarTerm (MRVar ec) = @@ -1074,10 +1081,11 @@ mrProvableRaw prop_term = debugPrint 2 ("Calling SMT solver with proposition: " ++ prettyProp defaultPPOpts prop) (smt_res, _) <- liftSC4 SBV.proveUnintSBVIO smt_conf mempty timeout prop - debugPrint 2 "Finished calling SMT solver" case smt_res of - Just _ -> return False - Nothing -> return True + Just _ -> + debugPrint 2 "SMT solver response: not provable" >> return False + Nothing -> + debugPrint 2 "SMT solver response: provable" >> return True -- | Test if a Boolean term over the current uvars is provable given the current -- assumptions @@ -1085,9 +1093,8 @@ mrProvable :: Term -> MRM Bool mrProvable bool_tm = do assumps <- mrAssumptions <$> get prop <- liftSC2 scImplies assumps bool_tm >>= liftSC1 scEqTrue - forall_prop <- piUVarsM prop - forall_prop' <- liftSC2 scGeneralizeExts (getAllExts forall_prop) forall_prop - mrProvableRaw forall_prop' + forall_prop <- instantiateUVarsM prop + mrProvableRaw forall_prop -- | Build a Boolean 'Term' stating that two 'Term's are equal. This is like -- 'scEq' except that it works on open terms. From 536dccad9b7c923d9e555af904e55291e7b13f00 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Tue, 15 Feb 2022 12:41:12 -0800 Subject: [PATCH 019/105] whoops, fixed instantiateUVarsM to reverse the list of uvars and substitute outer instantiations into the types of inner ones as it goes --- src/SAWScript/Prover/MRSolver.hs | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/src/SAWScript/Prover/MRSolver.hs b/src/SAWScript/Prover/MRSolver.hs index e6ba22701b..bc63f9dc7b 100644 --- a/src/SAWScript/Prover/MRSolver.hs +++ b/src/SAWScript/Prover/MRSolver.hs @@ -798,7 +798,17 @@ piUVarsM t = mrUVarCtx >>= \ctx -> liftSC2 scPiList ctx t instantiateUVarsM :: TermLike a => a -> MRM a instantiateUVarsM a = do ctx <- mrUVarCtx - ecs <- mapM (\(nm,tp) -> liftSC2 scFreshEC nm tp >>= liftSC1 scExtCns) ctx + -- Remember: the uvar context is outermost to innermost, so we bind + -- variables from left to right, substituting earlier ones into the types + -- of later ones, but all substitutions are in reverse order, since + -- substTerm and friends like innermost bindings first + let helper :: [Term] -> [(LocalName,Term)] -> MRM [Term] + helper tms [] = return tms + helper tms ((nm,tp):vars) = + do tp' <- substTerm 0 tms tp + tm <- liftSC2 scFreshEC nm tp' >>= liftSC1 scExtCns + helper (tm:tms) vars + ecs <- helper [] ctx substTermLike 0 ecs a -- | Convert an 'MRVar' to a 'Term', applying it to all the uvars in scope From ab31ae3f6453efec78f869c655188280865eb538 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Tue, 15 Feb 2022 14:18:34 -0800 Subject: [PATCH 020/105] added support for the maybe eliminator --- src/SAWScript/Prover/MRSolver.hs | 41 +++++++++++++++++++++++++++++--- 1 file changed, 38 insertions(+), 3 deletions(-) diff --git a/src/SAWScript/Prover/MRSolver.hs b/src/SAWScript/Prover/MRSolver.hs index bc63f9dc7b..97563faf49 100644 --- a/src/SAWScript/Prover/MRSolver.hs +++ b/src/SAWScript/Prover/MRSolver.hs @@ -261,6 +261,7 @@ data NormComp | ErrorM Term -- ^ A term @errorM a str@ | Ite Term Comp Comp -- ^ If-then-else computation | Either CompFun CompFun Term -- ^ A sum elimination + | MaybeElim Type Comp CompFun Term -- ^ A maybe elimination | OrM Comp Comp -- ^ an @orM@ computation | ExistsM Type CompFun -- ^ an @existsM@ computation | ForallM Type CompFun -- ^ a @forallM@ computation @@ -363,11 +364,16 @@ instance PrettyInCtx NormComp where prettyInCtx (ErrorM str) = prettyAppList [return "errorM", return "_", parens <$> prettyInCtx str] prettyInCtx (Ite cond t1 t2) = - prettyAppList [return "ite", return "_", prettyInCtx cond, + prettyAppList [return "ite", return "_", parens <$> prettyInCtx cond, parens <$> prettyInCtx t1, parens <$> prettyInCtx t2] prettyInCtx (Either f g eith) = prettyAppList [return "either", return "_", return "_", return "_", - prettyInCtx f, prettyInCtx g, prettyInCtx eith] + parens <$> prettyInCtx f, parens <$> prettyInCtx g, + parens <$> prettyInCtx eith] + prettyInCtx (MaybeElim tp m f mayb) = + prettyAppList [return "maybe", parens <$> prettyInCtx tp, + return (parens "CompM _"), parens <$> prettyInCtx m, + parens <$> prettyInCtx f, parens <$> prettyInCtx mayb] prettyInCtx (OrM t1 t2) = prettyAppList [return "orM", return "_", parens <$> prettyInCtx t1, parens <$> prettyInCtx t2] @@ -419,7 +425,11 @@ instance TermLike NormComp where Ite <$> liftTermLike n i cond <*> liftTermLike n i t1 <*> liftTermLike n i t2 liftTermLike n i (Either f g eith) = Either <$> liftTermLike n i f <*> liftTermLike n i g <*> liftTermLike n i eith - liftTermLike n i (OrM t1 t2) = OrM <$> liftTermLike n i t1 <*> liftTermLike n i t2 + liftTermLike n i (MaybeElim tp m f mayb) = + MaybeElim <$> liftTermLike n i tp <*> liftTermLike n i m + <*> liftTermLike n i f <*> liftTermLike n i mayb + liftTermLike n i (OrM t1 t2) = + OrM <$> liftTermLike n i t1 <*> liftTermLike n i t2 liftTermLike n i (ExistsM tp f) = ExistsM <$> liftTermLike n i tp <*> liftTermLike n i f liftTermLike n i (ForallM tp f) = @@ -435,6 +445,9 @@ instance TermLike NormComp where substTermLike n s (Either f g eith) = Either <$> substTermLike n s f <*> substTermLike n s g <*> substTermLike n s eith + substTermLike n s (MaybeElim tp m f mayb) = + MaybeElim <$> substTermLike n s tp <*> substTermLike n s m + <*> substTermLike n s f <*> substTermLike n s mayb substTermLike n s (OrM t1 t2) = OrM <$> substTermLike n s t1 <*> substTermLike n s t2 substTermLike n s (ExistsM tp f) = @@ -1294,6 +1307,8 @@ normComp (CompTerm t) = return $ Ite cond (CompTerm then_tm) (CompTerm else_tm) (isGlobalDef "Prelude.either" -> Just (), [_, _, _, f, g, eith]) -> return $ Either (CompFunTerm f) (CompFunTerm g) eith + (isGlobalDef "Prelude.maybe" -> Just (), [tp, _, m, f, mayb]) -> + return $ MaybeElim (Type tp) (CompTerm m) (CompFunTerm f) mayb (isGlobalDef "Prelude.orM" -> Just (), [_, m1, m2]) -> return $ OrM (CompTerm m1) (CompTerm m2) (isGlobalDef "Prelude.existsM" -> Just (), [tp, _, body_tm]) -> @@ -1356,6 +1371,8 @@ normBind (Ite cond comp1 comp2) k = return $ Ite cond (CompBind comp1 k) (CompBind comp2 k) normBind (Either f g t) k = return $ Either (compFunComp f k) (compFunComp g k) t +normBind (MaybeElim tp m f t) k = + return $ MaybeElim tp (CompBind m k) (compFunComp f k) t normBind (OrM comp1 comp2) k = return $ OrM (CompBind comp1 k) (CompBind comp2 k) normBind (ExistsM tp f) k = return $ ExistsM tp (compFunComp f k) @@ -1463,6 +1480,24 @@ mrRefines' m1 (Ite cond2 m2 m2') = do not_cond2 <- liftSC1 scNot cond2 withAssumption cond2 (mrRefines m1 m2) withAssumption not_cond2 (mrRefines m1 m2') +mrRefines' (MaybeElim (Type (asEq -> Just (tp,e1,e2))) m1 f1 _) m2 = + do cond <- mrEq' tp e1 e2 + not_cond <- liftSC1 scNot cond + cond_pf <- piUVarsM cond >>= mrFreshVar "pf" >>= mrVarTerm + m1' <- applyNormCompFun f1 cond_pf + cond_holds <- mrProvable cond + if cond_holds then mrRefines m1' m2 else + withAssumption cond (mrRefines m1' m2) >> + withAssumption not_cond (mrRefines m1 m2) +mrRefines' m1 (MaybeElim (Type (asEq -> Just (tp,e1,e2))) m2 f2 _) = + do cond <- mrEq' tp e1 e2 + not_cond <- liftSC1 scNot cond + cond_pf <- piUVarsM cond >>= mrFreshVar "pf" >>= mrVarTerm + m2' <- applyNormCompFun f2 cond_pf + cond_holds <- mrProvable cond + if cond_holds then mrRefines m1 m2' else + withAssumption cond (mrRefines m1 m2') >> + withAssumption not_cond (mrRefines m1 m2) -- FIXME: handle sum elimination -- mrRefines (Either f1 g1 e1) (Either f2 g2 e2) = mrRefines' m1 (ForallM tp f2) = From ae897344d01cb7602a2b3efcba18364398bd8094 Mon Sep 17 00:00:00 2001 From: Rob Dockins Date: Tue, 15 Feb 2022 15:24:37 -0800 Subject: [PATCH 021/105] Add some comments on the variable-binding structure of `scMatch`. --- saw-core/src/Verifier/SAW/Rewriter.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/saw-core/src/Verifier/SAW/Rewriter.hs b/saw-core/src/Verifier/SAW/Rewriter.hs index 0b5e47ba9a..4d267f3435 100644 --- a/saw-core/src/Verifier/SAW/Rewriter.hs +++ b/saw-core/src/Verifier/SAW/Rewriter.hs @@ -181,6 +181,12 @@ asConstantNat t = _ -> Nothing -- | An enhanced matcher that can handle higher-order patterns. +-- +-- This matching procedure will attempt to find an instantiation +-- for the dangling variables appearing in @pattern@. +-- The resulting instantation will return terms that are in the same +-- variable-scoping context as @term@. In particular, if @term@ +-- is closed, then the terms in the instantiation will also be closed. scMatch :: SharedContext -> Term {- ^ pattern -} -> From 5cf7a30fe11edc2da6e3b20343f84f1f9c5b7732 Mon Sep 17 00:00:00 2001 From: Rob Dockins Date: Tue, 15 Feb 2022 15:25:12 -0800 Subject: [PATCH 022/105] Make the `asEqTrue` recognizer more robust --- saw-core/src/Verifier/SAW/Recognizer.hs | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/saw-core/src/Verifier/SAW/Recognizer.hs b/saw-core/src/Verifier/SAW/Recognizer.hs index cea4a0acae..ba3d81ead7 100644 --- a/saw-core/src/Verifier/SAW/Recognizer.hs +++ b/saw-core/src/Verifier/SAW/Recognizer.hs @@ -382,7 +382,14 @@ asEq t = _ -> Nothing asEqTrue :: Recognizer Term Term -asEqTrue = isGlobalDef "Prelude.EqTrue" @> return +asEqTrue t = + case (isGlobalDef "Prelude.EqTrue" @> return) t of + Just x -> Just x + Nothing -> + do (a,x,y) <- asEq t + isGlobalDef "Prelude.Bool" a + isGlobalDef "Prelude.True" y + return x asArrayType :: Recognizer Term (Term :*: Term) asArrayType = (isGlobalDef "Prelude.Array" @> return) <@> return From 02bcea38365991cdc2d962d6cd8cf45c963355ca Mon Sep 17 00:00:00 2001 From: Rob Dockins Date: Tue, 15 Feb 2022 15:28:34 -0800 Subject: [PATCH 023/105] Fix the processing of `ApplyEvidence` to handle quantified theorems. We now capture the instantiation computed in `goalApply` and use it to specialize the input theorem during evidence checking. --- src/SAWScript/Proof.hs | 154 ++++++++++++++++++++++++++++------------- 1 file changed, 105 insertions(+), 49 deletions(-) diff --git a/src/SAWScript/Proof.hs b/src/SAWScript/Proof.hs index 906c92ddee..3ce97ac4b0 100644 --- a/src/SAWScript/Proof.hs +++ b/src/SAWScript/Proof.hs @@ -9,6 +9,7 @@ Stability : provisional {-# LANGUAGE BlockArguments #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ParallelListComp #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} @@ -22,6 +23,7 @@ module SAWScript.Proof , betaReduceProp , falseProp , termToProp + , termToMaybeProp , propToTerm , propToRewriteRule , propSize @@ -112,7 +114,7 @@ import Verifier.SAW.TypedAST import Verifier.SAW.TypedTerm import Verifier.SAW.FiniteValue (FirstOrderValue) import Verifier.SAW.Term.Pretty (SawDoc) -import Verifier.SAW.SCTypeCheck (scTypeCheckError) +import qualified Verifier.SAW.SCTypeCheck as TC import Verifier.SAW.Simulator.Concrete (evalSharedTerm) import Verifier.SAW.Simulator.Value (asFirstOrderTypeValue, Value(..), TValue(..)) @@ -141,10 +143,9 @@ unProp (Prop tm) = tm -- is a sort. termToProp :: SharedContext -> Term -> IO Prop termToProp sc tm = - do mmap <- scGetModuleMap sc - ty <- scTypeOf sc tm - case evalSharedTerm mmap mempty mempty ty of - TValue (VSort s) | s == propSort -> return (Prop tm) + do ty <- scWhnf sc =<< scTypeOf sc tm + case asSort ty of + Just s | s == propSort -> return (Prop tm) _ -> case asLambda tm of Just _ -> @@ -155,6 +156,15 @@ termToProp sc tm = Nothing -> fail $ unlines [ "termToProp: Term is not a proposition", showTerm tm, showTerm ty ] +-- | Turn a saw-core term into a proposition under the type-as-propositions +-- regime. The given term must be a type, which means that its own type +-- is a sort. If it is not, return @Nothing@. +termToMaybeProp :: SharedContext -> Term -> IO (Maybe Prop) +termToMaybeProp sc tm = + do ty <- scWhnf sc =<< scTypeOf sc tm + case asSort ty of + Just s | s == propSort -> return (Just (Prop tm)) + _ -> return Nothing -- | Turn a boolean-valued saw-core term into a proposition by asserting -- that it is equal to the true boolean value. Generalize the proposition @@ -231,7 +241,7 @@ evalProp sc unints (Prop p) = body' <- case asEqTrue body of Just t -> pure t - Nothing -> fail "goal_eval: expected EqTrue" + Nothing -> fail ("goal_eval: expected EqTrue\n" ++ scPrettyTerm defaultPPOpts p) ecs <- traverse (\(nm, ty) -> scFreshEC sc nm ty) args vars <- traverse (scExtCns sc) ecs @@ -415,10 +425,12 @@ data Evidence | SplitEvidence Evidence Evidence -- | This type of evidence is produced when a previously-proved theorem is - -- applied via backward reasoning to prove a goal. Some of the hypotheses - -- of the theorem may be discharged via the included list of evidence, and - -- then the proposition must match the conclusion of the theorem. - | ApplyEvidence Theorem [Evidence] + -- applied via backward reasoning to prove a goal. Pi-quantified variables + -- of the theorem may be specialized either by giving an explicit @Term@ to + -- instantiate the variable, or by giving @Evidence@ for @Prop@ hypotheses. + -- After specializing the given @Theorem@ the result must match the + -- current goal. + | ApplyEvidence Theorem [Either Term Evidence] -- | This type of evidence is used to prove an implication. The included -- proposition must match the hypothesis of the goal, and the included @@ -688,14 +700,19 @@ psStats :: ProofState -> SolverStats psStats = _psStats -- | Verify that the given evidence in fact supports the given proposition. --- Returns the identifers of all the theorems depened on while checking evidence. +-- Returns the identifers of all the theorems depended on while checking evidence. checkEvidence :: SharedContext -> TheoremDB -> Evidence -> Prop -> IO (Set TheoremNonce, TheoremSummary) checkEvidence sc db = \e p -> do hyps <- Map.keysSet <$> readIORef (theoremMap db) check hyps e p where checkApply _hyps (Prop p) [] = return (mempty, mempty, p) - checkApply hyps (Prop p) (e:es) + + -- Check a theorem applied to "Evidence". + -- The given prop must be an implication + -- (i.e., nondependent Pi quantifying over a Prop) + -- and the given evidence must match the expected prop. + checkApply hyps (Prop p) (Right e:es) | Just (_lnm, tp, body) <- asPi p , looseVars body == emptyBitSet = do (d1,sy1) <- check hyps e =<< termToProp sc tp @@ -706,6 +723,18 @@ checkEvidence sc db = \e p -> do hyps <- Map.keysSet <$> readIORef (theoremMap d , showTerm p ] + -- Check a theorem applied to a term. This explicity instantiates + -- a Pi binder with the given term. + checkApply hyps (Prop p) (Left tm:es) = + do propTerm <- scSort sc propSort + let m = do tm' <- TC.typeInferComplete tm + let err = TC.NotFuncTypeInApp (TC.TypedTerm p propTerm) tm' + TC.applyPiTyped err p tm' + res <- TC.runTCM m sc Nothing [] + case res of + Left msg -> fail (unlines (TC.prettyTCError msg)) + Right p' -> checkApply hyps (Prop p') es + checkTheorem :: Set TheoremNonce -> Theorem -> IO () checkTheorem hyps (LocalAssumption p loc n) = unless (Set.member n hyps) $ fail $ unlines @@ -722,7 +751,7 @@ checkEvidence sc db = \e p -> do hyps <- Map.keysSet <$> readIORef (theoremMap d IO (Set TheoremNonce, TheoremSummary) check hyps e p@(Prop ptm) = case e of ProofTerm tm -> - do ty <- scTypeCheckError sc tm + do ty <- TC.scTypeCheckError sc tm ok <- scConvertible sc True ptm ty unless ok $ fail $ unlines [ "Proof term does not prove the required proposition" @@ -1003,34 +1032,44 @@ propToSATQuery sc unintSet prop = Just fot -> filterFirstOrderVars mmap (Map.insert e fot fovars) absvars es processTerm mmap vars xs tm = - case asPi tm of - Just (lnm, tp, body) - | Just x <- asEqTrue tp - , looseVars body == emptyBitSet -> - do processTerm mmap vars (x:xs) body - - -- TODO? Allow universal hypotheses... - - | otherwise -> - case evalFOT mmap tp of - Nothing -> fail ("propToSATQuery: expected first order type: " ++ showTerm tp) - Just fot -> - do ec <- scFreshEC sc lnm tp - etm <- scExtCns sc ec - body' <- instantiateVar sc 0 etm body - processTerm mmap (Map.insert ec fot vars) xs body' - - Nothing -> - case asEqTrue tm of - Nothing -> fail $ "propToSATQuery: expected EqTrue, actual " ++ showTerm tm - Just tmBool -> - do tmNeg <- scNot sc tmBool - return (vars, reverse (tmNeg:xs)) + do -- TODO: I would like to WHNF here, but that evalutes too aggressively + -- because scWhnf evaluates strictly through the `Eq` datatype former. + -- This breaks some proof examples by unfolding things that need to + -- be uninterpreted. + -- tm' <- scWhnf sc tm + let tm' = tm + + case asPi tm' of + Just (lnm, tp, body) -> + do -- same issue with WHNF + -- tp' <- scWhnf sc tp + let tp' = tp + case asEqTrue tp' of + Just x | looseVars body == emptyBitSet -> + processTerm mmap vars (x:xs) body + + -- TODO? Allow universal hypotheses... + + _ -> + case evalFOT mmap tp' of + Nothing -> fail ("propToSATQuery: expected first order type: " ++ showTerm tp') + Just fot -> + do ec <- scFreshEC sc lnm tp' + etm <- scExtCns sc ec + body' <- instantiateVar sc 0 etm body + processTerm mmap (Map.insert ec fot vars) xs body' + + Nothing -> + case asEqTrue tm' of + Nothing -> fail $ "propToSATQuery: expected EqTrue, actual " ++ showTerm tm' + Just tmBool -> + do tmNeg <- scNot sc tmBool + return (vars, reverse (tmNeg:xs)) -- | Given a goal to prove, attempt to apply the given proposition, producing -- new subgoals for any necessary hypotheses of the proposition. Returns -- @Nothing@ if the given proposition does not apply to the goal. -goalApply :: SharedContext -> Prop-> ProofGoal -> IO (Maybe [ProofGoal]) +goalApply :: SharedContext -> Prop -> ProofGoal -> IO (Maybe [Either Term Prop]) goalApply sc rule goal = applyFirst (asPiLists (unProp rule)) where @@ -1042,17 +1081,22 @@ goalApply sc rule goal = applyFirst (asPiLists (unProp rule)) Just inst -> do let inst' = [ Map.lookup i inst | i <- take (length ruleArgs) [0..] ] dummy <- scUnitType sc - let mkNewGoals (Nothing : mts) ((_, prop) : args) = + let mkNewGoals (Nothing : mts) ((nm, prop) : args) = do c0 <- instantiateVarList sc 0 (map (fromMaybe dummy) mts) prop - cs <- mkNewGoals mts args - return (Prop c0 : cs) - mkNewGoals (Just _ : mts) (_ : args) = - mkNewGoals mts args + mp <- termToMaybeProp sc c0 + case mp of + Nothing -> + fail ("goal_apply: could not find instantiation for " ++ show nm) + Just p -> + do cs <- mkNewGoals mts args + return (Right p : cs) + mkNewGoals (Just tm : mts) (_ : args) = + do cs <- mkNewGoals mts args + return (Left tm : cs) mkNewGoals _ _ = return [] + newgoalterms <- mkNewGoals inst' (reverse ruleArgs) - -- TODO, change the "ty" field to list the hypotheses? - let newgoals = reverse [ goal { goalProp = t } | t <- newgoalterms ] - return (Just newgoals) + return (Just (reverse newgoalterms)) asPiLists :: Term -> [([(Text, Term)], Term)] asPiLists t = @@ -1112,8 +1156,20 @@ tacticApply :: (F.MonadFail m, MonadIO m) => SharedContext -> Theorem -> Tactic tacticApply sc thm = Tactic \goal -> liftIO (goalApply sc (thmProp thm) goal) >>= \case Nothing -> fail "apply tactic failed: no match" - Just newgoals -> - return ((), mempty, newgoals, pure . ApplyEvidence thm) + Just newterms -> + let newgoals = + [ goal{ goalProp = p, goalType = goalType goal ++ ".subgoal" ++ show i } + | Right p <- newterms + | i <- [0::Integer ..] + ] in + return ((), mempty, newgoals, \es -> ApplyEvidence thm <$> processEvidence newterms es) + + where + processEvidence :: [Either Term Prop] -> [Evidence] -> IO [Either Term Evidence] + processEvidence (Left tm : xs) es = (Left tm :) <$> processEvidence xs es + processEvidence (Right _ : xs) (e:es) = (Right e :) <$> processEvidence xs es + processEvidence [] [] = pure [] + processEvidence _ _ = fail "apply tactic failed: evidence mismatch" -- | Attempt to simplify a goal by splitting it along conjunctions. If successful, -- two subgoals will be produced, representing the two conjuncts to be proved. @@ -1133,7 +1189,7 @@ tacticTrivial sc = Tactic \goal -> Left err -> fail err Right pf -> do let gp = unProp (goalProp goal) - ty <- liftIO $ scTypeCheckError sc pf + ty <- liftIO $ TC.scTypeCheckError sc pf ok <- liftIO $ scConvertible sc True gp ty unless ok $ fail $ unlines [ "The trivial tactic cannot prove this equality" @@ -1144,7 +1200,7 @@ tacticTrivial sc = Tactic \goal -> tacticExact :: (F.MonadFail m, MonadIO m) => SharedContext -> Term -> Tactic m () tacticExact sc tm = Tactic \goal -> do let gp = unProp (goalProp goal) - ty <- liftIO $ scTypeCheckError sc tm + ty <- liftIO $ TC.scTypeCheckError sc tm ok <- liftIO $ scConvertible sc True gp ty unless ok $ fail $ unlines [ "Proof term does not prove the required proposition" From fddab4f4a5dc7fbb35470d2c69da6294ffd6d9fb Mon Sep 17 00:00:00 2001 From: Rob Dockins Date: Tue, 15 Feb 2022 15:33:51 -0800 Subject: [PATCH 024/105] More accurate reporting of theorem status in `summarize_verification`. --- src/SAWScript/VerificationSummary.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/SAWScript/VerificationSummary.hs b/src/SAWScript/VerificationSummary.hs index 60799cdd1a..35e8d10613 100644 --- a/src/SAWScript/VerificationSummary.hs +++ b/src/SAWScript/VerificationSummary.hs @@ -172,9 +172,10 @@ prettyVerificationSummary vs@(VerificationSummary jspecs lspecs thms) = prettyTheorems ts = sectionWithItems "Theorems Proved or Assumed" (item . prettyTheorem) ts prettyTheorem t = - vsep [ if Set.null (solverStatsSolvers (thmStats t)) - then "Axiom:" - else "Theorem:" + vsep [ case thmSummary t of + ProvedTheorem{} -> "Theorem:" + TestedTheorem n -> "Theorem (randomly tested on" <+> viaShow n <+> "samples):" + AdmittedTheorem{} -> "Axiom:" , code (indent 2 (ppProp PP.defaultPPOpts (thmProp t))) , "" ] From e6ff0ec813b20609db6ec5a887b20b4430f05540 Mon Sep 17 00:00:00 2001 From: Rob Dockins Date: Tue, 15 Feb 2022 16:16:34 -0800 Subject: [PATCH 025/105] Add a new `specialize_theorem` command that allows users to do explicit forward reasoning from theorems. --- src/SAWScript/Builtins.hs | 8 ++++++++ src/SAWScript/Interpreter.hs | 7 +++++++ src/SAWScript/Proof.hs | 25 +++++++++++++++++++++++++ 3 files changed, 40 insertions(+) diff --git a/src/SAWScript/Builtins.hs b/src/SAWScript/Builtins.hs index d9c2244a42..f67330163c 100644 --- a/src/SAWScript/Builtins.hs +++ b/src/SAWScript/Builtins.hs @@ -1443,6 +1443,14 @@ core_thm input = thm <- io (proofByTerm sc db t pos "core_thm") SV.returnProof thm +specialize_theorem :: Theorem -> [TypedTerm] -> TopLevel Theorem +specialize_theorem thm ts = + do sc <- getSharedContext + db <- roTheoremDB <$> getTopLevelRO + pos <- SV.getPosition + thm' <- io (specializeTheorem sc db pos "specialize_theorem" thm (map ttTerm ts)) + SV.returnProof thm' + get_opt :: Int -> TopLevel String get_opt n = do prog <- io $ System.Environment.getProgName diff --git a/src/SAWScript/Interpreter.hs b/src/SAWScript/Interpreter.hs index aba99d5e22..6a5aba8d6f 100644 --- a/src/SAWScript/Interpreter.hs +++ b/src/SAWScript/Interpreter.hs @@ -2247,6 +2247,13 @@ primitives = Map.fromList Current [ "Create a theorem from the type of the given core expression." ] + , prim "specialize_theorem" "Theorem -> [Term] -> TopLevel Theorem" + (pureVal specialize_theorem) + Experimental + [ "Specialize a theorem by instantiating universal quantifiers" + , "with the given list of terms." + ] + , prim "get_opt" "Int -> String" (funVal1 get_opt) Current diff --git a/src/SAWScript/Proof.hs b/src/SAWScript/Proof.hs index 3ce97ac4b0..75dc6d81b2 100644 --- a/src/SAWScript/Proof.hs +++ b/src/SAWScript/Proof.hs @@ -54,6 +54,7 @@ module SAWScript.Proof , proofByTerm , constructTheorem , validateTheorem + , specializeTheorem , Evidence(..) , checkEvidence @@ -351,6 +352,7 @@ reachableTheorems db roots = | otherwise = panic "reachableTheorems" ["Could not find theorem with identifier", show (indexValue curr)] + -- | Check that the purported theorem is valid. -- -- This checks that the given theorem object does not correspond @@ -584,6 +586,29 @@ constructTheorem sc db p e loc ploc rsn elapsed = , _thmSummary = sy } + +-- | Given a theorem with quantified variables, build a new theorem that +-- specializes the leading quantifiers with the given terms. +-- This will fail if the given terms to not match the quantifier structure +-- of the given theorem. +specializeTheorem :: SharedContext -> TheoremDB -> Pos -> Text -> Theorem -> [Term] -> IO Theorem +specializeTheorem _sc _db _loc _rsn thm [] = return thm +specializeTheorem sc db loc rsn thm ts0 = + do let p0 = unProp (_thmProp thm) + res <- TC.runTCM (loop p0 ts0) sc Nothing [] + case res of + Left err -> fail (unlines (["specialize_theorem: failed to specialize"] ++ TC.prettyTCError err)) + Right p' -> + constructTheorem sc db (Prop p') (ApplyEvidence thm (map Left ts0)) loc Nothing rsn 0 + + where + loop p [] = return p + loop p (t:ts) = + do prop <- liftIO (scSort sc propSort) + t' <- TC.typeInferComplete t + p' <- TC.applyPiTyped (TC.NotFuncTypeInApp (TC.TypedTerm p prop) t') p t' + loop p' ts + -- | Admit the given theorem without evidence. -- The provided message allows the user to -- explain why this proposition is being admitted. From 0a0aa7a4b8071c8fff11b60bb5570a8b9552c84c Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Wed, 16 Feb 2022 16:55:58 -0800 Subject: [PATCH 026/105] added support for SAW core bitvector notation 0xXXXX and 0bBBBBB, both in the SAW core parser and pretty-printer --- saw-core/saw-core.cabal | 1 + saw-core/src/Verifier/SAW/Grammar.y | 2 ++ saw-core/src/Verifier/SAW/Lexer.x | 17 +++++++++++++++++ saw-core/src/Verifier/SAW/Term/Pretty.hs | 18 ++++++++++++++++++ saw-core/src/Verifier/SAW/Typechecker.hs | 5 +++++ saw-core/src/Verifier/SAW/UntypedAST.hs | 3 +++ 6 files changed, 46 insertions(+) diff --git a/saw-core/saw-core.cabal b/saw-core/saw-core.cabal index 6775dc328b..aefb6bd743 100644 --- a/saw-core/saw-core.cabal +++ b/saw-core/saw-core.cabal @@ -26,6 +26,7 @@ library build-depends: base == 4.*, array, + bv-sized, bytestring, containers, data-inttrie, diff --git a/saw-core/src/Verifier/SAW/Grammar.y b/saw-core/src/Verifier/SAW/Grammar.y index 9ecdf4fecf..a37fee8d01 100644 --- a/saw-core/src/Verifier/SAW/Grammar.y +++ b/saw-core/src/Verifier/SAW/Grammar.y @@ -80,6 +80,7 @@ import Verifier.SAW.Lexer 'injectCode' { PosPair _ (TKey "injectCode") } nat { PosPair _ (TNat _) } + bvlit { PosPair _ (TBitvector _) } '_' { PosPair _ (TIdent "_") } ident { PosPair _ (TIdent _) } identrec { PosPair _ (TRecursor _) } @@ -177,6 +178,7 @@ AppTerm : AtomTerm { $1 } AtomTerm :: { Term } AtomTerm : nat { NatLit (pos $1) (tokNat (val $1)) } + | bvlit { BVLit (pos $1) (tokBits (val $1)) } | string { StringLit (pos $1) (Text.pack (tokString (val $1))) } | Ident { Name $1 } | IdentRec { Recursor Nothing $1 } diff --git a/saw-core/src/Verifier/SAW/Lexer.x b/saw-core/src/Verifier/SAW/Lexer.x index 53bc175153..ffb2e9f77b 100644 --- a/saw-core/src/Verifier/SAW/Lexer.x +++ b/saw-core/src/Verifier/SAW/Lexer.x @@ -37,6 +37,8 @@ import Control.Monad.State.Strict import qualified Data.ByteString.Lazy as B import Data.ByteString.Lazy.UTF8 (toString) import Data.Word (Word8) +import Data.Bits +import Data.Char (digitToInt) import Numeric.Natural import Verifier.SAW.Position @@ -86,6 +88,8 @@ $white+; "-}" { \_ -> TCmntE } \" @string* \" { TString . read } @num { TNat . read } +"0x"@hex { TBitvector . readHexBV . drop 2 } +"0b"[0-1]+ { TBitvector . readBinBV . drop 2 } @key { TKey } @ident { TIdent } @ident "#rec" { TRecursor . dropRecSuffix } @@ -96,6 +100,7 @@ data Token = TIdent { tokIdent :: String } -- ^ Identifier | TRecursor { tokRecursor :: String } -- ^ Recursor | TNat { tokNat :: Natural } -- ^ Natural number literal + | TBitvector { tokBits :: [Bool] } -- ^ Bitvector literal | TString { tokString :: String } -- ^ String literal | TKey String -- ^ Keyword or predefined symbol | TEnd -- ^ End of file. @@ -108,12 +113,24 @@ data Token dropRecSuffix :: String -> String dropRecSuffix str = take (length str - 4) str +-- | Convert a hexadecimal string to a big endian list of bits +readHexBV :: String -> [Bool] +readHexBV = + concatMap (\c -> let i = digitToInt c in + [testBit i 3, testBit i 2, testBit i 1, testBit i 0]) + +-- | Convert a binary string to a big endian list of bits +readBinBV :: String -> [Bool] +readBinBV = map (\c -> c == '1') + ppToken :: Token -> String ppToken tkn = case tkn of TIdent s -> s TRecursor s -> s ++ "#rec" TNat n -> show n + TBitvector bits -> + "0b" ++ map (\b -> if b then '1' else '0') bits TString s -> show s TKey s -> s TEnd -> "END" diff --git a/saw-core/src/Verifier/SAW/Term/Pretty.hs b/saw-core/src/Verifier/SAW/Term/Pretty.hs index 981cfbe663..c857ab1ba6 100644 --- a/saw-core/src/Verifier/SAW/Term/Pretty.hs +++ b/saw-core/src/Verifier/SAW/Term/Pretty.hs @@ -6,6 +6,7 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE PatternGuards #-} {- | Module : Verifier.SAW.Term.Pretty @@ -40,6 +41,7 @@ module Verifier.SAW.Term.Pretty , ppName ) where +import Data.Char (intToDigit) import Data.Maybe (isJust) import Control.Monad.Reader import Control.Monad.State.Strict as State @@ -62,6 +64,7 @@ import qualified Data.IntMap.Strict as IntMap import Verifier.SAW.Name import Verifier.SAW.Term.Functor import Verifier.SAW.Utils (panic) +import Verifier.SAW.Recognizer -------------------------------------------------------------------------------- -- * Doc annotations @@ -469,11 +472,26 @@ ppFlatTermF prec tf = RecordProj e fld -> ppProj fld <$> ppTerm' PrecArg e Sort s h -> return ((if h then pretty ("i"::String) else mempty) <> viaShow s) NatLit i -> ppNat <$> (ppOpts <$> ask) <*> return (toInteger i) + ArrayValue (asBoolType -> Just _) args + | Just bits <- mapM asBool $ V.toList args -> + if length bits `mod` 4 == 0 then + return $ pretty ("0x" ++ ppBitsToHex bits) + else + return $ pretty ("0b" ++ map (\b -> if b then '1' else '0') bits) ArrayValue _ args -> ppArrayValue <$> mapM (ppTerm' PrecTerm) (V.toList args) StringLit s -> return $ viaShow s ExtCns cns -> annotate ExtCnsStyle <$> ppBestName (ecName cns) +-- | Pretty-print a big endian list of bit values as a hexadecimal number +ppBitsToHex :: [Bool] -> String +ppBitsToHex (b8:b4:b2:b1:bits') = + intToDigit (8 * toInt b8 + 4 * toInt b4 + 2 * toInt b2 + toInt b1) : + ppBitsToHex bits' + where toInt True = 1 + toInt False = 0 +ppBitsToHex _ = "" + -- | Pretty-print a name, using the best unambiguous alias from the -- naming environment. ppBestName :: NameInfo -> PPM SawDoc diff --git a/saw-core/src/Verifier/SAW/Typechecker.hs b/saw-core/src/Verifier/SAW/Typechecker.hs index cf5bc73700..c2ccb0903a 100644 --- a/saw-core/src/Verifier/SAW/Typechecker.hs +++ b/saw-core/src/Verifier/SAW/Typechecker.hs @@ -278,6 +278,11 @@ typeInferCompleteTerm (Un.VecLit _ ts) = type_of_tp <- typeInfer tp typeInferComplete (ArrayValue (TypedTerm tp type_of_tp) $ V.fromList typed_ts) +typeInferCompleteTerm (Un.BVLit _ []) = throwTCError EmptyVectorLit +typeInferCompleteTerm (Un.BVLit _ bits) = + do tp <- liftTCM scBoolType + bit_tms <- mapM (liftTCM scBool) bits + typeInferComplete $ ArrayValue tp $ V.fromList bit_tms typeInferCompleteTerm (Un.BadTerm _) = -- Should be unreachable, since BadTerms represent parse errors, that should diff --git a/saw-core/src/Verifier/SAW/UntypedAST.hs b/saw-core/src/Verifier/SAW/UntypedAST.hs index b09ee9a1ff..d889210fe2 100644 --- a/saw-core/src/Verifier/SAW/UntypedAST.hs +++ b/saw-core/src/Verifier/SAW/UntypedAST.hs @@ -84,6 +84,8 @@ data Term | StringLit Pos Text -- | Vector literal. | VecLit Pos [Term] + -- | Bitvector literal. + | BVLit Pos [Bool] | BadTerm Pos deriving (Show, TH.Lift) @@ -128,6 +130,7 @@ instance Positioned Term where NatLit p _ -> p StringLit p _ -> p VecLit p _ -> p + BVLit p _ -> p BadTerm p -> p instance Positioned TermVar where From a1d5e4fa27ded8bdbde323af79e758187fc81553 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Thu, 17 Feb 2022 17:31:12 -0800 Subject: [PATCH 027/105] added applyGlobalOpenTerm and vectorTypeOpenTerm combinators --- saw-core/src/Verifier/SAW/OpenTerm.hs | 13 +++++++++++-- 1 file changed, 11 insertions(+), 2 deletions(-) diff --git a/saw-core/src/Verifier/SAW/OpenTerm.hs b/saw-core/src/Verifier/SAW/OpenTerm.hs index d271153071..57c1fd7ad0 100644 --- a/saw-core/src/Verifier/SAW/OpenTerm.hs +++ b/saw-core/src/Verifier/SAW/OpenTerm.hs @@ -27,13 +27,14 @@ module Verifier.SAW.OpenTerm ( unitOpenTerm, unitTypeOpenTerm, stringLitOpenTerm, stringTypeOpenTerm, trueOpenTerm, falseOpenTerm, boolOpenTerm, boolTypeOpenTerm, - arrayValueOpenTerm, bvLitOpenTerm, bvTypeOpenTerm, + arrayValueOpenTerm, vectorTypeOpenTerm, bvLitOpenTerm, bvTypeOpenTerm, pairOpenTerm, pairTypeOpenTerm, pairLeftOpenTerm, pairRightOpenTerm, tupleOpenTerm, tupleTypeOpenTerm, projTupleOpenTerm, tupleOpenTerm', tupleTypeOpenTerm', recordOpenTerm, recordTypeOpenTerm, projRecordOpenTerm, ctorOpenTerm, dataTypeOpenTerm, globalOpenTerm, extCnsOpenTerm, - applyOpenTerm, applyOpenTermMulti, applyPiOpenTerm, piArgOpenTerm, + applyOpenTerm, applyOpenTermMulti, applyGlobalOpenTerm, + applyPiOpenTerm, piArgOpenTerm, lambdaOpenTerm, lambdaOpenTermMulti, piOpenTerm, piOpenTermMulti, arrowOpenTerm, letOpenTerm, sawLetOpenTerm, -- * Monadic operations for building terms with binders @@ -179,6 +180,10 @@ bvLitOpenTerm :: [Bool] -> OpenTerm bvLitOpenTerm bits = arrayValueOpenTerm boolTypeOpenTerm $ map boolOpenTerm bits +-- | Create a SAW core term for a vector type +vectorTypeOpenTerm :: OpenTerm -> OpenTerm -> OpenTerm +vectorTypeOpenTerm n a = applyGlobalOpenTerm "Prelude.Vec" [n,a] + -- | Create a SAW core term for the type of a bitvector bvTypeOpenTerm :: Integral a => a -> OpenTerm bvTypeOpenTerm n = @@ -287,6 +292,10 @@ applyOpenTerm (OpenTerm f) (OpenTerm arg) = applyOpenTermMulti :: OpenTerm -> [OpenTerm] -> OpenTerm applyOpenTermMulti = foldl applyOpenTerm +-- | Apply a named global to 0 or more arguments +applyGlobalOpenTerm :: Ident -> [OpenTerm] -> OpenTerm +applyGlobalOpenTerm ident = applyOpenTermMulti (globalOpenTerm ident) + -- | Compute the output type of applying a function of a given type to an -- argument. That is, given @tp@ and @arg@, compute the type of applying any @f@ -- of type @tp@ to @arg@. From 2820052bfa1b71fb2f72eaa3d577d82a5140b4d0 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Thu, 17 Feb 2022 17:31:50 -0800 Subject: [PATCH 028/105] trying a new approach to getting SMT solving to work, by substiting uninterpreted functions in place of variable-length vectors --- src/SAWScript/Prover/MRSolver.hs | 127 ++++++++++++++++++++++++++++--- 1 file changed, 117 insertions(+), 10 deletions(-) diff --git a/src/SAWScript/Prover/MRSolver.hs b/src/SAWScript/Prover/MRSolver.hs index 97563faf49..a9c51b5e80 100644 --- a/src/SAWScript/Prover/MRSolver.hs +++ b/src/SAWScript/Prover/MRSolver.hs @@ -135,6 +135,7 @@ import Control.Monad.Trans.Maybe import qualified Data.IntMap as IntMap import Data.Map (Map) import qualified Data.Map as Map +import qualified Data.Set as Set import Prettyprinter @@ -144,8 +145,14 @@ import Verifier.SAW.Term.Pretty import Verifier.SAW.SCTypeCheck import Verifier.SAW.SharedTerm import Verifier.SAW.Recognizer +import Verifier.SAW.OpenTerm import Verifier.SAW.Cryptol.Monadify +import Verifier.SAW.Simulator +import qualified Verifier.SAW.Prim as Prim +import Verifier.SAW.Simulator.TermModel +import Verifier.SAW.Simulator.Prims + import SAWScript.Proof (termToProp, prettyProp) import qualified SAWScript.Prover.SBV as SBV @@ -691,11 +698,9 @@ catchErrorEither m = catchError (Right <$> m) (return . Left) -- FIXME: replace these individual lifting functions with a more general -- typeclass like LiftTCM -{- -- | Lift a nullary SharedTerm computation into 'MRM' liftSC0 :: (SharedContext -> IO a) -> MRM a liftSC0 f = (mrSC <$> get) >>= \sc -> liftIO (f sc) --} -- | Lift a unary SharedTerm computation into 'MRM' liftSC1 :: (SharedContext -> a -> IO b) -> a -> MRM b @@ -714,6 +719,11 @@ liftSC4 :: (SharedContext -> a -> b -> c -> d -> IO e) -> a -> b -> c -> d -> MRM e liftSC4 f a b c d = (mrSC <$> get) >>= \sc -> liftIO (f sc a b c d) +-- | Lift a quaternary SharedTerm computation into 'MRM' +liftSC5 :: (SharedContext -> a -> b -> c -> d -> e -> IO f) -> + a -> b -> c -> d -> e -> MRM f +liftSC5 f a b c d e = (mrSC <$> get) >>= \sc -> liftIO (f sc a b c d e) + -- | Apply a 'Term' to a list of arguments and beta-reduce in Mr. Monad mrApplyAll :: Term -> [Term] -> MRM Term mrApplyAll f args = liftSC2 scApplyAll f args >>= liftSC1 betaNormalize @@ -807,9 +817,9 @@ lambdaUVarsM t = mrUVarCtx >>= \ctx -> liftSC2 scLambdaList ctx t piUVarsM :: Term -> MRM Term piUVarsM t = mrUVarCtx >>= \ctx -> liftSC2 scPiList ctx t --- | Instantiate all uvars in a term with fresh 'ExtCns's -instantiateUVarsM :: TermLike a => a -> MRM a -instantiateUVarsM a = +-- | Instantiate all uvars in a term using the supplied function +instantiateUVarsM :: TermLike a => (LocalName -> Term -> MRM Term) -> a -> MRM a +instantiateUVarsM f a = do ctx <- mrUVarCtx -- Remember: the uvar context is outermost to innermost, so we bind -- variables from left to right, substituting earlier ones into the types @@ -819,7 +829,7 @@ instantiateUVarsM a = helper tms [] = return tms helper tms ((nm,tp):vars) = do tp' <- substTerm 0 tms tp - tm <- liftSC2 scFreshEC nm tp' >>= liftSC1 scExtCns + tm <- f nm tp' helper (tm:tms) vars ecs <- helper [] ctx substTermLike 0 ecs a @@ -1069,8 +1079,8 @@ debugPretty i pp = debugPrint i $ renderSawDoc defaultPPOpts pp -- | Pretty-print an object in the current context if the current debug level is -- at least the supplied 'Int' -_debugPrettyInCtx :: PrettyInCtx a => Int -> a -> MRM () -_debugPrettyInCtx i a = +debugPrettyInCtx :: PrettyInCtx a => Int -> a -> MRM () +debugPrettyInCtx i a = (mrUVars <$> get) >>= \ctx -> debugPrint i (showInCtx (map fst ctx) a) -- | Pretty-print an object relative to the current context @@ -1093,6 +1103,86 @@ mrDebugPPPrefixSep i pre a1 sp a2 = -- * Calling Out to SMT ---------------------------------------------------------------------- +-- | Test if a 'Term' is a 'BVVec' type +asBVVecType :: Recognizer Term (Term, Term, Term) +asBVVecType (asApplyAll -> + (isGlobalDef "Prelude.Vec" -> Just _, + [(asApplyAll -> + (isGlobalDef "Prelude.bvToNat" -> Just _, [n, len])), a])) = + Just (n, len, a) +asBVVecType _ = Nothing + +-- | Apply @genBVVec@ to arguments @n@, @len@, and @a@, along with a function of +-- type @Vec n Bool -> a@ +genBVVecTerm :: SharedContext -> Term -> Term -> Term -> Term -> IO Term +genBVVecTerm sc n_tm len_tm a_tm f_tm = + let n = closedOpenTerm n_tm + len = closedOpenTerm len_tm + a = closedOpenTerm a_tm + f = closedOpenTerm f_tm in + completeOpenTerm sc $ + applyOpenTermMulti (globalOpenTerm "Prelude.genBVVec") + [n, len, a, + lambdaOpenTerm "i" (vectorTypeOpenTerm n boolTypeOpenTerm) $ \i -> + lambdaOpenTerm "_" (applyGlobalOpenTerm "Prelude.is_bvult" [n, i, len]) $ \_ -> + applyOpenTerm f i] + +-- | Match a term of the form @genBVVec n len a (\ i _ -> f i)@ and return @f@ +asGenBVVecTerm :: Recognizer Term Term +asGenBVVecTerm (asApplyAll -> + (isGlobalDef "Prelude.genBVVec" -> Just _, + [_, _, _, + (asLambdaList -> ([_,_], asApp -> + Just (f, asLocalVar -> Just 1)))])) = + Just f +asGenBVVecTerm _ = Nothing + +type TmPrim = Prim TermModel + +-- | An implementation of a primitive function that expects a @genBVVec@ term +primGenBVVec :: (Term -> TmPrim) -> TmPrim +primGenBVVec f = + PrimFilterFun "genBVVecPrim" + (\case + VExtra (VExtraTerm _ (asGenBVVecTerm -> Just g)) -> return g + _ -> mzero) + f + +-- | An implementation of a primitive function that expects a bitvector term +primBVTermFun :: SharedContext -> (Term -> TmPrim) -> TmPrim +primBVTermFun sc = + PrimFilterFun "primBVTermFun" $ + \case + VExtra (VExtraTerm _ w_tm) -> return w_tm + VWord (Left (_,w_tm)) -> return w_tm + VWord (Right bv) -> + lift $ scBvConst sc (fromIntegral (Prim.width bv)) (Prim.unsigned bv) + _ -> mzero + +-- | Implementations of primitives for normalizing SMT terms +smtNormPrims :: SharedContext -> Map Ident TmPrim +smtNormPrims sc = Map.fromList + [ + ("Prelude.genBVVec", + Prim (do tp <- scTypeOfGlobal sc "Prelude.genBVVec" + VExtra <$> VExtraTerm (VTyTerm (mkSort 1) tp) <$> + scGlobalDef sc "Prelude.genBVVec")), + + ("Prelude.atBVVec", + PrimFun $ \_n -> PrimFun $ \_len -> tvalFun $ \a -> + primGenBVVec $ \f -> primBVTermFun sc $ \ix -> PrimFun $ \_pf -> + Prim (VExtra <$> VExtraTerm a <$> scApply sc f ix)) + ] + +-- | Normalize a 'Term' before building an SMT query for it +normSMTProp :: Term -> MRM Term +normSMTProp t = + debugPrint 2 "Normalizing term:" >> + debugPrettyInCtx 2 t >> + liftSC0 return >>= \sc -> + liftSC0 scGetModuleMap >>= \modmap -> + liftSC5 normalizeSharedTerm modmap (smtNormPrims sc) Map.empty Set.empty t + -- | Test if a closed Boolean term is "provable", i.e., its negation is -- unsatisfiable, using an SMT solver. By "closed" we mean that it contains no -- uvars or 'MRVar's. @@ -1116,8 +1206,25 @@ mrProvable :: Term -> MRM Bool mrProvable bool_tm = do assumps <- mrAssumptions <$> get prop <- liftSC2 scImplies assumps bool_tm >>= liftSC1 scEqTrue - forall_prop <- instantiateUVarsM prop - mrProvableRaw forall_prop + prop_inst <- flip instantiateUVarsM prop $ \nm tp -> + liftSC1 scWhnf tp >>= \case + (asBVVecType -> Just (n, len, a)) -> + -- For variables of type BVVec, create a Vec n Bool -> a function as an + -- ExtCns and apply genBVVec to it + do + debugPrint 2 ("Is BVVec variable: " ++ show nm) + ec_tp <- + liftSC1 completeOpenTerm $ + arrowOpenTerm "_" (applyOpenTermMulti (globalOpenTerm "Prelude.Vec") + [closedOpenTerm n, boolTypeOpenTerm]) + (closedOpenTerm a) + ec <- liftSC2 scFreshEC nm ec_tp >>= liftSC1 scExtCns + liftSC4 genBVVecTerm n len a ec + tp' -> + debugPrint 2 ("Is not BVVec variable: " ++ show nm ++ " of type:") >> + debugPrettyInCtx 2 tp' >> + liftSC2 scFreshEC nm tp >>= liftSC1 scExtCns + normSMTProp prop_inst >>= mrProvableRaw -- | Build a Boolean 'Term' stating that two 'Term's are equal. This is like -- 'scEq' except that it works on open terms. From 201c796a0431aacbc5bef56124d95453771c4a0a Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Fri, 18 Feb 2022 06:45:59 -0800 Subject: [PATCH 029/105] whoops: need to coerce the type of the condition in MaybeElim to a proposition by adding an EqTrue --- src/SAWScript/Prover/MRSolver.hs | 14 +++++++++++--- 1 file changed, 11 insertions(+), 3 deletions(-) diff --git a/src/SAWScript/Prover/MRSolver.hs b/src/SAWScript/Prover/MRSolver.hs index a9c51b5e80..fbcff18d0f 100644 --- a/src/SAWScript/Prover/MRSolver.hs +++ b/src/SAWScript/Prover/MRSolver.hs @@ -1169,9 +1169,15 @@ smtNormPrims sc = Map.fromList scGlobalDef sc "Prelude.genBVVec")), ("Prelude.atBVVec", + Prim (do tp <- scTypeOfGlobal sc "Prelude.atBVVec" + VExtra <$> VExtraTerm (VTyTerm (mkSort 1) tp) <$> + scGlobalDef sc "Prelude.atBVVec") + -- FIXME HERE NOW: use the following for atBVVec! + {- PrimFun $ \_n -> PrimFun $ \_len -> tvalFun $ \a -> primGenBVVec $ \f -> primBVTermFun sc $ \ix -> PrimFun $ \_pf -> - Prim (VExtra <$> VExtraTerm a <$> scApply sc f ix)) + Prim (VExtra <$> VExtraTerm a <$> scApply sc f ix) -} + ) ] -- | Normalize a 'Term' before building an SMT query for it @@ -1590,7 +1596,8 @@ mrRefines' m1 (Ite cond2 m2 m2') = mrRefines' (MaybeElim (Type (asEq -> Just (tp,e1,e2))) m1 f1 _) m2 = do cond <- mrEq' tp e1 e2 not_cond <- liftSC1 scNot cond - cond_pf <- piUVarsM cond >>= mrFreshVar "pf" >>= mrVarTerm + cond_pf <- + liftSC1 scEqTrue cond >>= piUVarsM >>= mrFreshVar "pf" >>= mrVarTerm m1' <- applyNormCompFun f1 cond_pf cond_holds <- mrProvable cond if cond_holds then mrRefines m1' m2 else @@ -1599,7 +1606,8 @@ mrRefines' (MaybeElim (Type (asEq -> Just (tp,e1,e2))) m1 f1 _) m2 = mrRefines' m1 (MaybeElim (Type (asEq -> Just (tp,e1,e2))) m2 f2 _) = do cond <- mrEq' tp e1 e2 not_cond <- liftSC1 scNot cond - cond_pf <- piUVarsM cond >>= mrFreshVar "pf" >>= mrVarTerm + cond_pf <- + liftSC1 scEqTrue cond >>= piUVarsM >>= mrFreshVar "pf" >>= mrVarTerm m2' <- applyNormCompFun f2 cond_pf cond_holds <- mrProvable cond if cond_holds then mrRefines m1 m2' else From b388f9a4fb36ee4f9cd4a15cccb24f424f939820 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Fri, 18 Feb 2022 09:49:34 -0800 Subject: [PATCH 030/105] added back the implementaiton of atBVVec; enriched primBVTermFun to handle vector values --- src/SAWScript/Prover/MRSolver.hs | 25 +++++++++++++++++-------- 1 file changed, 17 insertions(+), 8 deletions(-) diff --git a/src/SAWScript/Prover/MRSolver.hs b/src/SAWScript/Prover/MRSolver.hs index fbcff18d0f..3a0ca68de3 100644 --- a/src/SAWScript/Prover/MRSolver.hs +++ b/src/SAWScript/Prover/MRSolver.hs @@ -125,6 +125,7 @@ module SAWScript.Prover.MRSolver import Data.List (find, findIndex) import qualified Data.Text as T +import qualified Data.Vector as V import Data.IORef import System.IO (hPutStrLn, stderr) import Control.Monad.Reader @@ -148,10 +149,10 @@ import Verifier.SAW.Recognizer import Verifier.SAW.OpenTerm import Verifier.SAW.Cryptol.Monadify -import Verifier.SAW.Simulator import qualified Verifier.SAW.Prim as Prim import Verifier.SAW.Simulator.TermModel import Verifier.SAW.Simulator.Prims +import Verifier.SAW.Simulator.MonadLazy import SAWScript.Proof (termToProp, prettyProp) import qualified SAWScript.Prover.SBV as SBV @@ -1139,6 +1140,14 @@ asGenBVVecTerm _ = Nothing type TmPrim = Prim TermModel +-- | Convert a Boolean value to a 'Term'; like 'readBackValue' but that function +-- requires a 'SimulatorConfig' which we cannot easily generate here... +boolValToTerm :: SharedContext -> Value TermModel -> IO Term +boolValToTerm _ (VBool (Left tm)) = return tm +boolValToTerm sc (VBool (Right b)) = scBool sc b +boolValToTerm _ (VExtra (VExtraTerm _tp tm)) = return tm +boolValToTerm _ v = error ("boolValToTerm: unexpected value: " ++ show v) + -- | An implementation of a primitive function that expects a @genBVVec@ term primGenBVVec :: (Term -> TmPrim) -> TmPrim primGenBVVec f = @@ -1157,7 +1166,12 @@ primBVTermFun sc = VWord (Left (_,w_tm)) -> return w_tm VWord (Right bv) -> lift $ scBvConst sc (fromIntegral (Prim.width bv)) (Prim.unsigned bv) - _ -> mzero + VVector vs -> + lift $ + do tms <- traverse (boolValToTerm sc <=< force) (V.toList vs) + tp <- scBoolType sc + scVectorReduced sc tp tms + v -> lift (putStrLn ("primBVTermFun: unhandled value: " ++ show v)) >> mzero -- | Implementations of primitives for normalizing SMT terms smtNormPrims :: SharedContext -> Map Ident TmPrim @@ -1169,14 +1183,9 @@ smtNormPrims sc = Map.fromList scGlobalDef sc "Prelude.genBVVec")), ("Prelude.atBVVec", - Prim (do tp <- scTypeOfGlobal sc "Prelude.atBVVec" - VExtra <$> VExtraTerm (VTyTerm (mkSort 1) tp) <$> - scGlobalDef sc "Prelude.atBVVec") - -- FIXME HERE NOW: use the following for atBVVec! - {- PrimFun $ \_n -> PrimFun $ \_len -> tvalFun $ \a -> primGenBVVec $ \f -> primBVTermFun sc $ \ix -> PrimFun $ \_pf -> - Prim (VExtra <$> VExtraTerm a <$> scApply sc f ix) -} + Prim (VExtra <$> VExtraTerm a <$> scApply sc f ix) ) ] From a8e714bb580992b25aa1a9612ee9f1d6f238d503 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Fri, 18 Feb 2022 11:10:35 -0800 Subject: [PATCH 031/105] re-removing dependency on bv-sized from the saw-core package --- saw-core/saw-core.cabal | 1 - 1 file changed, 1 deletion(-) diff --git a/saw-core/saw-core.cabal b/saw-core/saw-core.cabal index aefb6bd743..6775dc328b 100644 --- a/saw-core/saw-core.cabal +++ b/saw-core/saw-core.cabal @@ -26,7 +26,6 @@ library build-depends: base == 4.*, array, - bv-sized, bytestring, containers, data-inttrie, From af6d5165953e1e78bd36f509df5a711e83f59539 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Fri, 18 Feb 2022 11:14:52 -0800 Subject: [PATCH 032/105] refactored mrProveEq to support proving equality of arbitrary vectors by proving equality at all indices --- src/SAWScript/Prover/MRSolver.hs | 109 +++++++++++++++++-------------- 1 file changed, 60 insertions(+), 49 deletions(-) diff --git a/src/SAWScript/Prover/MRSolver.hs b/src/SAWScript/Prover/MRSolver.hs index 3a0ca68de3..4eb427fcfd 100644 --- a/src/SAWScript/Prover/MRSolver.hs +++ b/src/SAWScript/Prover/MRSolver.hs @@ -1259,72 +1259,83 @@ mrEq' (asVectorType -> Just (n, asBoolType -> Just ())) t1 t2 = mrEq' _ _ _ = error "mrEq': unsupported type" -- | A "simple" strategy for proving equality between two terms, which we assume --- are of the same type. This strategy first checks if either side is an --- uninstantiated evar, in which case it set that evar to the other side. If --- not, it builds an equality proposition by applying the supplied function to --- both sides, and passes this proposition to an SMT solver. +-- are of the same type, which builds an equality proposition by applying the +-- supplied function to both sides and passes this proposition to an SMT solver. mrProveEqSimple :: (Term -> Term -> MRM Term) -> MRVarMap -> Term -> Term -> MRM () +-- NOTE: The use of mrSubstEVars instead of mrSubstEVarsStrict means that we +-- allow evars in the terms we send to the SMT solver, but we treat them as +-- uvars. +mrProveEqSimple eqf _ t1 t2 = + do t1' <- mrSubstEVars t1 + t2' <- mrSubstEVars t2 + prop <- eqf t1' t2' + success <- mrProvable prop + if success then return () else + throwError (TermsNotEq t1 t2) + + +-- | Prove that two terms are equal, instantiating evars if necessary, or +-- throwing an error if this is not possible +mrProveEq :: Term -> Term -> MRM () +mrProveEq t1 t2 = + do mrDebugPPPrefixSep 1 "mrProveEq" t1 "==" t2 + tp <- mrTypeOf t1 + varmap <- mrVars <$> get + mrProveEqH varmap tp t1 t2 + + +-- | The main workhorse for 'prProveEq' +mrProveEqH :: Map MRVar MRVarInfo -> Term -> Term -> Term -> MRM () -- If t1 is an instantiated evar, substitute and recurse -mrProveEqSimple eqf var_map (asEVarApp var_map -> Just (_, args, Just f)) t2 = - mrApplyAll f args >>= \t1' -> mrProveEqSimple eqf var_map t1' t2 +mrProveEqH var_map tp (asEVarApp var_map -> Just (_, args, Just f)) t2 = + mrApplyAll f args >>= \t1' -> mrProveEqH var_map tp t1' t2 -- If t1 is an uninstantiated evar, instantiate it with t2 -mrProveEqSimple _ var_map t1@(asEVarApp var_map -> - Just (evar, args, Nothing)) t2 = +mrProveEqH var_map _tp t1@(asEVarApp var_map -> Just (evar, args, Nothing)) t2 = do t2' <- mrSubstEVars t2 success <- mrTrySetAppliedEVar evar args t2' if success then return () else throwError (TermsNotEq t1 t2) -- If t2 is an instantiated evar, substitute and recurse -mrProveEqSimple eqf var_map t1 (asEVarApp var_map -> Just (_, args, Just f)) = - mrApplyAll f args >>= \t2' -> mrProveEqSimple eqf var_map t1 t2' +mrProveEqH var_map tp t1 (asEVarApp var_map -> Just (_, args, Just f)) = + mrApplyAll f args >>= \t2' -> mrProveEqH var_map tp t1 t2' -- If t2 is an uninstantiated evar, instantiate it with t1 -mrProveEqSimple _ var_map t1 t2@(asEVarApp var_map -> - Just (evar, args, Nothing)) = +mrProveEqH var_map _tp t1 t2@(asEVarApp var_map -> Just (evar, args, Nothing)) = do t1' <- mrSubstEVars t1 success <- mrTrySetAppliedEVar evar args t1' if success then return () else throwError (TermsNotEq t1 t2) --- Otherwise, try to prove both sides are equal. The use of mrSubstEVars instead --- of mrSubstEVarsStrict means that we allow evars in the terms we send to the --- SMT solver, but we treat them as uvars. -mrProveEqSimple eqf _ t1 t2 = - do t1' <- mrSubstEVars t1 - t2' <- mrSubstEVars t2 - prop <- eqf t1' t2' - success <- mrProvable prop - if success then return () else - throwError (TermsNotEq t1 t2) - - --- | Prove that two terms are equal, instantiating evars if necessary, or --- throwing an error if this is not possible -mrProveEq :: Term -> Term -> MRM () -mrProveEq t1_top t2_top = - (do mrDebugPPPrefixSep 1 "mrProveEq" t1_top "==" t2_top - tp <- mrTypeOf t1_top - varmap <- mrVars <$> get - proveEq varmap tp t1_top t2_top) - where - proveEq :: Map MRVar MRVarInfo -> Term -> Term -> Term -> MRM () - proveEq var_map (asDataType -> Just (pn, [])) t1 t2 - | primName pn == "Prelude.Nat" = - mrProveEqSimple (liftSC2 scEqualNat) var_map t1 t2 - proveEq var_map (asVectorType -> Just (n, asBoolType -> Just ())) t1 t2 = - -- FIXME: make a better solver for bitvector equalities - mrProveEqSimple (liftSC3 scBvEq n) var_map t1 t2 - proveEq var_map (asBoolType -> Just _) t1 t2 = - mrProveEqSimple (liftSC2 scBoolEq) var_map t1 t2 - proveEq var_map (asIntegerType -> Just _) t1 t2 = - mrProveEqSimple (liftSC2 scIntEq) var_map t1 t2 - proveEq _ _ t1 t2 = - -- As a fallback, for types we can't handle, just check convertibility - mrConvertible t1 t2 >>= \case - True -> return () - False -> throwError (TermsNotEq t1 t2) +-- For the nat, bitvector, Boolean, and integer types, call mrProveEqSimple +mrProveEqH var_map (asDataType -> Just (pn, [])) t1 t2 + | primName pn == "Prelude.Nat" = + mrProveEqSimple (liftSC2 scEqualNat) var_map t1 t2 +mrProveEqH var_map (asVectorType -> Just (n, asBoolType -> Just ())) t1 t2 = + -- FIXME: make a better solver for bitvector equalities + mrProveEqSimple (liftSC3 scBvEq n) var_map t1 t2 +mrProveEqH var_map (asBoolType -> Just _) t1 t2 = + mrProveEqSimple (liftSC2 scBoolEq) var_map t1 t2 +mrProveEqH var_map (asIntegerType -> Just _) t1 t2 = + mrProveEqSimple (liftSC2 scIntEq) var_map t1 t2 + +-- For non-bitvector vector types, prove all projections are equal by +-- quantifying over a universal index variable and proving equality at that +-- index +mrProveEqH var_map (asBVVecType -> Just (n, len, tp)) t1 t2 = + withUVar "eq_ix" (Type tp) $ \ix -> + liftSC2 scGlobalApply "Prelude.is_bvult" [n, ix, len] >>= \pf_tp -> + withUVar "eq_pf" (Type pf_tp) $ \pf -> + do t1' <- liftSC2 scGlobalApply "Prelude.atBVVec" [n, len, tp, t1, ix, pf] + t2' <- liftSC2 scGlobalApply "Prelude.atBVVec" [n, len, tp, t2, ix, pf] + mrProveEqH var_map tp t1' t2' + +-- As a fallback, for types we can't handle, just check convertibility +mrProveEqH _ _ t1 t2 = + mrConvertible t1 t2 >>= \case + True -> return () + False -> throwError (TermsNotEq t1 t2) ---------------------------------------------------------------------- From afac7588689c4b18ac907d4db8c91d15981ac501 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Fri, 18 Feb 2022 12:42:15 -0800 Subject: [PATCH 033/105] changed ppBitsToHex to panic if its input has the wrong size --- saw-core/src/Verifier/SAW/Term/Pretty.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/saw-core/src/Verifier/SAW/Term/Pretty.hs b/saw-core/src/Verifier/SAW/Term/Pretty.hs index c857ab1ba6..58cf0de96e 100644 --- a/saw-core/src/Verifier/SAW/Term/Pretty.hs +++ b/saw-core/src/Verifier/SAW/Term/Pretty.hs @@ -490,7 +490,9 @@ ppBitsToHex (b8:b4:b2:b1:bits') = ppBitsToHex bits' where toInt True = 1 toInt False = 0 -ppBitsToHex _ = "" +ppBitsToHex [] = "" +ppBitsToHex bits = + panic "ppBitsToHex" ["length of bit list is not a multiple of 4", show bits] -- | Pretty-print a name, using the best unambiguous alias from the -- naming environment. From 338aa0e977ee577a9ea9701d05d6906fe57c36ee Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Fri, 18 Feb 2022 17:10:47 -0800 Subject: [PATCH 034/105] got mrProveEq to handle pair types by changing it to return a TermInCtx; fixed a bug in withUVar, that assumptions added under the extended context should be thrown away when that context ends --- src/SAWScript/Prover/MRSolver.hs | 162 ++++++++++++++++++++++--------- 1 file changed, 114 insertions(+), 48 deletions(-) diff --git a/src/SAWScript/Prover/MRSolver.hs b/src/SAWScript/Prover/MRSolver.hs index 4eb427fcfd..f05eb37aab 100644 --- a/src/SAWScript/Prover/MRSolver.hs +++ b/src/SAWScript/Prover/MRSolver.hs @@ -157,6 +157,8 @@ import Verifier.SAW.Simulator.MonadLazy import SAWScript.Proof (termToProp, prettyProp) import qualified SAWScript.Prover.SBV as SBV +-- import Debug.Trace + ---------------------------------------------------------------------- -- * Utility Functions for Transforming 'Term's @@ -642,7 +644,8 @@ data MRState = MRState { mrVars :: MRVarMap, -- | The current assumptions of function refinement mrFunAssumps :: Map FunName FunAssump, - -- | The current assumptions, which are conjoined into a single Boolean term + -- | The current assumptions, which are conjoined into a single Boolean term; + -- note that these have the current UVars free mrAssumptions :: Term, -- | The debug level, which controls debug printing mrDebugLevel :: Int @@ -770,14 +773,18 @@ uniquifyName nm nms = Nothing -> error "uniquifyName" -- | Run a MR Solver computation in a context extended with a universal --- variable, which is passed as a 'Term' to the sub-computation +-- variable, which is passed as a 'Term' to the sub-computation. Note that any +-- assumptions made in the sub-computation will be lost when it completes. withUVar :: LocalName -> Type -> (Term -> MRM a) -> MRM a withUVar nm tp m = do st <- get let nm' = uniquifyName nm (map fst $ mrUVars st) - put (st { mrUVars = (nm',tp) : mrUVars st }) + assumps' <- liftTerm 0 1 $ mrAssumptions st + put (st { mrUVars = (nm',tp) : mrUVars st, + mrAssumptions = assumps' }) ret <- mapFailure (MRFailureLocalVar nm') (liftSC1 scLocalVar 0 >>= m) - modify (\st' -> st' { mrUVars = mrUVars st }) + modify (\st' -> st' { mrUVars = mrUVars st, + mrAssumptions = mrAssumptions st }) return ret -- | Run a MR Solver computation in a context extended with a universal variable @@ -1128,14 +1135,15 @@ genBVVecTerm sc n_tm len_tm a_tm f_tm = lambdaOpenTerm "_" (applyGlobalOpenTerm "Prelude.is_bvult" [n, i, len]) $ \_ -> applyOpenTerm f i] --- | Match a term of the form @genBVVec n len a (\ i _ -> f i)@ and return @f@ -asGenBVVecTerm :: Recognizer Term Term +-- | Match a term of the form @genBVVec n len a (\ i _ -> e)@, i.e., where @e@ +-- does not have the proof variable (the underscore) free +asGenBVVecTerm :: Recognizer Term (Term, Term, Term, Term) asGenBVVecTerm (asApplyAll -> (isGlobalDef "Prelude.genBVVec" -> Just _, - [_, _, _, - (asLambdaList -> ([_,_], asApp -> - Just (f, asLocalVar -> Just 1)))])) = - Just f + [n, len, a, + (asLambdaList -> ([_,_], e))])) + | not $ inBitSet 0 $ looseVars e + = Just (n, len, a, e) asGenBVVecTerm _ = Nothing type TmPrim = Prim TermModel @@ -1149,11 +1157,18 @@ boolValToTerm _ (VExtra (VExtraTerm _tp tm)) = return tm boolValToTerm _ v = error ("boolValToTerm: unexpected value: " ++ show v) -- | An implementation of a primitive function that expects a @genBVVec@ term -primGenBVVec :: (Term -> TmPrim) -> TmPrim -primGenBVVec f = +primGenBVVec :: SharedContext -> (Term -> TmPrim) -> TmPrim +primGenBVVec sc f = PrimFilterFun "genBVVecPrim" (\case - VExtra (VExtraTerm _ (asGenBVVecTerm -> Just g)) -> return g + VExtra (VExtraTerm _ (asGenBVVecTerm -> Just (n, _, _, e))) -> + -- Generate the function \i -> [i/1,error/0]e + lift $ + do i_tp <- scBoolType sc >>= scVecType sc n + let err_tm = error "primGenBVVec: unexpected variable occurrence" + i_tm <- scLocalVar sc 0 + body <- instantiateVarList sc 0 [err_tm,i_tm] e + scLambda sc "i" i_tp body _ -> mzero) f @@ -1184,7 +1199,7 @@ smtNormPrims sc = Map.fromList ("Prelude.atBVVec", PrimFun $ \_n -> PrimFun $ \_len -> tvalFun $ \a -> - primGenBVVec $ \f -> primBVTermFun sc $ \ix -> PrimFun $ \_pf -> + primGenBVVec sc $ \f -> primBVTermFun sc $ \ix -> PrimFun $ \_pf -> Prim (VExtra <$> VExtraTerm a <$> scApply sc f ix) ) ] @@ -1227,7 +1242,6 @@ mrProvable bool_tm = -- For variables of type BVVec, create a Vec n Bool -> a function as an -- ExtCns and apply genBVVec to it do - debugPrint 2 ("Is BVVec variable: " ++ show nm) ec_tp <- liftSC1 completeOpenTerm $ arrowOpenTerm "_" (applyOpenTermMulti (globalOpenTerm "Prelude.Vec") @@ -1236,7 +1250,6 @@ mrProvable bool_tm = ec <- liftSC2 scFreshEC nm ec_tp >>= liftSC1 scExtCns liftSC4 genBVVecTerm n len a ec tp' -> - debugPrint 2 ("Is not BVVec variable: " ++ show nm ++ " of type:") >> debugPrettyInCtx 2 tp' >> liftSC2 scFreshEC nm tp >>= liftSC1 scExtCns normSMTProp prop_inst >>= mrProvableRaw @@ -1258,21 +1271,47 @@ mrEq' (asVectorType -> Just (n, asBoolType -> Just ())) t1 t2 = liftSC3 scBvEq n t1 t2 mrEq' _ _ _ = error "mrEq': unsupported type" +-- | A 'Term' in an extended context of universal variables, which are listed +-- "outside in", meaning the highest deBruijn index comes first +data TermInCtx = TermInCtx [(LocalName,Term)] Term + +-- | Conjoin two 'TermInCtx's, assuming they both have Boolean type +andTermInCtx :: TermInCtx -> TermInCtx -> MRM TermInCtx +andTermInCtx (TermInCtx ctx1 t1) (TermInCtx ctx2 t2) = + do + -- Insert the variables in ctx2 into the context of t1 starting at index 0, + -- by lifting its variables starting at 0 by length ctx2 + t1' <- liftTermLike 0 (length ctx2) t1 + -- Insert the variables in ctx1 into the context of t1 starting at index + -- length ctx2, by lifting its variables starting at length ctx2 by length + -- ctx1 + t2' <- liftTermLike (length ctx2) (length ctx1) t2 + TermInCtx (ctx1++ctx2) <$> liftSC2 scAnd t1' t2' + +-- | Extend the context of a 'TermInCtx' with additional universal variables +-- bound "outside" the 'TermInCtx' +extTermInCtx :: [(LocalName,Term)] -> TermInCtx -> TermInCtx +extTermInCtx ctx (TermInCtx ctx' t) = TermInCtx (ctx++ctx') t + +-- | Run an 'MRM' computation in the context of a 'TermInCtx', passing in the +-- 'Term' +withTermInCtx :: TermInCtx -> (Term -> MRM a) -> MRM a +withTermInCtx (TermInCtx [] tm) f = f tm +withTermInCtx (TermInCtx ((nm,tp):ctx) tm) f = + withUVar nm (Type tp) $ const $ withTermInCtx (TermInCtx ctx tm) f + -- | A "simple" strategy for proving equality between two terms, which we assume -- are of the same type, which builds an equality proposition by applying the -- supplied function to both sides and passes this proposition to an SMT solver. -mrProveEqSimple :: (Term -> Term -> MRM Term) -> MRVarMap -> Term -> Term -> - MRM () +mrProveEqSimple :: (Term -> Term -> MRM Term) -> Term -> Term -> + MRM TermInCtx -- NOTE: The use of mrSubstEVars instead of mrSubstEVarsStrict means that we -- allow evars in the terms we send to the SMT solver, but we treat them as -- uvars. -mrProveEqSimple eqf _ t1 t2 = +mrProveEqSimple eqf t1 t2 = do t1' <- mrSubstEVars t1 t2' <- mrSubstEVars t2 - prop <- eqf t1' t2' - success <- mrProvable prop - if success then return () else - throwError (TermsNotEq t1 t2) + TermInCtx [] <$> eqf t1' t2' -- | Prove that two terms are equal, instantiating evars if necessary, or @@ -1282,60 +1321,87 @@ mrProveEq t1 t2 = do mrDebugPPPrefixSep 1 "mrProveEq" t1 "==" t2 tp <- mrTypeOf t1 varmap <- mrVars <$> get - mrProveEqH varmap tp t1 t2 + cond_in_ctx <- mrProveEqH varmap tp t1 t2 + success <- withTermInCtx cond_in_ctx mrProvable + if success then return () else + throwError (TermsNotEq t1 t2) +-- | The main workhorse for 'prProveEq'. Build a Boolean term expressing that +-- the third and fourth arguments, whose type is given by the second. This is +-- done in a continuation monad so that the output term can be in a context with +-- additional universal variables. +mrProveEqH :: Map MRVar MRVarInfo -> Term -> Term -> Term -> MRM TermInCtx --- | The main workhorse for 'prProveEq' -mrProveEqH :: Map MRVar MRVarInfo -> Term -> Term -> Term -> MRM () +{- +mrProveEqH _ _ t1 t2 + | trace ("mrProveEqH:\n" ++ showTerm t1 ++ "\n==\n" ++ showTerm t2) False = undefined +-} -- If t1 is an instantiated evar, substitute and recurse mrProveEqH var_map tp (asEVarApp var_map -> Just (_, args, Just f)) t2 = mrApplyAll f args >>= \t1' -> mrProveEqH var_map tp t1' t2 -- If t1 is an uninstantiated evar, instantiate it with t2 -mrProveEqH var_map _tp t1@(asEVarApp var_map -> Just (evar, args, Nothing)) t2 = +mrProveEqH var_map _tp (asEVarApp var_map -> Just (evar, args, Nothing)) t2 = do t2' <- mrSubstEVars t2 success <- mrTrySetAppliedEVar evar args t2' - if success then return () else throwError (TermsNotEq t1 t2) + TermInCtx [] <$> liftSC1 scBool success -- If t2 is an instantiated evar, substitute and recurse mrProveEqH var_map tp t1 (asEVarApp var_map -> Just (_, args, Just f)) = mrApplyAll f args >>= \t2' -> mrProveEqH var_map tp t1 t2' -- If t2 is an uninstantiated evar, instantiate it with t1 -mrProveEqH var_map _tp t1 t2@(asEVarApp var_map -> Just (evar, args, Nothing)) = +mrProveEqH var_map _tp t1 (asEVarApp var_map -> Just (evar, args, Nothing)) = do t1' <- mrSubstEVars t1 success <- mrTrySetAppliedEVar evar args t1' - if success then return () else throwError (TermsNotEq t1 t2) + TermInCtx [] <$> liftSC1 scBool success -- For the nat, bitvector, Boolean, and integer types, call mrProveEqSimple -mrProveEqH var_map (asDataType -> Just (pn, [])) t1 t2 +mrProveEqH _ (asDataType -> Just (pn, [])) t1 t2 | primName pn == "Prelude.Nat" = - mrProveEqSimple (liftSC2 scEqualNat) var_map t1 t2 -mrProveEqH var_map (asVectorType -> Just (n, asBoolType -> Just ())) t1 t2 = + mrProveEqSimple (liftSC2 scEqualNat) t1 t2 +mrProveEqH _ (asVectorType -> Just (n, asBoolType -> Just ())) t1 t2 = -- FIXME: make a better solver for bitvector equalities - mrProveEqSimple (liftSC3 scBvEq n) var_map t1 t2 -mrProveEqH var_map (asBoolType -> Just _) t1 t2 = - mrProveEqSimple (liftSC2 scBoolEq) var_map t1 t2 -mrProveEqH var_map (asIntegerType -> Just _) t1 t2 = - mrProveEqSimple (liftSC2 scIntEq) var_map t1 t2 + mrProveEqSimple (liftSC3 scBvEq n) t1 t2 +mrProveEqH _ (asBoolType -> Just _) t1 t2 = + mrProveEqSimple (liftSC2 scBoolEq) t1 t2 +mrProveEqH _ (asIntegerType -> Just _) t1 t2 = + mrProveEqSimple (liftSC2 scIntEq) t1 t2 + +-- For pair types, prove both the left and right projections are equal +mrProveEqH var_map (asPairType -> Just (tpL, tpR)) t1 t2 = + do t1L <- liftSC1 scPairLeft t1 + t2L <- liftSC1 scPairLeft t2 + t1R <- liftSC1 scPairRight t1 + t2R <- liftSC1 scPairRight t2 + condL <- mrProveEqH var_map tpL t1L t2L + condR <- mrProveEqH var_map tpR t1R t2R + andTermInCtx condL condR -- For non-bitvector vector types, prove all projections are equal by -- quantifying over a universal index variable and proving equality at that -- index -mrProveEqH var_map (asBVVecType -> Just (n, len, tp)) t1 t2 = - withUVar "eq_ix" (Type tp) $ \ix -> - liftSC2 scGlobalApply "Prelude.is_bvult" [n, ix, len] >>= \pf_tp -> - withUVar "eq_pf" (Type pf_tp) $ \pf -> - do t1' <- liftSC2 scGlobalApply "Prelude.atBVVec" [n, len, tp, t1, ix, pf] - t2' <- liftSC2 scGlobalApply "Prelude.atBVVec" [n, len, tp, t2, ix, pf] - mrProveEqH var_map tp t1' t2' +mrProveEqH _ (asBVVecType -> Just (n, len, tp)) t1 t2 = + liftSC0 scBoolType >>= \bool_tp -> + liftSC2 scVecType n bool_tp >>= \ix_tp -> + withUVarLift "eq_ix" (Type ix_tp) (n,(len,(tp,(t1,t2)))) $ + \ix' (n',(len',(tp',(t1',t2')))) -> + liftSC2 scGlobalApply "Prelude.is_bvult" [n', ix', len'] >>= \pf_tp -> + withUVarLift "eq_pf" (Type pf_tp) (n',(len',(tp',(ix',(t1',t2'))))) $ + \pf'' (n'',(len'',(tp'',(ix'',(t1'',t2''))))) -> + do t1_prj <- liftSC2 scGlobalApply "Prelude.atBVVec" [n'', len'', tp'', + t1'', ix'', pf''] + t2_prj <- liftSC2 scGlobalApply "Prelude.atBVVec" [n'', len'', tp'', + t2'', ix'', pf''] + var_map <- mrVars <$> get + extTermInCtx [("eq_ix",ix_tp),("eq_pf",pf_tp)] <$> + mrProveEqH var_map tp'' t1_prj t2_prj -- As a fallback, for types we can't handle, just check convertibility mrProveEqH _ _ t1 t2 = - mrConvertible t1 t2 >>= \case - True -> return () - False -> throwError (TermsNotEq t1 t2) + do success <- mrConvertible t1 t2 + TermInCtx [] <$> liftSC1 scBool success ---------------------------------------------------------------------- From 5778c25959b246b2603eb85a3ec53586af72ecd9 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Fri, 18 Feb 2022 17:10:47 -0800 Subject: [PATCH 035/105] got mrProveEq to handle pair types by changing it to return a TermInCtx; fixed a bug in withUVar, that assumptions need to be lifted in the new context and then reverted when that context ends --- src/SAWScript/Prover/MRSolver.hs | 162 ++++++++++++++++++++++--------- 1 file changed, 114 insertions(+), 48 deletions(-) diff --git a/src/SAWScript/Prover/MRSolver.hs b/src/SAWScript/Prover/MRSolver.hs index 4eb427fcfd..f05eb37aab 100644 --- a/src/SAWScript/Prover/MRSolver.hs +++ b/src/SAWScript/Prover/MRSolver.hs @@ -157,6 +157,8 @@ import Verifier.SAW.Simulator.MonadLazy import SAWScript.Proof (termToProp, prettyProp) import qualified SAWScript.Prover.SBV as SBV +-- import Debug.Trace + ---------------------------------------------------------------------- -- * Utility Functions for Transforming 'Term's @@ -642,7 +644,8 @@ data MRState = MRState { mrVars :: MRVarMap, -- | The current assumptions of function refinement mrFunAssumps :: Map FunName FunAssump, - -- | The current assumptions, which are conjoined into a single Boolean term + -- | The current assumptions, which are conjoined into a single Boolean term; + -- note that these have the current UVars free mrAssumptions :: Term, -- | The debug level, which controls debug printing mrDebugLevel :: Int @@ -770,14 +773,18 @@ uniquifyName nm nms = Nothing -> error "uniquifyName" -- | Run a MR Solver computation in a context extended with a universal --- variable, which is passed as a 'Term' to the sub-computation +-- variable, which is passed as a 'Term' to the sub-computation. Note that any +-- assumptions made in the sub-computation will be lost when it completes. withUVar :: LocalName -> Type -> (Term -> MRM a) -> MRM a withUVar nm tp m = do st <- get let nm' = uniquifyName nm (map fst $ mrUVars st) - put (st { mrUVars = (nm',tp) : mrUVars st }) + assumps' <- liftTerm 0 1 $ mrAssumptions st + put (st { mrUVars = (nm',tp) : mrUVars st, + mrAssumptions = assumps' }) ret <- mapFailure (MRFailureLocalVar nm') (liftSC1 scLocalVar 0 >>= m) - modify (\st' -> st' { mrUVars = mrUVars st }) + modify (\st' -> st' { mrUVars = mrUVars st, + mrAssumptions = mrAssumptions st }) return ret -- | Run a MR Solver computation in a context extended with a universal variable @@ -1128,14 +1135,15 @@ genBVVecTerm sc n_tm len_tm a_tm f_tm = lambdaOpenTerm "_" (applyGlobalOpenTerm "Prelude.is_bvult" [n, i, len]) $ \_ -> applyOpenTerm f i] --- | Match a term of the form @genBVVec n len a (\ i _ -> f i)@ and return @f@ -asGenBVVecTerm :: Recognizer Term Term +-- | Match a term of the form @genBVVec n len a (\ i _ -> e)@, i.e., where @e@ +-- does not have the proof variable (the underscore) free +asGenBVVecTerm :: Recognizer Term (Term, Term, Term, Term) asGenBVVecTerm (asApplyAll -> (isGlobalDef "Prelude.genBVVec" -> Just _, - [_, _, _, - (asLambdaList -> ([_,_], asApp -> - Just (f, asLocalVar -> Just 1)))])) = - Just f + [n, len, a, + (asLambdaList -> ([_,_], e))])) + | not $ inBitSet 0 $ looseVars e + = Just (n, len, a, e) asGenBVVecTerm _ = Nothing type TmPrim = Prim TermModel @@ -1149,11 +1157,18 @@ boolValToTerm _ (VExtra (VExtraTerm _tp tm)) = return tm boolValToTerm _ v = error ("boolValToTerm: unexpected value: " ++ show v) -- | An implementation of a primitive function that expects a @genBVVec@ term -primGenBVVec :: (Term -> TmPrim) -> TmPrim -primGenBVVec f = +primGenBVVec :: SharedContext -> (Term -> TmPrim) -> TmPrim +primGenBVVec sc f = PrimFilterFun "genBVVecPrim" (\case - VExtra (VExtraTerm _ (asGenBVVecTerm -> Just g)) -> return g + VExtra (VExtraTerm _ (asGenBVVecTerm -> Just (n, _, _, e))) -> + -- Generate the function \i -> [i/1,error/0]e + lift $ + do i_tp <- scBoolType sc >>= scVecType sc n + let err_tm = error "primGenBVVec: unexpected variable occurrence" + i_tm <- scLocalVar sc 0 + body <- instantiateVarList sc 0 [err_tm,i_tm] e + scLambda sc "i" i_tp body _ -> mzero) f @@ -1184,7 +1199,7 @@ smtNormPrims sc = Map.fromList ("Prelude.atBVVec", PrimFun $ \_n -> PrimFun $ \_len -> tvalFun $ \a -> - primGenBVVec $ \f -> primBVTermFun sc $ \ix -> PrimFun $ \_pf -> + primGenBVVec sc $ \f -> primBVTermFun sc $ \ix -> PrimFun $ \_pf -> Prim (VExtra <$> VExtraTerm a <$> scApply sc f ix) ) ] @@ -1227,7 +1242,6 @@ mrProvable bool_tm = -- For variables of type BVVec, create a Vec n Bool -> a function as an -- ExtCns and apply genBVVec to it do - debugPrint 2 ("Is BVVec variable: " ++ show nm) ec_tp <- liftSC1 completeOpenTerm $ arrowOpenTerm "_" (applyOpenTermMulti (globalOpenTerm "Prelude.Vec") @@ -1236,7 +1250,6 @@ mrProvable bool_tm = ec <- liftSC2 scFreshEC nm ec_tp >>= liftSC1 scExtCns liftSC4 genBVVecTerm n len a ec tp' -> - debugPrint 2 ("Is not BVVec variable: " ++ show nm ++ " of type:") >> debugPrettyInCtx 2 tp' >> liftSC2 scFreshEC nm tp >>= liftSC1 scExtCns normSMTProp prop_inst >>= mrProvableRaw @@ -1258,21 +1271,47 @@ mrEq' (asVectorType -> Just (n, asBoolType -> Just ())) t1 t2 = liftSC3 scBvEq n t1 t2 mrEq' _ _ _ = error "mrEq': unsupported type" +-- | A 'Term' in an extended context of universal variables, which are listed +-- "outside in", meaning the highest deBruijn index comes first +data TermInCtx = TermInCtx [(LocalName,Term)] Term + +-- | Conjoin two 'TermInCtx's, assuming they both have Boolean type +andTermInCtx :: TermInCtx -> TermInCtx -> MRM TermInCtx +andTermInCtx (TermInCtx ctx1 t1) (TermInCtx ctx2 t2) = + do + -- Insert the variables in ctx2 into the context of t1 starting at index 0, + -- by lifting its variables starting at 0 by length ctx2 + t1' <- liftTermLike 0 (length ctx2) t1 + -- Insert the variables in ctx1 into the context of t1 starting at index + -- length ctx2, by lifting its variables starting at length ctx2 by length + -- ctx1 + t2' <- liftTermLike (length ctx2) (length ctx1) t2 + TermInCtx (ctx1++ctx2) <$> liftSC2 scAnd t1' t2' + +-- | Extend the context of a 'TermInCtx' with additional universal variables +-- bound "outside" the 'TermInCtx' +extTermInCtx :: [(LocalName,Term)] -> TermInCtx -> TermInCtx +extTermInCtx ctx (TermInCtx ctx' t) = TermInCtx (ctx++ctx') t + +-- | Run an 'MRM' computation in the context of a 'TermInCtx', passing in the +-- 'Term' +withTermInCtx :: TermInCtx -> (Term -> MRM a) -> MRM a +withTermInCtx (TermInCtx [] tm) f = f tm +withTermInCtx (TermInCtx ((nm,tp):ctx) tm) f = + withUVar nm (Type tp) $ const $ withTermInCtx (TermInCtx ctx tm) f + -- | A "simple" strategy for proving equality between two terms, which we assume -- are of the same type, which builds an equality proposition by applying the -- supplied function to both sides and passes this proposition to an SMT solver. -mrProveEqSimple :: (Term -> Term -> MRM Term) -> MRVarMap -> Term -> Term -> - MRM () +mrProveEqSimple :: (Term -> Term -> MRM Term) -> Term -> Term -> + MRM TermInCtx -- NOTE: The use of mrSubstEVars instead of mrSubstEVarsStrict means that we -- allow evars in the terms we send to the SMT solver, but we treat them as -- uvars. -mrProveEqSimple eqf _ t1 t2 = +mrProveEqSimple eqf t1 t2 = do t1' <- mrSubstEVars t1 t2' <- mrSubstEVars t2 - prop <- eqf t1' t2' - success <- mrProvable prop - if success then return () else - throwError (TermsNotEq t1 t2) + TermInCtx [] <$> eqf t1' t2' -- | Prove that two terms are equal, instantiating evars if necessary, or @@ -1282,60 +1321,87 @@ mrProveEq t1 t2 = do mrDebugPPPrefixSep 1 "mrProveEq" t1 "==" t2 tp <- mrTypeOf t1 varmap <- mrVars <$> get - mrProveEqH varmap tp t1 t2 + cond_in_ctx <- mrProveEqH varmap tp t1 t2 + success <- withTermInCtx cond_in_ctx mrProvable + if success then return () else + throwError (TermsNotEq t1 t2) +-- | The main workhorse for 'prProveEq'. Build a Boolean term expressing that +-- the third and fourth arguments, whose type is given by the second. This is +-- done in a continuation monad so that the output term can be in a context with +-- additional universal variables. +mrProveEqH :: Map MRVar MRVarInfo -> Term -> Term -> Term -> MRM TermInCtx --- | The main workhorse for 'prProveEq' -mrProveEqH :: Map MRVar MRVarInfo -> Term -> Term -> Term -> MRM () +{- +mrProveEqH _ _ t1 t2 + | trace ("mrProveEqH:\n" ++ showTerm t1 ++ "\n==\n" ++ showTerm t2) False = undefined +-} -- If t1 is an instantiated evar, substitute and recurse mrProveEqH var_map tp (asEVarApp var_map -> Just (_, args, Just f)) t2 = mrApplyAll f args >>= \t1' -> mrProveEqH var_map tp t1' t2 -- If t1 is an uninstantiated evar, instantiate it with t2 -mrProveEqH var_map _tp t1@(asEVarApp var_map -> Just (evar, args, Nothing)) t2 = +mrProveEqH var_map _tp (asEVarApp var_map -> Just (evar, args, Nothing)) t2 = do t2' <- mrSubstEVars t2 success <- mrTrySetAppliedEVar evar args t2' - if success then return () else throwError (TermsNotEq t1 t2) + TermInCtx [] <$> liftSC1 scBool success -- If t2 is an instantiated evar, substitute and recurse mrProveEqH var_map tp t1 (asEVarApp var_map -> Just (_, args, Just f)) = mrApplyAll f args >>= \t2' -> mrProveEqH var_map tp t1 t2' -- If t2 is an uninstantiated evar, instantiate it with t1 -mrProveEqH var_map _tp t1 t2@(asEVarApp var_map -> Just (evar, args, Nothing)) = +mrProveEqH var_map _tp t1 (asEVarApp var_map -> Just (evar, args, Nothing)) = do t1' <- mrSubstEVars t1 success <- mrTrySetAppliedEVar evar args t1' - if success then return () else throwError (TermsNotEq t1 t2) + TermInCtx [] <$> liftSC1 scBool success -- For the nat, bitvector, Boolean, and integer types, call mrProveEqSimple -mrProveEqH var_map (asDataType -> Just (pn, [])) t1 t2 +mrProveEqH _ (asDataType -> Just (pn, [])) t1 t2 | primName pn == "Prelude.Nat" = - mrProveEqSimple (liftSC2 scEqualNat) var_map t1 t2 -mrProveEqH var_map (asVectorType -> Just (n, asBoolType -> Just ())) t1 t2 = + mrProveEqSimple (liftSC2 scEqualNat) t1 t2 +mrProveEqH _ (asVectorType -> Just (n, asBoolType -> Just ())) t1 t2 = -- FIXME: make a better solver for bitvector equalities - mrProveEqSimple (liftSC3 scBvEq n) var_map t1 t2 -mrProveEqH var_map (asBoolType -> Just _) t1 t2 = - mrProveEqSimple (liftSC2 scBoolEq) var_map t1 t2 -mrProveEqH var_map (asIntegerType -> Just _) t1 t2 = - mrProveEqSimple (liftSC2 scIntEq) var_map t1 t2 + mrProveEqSimple (liftSC3 scBvEq n) t1 t2 +mrProveEqH _ (asBoolType -> Just _) t1 t2 = + mrProveEqSimple (liftSC2 scBoolEq) t1 t2 +mrProveEqH _ (asIntegerType -> Just _) t1 t2 = + mrProveEqSimple (liftSC2 scIntEq) t1 t2 + +-- For pair types, prove both the left and right projections are equal +mrProveEqH var_map (asPairType -> Just (tpL, tpR)) t1 t2 = + do t1L <- liftSC1 scPairLeft t1 + t2L <- liftSC1 scPairLeft t2 + t1R <- liftSC1 scPairRight t1 + t2R <- liftSC1 scPairRight t2 + condL <- mrProveEqH var_map tpL t1L t2L + condR <- mrProveEqH var_map tpR t1R t2R + andTermInCtx condL condR -- For non-bitvector vector types, prove all projections are equal by -- quantifying over a universal index variable and proving equality at that -- index -mrProveEqH var_map (asBVVecType -> Just (n, len, tp)) t1 t2 = - withUVar "eq_ix" (Type tp) $ \ix -> - liftSC2 scGlobalApply "Prelude.is_bvult" [n, ix, len] >>= \pf_tp -> - withUVar "eq_pf" (Type pf_tp) $ \pf -> - do t1' <- liftSC2 scGlobalApply "Prelude.atBVVec" [n, len, tp, t1, ix, pf] - t2' <- liftSC2 scGlobalApply "Prelude.atBVVec" [n, len, tp, t2, ix, pf] - mrProveEqH var_map tp t1' t2' +mrProveEqH _ (asBVVecType -> Just (n, len, tp)) t1 t2 = + liftSC0 scBoolType >>= \bool_tp -> + liftSC2 scVecType n bool_tp >>= \ix_tp -> + withUVarLift "eq_ix" (Type ix_tp) (n,(len,(tp,(t1,t2)))) $ + \ix' (n',(len',(tp',(t1',t2')))) -> + liftSC2 scGlobalApply "Prelude.is_bvult" [n', ix', len'] >>= \pf_tp -> + withUVarLift "eq_pf" (Type pf_tp) (n',(len',(tp',(ix',(t1',t2'))))) $ + \pf'' (n'',(len'',(tp'',(ix'',(t1'',t2''))))) -> + do t1_prj <- liftSC2 scGlobalApply "Prelude.atBVVec" [n'', len'', tp'', + t1'', ix'', pf''] + t2_prj <- liftSC2 scGlobalApply "Prelude.atBVVec" [n'', len'', tp'', + t2'', ix'', pf''] + var_map <- mrVars <$> get + extTermInCtx [("eq_ix",ix_tp),("eq_pf",pf_tp)] <$> + mrProveEqH var_map tp'' t1_prj t2_prj -- As a fallback, for types we can't handle, just check convertibility mrProveEqH _ _ t1 t2 = - mrConvertible t1 t2 >>= \case - True -> return () - False -> throwError (TermsNotEq t1 t2) + do success <- mrConvertible t1 t2 + TermInCtx [] <$> liftSC1 scBool success ---------------------------------------------------------------------- From 4fbc4c4d4139e43bf21fd805a9026e8cbd4a34f1 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Fri, 18 Feb 2022 17:31:31 -0800 Subject: [PATCH 036/105] reordered some mrRefines cases; removed some unneeded debugging; changed variable instantiation in mrProvable to use the normalized types --- src/SAWScript/Prover/MRSolver.hs | 44 +++++++++++++++----------------- 1 file changed, 21 insertions(+), 23 deletions(-) diff --git a/src/SAWScript/Prover/MRSolver.hs b/src/SAWScript/Prover/MRSolver.hs index f05eb37aab..c3c25e3588 100644 --- a/src/SAWScript/Prover/MRSolver.hs +++ b/src/SAWScript/Prover/MRSolver.hs @@ -1249,9 +1249,7 @@ mrProvable bool_tm = (closedOpenTerm a) ec <- liftSC2 scFreshEC nm ec_tp >>= liftSC1 scExtCns liftSC4 genBVVecTerm n len a ec - tp' -> - debugPrettyInCtx 2 tp' >> - liftSC2 scFreshEC nm tp >>= liftSC1 scExtCns + tp' -> liftSC2 scFreshEC nm tp' >>= liftSC1 scExtCns normSMTProp prop_inst >>= mrProvableRaw -- | Build a Boolean 'Term' stating that two 'Term's are equal. This is like @@ -1658,6 +1656,26 @@ mrRefines' (ReturnM e1) (ReturnM e2) = mrProveEq e1 e2 mrRefines' (ErrorM _) (ErrorM _) = return () mrRefines' (ReturnM e) (ErrorM _) = throwError (ReturnNotError e) mrRefines' (ErrorM _) (ReturnM e) = throwError (ReturnNotError e) +mrRefines' (MaybeElim (Type (asEq -> Just (tp,e1,e2))) m1 f1 _) m2 = + do cond <- mrEq' tp e1 e2 + not_cond <- liftSC1 scNot cond + cond_pf <- + liftSC1 scEqTrue cond >>= piUVarsM >>= mrFreshVar "pf" >>= mrVarTerm + m1' <- applyNormCompFun f1 cond_pf + cond_holds <- mrProvable cond + if cond_holds then mrRefines m1' m2 else + withAssumption cond (mrRefines m1' m2) >> + withAssumption not_cond (mrRefines m1 m2) +mrRefines' m1 (MaybeElim (Type (asEq -> Just (tp,e1,e2))) m2 f2 _) = + do cond <- mrEq' tp e1 e2 + not_cond <- liftSC1 scNot cond + cond_pf <- + liftSC1 scEqTrue cond >>= piUVarsM >>= mrFreshVar "pf" >>= mrVarTerm + m2' <- applyNormCompFun f2 cond_pf + cond_holds <- mrProvable cond + if cond_holds then mrRefines m1 m2' else + withAssumption cond (mrRefines m1 m2') >> + withAssumption not_cond (mrRefines m1 m2) mrRefines' (Ite cond1 m1 m1') m2_all@(Ite cond2 m2 m2') = liftSC1 scNot cond1 >>= \not_cond1 -> (mrEq cond1 cond2 >>= mrProvable) >>= \case @@ -1679,26 +1697,6 @@ mrRefines' m1 (Ite cond2 m2 m2') = do not_cond2 <- liftSC1 scNot cond2 withAssumption cond2 (mrRefines m1 m2) withAssumption not_cond2 (mrRefines m1 m2') -mrRefines' (MaybeElim (Type (asEq -> Just (tp,e1,e2))) m1 f1 _) m2 = - do cond <- mrEq' tp e1 e2 - not_cond <- liftSC1 scNot cond - cond_pf <- - liftSC1 scEqTrue cond >>= piUVarsM >>= mrFreshVar "pf" >>= mrVarTerm - m1' <- applyNormCompFun f1 cond_pf - cond_holds <- mrProvable cond - if cond_holds then mrRefines m1' m2 else - withAssumption cond (mrRefines m1' m2) >> - withAssumption not_cond (mrRefines m1 m2) -mrRefines' m1 (MaybeElim (Type (asEq -> Just (tp,e1,e2))) m2 f2 _) = - do cond <- mrEq' tp e1 e2 - not_cond <- liftSC1 scNot cond - cond_pf <- - liftSC1 scEqTrue cond >>= piUVarsM >>= mrFreshVar "pf" >>= mrVarTerm - m2' <- applyNormCompFun f2 cond_pf - cond_holds <- mrProvable cond - if cond_holds then mrRefines m1 m2' else - withAssumption cond (mrRefines m1 m2') >> - withAssumption not_cond (mrRefines m1 m2) -- FIXME: handle sum elimination -- mrRefines (Either f1 g1 e1) (Either f2 g2 e2) = mrRefines' m1 (ForallM tp f2) = From 6c324e3340a179b02f54bd090cb0496ed1e273de Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Fri, 18 Feb 2022 18:37:39 -0800 Subject: [PATCH 037/105] bug fix in mrSetEVarClosed, to instantiate evars in the type of the evar being instantiated; trying to figure out why my uninterpreted functions do not work when passing them to the SMT solver... --- src/SAWScript/Prover/MRSolver.hs | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/src/SAWScript/Prover/MRSolver.hs b/src/SAWScript/Prover/MRSolver.hs index c3c25e3588..24eb831fd6 100644 --- a/src/SAWScript/Prover/MRSolver.hs +++ b/src/SAWScript/Prover/MRSolver.hs @@ -154,7 +154,7 @@ import Verifier.SAW.Simulator.TermModel import Verifier.SAW.Simulator.Prims import Verifier.SAW.Simulator.MonadLazy -import SAWScript.Proof (termToProp, prettyProp) +import SAWScript.Proof (termToProp, propToTerm, prettyProp) import qualified SAWScript.Prover.SBV as SBV -- import Debug.Trace @@ -952,8 +952,11 @@ mrFreshEVars = helper [] where mrSetEVarClosed :: MRVar -> Term -> MRM () mrSetEVarClosed var val = do val_tp <- mrTypeOf val + -- NOTE: need to instantiate any evars in the type of var, to ensure the + -- following subtyping check will succeed + var_tp <- mrSubstEVars $ mrVarType var -- FIXME: catch subtyping errors and report them as being evar failures - liftSC3 scCheckSubtype Nothing (TypedTerm val val_tp) (mrVarType var) + liftSC3 scCheckSubtype Nothing (TypedTerm val val_tp) var_tp modify $ \st -> st { mrVars = Map.alter @@ -1223,7 +1226,8 @@ mrProvableRaw prop_term = prop <- liftSC1 termToProp prop_term debugPrint 2 ("Calling SMT solver with proposition: " ++ prettyProp defaultPPOpts prop) - (smt_res, _) <- liftSC4 SBV.proveUnintSBVIO smt_conf mempty timeout prop + unints <- Set.map ecVarIndex <$> getAllExtSet <$> liftSC1 propToTerm prop + (smt_res, _) <- liftSC4 SBV.proveUnintSBVIO smt_conf unints timeout prop case smt_res of Just _ -> debugPrint 2 "SMT solver response: not provable" >> return False From 147209be192ae3f4dbd7db0ffc4909eeea034e06 Mon Sep 17 00:00:00 2001 From: Brian Huffman Date: Wed, 16 Feb 2022 16:22:01 -0800 Subject: [PATCH 038/105] Make `goal_eval_unint` handle functions with arguments of type `Nat`. We can now make functions like `take` and `drop` uninterpreted. Fixes #1588. --- saw-core-what4/src/Verifier/SAW/Simulator/What4.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/saw-core-what4/src/Verifier/SAW/Simulator/What4.hs b/saw-core-what4/src/Verifier/SAW/Simulator/What4.hs index 232d685758..d23043c761 100644 --- a/saw-core-what4/src/Verifier/SAW/Simulator/What4.hs +++ b/saw-core-what4/src/Verifier/SAW/Simulator/What4.hs @@ -1519,6 +1519,10 @@ mkArgTerm sc ty val = do x <- termOfTValue sc tval pure (ArgTermConst x) + (_, VNat n) -> + do x <- scNat sc n + pure (ArgTermConst x) + _ -> fail $ "could not create uninterpreted function argument of type " ++ show ty termOfTValue :: SharedContext -> TValue (What4 sym) -> IO Term From 60e5a48930041eeda472dc8d35748e36529bf801 Mon Sep 17 00:00:00 2001 From: Brian Huffman Date: Wed, 16 Feb 2022 18:10:10 -0800 Subject: [PATCH 039/105] Support `bvToNat` in uninterpreted functions. This lets `goal_eval_unint` and `w4_unint` work with functions like `at`. Fixes #1591. --- saw-core-what4/src/Verifier/SAW/Simulator/What4.hs | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/saw-core-what4/src/Verifier/SAW/Simulator/What4.hs b/saw-core-what4/src/Verifier/SAW/Simulator/What4.hs index d23043c761..f106645b9e 100644 --- a/saw-core-what4/src/Verifier/SAW/Simulator/What4.hs +++ b/saw-core-what4/src/Verifier/SAW/Simulator/What4.hs @@ -961,6 +961,8 @@ applyUnintApp sym app0 v = VCtorApp i ps xv -> foldM (applyUnintApp sym) app' =<< traverse force (ps++xv) where app' = suffixUnintApp ("_" ++ (Text.unpack (identBaseName (primName i)))) app0 VNat n -> return (suffixUnintApp ("_" ++ show n) app0) + VBVToNat w v' -> applyUnintApp sym app' v' + where app' = suffixUnintApp ("_" ++ show w) app0 TValue (suffixTValue -> Just s) -> return (suffixUnintApp s app0) VFun _ _ -> @@ -1399,6 +1401,7 @@ data ArgTerm -- ^ length, element type, list, index | ArgTermPairLeft ArgTerm | ArgTermPairRight ArgTerm + | ArgTermBVToNat Natural ArgTerm -- | Reassemble a saw-core term from an 'ArgTerm' and a list of parts. -- The length of the list should be equal to the number of @@ -1468,6 +1471,10 @@ reconstructArgTerm atrm sc ts = do (x1, ts1) <- parse at1 ts0 x <- scPairRight sc x1 return (x, ts1) + ArgTermBVToNat w at1 -> + do (x1, ts1) <- parse at1 ts0 + x <- scBvToNat sc w x1 + pure (x, ts1) parseList :: [ArgTerm] -> [Term] -> IO ([Term], [Term]) parseList [] ts0 = return ([], ts0) @@ -1523,6 +1530,11 @@ mkArgTerm sc ty val = do x <- scNat sc n pure (ArgTermConst x) + (_, VBVToNat w v) -> + do let w' = fromIntegral w -- FIXME: make w :: Natural to avoid fromIntegral + x <- mkArgTerm sc (VVecType w' VBoolType) v + pure (ArgTermBVToNat w' x) + _ -> fail $ "could not create uninterpreted function argument of type " ++ show ty termOfTValue :: SharedContext -> TValue (What4 sym) -> IO Term From 4916239a63b5129314ca73785cb704e01da4b5aa Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Mon, 21 Feb 2022 10:19:50 -0800 Subject: [PATCH 040/105] added MR solver test case for the arrays example --- heapster-saw/examples/arrays_mr_solver.saw | 3 +++ 1 file changed, 3 insertions(+) create mode 100644 heapster-saw/examples/arrays_mr_solver.saw diff --git a/heapster-saw/examples/arrays_mr_solver.saw b/heapster-saw/examples/arrays_mr_solver.saw new file mode 100644 index 0000000000..0229540028 --- /dev/null +++ b/heapster-saw/examples/arrays_mr_solver.saw @@ -0,0 +1,3 @@ +include "arrays.saw"; +contains0 <- parse_core_mod "arrays" "contains0"; +mr_solver_debug 2 contains0 contains0; From 19280f4ccde8da3f43766e4257cbff43af91ce9b Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Mon, 21 Feb 2022 11:17:23 -0800 Subject: [PATCH 041/105] added a comment about withUVars being wrong --- src/SAWScript/Prover/MRSolver.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/SAWScript/Prover/MRSolver.hs b/src/SAWScript/Prover/MRSolver.hs index 24eb831fd6..5591ecff6a 100644 --- a/src/SAWScript/Prover/MRSolver.hs +++ b/src/SAWScript/Prover/MRSolver.hs @@ -805,6 +805,8 @@ withUVars = helper [] where helper :: [Term] -> [(LocalName,Term)] -> ([Term] -> MRM a) -> MRM a helper vars [] m = m $ reverse vars helper vars ((nm,tp):ctx) m = + -- FIXME: I think substituting here is wrong, but works on closed terms, so + -- it's fine to use at the top level at least... substTerm 0 vars tp >>= \tp' -> withUVarLift nm (Type tp') vars $ \var vars' -> helper (var:vars') ctx m From 26fcc21b0c9272eae6f5180e58c3d6988bce5ab4 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Mon, 21 Feb 2022 12:27:33 -0800 Subject: [PATCH 042/105] changed MR Solver to use the What4 backend in place of SBV --- src/SAWScript/Builtins.hs | 2 +- src/SAWScript/Prover/MRSolver.hs | 32 +++++++++++++++----------------- 2 files changed, 16 insertions(+), 18 deletions(-) diff --git a/src/SAWScript/Builtins.hs b/src/SAWScript/Builtins.hs index 22e6c9c25c..22e4565920 100644 --- a/src/SAWScript/Builtins.hs +++ b/src/SAWScript/Builtins.hs @@ -1562,7 +1562,7 @@ mrSolver :: SharedContext -> Int -> TypedTerm -> TypedTerm -> TopLevel Bool mrSolver sc dlvl t1 t2 = do m1 <- ttTerm <$> ensureMonadicTerm sc t1 m2 <- ttTerm <$> ensureMonadicTerm sc t2 - res <- liftIO $ Prover.askMRSolver sc dlvl SBV.z3 Nothing m1 m2 + res <- liftIO $ Prover.askMRSolver sc dlvl Nothing m1 m2 case res of Just err -> io (putStrLn $ Prover.showMRFailure err) >> return False Nothing -> return True diff --git a/src/SAWScript/Prover/MRSolver.hs b/src/SAWScript/Prover/MRSolver.hs index 5591ecff6a..b208a31dce 100644 --- a/src/SAWScript/Prover/MRSolver.hs +++ b/src/SAWScript/Prover/MRSolver.hs @@ -118,10 +118,7 @@ C |- F e1 ... en >>= k |= F' e1' ... em' >>= k': -} module SAWScript.Prover.MRSolver - (askMRSolver, MRFailure(..), showMRFailure, isCompFunType - , SBV.SMTConfig - , SBV.z3, SBV.cvc4, SBV.yices, SBV.mathSAT, SBV.boolector - ) where + (askMRSolver, MRFailure(..), showMRFailure, isCompFunType) where import Data.List (find, findIndex) import qualified Data.Text as T @@ -155,7 +152,8 @@ import Verifier.SAW.Simulator.Prims import Verifier.SAW.Simulator.MonadLazy import SAWScript.Proof (termToProp, propToTerm, prettyProp) -import qualified SAWScript.Prover.SBV as SBV +import What4.Solver +import SAWScript.Prover.What4 -- import Debug.Trace @@ -632,8 +630,6 @@ data FunAssump = FunAssump { data MRState = MRState { -- | Global shared context for building terms, etc. mrSC :: SharedContext, - -- | Global SMT configuration for the duration of the MR. Solver call - mrSMTConfig :: SBV.SMTConfig, -- | SMT timeout for SMT calls made by Mr. Solver mrSMTTimeout :: Maybe Integer, -- | The context of universal variables, which are free SAW core variables, in @@ -653,11 +649,11 @@ data MRState = MRState { -- | Build a default, empty state from SMT configuration parameters and a set of -- function refinement assumptions -mkMRState :: SharedContext -> Map FunName FunAssump -> SBV.SMTConfig -> +mkMRState :: SharedContext -> Map FunName FunAssump -> Maybe Integer -> Int -> IO MRState -mkMRState sc fun_assumps smt_config timeout dlvl = +mkMRState sc fun_assumps timeout dlvl = scBool sc True >>= \true_tm -> - return $ MRState { mrSC = sc, mrSMTConfig = smt_config, + return $ MRState { mrSC = sc, mrSMTTimeout = timeout, mrUVars = [], mrVars = Map.empty, mrFunAssumps = fun_assumps, mrAssumptions = true_tm, mrDebugLevel = dlvl } @@ -1221,15 +1217,18 @@ normSMTProp t = -- | Test if a closed Boolean term is "provable", i.e., its negation is -- unsatisfiable, using an SMT solver. By "closed" we mean that it contains no -- uvars or 'MRVar's. +-- +-- FIXME: use the timeout! mrProvableRaw :: Term -> MRM Bool mrProvableRaw prop_term = - do smt_conf <- mrSMTConfig <$> get - timeout <- mrSMTTimeout <$> get + do sc <- mrSC <$> get prop <- liftSC1 termToProp prop_term + unints <- Set.map ecVarIndex <$> getAllExtSet <$> liftSC1 propToTerm prop debugPrint 2 ("Calling SMT solver with proposition: " ++ prettyProp defaultPPOpts prop) - unints <- Set.map ecVarIndex <$> getAllExtSet <$> liftSC1 propToTerm prop - (smt_res, _) <- liftSC4 SBV.proveUnintSBVIO smt_conf unints timeout prop + sym <- liftIO $ setupWhat4_sym True + (smt_res, _) <- + liftIO $ proveWhat4_solver z3Adapter sym unints sc prop (return ()) case smt_res of Just _ -> debugPrint 2 "SMT solver response: not provable" >> return False @@ -1888,14 +1887,13 @@ mrRefinesFun _ _ = error "mrRefinesFun: unreachable!" askMRSolver :: SharedContext -> Int {- ^ The debug level -} -> - SBV.SMTConfig {- ^ SBV configuration -} -> Maybe Integer {- ^ Timeout in milliseconds for each SMT call -} -> Term -> Term -> IO (Maybe MRFailure) -askMRSolver sc dlvl smt_conf timeout t1 t2 = +askMRSolver sc dlvl timeout t1 t2 = do tp1 <- scTypeOf sc t1 >>= scWhnf sc tp2 <- scTypeOf sc t2 >>= scWhnf sc - init_st <- mkMRState sc Map.empty smt_conf timeout dlvl + init_st <- mkMRState sc Map.empty timeout dlvl case asPiList tp1 of (uvar_ctx, asCompM -> Just _) -> fmap (either Just (const Nothing)) $ runMRM init_st $ From e4f94a1e17b4c72ac669851aad5d34710072136f Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Mon, 21 Feb 2022 15:43:31 -0800 Subject: [PATCH 043/105] lowered the debug level of arrays_mr_solver.saw to 1 --- heapster-saw/examples/arrays_mr_solver.saw | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/heapster-saw/examples/arrays_mr_solver.saw b/heapster-saw/examples/arrays_mr_solver.saw index 0229540028..0326bac2ec 100644 --- a/heapster-saw/examples/arrays_mr_solver.saw +++ b/heapster-saw/examples/arrays_mr_solver.saw @@ -1,3 +1,3 @@ include "arrays.saw"; contains0 <- parse_core_mod "arrays" "contains0"; -mr_solver_debug 2 contains0 contains0; +mr_solver_debug 1 contains0 contains0; From 8d0aa64b19c5313f84ec5ecb3a0b6f66101cdfa4 Mon Sep 17 00:00:00 2001 From: Matthew Yacavone Date: Mon, 21 Feb 2022 19:10:36 -0500 Subject: [PATCH 044/105] fix typo in definition of `liftSC5` --- src/SAWScript/Prover/MRSolver.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/SAWScript/Prover/MRSolver.hs b/src/SAWScript/Prover/MRSolver.hs index b208a31dce..f828ee69a1 100644 --- a/src/SAWScript/Prover/MRSolver.hs +++ b/src/SAWScript/Prover/MRSolver.hs @@ -719,7 +719,7 @@ liftSC4 :: (SharedContext -> a -> b -> c -> d -> IO e) -> a -> b -> c -> d -> MRM e liftSC4 f a b c d = (mrSC <$> get) >>= \sc -> liftIO (f sc a b c d) --- | Lift a quaternary SharedTerm computation into 'MRM' +-- | Lift a quinary SharedTerm computation into 'MRM' liftSC5 :: (SharedContext -> a -> b -> c -> d -> e -> IO f) -> a -> b -> c -> d -> e -> MRM f liftSC5 f a b c d e = (mrSC <$> get) >>= \sc -> liftIO (f sc a b c d e) From 2847921807daa3067622c220832fabb3bc11c3a9 Mon Sep 17 00:00:00 2001 From: Ryan Scott Date: Mon, 21 Feb 2022 13:28:56 -0500 Subject: [PATCH 045/105] Bump macaw submodule, adapt to GaloisInc/macaw#264 This bumps the `macaw` submodule, which brings in changes from GaloisInc/macaw#264. This requires explicitly instantiating the new `personality` type variable of `LookupFunctionHandle` to accommodate. --- deps/macaw | 2 +- src/SAWScript/X86.hs | 2 +- src/SAWScript/X86Spec.hs | 7 +++++-- 3 files changed, 7 insertions(+), 4 deletions(-) diff --git a/deps/macaw b/deps/macaw index ad51ae3c54..a43151963d 160000 --- a/deps/macaw +++ b/deps/macaw @@ -1 +1 @@ -Subproject commit ad51ae3c54be97f4f7d15e8eaed9344341ce88e4 +Subproject commit a43151963da70e4d4c3d69f9605e82e44ff30731 diff --git a/src/SAWScript/X86.hs b/src/SAWScript/X86.hs index 578d2cbf35..ce90faef4b 100644 --- a/src/SAWScript/X86.hs +++ b/src/SAWScript/X86.hs @@ -185,7 +185,7 @@ data Fun = Fun { funName :: ByteString, funSpec :: FunSpec } -------------------------------------------------------------------------------- -type CallHandler = Sym -> Macaw.LookupFunctionHandle Sym X86_64 +type CallHandler = Sym -> Macaw.LookupFunctionHandle (MacawSimulatorState Sym) Sym X86_64 -- | Run a top-level proof. -- Should be used when making a standalone proof script. diff --git a/src/SAWScript/X86Spec.hs b/src/SAWScript/X86Spec.hs index f160e6bc00..d11e3ef2ae 100644 --- a/src/SAWScript/X86Spec.hs +++ b/src/SAWScript/X86Spec.hs @@ -123,7 +123,10 @@ import Lang.Crucible.Types import Verifier.SAW.SharedTerm (Term,scApplyAll,scVector,scBitvector,scAt,scNat) import Data.Macaw.Memory(RegionIndex) -import Data.Macaw.Symbolic(GlobalMap(..), ToCrucibleType, LookupFunctionHandle(..), MacawCrucibleRegTypes) +import Data.Macaw.Symbolic + ( GlobalMap(..), ToCrucibleType, LookupFunctionHandle(..) + , MacawCrucibleRegTypes, MacawSimulatorState + ) import Data.Macaw.Symbolic.Backend ( crucArchRegTypes ) import Data.Macaw.X86.X86Reg import Data.Macaw.X86.Symbolic @@ -1203,7 +1206,7 @@ _debugDumpGoals opts = sh (ProofGoal _hyps g) = print (view labeledPredMsg g) -type Overrides = Map (Natural,Integer) (Sym -> LookupFunctionHandle Sym X86_64) +type Overrides = Map (Natural,Integer) (Sym -> LookupFunctionHandle (MacawSimulatorState Sym) Sym X86_64) -- | Use a specification to verify a function. -- Returns the initial state for the function, and a post-condition. From bf442c73b865fdeb27bceb578edcf56111e207ee Mon Sep 17 00:00:00 2001 From: Matthew Yacavone Date: Tue, 22 Feb 2022 14:37:09 -0800 Subject: [PATCH 046/105] split MRSolver.hs into multiple files --- saw-script.cabal | 4 + src/SAWScript/Prover/MRSolver.hs | 1902 +---------------------- src/SAWScript/Prover/MRSolver/Monad.hs | 695 +++++++++ src/SAWScript/Prover/MRSolver/SMT.hs | 353 +++++ src/SAWScript/Prover/MRSolver/Solver.hs | 617 ++++++++ src/SAWScript/Prover/MRSolver/Term.hs | 341 ++++ 6 files changed, 2015 insertions(+), 1897 deletions(-) create mode 100644 src/SAWScript/Prover/MRSolver/Monad.hs create mode 100644 src/SAWScript/Prover/MRSolver/SMT.hs create mode 100644 src/SAWScript/Prover/MRSolver/Solver.hs create mode 100644 src/SAWScript/Prover/MRSolver/Term.hs diff --git a/saw-script.cabal b/saw-script.cabal index e3cddc58b6..47496b4791 100644 --- a/saw-script.cabal +++ b/saw-script.cabal @@ -159,6 +159,10 @@ library SAWScript.Prover.Util SAWScript.Prover.SBV SAWScript.Prover.MRSolver + SAWScript.Prover.MRSolver.Monad + SAWScript.Prover.MRSolver.SMT + SAWScript.Prover.MRSolver.Solver + SAWScript.Prover.MRSolver.Term SAWScript.Prover.RME SAWScript.Prover.ABC SAWScript.Prover.What4 diff --git a/src/SAWScript/Prover/MRSolver.hs b/src/SAWScript/Prover/MRSolver.hs index f828ee69a1..856f94a5a7 100644 --- a/src/SAWScript/Prover/MRSolver.hs +++ b/src/SAWScript/Prover/MRSolver.hs @@ -1,1908 +1,16 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE TupleSections #-} - {- | Module : SAWScript.Prover.MRSolver -Copyright : Galois, Inc. 2021 +Description : The SAW monadic-recursive solver (Mr. Solver) +Copyright : Galois, Inc. 2022 License : BSD3 Maintainer : westbrook@galois.com Stability : experimental Portability : non-portable (language extensions) - -This module implements a monadic-recursive solver, for proving that one monadic -term refines another. The algorithm works on the "monadic normal form" of -computations, which uses the following laws to simplify binds in computations, -where either is the sum elimination function defined in the SAW core prelude: - -returnM x >>= k = k x -errorM str >>= k = errorM -(m >>= k1) >>= k2 = m >>= \x -> k1 x >>= k2 -(existsM f) >>= k = existsM (\x -> f x >>= k) -(forallM f) >>= k = forallM (\x -> f x >>= k) -(orM m1 m2) >>= k = orM (m1 >>= k) (m2 >>= k) -(if b then m1 else m2) >>= k = if b then m1 >>= k else m2 >>1 k -(either f1 f2 e) >>= k = either (\x -> f1 x >= k) (\x -> f2 x >= k) e -(letrecM funs body) >>= k = letrecM funs (\F1 ... Fn -> body F1 ... Fn >>= k) - -The resulting computations of one of the following forms: - -returnM e | errorM str | existsM f | forallM f | orM m1 m2 | -if b then m1 else m2 | either f1 f2 e | F e1 ... en | F e1 ... en >>= k | -letrecM lrts B (\F1 ... Fn -> (f1, ..., fn)) (\F1 ... Fn -> m) - -The form F e1 ... en refers to a recursively-defined function or a function -variable that has been locally bound by a letrecM. Either way, monadic -normalization does not attempt to normalize these functions. - -The algorithm maintains a context of three sorts of variables: letrec-bound -variables, existential variables, and universal variables. Universal variables -are represented as free SAW core variables, while the other two forms of -variable are represented as SAW core 'ExtCns's terms, which are essentially -axioms that have been generated internally. These 'ExtCns's are Skolemized, -meaning that they take in as arguments all universal variables that were in -scope when they were created. The context also maintains a partial substitution -for the existential variables, as they become instantiated with values, and it -additionally remembers the bodies / unfoldings of the letrec-bound variables. - -The goal of the solver at any point is of the form C |- m1 |= m2, meaning that -we are trying to prove m1 refines m2 in context C. This proceed by cases: - -C |- returnM e1 |= returnM e2: prove C |- e1 = e2 - -C |- errorM str1 |= errorM str2: vacuously true - -C |- if b then m1' else m1'' |= m2: prove C,b=true |- m1' |= m2 and -C,b=false |- m1'' |= m2, skipping either case where C,b=X is unsatisfiable; - -C |- m1 |= if b then m2' else m2'': similar to the above - -C |- either T U (CompM V) f1 f2 e |= m: prove C,x:T,e=inl x |- f1 x |= m and -C,y:U,e=inl y |- f2 y |= m, again skippping any case with unsatisfiable context; - -C |- m |= either T U (CompM V) f1 f2 e: similar to previous - -C |- m |= forallM f: make a new universal variable x and recurse - -C |- existsM f |= m: make a new universal variable x and recurse (existential -elimination uses universal variables and vice-versa) - -C |- m |= existsM f: make a new existential variable x and recurse - -C |- forall f |= m: make a new existential variable x and recurse - -C |- m |= orM m1 m2: try to prove C |- m |= m1, and if that fails, backtrack and -prove C |- m |= m2 - -C |- orM m1 m2 |= m: prove both C |- m1 |= m and C |- m2 |= m - -C |- letrec (\F1 ... Fn -> (f1, ..., fn)) (\F1 ... Fn -> body) |= m: create -letrec-bound variables F1 through Fn in the context bound to their unfoldings f1 -through fn, respectively, and recurse on body |= m - -C |- m |= letrec (\F1 ... Fn -> (f1, ..., fn)) (\F1 ... Fn -> body): similar to -previous case - -C |- F e1 ... en >>= k |= F e1' ... en' >>= k': prove C |- ei = ei' for each i -and then prove k x |= k' x for new universal variable x - -C |- F e1 ... en >>= k |= F' e1' ... em' >>= k': - -* If we have an assumption that forall x1 ... xj, F a1 ... an |= F' a1' .. am', - prove ei = ai and ei' = ai' and then that C |- k x |= k' x for fresh uvar x - -* If we have an assumption that forall x1, ..., xn, F e1'' ... en'' |= m' for - some ei'' and m', match the ei'' against the ei by instantiating the xj with - fresh evars, and if this succeeds then recursively prove C |- m' >>= k |= RHS - -(We don't do this one right now) -* If we have an assumption that forall x1', ..., xn', m |= F e1'' ... en'' for - some ei'' and m', match the ei'' against the ei by instantiating the xj with - fresh evars, and if this succeeds then recursively prove C |- LHS |= m' >>= k' - -* If either side is a definition whose unfolding does not contain letrecM, fixM, - or any related operations, unfold it - -* If F and F' have the same return type, add an assumption forall uvars in scope - that F e1 ... en |= F' e1' ... em' and unfold both sides, recursively proving - that F_body e1 ... en |= F_body' e1' ... em'. Then also prove k x |= k' x for - fresh uvar x. - -* Otherwise we don't know to "split" one of the sides into a bind whose - components relate to the two components on the other side, so just fail -} module SAWScript.Prover.MRSolver (askMRSolver, MRFailure(..), showMRFailure, isCompFunType) where -import Data.List (find, findIndex) -import qualified Data.Text as T -import qualified Data.Vector as V -import Data.IORef -import System.IO (hPutStrLn, stderr) -import Control.Monad.Reader -import Control.Monad.State -import Control.Monad.Except -import Control.Monad.Trans.Maybe - -import qualified Data.IntMap as IntMap -import Data.Map (Map) -import qualified Data.Map as Map -import qualified Data.Set as Set - -import Prettyprinter - -import Verifier.SAW.Term.Functor -import Verifier.SAW.Term.CtxTerm (MonadTerm(..)) -import Verifier.SAW.Term.Pretty -import Verifier.SAW.SCTypeCheck -import Verifier.SAW.SharedTerm -import Verifier.SAW.Recognizer -import Verifier.SAW.OpenTerm -import Verifier.SAW.Cryptol.Monadify - -import qualified Verifier.SAW.Prim as Prim -import Verifier.SAW.Simulator.TermModel -import Verifier.SAW.Simulator.Prims -import Verifier.SAW.Simulator.MonadLazy - -import SAWScript.Proof (termToProp, propToTerm, prettyProp) -import What4.Solver -import SAWScript.Prover.What4 - --- import Debug.Trace - - ----------------------------------------------------------------------- --- * Utility Functions for Transforming 'Term's ----------------------------------------------------------------------- - --- | Transform the immediate subterms of a term using the supplied function -traverseSubterms :: MonadTerm m => (Term -> m Term) -> Term -> m Term -traverseSubterms f (unwrapTermF -> tf) = traverse f tf >>= mkTermF - --- | Build a recursive memoized function for tranforming 'Term's. Take in a --- function @f@ that intuitively performs one step of the transformation and --- allow it to recursively call the memoized function being defined by passing --- it as the first argument to @f@. -memoFixTermFun :: MonadIO m => ((Term -> m a) -> Term -> m a) -> Term -> m a -memoFixTermFun f term_top = - do table_ref <- liftIO $ newIORef IntMap.empty - let go t@(STApp { stAppIndex = ix }) = - liftIO (readIORef table_ref) >>= \table -> - case IntMap.lookup ix table of - Just ret -> return ret - Nothing -> - do ret <- f go t - liftIO $ modifyIORef' table_ref (IntMap.insert ix ret) - return ret - go t = f go t - go term_top - --- | Recursively test if a 'Term' contains @letRecM@ -_containsLetRecM :: Term -> Bool -_containsLetRecM (asGlobalDef -> Just "Prelude.letRecM") = True -_containsLetRecM (unwrapTermF -> tf) = any _containsLetRecM tf - - ----------------------------------------------------------------------- --- * MR Solver Term Representation ----------------------------------------------------------------------- - --- | A variable used by the MR solver -newtype MRVar = MRVar { unMRVar :: ExtCns Term } deriving (Eq, Show, Ord) - --- | Get the type of an 'MRVar' -mrVarType :: MRVar -> Term -mrVarType = ecType . unMRVar - --- | A tuple or record projection of a 'Term' -data TermProj = TermProjLeft | TermProjRight | TermProjRecord FieldName - deriving (Eq, Ord, Show) - --- | Apply a 'TermProj' to perform a projection on a 'Term' -doTermProj :: Term -> TermProj -> MRM Term -doTermProj t TermProjLeft = liftSC1 scPairLeft t -doTermProj t TermProjRight = liftSC1 scPairRight t -doTermProj t (TermProjRecord fld) = liftSC2 scRecordSelect t fld - --- | Apply a 'TermProj' to a type to get the output type of the projection, --- assuming that the type is already normalized -doTypeProj :: Term -> TermProj -> MRM Term -doTypeProj (asPairType -> Just (tp1, _)) TermProjLeft = return tp1 -doTypeProj (asPairType -> Just (_, tp2)) TermProjRight = return tp2 -doTypeProj (asRecordType -> Just tp_map) (TermProjRecord fld) - | Just tp <- Map.lookup fld tp_map - = return tp -doTypeProj _ _ = - -- FIXME: better error message? This is an error and not an MRFailure because - -- we should only be projecting types for terms that we have already seen... - error "doTypeProj" - --- | Recognize a 'Term' as 0 or more projections -asProjAll :: Term -> (Term, [TermProj]) -asProjAll (asRecordSelector -> Just ((asProjAll -> (t, projs)), fld)) = - (t, TermProjRecord fld:projs) -asProjAll (asPairSelector -> Just ((asProjAll -> (t, projs)), isRight)) - | isRight = (t, TermProjRight:projs) - | not isRight = (t, TermProjLeft:projs) -asProjAll t = (t, []) - --- | Names of functions to be used in computations, which are either names bound --- by letrec to for recursive calls to fixed-points, existential variables, or --- (possibly projections of) of global named constants -data FunName - = LetRecName MRVar | EVarFunName MRVar | GlobalName GlobalDef [TermProj] - deriving (Eq, Ord, Show) - --- | Get and normalize the type of a 'FunName' -funNameType :: FunName -> MRM Term -funNameType (LetRecName var) = liftSC1 scWhnf $ mrVarType var -funNameType (EVarFunName var) = liftSC1 scWhnf $ mrVarType var -funNameType (GlobalName gd projs) = - liftSC1 scWhnf (globalDefType gd) >>= \gd_tp -> - foldM doTypeProj gd_tp projs - --- | Recognize a 'Term' as (possibly a projection of) a global name -asTypedGlobalProj :: Recognizer Term (GlobalDef, [TermProj]) -asTypedGlobalProj (asProjAll -> ((asTypedGlobalDef -> Just glob), projs)) = - Just (glob, projs) -asTypedGlobalProj _ = Nothing - --- | Recognize a 'Term' as (possibly a projection of) a global name -asGlobalFunName :: Recognizer Term FunName -asGlobalFunName (asTypedGlobalProj -> Just (glob, projs)) = - Just $ GlobalName glob projs -asGlobalFunName _ = Nothing - --- | A term specifically known to be of type @sort i@ for some @i@ -newtype Type = Type Term deriving Show - --- | A Haskell representation of a @CompM@ in "monadic normal form" -data NormComp - = ReturnM Term -- ^ A term @returnM a x@ - | ErrorM Term -- ^ A term @errorM a str@ - | Ite Term Comp Comp -- ^ If-then-else computation - | Either CompFun CompFun Term -- ^ A sum elimination - | MaybeElim Type Comp CompFun Term -- ^ A maybe elimination - | OrM Comp Comp -- ^ an @orM@ computation - | ExistsM Type CompFun -- ^ an @existsM@ computation - | ForallM Type CompFun -- ^ a @forallM@ computation - | FunBind FunName [Term] CompFun - -- ^ Bind a monadic function with @N@ arguments in an @a -> CompM b@ term - deriving Show - --- | A computation function of type @a -> CompM b@ for some @a@ and @b@ -data CompFun - -- | An arbitrary term - = CompFunTerm Term - -- | A special case for the term @\ (x:a) -> returnM a x@ - | CompFunReturn - -- | The monadic composition @f >=> g@ - | CompFunComp CompFun CompFun - deriving Show - --- | Compose two 'CompFun's, simplifying if one is a 'CompFunReturn' -compFunComp :: CompFun -> CompFun -> CompFun -compFunComp CompFunReturn f = f -compFunComp f CompFunReturn = f -compFunComp f g = CompFunComp f g - --- | If a 'CompFun' contains an explicit lambda-abstraction, then return the --- textual name bound by that lambda -compFunVarName :: CompFun -> Maybe LocalName -compFunVarName (CompFunTerm (asLambda -> Just (nm, _, _))) = Just nm -compFunVarName (CompFunComp f _) = compFunVarName f -compFunVarName _ = Nothing - --- | If a 'CompFun' contains an explicit lambda-abstraction, then return the --- input type for it -compFunInputType :: CompFun -> Maybe Type -compFunInputType (CompFunTerm (asLambda -> Just (_, tp, _))) = Just $ Type tp -compFunInputType (CompFunComp f _) = compFunInputType f -compFunInputType _ = Nothing - --- | A computation of type @CompM a@ for some @a@ -data Comp = CompTerm Term | CompBind Comp CompFun | CompReturn Term - deriving Show - - ----------------------------------------------------------------------- --- * Pretty-Printing MR Solver Terms ----------------------------------------------------------------------- - --- | The monad for pretty-printing in a context of SAW core variables -type PPInCtxM = Reader [LocalName] - --- | Pretty-print an object in a SAW core context and render to a 'String' -showInCtx :: PrettyInCtx a => [LocalName] -> a -> String -showInCtx ctx a = - renderSawDoc defaultPPOpts $ runReader (prettyInCtx a) ctx - --- | A generic function for pretty-printing an object in a SAW core context of --- locally-bound names -class PrettyInCtx a where - prettyInCtx :: a -> PPInCtxM SawDoc - -instance PrettyInCtx Term where - prettyInCtx t = flip (ppTermInCtx defaultPPOpts) t <$> ask - --- | Combine a list of pretty-printed documents that represent an application -prettyAppList :: [PPInCtxM SawDoc] -> PPInCtxM SawDoc -prettyAppList = fmap (group . hang 2 . vsep) . sequence - -instance PrettyInCtx Type where - prettyInCtx (Type t) = prettyInCtx t - -instance PrettyInCtx MRVar where - prettyInCtx (MRVar ec) = return $ ppName $ ecName ec - -instance PrettyInCtx TermProj where - prettyInCtx TermProjLeft = return (pretty '.' <> "1") - prettyInCtx TermProjRight = return (pretty '.' <> "2") - prettyInCtx (TermProjRecord fld) = return (pretty '.' <> pretty fld) - -instance PrettyInCtx FunName where - prettyInCtx (LetRecName var) = prettyInCtx var - prettyInCtx (EVarFunName var) = prettyInCtx var - prettyInCtx (GlobalName g projs) = - foldM (\pp proj -> (pp <>) <$> prettyInCtx proj) (viaShow g) projs - -instance PrettyInCtx Comp where - prettyInCtx (CompTerm t) = prettyInCtx t - prettyInCtx (CompBind c f) = - prettyAppList [prettyInCtx c, return ">>=", prettyInCtx f] - prettyInCtx (CompReturn t) = - prettyAppList [ return "returnM", return "_", parens <$> prettyInCtx t] - -instance PrettyInCtx CompFun where - prettyInCtx (CompFunTerm t) = prettyInCtx t - prettyInCtx CompFunReturn = return "returnM" - prettyInCtx (CompFunComp f g) = - prettyAppList [prettyInCtx f, return ">=>", prettyInCtx g] - -instance PrettyInCtx NormComp where - prettyInCtx (ReturnM t) = - prettyAppList [return "returnM", return "_", parens <$> prettyInCtx t] - prettyInCtx (ErrorM str) = - prettyAppList [return "errorM", return "_", parens <$> prettyInCtx str] - prettyInCtx (Ite cond t1 t2) = - prettyAppList [return "ite", return "_", parens <$> prettyInCtx cond, - parens <$> prettyInCtx t1, parens <$> prettyInCtx t2] - prettyInCtx (Either f g eith) = - prettyAppList [return "either", return "_", return "_", return "_", - parens <$> prettyInCtx f, parens <$> prettyInCtx g, - parens <$> prettyInCtx eith] - prettyInCtx (MaybeElim tp m f mayb) = - prettyAppList [return "maybe", parens <$> prettyInCtx tp, - return (parens "CompM _"), parens <$> prettyInCtx m, - parens <$> prettyInCtx f, parens <$> prettyInCtx mayb] - prettyInCtx (OrM t1 t2) = - prettyAppList [return "orM", return "_", - parens <$> prettyInCtx t1, parens <$> prettyInCtx t2] - prettyInCtx (ExistsM tp f) = - prettyAppList [return "existsM", prettyInCtx tp, return "_", - parens <$> prettyInCtx f] - prettyInCtx (ForallM tp f) = - prettyAppList [return "forallM", prettyInCtx tp, return "_", - parens <$> prettyInCtx f] - prettyInCtx (FunBind f args CompFunReturn) = - prettyAppList (prettyInCtx f : map prettyInCtx args) - prettyInCtx (FunBind f [] k) = - prettyAppList [prettyInCtx f, return ">>=", prettyInCtx k] - prettyInCtx (FunBind f args k) = - prettyAppList - [parens <$> prettyAppList (prettyInCtx f : map prettyInCtx args), - return ">>=", prettyInCtx k] - - ----------------------------------------------------------------------- --- * Lifting MR Solver Terms ----------------------------------------------------------------------- - --- | A term-like object is one that supports lifting and substitution -class TermLike a where - liftTermLike :: MonadTerm m => DeBruijnIndex -> DeBruijnIndex -> a -> m a - substTermLike :: MonadTerm m => DeBruijnIndex -> [Term] -> a -> m a - -instance (TermLike a, TermLike b) => TermLike (a,b) where - liftTermLike n i (a,b) = (,) <$> liftTermLike n i a <*> liftTermLike n i b - substTermLike n s (a,b) = (,) <$> substTermLike n s a <*> substTermLike n s b - -instance TermLike a => TermLike [a] where - liftTermLike n i l = mapM (liftTermLike n i) l - substTermLike n s l = mapM (substTermLike n s) l - -instance TermLike Term where - liftTermLike = liftTerm - substTermLike = substTerm - -instance TermLike Type where - liftTermLike n i (Type tp) = Type <$> liftTerm n i tp - substTermLike n s (Type tp) = Type <$> substTerm n s tp - -instance TermLike NormComp where - liftTermLike n i (ReturnM t) = ReturnM <$> liftTermLike n i t - liftTermLike n i (ErrorM str) = ErrorM <$> liftTermLike n i str - liftTermLike n i (Ite cond t1 t2) = - Ite <$> liftTermLike n i cond <*> liftTermLike n i t1 <*> liftTermLike n i t2 - liftTermLike n i (Either f g eith) = - Either <$> liftTermLike n i f <*> liftTermLike n i g <*> liftTermLike n i eith - liftTermLike n i (MaybeElim tp m f mayb) = - MaybeElim <$> liftTermLike n i tp <*> liftTermLike n i m - <*> liftTermLike n i f <*> liftTermLike n i mayb - liftTermLike n i (OrM t1 t2) = - OrM <$> liftTermLike n i t1 <*> liftTermLike n i t2 - liftTermLike n i (ExistsM tp f) = - ExistsM <$> liftTermLike n i tp <*> liftTermLike n i f - liftTermLike n i (ForallM tp f) = - ForallM <$> liftTermLike n i tp <*> liftTermLike n i f - liftTermLike n i (FunBind nm args f) = - FunBind nm <$> mapM (liftTermLike n i) args <*> liftTermLike n i f - - substTermLike n s (ReturnM t) = ReturnM <$> substTermLike n s t - substTermLike n s (ErrorM str) = ErrorM <$> substTermLike n s str - substTermLike n s (Ite cond t1 t2) = - Ite <$> substTermLike n s cond <*> substTermLike n s t1 - <*> substTermLike n s t2 - substTermLike n s (Either f g eith) = - Either <$> substTermLike n s f <*> substTermLike n s g - <*> substTermLike n s eith - substTermLike n s (MaybeElim tp m f mayb) = - MaybeElim <$> substTermLike n s tp <*> substTermLike n s m - <*> substTermLike n s f <*> substTermLike n s mayb - substTermLike n s (OrM t1 t2) = - OrM <$> substTermLike n s t1 <*> substTermLike n s t2 - substTermLike n s (ExistsM tp f) = - ExistsM <$> substTermLike n s tp <*> substTermLike n s f - substTermLike n s (ForallM tp f) = - ForallM <$> substTermLike n s tp <*> substTermLike n s f - substTermLike n s (FunBind nm args f) = - FunBind nm <$> mapM (substTermLike n s) args <*> substTermLike n s f - -instance TermLike CompFun where - liftTermLike n i (CompFunTerm t) = CompFunTerm <$> liftTermLike n i t - liftTermLike _ _ CompFunReturn = return CompFunReturn - liftTermLike n i (CompFunComp f g) = - CompFunComp <$> liftTermLike n i f <*> liftTermLike n i g - - substTermLike n s (CompFunTerm t) = CompFunTerm <$> substTermLike n s t - substTermLike _ _ CompFunReturn = return CompFunReturn - substTermLike n s (CompFunComp f g) = - CompFunComp <$> substTermLike n s f <*> substTermLike n s g - -instance TermLike Comp where - liftTermLike n i (CompTerm t) = CompTerm <$> liftTermLike n i t - liftTermLike n i (CompBind m f) = - CompBind <$> liftTermLike n i m <*> liftTermLike n i f - liftTermLike n i (CompReturn t) = CompReturn <$> liftTermLike n i t - substTermLike n s (CompTerm t) = CompTerm <$> substTermLike n s t - substTermLike n s (CompBind m f) = - CompBind <$> substTermLike n s m <*> substTermLike n s f - substTermLike n s (CompReturn t) = CompReturn <$> substTermLike n s t - - ----------------------------------------------------------------------- --- * MR Solver Errors ----------------------------------------------------------------------- - --- | The context in which a failure occurred -data FailCtx - = FailCtxRefines NormComp NormComp - | FailCtxMNF Term - deriving Show - --- | That's MR. Failure to you -data MRFailure - = TermsNotEq Term Term - | TypesNotEq Type Type - | CompsDoNotRefine NormComp NormComp - | ReturnNotError Term - | FunsNotEq FunName FunName - | CannotLookupFunDef FunName - | RecursiveUnfold FunName - | MalformedLetRecTypes Term - | MalformedDefsFun Term - | MalformedComp Term - | NotCompFunType Term - -- | A local variable binding - | MRFailureLocalVar LocalName MRFailure - -- | Information about the context of the failure - | MRFailureCtx FailCtx MRFailure - -- | Records a disjunctive branch we took, where both cases failed - | MRFailureDisj MRFailure MRFailure - deriving Show - --- | Pretty-print an object prefixed with a 'String' that describes it -ppWithPrefix :: PrettyInCtx a => String -> a -> PPInCtxM SawDoc -ppWithPrefix str a = (pretty str <>) <$> nest 2 <$> (line <>) <$> prettyInCtx a - --- | Pretty-print two objects, prefixed with a 'String' and with a separator -ppWithPrefixSep :: PrettyInCtx a => String -> a -> String -> a -> - PPInCtxM SawDoc -ppWithPrefixSep d1 t2 d3 t4 = - prettyInCtx t2 >>= \d2 -> prettyInCtx t4 >>= \d4 -> - return $ group (pretty d1 <> nest 2 (line <> d2) <> line <> - pretty d3 <> nest 2 (line <> d4)) - --- | Apply 'vsep' to a list of pretty-printing computations -vsepM :: [PPInCtxM SawDoc] -> PPInCtxM SawDoc -vsepM = fmap vsep . sequence - -instance PrettyInCtx FailCtx where - prettyInCtx (FailCtxRefines m1 m2) = - group <$> nest 2 <$> - ppWithPrefixSep "When proving refinement:" m1 "|=" m2 - prettyInCtx (FailCtxMNF t) = - group <$> nest 2 <$> vsepM [return "When normalizing computation:", - prettyInCtx t] - -instance PrettyInCtx MRFailure where - prettyInCtx (TermsNotEq t1 t2) = - ppWithPrefixSep "Could not prove terms equal:" t1 "and" t2 - prettyInCtx (TypesNotEq tp1 tp2) = - ppWithPrefixSep "Types not equal:" tp1 "and" tp2 - prettyInCtx (CompsDoNotRefine m1 m2) = - ppWithPrefixSep "Could not prove refinement: " m1 "|=" m2 - prettyInCtx (ReturnNotError t) = - ppWithPrefix "errorM computation not equal to:" (ReturnM t) - prettyInCtx (FunsNotEq nm1 nm2) = - vsepM [return "Named functions not equal:", - prettyInCtx nm1, prettyInCtx nm2] - prettyInCtx (CannotLookupFunDef nm) = - ppWithPrefix "Could not find definition for function:" nm - prettyInCtx (RecursiveUnfold nm) = - ppWithPrefix "Recursive unfolding of function inside its own body:" nm - prettyInCtx (MalformedLetRecTypes t) = - ppWithPrefix "Not a ground LetRecTypes list:" t - prettyInCtx (MalformedDefsFun t) = - ppWithPrefix "Cannot handle letRecM recursive definitions term:" t - prettyInCtx (MalformedComp t) = - ppWithPrefix "Could not handle computation:" t - prettyInCtx (NotCompFunType tp) = - ppWithPrefix "Not a computation or computational function type:" tp - prettyInCtx (MRFailureLocalVar x err) = - local (x:) $ prettyInCtx err - prettyInCtx (MRFailureCtx ctx err) = - do pp1 <- prettyInCtx ctx - pp2 <- prettyInCtx err - return (pp1 <> line <> pp2) - prettyInCtx (MRFailureDisj err1 err2) = - ppWithPrefixSep "Tried two comparisons:" err1 "Backtracking..." err2 - --- | Render a 'MRFailure' to a 'String' -showMRFailure :: MRFailure -> String -showMRFailure = showInCtx [] - - ----------------------------------------------------------------------- --- * MR Monad ----------------------------------------------------------------------- - --- | Classification info for what sort of variable an 'MRVar' is -data MRVarInfo - -- | An existential variable, that might be instantiated - = EVarInfo (Maybe Term) - -- | A letrec-bound function, with its body - | FunVarInfo Term - --- | A map from 'MRVar's to their info -type MRVarMap = Map MRVar MRVarInfo - --- | Test if a 'Term' is an application of an 'ExtCns' to some arguments -asExtCnsApp :: Recognizer Term (ExtCns Term, [Term]) -asExtCnsApp (asApplyAll -> (asExtCns -> Just ec, args)) = - return (ec, args) -asExtCnsApp _ = Nothing - --- | Recognize an evar applied to 0 or more arguments relative to a 'MRVarMap' --- along with its instantiation, if any -asEVarApp :: MRVarMap -> Recognizer Term (MRVar, [Term], Maybe Term) -asEVarApp var_map (asExtCnsApp -> Just (ec, args)) - | Just (EVarInfo maybe_inst) <- Map.lookup (MRVar ec) var_map = - Just (MRVar ec, args, maybe_inst) -asEVarApp _ _ = Nothing - --- | An assumption that a named function refines some specificaiton. This has --- the form --- --- > forall x1, ..., xn. F e1 ... ek |= m --- --- for some universal context @x1:T1, .., xn:Tn@, some list of argument --- expressions @ei@ over the universal @xj@ variables, and some right-hand side --- computation expression @m@. -data FunAssump = FunAssump { - -- | The uvars that were in scope when this assmption was created, in order - -- from outermost to innermost; that is, the uvars as "seen from outside their - -- scope", which is the reverse of the order of 'mrUVars', below - fassumpCtx :: [(LocalName,Term)], - -- | The argument expressions @e1, ..., en@ over the 'fassumpCtx' uvars - fassumpArgs :: [Term], - -- | The right-hand side upper bound @m@ over the 'fassumpCtx' uvars - fassumpRHS :: NormComp } - --- | State maintained by MR. Solver -data MRState = MRState { - -- | Global shared context for building terms, etc. - mrSC :: SharedContext, - -- | SMT timeout for SMT calls made by Mr. Solver - mrSMTTimeout :: Maybe Integer, - -- | The context of universal variables, which are free SAW core variables, in - -- order from innermost to outermost, i.e., where element @0@ corresponds to - -- deBruijn index @0@ - mrUVars :: [(LocalName,Type)], - -- | The existential and letrec-bound variables - mrVars :: MRVarMap, - -- | The current assumptions of function refinement - mrFunAssumps :: Map FunName FunAssump, - -- | The current assumptions, which are conjoined into a single Boolean term; - -- note that these have the current UVars free - mrAssumptions :: Term, - -- | The debug level, which controls debug printing - mrDebugLevel :: Int -} - --- | Build a default, empty state from SMT configuration parameters and a set of --- function refinement assumptions -mkMRState :: SharedContext -> Map FunName FunAssump -> - Maybe Integer -> Int -> IO MRState -mkMRState sc fun_assumps timeout dlvl = - scBool sc True >>= \true_tm -> - return $ MRState { mrSC = sc, - mrSMTTimeout = timeout, mrUVars = [], mrVars = Map.empty, - mrFunAssumps = fun_assumps, mrAssumptions = true_tm, - mrDebugLevel = dlvl } - --- | Mr. Monad, the monad used by MR. Solver, which is the state-exception monad -newtype MRM a = MRM { unMRM :: StateT MRState (ExceptT MRFailure IO) a } - deriving (Functor, Applicative, Monad, MonadIO, - MonadState MRState, MonadError MRFailure) - -instance MonadTerm MRM where - mkTermF = liftSC1 scTermF - liftTerm = liftSC3 incVars - whnfTerm = liftSC1 scWhnf - substTerm = liftSC3 instantiateVarList - --- | Run an 'MRM' computation and return a result or an error -runMRM :: MRState -> MRM a -> IO (Either MRFailure a) -runMRM init_st m = runExceptT $ flip evalStateT init_st $ unMRM m - --- | Apply a function to any failure thrown by an 'MRM' computation -mapFailure :: (MRFailure -> MRFailure) -> MRM a -> MRM a -mapFailure f m = catchError m (throwError . f) - --- | Try two different 'MRM' computations, combining their failures if needed. --- Note that the 'MRState' will reset if the first computation fails. -mrOr :: MRM a -> MRM a -> MRM a -mrOr m1 m2 = - catchError m1 $ \err1 -> - catchError m2 $ \err2 -> - throwError $ MRFailureDisj err1 err2 - --- | Run an 'MRM' computation in an extended failure context -withFailureCtx :: FailCtx -> MRM a -> MRM a -withFailureCtx ctx = mapFailure (MRFailureCtx ctx) - -{- --- | Catch any errors thrown by a computation and coerce them to a 'Left' -catchErrorEither :: MonadError e m => m a -> m (Either e a) -catchErrorEither m = catchError (Right <$> m) (return . Left) --} - --- FIXME: replace these individual lifting functions with a more general --- typeclass like LiftTCM - --- | Lift a nullary SharedTerm computation into 'MRM' -liftSC0 :: (SharedContext -> IO a) -> MRM a -liftSC0 f = (mrSC <$> get) >>= \sc -> liftIO (f sc) - --- | Lift a unary SharedTerm computation into 'MRM' -liftSC1 :: (SharedContext -> a -> IO b) -> a -> MRM b -liftSC1 f a = (mrSC <$> get) >>= \sc -> liftIO (f sc a) - --- | Lift a binary SharedTerm computation into 'MRM' -liftSC2 :: (SharedContext -> a -> b -> IO c) -> a -> b -> MRM c -liftSC2 f a b = (mrSC <$> get) >>= \sc -> liftIO (f sc a b) - --- | Lift a ternary SharedTerm computation into 'MRM' -liftSC3 :: (SharedContext -> a -> b -> c -> IO d) -> a -> b -> c -> MRM d -liftSC3 f a b c = (mrSC <$> get) >>= \sc -> liftIO (f sc a b c) - --- | Lift a quaternary SharedTerm computation into 'MRM' -liftSC4 :: (SharedContext -> a -> b -> c -> d -> IO e) -> a -> b -> c -> d -> - MRM e -liftSC4 f a b c d = (mrSC <$> get) >>= \sc -> liftIO (f sc a b c d) - --- | Lift a quinary SharedTerm computation into 'MRM' -liftSC5 :: (SharedContext -> a -> b -> c -> d -> e -> IO f) -> - a -> b -> c -> d -> e -> MRM f -liftSC5 f a b c d e = (mrSC <$> get) >>= \sc -> liftIO (f sc a b c d e) - --- | Apply a 'Term' to a list of arguments and beta-reduce in Mr. Monad -mrApplyAll :: Term -> [Term] -> MRM Term -mrApplyAll f args = liftSC2 scApplyAll f args >>= liftSC1 betaNormalize - --- | Get the current context of uvars as a list of variable names and their --- types as SAW core 'Term's, with the least recently bound uvar first, i.e., in --- the order as seen "from the outside" -mrUVarCtx :: MRM [(LocalName,Term)] -mrUVarCtx = reverse <$> map (\(nm,Type tp) -> (nm,tp)) <$> mrUVars <$> get - --- | Get the type of a 'Term' in the current uvar context -mrTypeOf :: Term -> MRM Term -mrTypeOf t = mrUVarCtx >>= \ctx -> liftSC2 scTypeOf' (map snd ctx) t - --- | Check if two 'Term's are convertible in the 'MRM' monad -mrConvertible :: Term -> Term -> MRM Bool -mrConvertible = liftSC4 scConvertibleEval scTypeCheckWHNF True - --- | Take a 'FunName' @f@ for a monadic function of type @vars -> CompM a@ and --- compute the type @CompM [args/vars]a@ of @f@ applied to @args@. Return the --- type @[args/vars]a@ that @CompM@ is applied to. -mrFunOutType :: FunName -> [Term] -> MRM Term -mrFunOutType fname args = - funNameType fname >>= \case - (asPiList -> (vars, asCompM -> Just tp)) - | length vars == length args -> substTermLike 0 args tp - ftype@(asPiList -> (vars, _)) -> - do pp_ftype <- mrPPInCtx ftype - pp_fname <- mrPPInCtx fname - debugPrint 0 "mrFunOutType: function applied to the wrong number of args" - debugPrint 0 ("Expected: " ++ show (length vars) ++ - ", found: " ++ show (length args)) - debugPretty 0 ("For function: " <> pp_fname <> " with type: " <> pp_ftype) - error"mrFunOutType" - --- | Turn a 'LocalName' into one not in a list, adding a suffix if necessary -uniquifyName :: LocalName -> [LocalName] -> LocalName -uniquifyName nm nms | notElem nm nms = nm -uniquifyName nm nms = - case find (flip notElem nms) $ - map (T.append nm . T.pack . show) [(0::Int) ..] of - Just nm' -> nm' - Nothing -> error "uniquifyName" - --- | Run a MR Solver computation in a context extended with a universal --- variable, which is passed as a 'Term' to the sub-computation. Note that any --- assumptions made in the sub-computation will be lost when it completes. -withUVar :: LocalName -> Type -> (Term -> MRM a) -> MRM a -withUVar nm tp m = - do st <- get - let nm' = uniquifyName nm (map fst $ mrUVars st) - assumps' <- liftTerm 0 1 $ mrAssumptions st - put (st { mrUVars = (nm',tp) : mrUVars st, - mrAssumptions = assumps' }) - ret <- mapFailure (MRFailureLocalVar nm') (liftSC1 scLocalVar 0 >>= m) - modify (\st' -> st' { mrUVars = mrUVars st, - mrAssumptions = mrAssumptions st }) - return ret - --- | Run a MR Solver computation in a context extended with a universal variable --- and pass it the lifting (in the sense of 'incVars') of an MR Solver term -withUVarLift :: TermLike tm => LocalName -> Type -> tm -> - (Term -> tm -> MRM a) -> MRM a -withUVarLift nm tp t m = - withUVar nm tp (\x -> liftTermLike 0 1 t >>= m x) - --- | Run a MR Solver computation in a context extended with a list of universal --- variables, passing 'Term's for those variables to the supplied computation. --- The variables are bound "outside in", meaning the first variable in the list --- is bound outermost, and so will have the highest deBruijn index. -withUVars :: [(LocalName,Term)] -> ([Term] -> MRM a) -> MRM a -withUVars = helper [] where - -- The extra input list gives the variables that have already been bound, in - -- order from most to least recently bound - helper :: [Term] -> [(LocalName,Term)] -> ([Term] -> MRM a) -> MRM a - helper vars [] m = m $ reverse vars - helper vars ((nm,tp):ctx) m = - -- FIXME: I think substituting here is wrong, but works on closed terms, so - -- it's fine to use at the top level at least... - substTerm 0 vars tp >>= \tp' -> - withUVarLift nm (Type tp') vars $ \var vars' -> helper (var:vars') ctx m - --- | Build 'Term's for all the uvars currently in scope, ordered from least to --- most recently bound -getAllUVarTerms :: MRM [Term] -getAllUVarTerms = - (length <$> mrUVars <$> get) >>= \len -> - mapM (liftSC1 scLocalVar) [len-1, len-2 .. 0] - --- | Lambda-abstract all the current uvars out of a 'Term', with the least --- recently bound variable being abstracted first -lambdaUVarsM :: Term -> MRM Term -lambdaUVarsM t = mrUVarCtx >>= \ctx -> liftSC2 scLambdaList ctx t - --- | Pi-abstract all the current uvars out of a 'Term', with the least recently --- bound variable being abstracted first -piUVarsM :: Term -> MRM Term -piUVarsM t = mrUVarCtx >>= \ctx -> liftSC2 scPiList ctx t - --- | Instantiate all uvars in a term using the supplied function -instantiateUVarsM :: TermLike a => (LocalName -> Term -> MRM Term) -> a -> MRM a -instantiateUVarsM f a = - do ctx <- mrUVarCtx - -- Remember: the uvar context is outermost to innermost, so we bind - -- variables from left to right, substituting earlier ones into the types - -- of later ones, but all substitutions are in reverse order, since - -- substTerm and friends like innermost bindings first - let helper :: [Term] -> [(LocalName,Term)] -> MRM [Term] - helper tms [] = return tms - helper tms ((nm,tp):vars) = - do tp' <- substTerm 0 tms tp - tm <- f nm tp' - helper (tm:tms) vars - ecs <- helper [] ctx - substTermLike 0 ecs a - --- | Convert an 'MRVar' to a 'Term', applying it to all the uvars in scope -mrVarTerm :: MRVar -> MRM Term -mrVarTerm (MRVar ec) = - do var_tm <- liftSC1 scExtCns ec - vars <- getAllUVarTerms - liftSC2 scApplyAll var_tm vars - --- | Get the 'VarInfo' associated with a 'MRVar' -mrVarInfo :: MRVar -> MRM (Maybe MRVarInfo) -mrVarInfo var = Map.lookup var <$> mrVars <$> get - --- | Convert an 'ExtCns' to a 'FunName' -extCnsToFunName :: ExtCns Term -> MRM FunName -extCnsToFunName ec = let var = MRVar ec in mrVarInfo var >>= \case - Just (EVarInfo _) -> return $ EVarFunName var - Just (FunVarInfo _) -> return $ LetRecName var - Nothing - | Just glob <- asTypedGlobalDef (Unshared $ FTermF $ ExtCns ec) -> - return $ GlobalName glob [] - _ -> error "extCnsToFunName: unreachable" - --- | Get the body of a function @f@ if it has one -mrFunNameBody :: FunName -> MRM (Maybe Term) -mrFunNameBody (LetRecName var) = - mrVarInfo var >>= \case - Just (FunVarInfo body) -> return $ Just body - _ -> error "mrFunBody: unknown letrec var" -mrFunNameBody (GlobalName glob projs) - | Just body <- globalDefBody glob - = Just <$> foldM doTermProj body projs -mrFunNameBody (GlobalName _ _) = return Nothing -mrFunNameBody (EVarFunName _) = return Nothing - --- | Get the body of a function @f@ applied to some arguments, if possible -mrFunBody :: FunName -> [Term] -> MRM (Maybe Term) -mrFunBody f args = mrFunNameBody f >>= \case - Just body -> Just <$> mrApplyAll body args - Nothing -> return Nothing - --- | Get the body of a function @f@ applied to some arguments, as per --- 'mrFunBody', and also return whether its body recursively calls itself, as --- per 'mrCallsFun' -mrFunBodyRecInfo :: FunName -> [Term] -> MRM (Maybe (Term, Bool)) -mrFunBodyRecInfo f args = - mrFunBody f args >>= \case - Just f_body -> Just <$> (f_body,) <$> mrCallsFun f f_body - Nothing -> return Nothing - --- | Test if a 'Term' contains, after possibly unfolding some functions, a call --- to a given function @f@ again -mrCallsFun :: FunName -> Term -> MRM Bool -mrCallsFun f = memoFixTermFun $ \recurse t -> case t of - (asExtCns -> Just ec) -> - do g <- extCnsToFunName ec - maybe_body <- mrFunNameBody g - case maybe_body of - _ | f == g -> return True - Just body -> recurse body - Nothing -> return False - (asTypedGlobalProj -> Just (gdef, projs)) -> - case globalDefBody gdef of - _ | f == GlobalName gdef projs -> return True - Just body -> recurse body - Nothing -> return False - (unwrapTermF -> tf) -> - foldM (\b t' -> if b then return b else recurse t') False tf - --- | Make a fresh 'MRVar' of a given type, which must be closed, i.e., have no --- free uvars -mrFreshVar :: LocalName -> Term -> MRM MRVar -mrFreshVar nm tp = MRVar <$> liftSC2 scFreshEC nm tp - --- | Set the info associated with an 'MRVar', assuming it has not been set -mrSetVarInfo :: MRVar -> MRVarInfo -> MRM () -mrSetVarInfo var info = - modify $ \st -> - st { mrVars = - Map.alter (\case - Just _ -> error "mrSetVarInfo" - Nothing -> Just info) - var (mrVars st) } - --- | Make a fresh existential variable of the given type, abstracting out all --- the current uvars and returning the new evar applied to all current uvars -mrFreshEVar :: LocalName -> Type -> MRM Term -mrFreshEVar nm (Type tp) = - do tp' <- piUVarsM tp - var <- mrFreshVar nm tp' - mrSetVarInfo var (EVarInfo Nothing) - mrVarTerm var - --- | Return a fresh sequence of existential variables for a context of variable --- names and types, assuming each variable is free in the types that occur after --- it in the list. Return the new evars all applied to the current uvars. -mrFreshEVars :: [(LocalName,Term)] -> MRM [Term] -mrFreshEVars = helper [] where - -- Return fresh evars for the suffix of a context of variable names and types, - -- where the supplied Terms are evars that have already been generated for the - -- earlier part of the context, and so must be substituted into the remaining - -- types in the context - helper :: [Term] -> [(LocalName,Term)] -> MRM [Term] - helper evars [] = return evars - helper evars ((nm,tp):ctx) = - do evar <- substTerm 0 evars tp >>= mrFreshEVar nm . Type - helper (evar:evars) ctx - --- | Set the value of an evar to a closed term -mrSetEVarClosed :: MRVar -> Term -> MRM () -mrSetEVarClosed var val = - do val_tp <- mrTypeOf val - -- NOTE: need to instantiate any evars in the type of var, to ensure the - -- following subtyping check will succeed - var_tp <- mrSubstEVars $ mrVarType var - -- FIXME: catch subtyping errors and report them as being evar failures - liftSC3 scCheckSubtype Nothing (TypedTerm val val_tp) var_tp - modify $ \st -> - st { mrVars = - Map.alter - (\case - Just (EVarInfo Nothing) -> Just $ EVarInfo (Just val) - Just (EVarInfo (Just _)) -> - error "Setting existential variable: variable already set!" - _ -> error "Setting existential variable: not an evar!") - var (mrVars st) } - - --- | Try to set the value of the application @X e1 .. en@ of evar @X@ to an --- expression @e@ by trying to set @X@ to @\ x1 ... xn -> e@. This only works if --- each free uvar @xi@ in @e@ is one of the arguments @ej@ to @X@ (though it --- need not be the case that @i=j@). Return whether this succeeded. -mrTrySetAppliedEVar :: MRVar -> [Term] -> Term -> MRM Bool -mrTrySetAppliedEVar evar args t = - -- Get the complete list of argument variables of the type of evar - let (evar_vars, _) = asPiList (mrVarType evar) in - -- Get all the free variables of t - let free_vars = bitSetElems (looseVars t) in - -- For each free var of t, find an arg equal to it - case mapM (\i -> findIndex (\case - (asLocalVar -> Just j) -> i == j - _ -> False) args) free_vars of - Just fv_arg_ixs - -- Check to make sure we have the right number of args - | length args == length evar_vars -> do - -- Build a list of the input vars x1 ... xn as terms, noting that the - -- first variable is the least recently bound and so has the highest - -- deBruijn index - let arg_ixs = [length args - 1, length args - 2 .. 0] - arg_vars <- mapM (liftSC1 scLocalVar) arg_ixs - - -- For free variable of t, we substitute the corresponding variable - -- xi, substituting error terms for the variables that are not free - -- (since we have nothing else to substitute for them) - let var_map = zip free_vars fv_arg_ixs - let subst = flip map [0 .. length args - 1] $ \i -> - maybe (error "mrTrySetAppliedEVar: unexpected free variable") - (arg_vars !!) (lookup i var_map) - body <- substTerm 0 subst t - - -- Now instantiate evar to \x1 ... xn -> body - evar_inst <- liftSC2 scLambdaList evar_vars body - mrSetEVarClosed evar evar_inst - return True - - _ -> return False - - --- | Replace all evars in a 'Term' with their instantiations when they have one -mrSubstEVars :: Term -> MRM Term -mrSubstEVars = memoFixTermFun $ \recurse t -> - do var_map <- mrVars <$> get - case t of - -- If t is an instantiated evar, recurse on its instantiation - (asEVarApp var_map -> Just (_, args, Just t')) -> - mrApplyAll t' args >>= recurse - -- If t is anything else, recurse on its immediate subterms - _ -> traverseSubterms recurse t - --- | Replace all evars in a 'Term' with their instantiations, returning --- 'Nothing' if we hit an uninstantiated evar -mrSubstEVarsStrict :: Term -> MRM (Maybe Term) -mrSubstEVarsStrict top_t = - runMaybeT $ flip memoFixTermFun top_t $ \recurse t -> - do var_map <- mrVars <$> get - case t of - -- If t is an instantiated evar, recurse on its instantiation - (asEVarApp var_map -> Just (_, args, Just t')) -> - lift (mrApplyAll t' args) >>= recurse - -- If t is an uninstantiated evar, return Nothing - (asEVarApp var_map -> Just (_, _, Nothing)) -> - mzero - -- If t is anything else, recurse on its immediate subterms - _ -> traverseSubterms recurse t - --- | Makes 'mrSubstEVarsStrict' be marked as used -_mrSubstEVarsStrict :: Term -> MRM (Maybe Term) -_mrSubstEVarsStrict = mrSubstEVarsStrict - --- | Look up the 'FunAssump' for a 'FunName', if there is one -mrGetFunAssump :: FunName -> MRM (Maybe FunAssump) -mrGetFunAssump nm = Map.lookup nm <$> mrFunAssumps <$> get - --- | Run a computation under the additional assumption that a named function --- applied to a list of arguments refines a given right-hand side, all of which --- are 'Term's that can have the current uvars free -withFunAssump :: FunName -> [Term] -> NormComp -> MRM a -> MRM a -withFunAssump fname args rhs m = - do mrDebugPPPrefixSep 1 "withFunAssump" (FunBind - fname args CompFunReturn) "|=" rhs - ctx <- mrUVarCtx - assumps <- mrFunAssumps <$> get - let assumps' = Map.insert fname (FunAssump ctx args rhs) assumps - modify (\s -> s { mrFunAssumps = assumps' }) - ret <- m - modify (\s -> s { mrFunAssumps = assumps }) - return ret - --- | Generate fresh evars for the context of a 'FunAssump' and substitute them --- into its arguments and right-hand side -instantiateFunAssump :: FunAssump -> MRM ([Term], NormComp) -instantiateFunAssump fassump = - do evars <- mrFreshEVars $ fassumpCtx fassump - args <- substTermLike 0 evars $ fassumpArgs fassump - rhs <- substTermLike 0 evars $ fassumpRHS fassump - return (args, rhs) - --- | Add an assumption of type @Bool@ to the current path condition while --- executing a sub-computation -withAssumption :: Term -> MRM a -> MRM a -withAssumption phi m = - do assumps <- mrAssumptions <$> get - assumps' <- liftSC2 scAnd phi assumps - modify (\s -> s { mrAssumptions = assumps' }) - ret <- m - modify (\s -> s { mrAssumptions = assumps }) - return ret - --- | Print a 'String' if the debug level is at least the supplied 'Int' -debugPrint :: Int -> String -> MRM () -debugPrint i str = - (mrDebugLevel <$> get) >>= \lvl -> - if lvl >= i then liftIO (hPutStrLn stderr str) else return () - --- | Print a document if the debug level is at least the supplied 'Int' -debugPretty :: Int -> SawDoc -> MRM () -debugPretty i pp = debugPrint i $ renderSawDoc defaultPPOpts pp - --- | Pretty-print an object in the current context if the current debug level is --- at least the supplied 'Int' -debugPrettyInCtx :: PrettyInCtx a => Int -> a -> MRM () -debugPrettyInCtx i a = - (mrUVars <$> get) >>= \ctx -> debugPrint i (showInCtx (map fst ctx) a) - --- | Pretty-print an object relative to the current context -mrPPInCtx :: PrettyInCtx a => a -> MRM SawDoc -mrPPInCtx a = - runReader (prettyInCtx a) <$> map fst <$> mrUVars <$> get - --- | Pretty-print the result of 'ppWithPrefixSep' relative to the current uvar --- context to 'stderr' if the debug level is at least the 'Int' provided -mrDebugPPPrefixSep :: PrettyInCtx a => Int -> String -> a -> String -> a -> - MRM () -mrDebugPPPrefixSep i pre a1 sp a2 = - (mrUVars <$> get) >>= \ctx -> - debugPretty i $ - flip runReader (map fst ctx) (group <$> nest 2 <$> - ppWithPrefixSep pre a1 sp a2) - - ----------------------------------------------------------------------- --- * Calling Out to SMT ----------------------------------------------------------------------- - --- | Test if a 'Term' is a 'BVVec' type -asBVVecType :: Recognizer Term (Term, Term, Term) -asBVVecType (asApplyAll -> - (isGlobalDef "Prelude.Vec" -> Just _, - [(asApplyAll -> - (isGlobalDef "Prelude.bvToNat" -> Just _, [n, len])), a])) = - Just (n, len, a) -asBVVecType _ = Nothing - --- | Apply @genBVVec@ to arguments @n@, @len@, and @a@, along with a function of --- type @Vec n Bool -> a@ -genBVVecTerm :: SharedContext -> Term -> Term -> Term -> Term -> IO Term -genBVVecTerm sc n_tm len_tm a_tm f_tm = - let n = closedOpenTerm n_tm - len = closedOpenTerm len_tm - a = closedOpenTerm a_tm - f = closedOpenTerm f_tm in - completeOpenTerm sc $ - applyOpenTermMulti (globalOpenTerm "Prelude.genBVVec") - [n, len, a, - lambdaOpenTerm "i" (vectorTypeOpenTerm n boolTypeOpenTerm) $ \i -> - lambdaOpenTerm "_" (applyGlobalOpenTerm "Prelude.is_bvult" [n, i, len]) $ \_ -> - applyOpenTerm f i] - --- | Match a term of the form @genBVVec n len a (\ i _ -> e)@, i.e., where @e@ --- does not have the proof variable (the underscore) free -asGenBVVecTerm :: Recognizer Term (Term, Term, Term, Term) -asGenBVVecTerm (asApplyAll -> - (isGlobalDef "Prelude.genBVVec" -> Just _, - [n, len, a, - (asLambdaList -> ([_,_], e))])) - | not $ inBitSet 0 $ looseVars e - = Just (n, len, a, e) -asGenBVVecTerm _ = Nothing - -type TmPrim = Prim TermModel - --- | Convert a Boolean value to a 'Term'; like 'readBackValue' but that function --- requires a 'SimulatorConfig' which we cannot easily generate here... -boolValToTerm :: SharedContext -> Value TermModel -> IO Term -boolValToTerm _ (VBool (Left tm)) = return tm -boolValToTerm sc (VBool (Right b)) = scBool sc b -boolValToTerm _ (VExtra (VExtraTerm _tp tm)) = return tm -boolValToTerm _ v = error ("boolValToTerm: unexpected value: " ++ show v) - --- | An implementation of a primitive function that expects a @genBVVec@ term -primGenBVVec :: SharedContext -> (Term -> TmPrim) -> TmPrim -primGenBVVec sc f = - PrimFilterFun "genBVVecPrim" - (\case - VExtra (VExtraTerm _ (asGenBVVecTerm -> Just (n, _, _, e))) -> - -- Generate the function \i -> [i/1,error/0]e - lift $ - do i_tp <- scBoolType sc >>= scVecType sc n - let err_tm = error "primGenBVVec: unexpected variable occurrence" - i_tm <- scLocalVar sc 0 - body <- instantiateVarList sc 0 [err_tm,i_tm] e - scLambda sc "i" i_tp body - _ -> mzero) - f - --- | An implementation of a primitive function that expects a bitvector term -primBVTermFun :: SharedContext -> (Term -> TmPrim) -> TmPrim -primBVTermFun sc = - PrimFilterFun "primBVTermFun" $ - \case - VExtra (VExtraTerm _ w_tm) -> return w_tm - VWord (Left (_,w_tm)) -> return w_tm - VWord (Right bv) -> - lift $ scBvConst sc (fromIntegral (Prim.width bv)) (Prim.unsigned bv) - VVector vs -> - lift $ - do tms <- traverse (boolValToTerm sc <=< force) (V.toList vs) - tp <- scBoolType sc - scVectorReduced sc tp tms - v -> lift (putStrLn ("primBVTermFun: unhandled value: " ++ show v)) >> mzero - --- | Implementations of primitives for normalizing SMT terms -smtNormPrims :: SharedContext -> Map Ident TmPrim -smtNormPrims sc = Map.fromList - [ - ("Prelude.genBVVec", - Prim (do tp <- scTypeOfGlobal sc "Prelude.genBVVec" - VExtra <$> VExtraTerm (VTyTerm (mkSort 1) tp) <$> - scGlobalDef sc "Prelude.genBVVec")), - - ("Prelude.atBVVec", - PrimFun $ \_n -> PrimFun $ \_len -> tvalFun $ \a -> - primGenBVVec sc $ \f -> primBVTermFun sc $ \ix -> PrimFun $ \_pf -> - Prim (VExtra <$> VExtraTerm a <$> scApply sc f ix) - ) - ] - --- | Normalize a 'Term' before building an SMT query for it -normSMTProp :: Term -> MRM Term -normSMTProp t = - debugPrint 2 "Normalizing term:" >> - debugPrettyInCtx 2 t >> - liftSC0 return >>= \sc -> - liftSC0 scGetModuleMap >>= \modmap -> - liftSC5 normalizeSharedTerm modmap (smtNormPrims sc) Map.empty Set.empty t - --- | Test if a closed Boolean term is "provable", i.e., its negation is --- unsatisfiable, using an SMT solver. By "closed" we mean that it contains no --- uvars or 'MRVar's. --- --- FIXME: use the timeout! -mrProvableRaw :: Term -> MRM Bool -mrProvableRaw prop_term = - do sc <- mrSC <$> get - prop <- liftSC1 termToProp prop_term - unints <- Set.map ecVarIndex <$> getAllExtSet <$> liftSC1 propToTerm prop - debugPrint 2 ("Calling SMT solver with proposition: " ++ - prettyProp defaultPPOpts prop) - sym <- liftIO $ setupWhat4_sym True - (smt_res, _) <- - liftIO $ proveWhat4_solver z3Adapter sym unints sc prop (return ()) - case smt_res of - Just _ -> - debugPrint 2 "SMT solver response: not provable" >> return False - Nothing -> - debugPrint 2 "SMT solver response: provable" >> return True - --- | Test if a Boolean term over the current uvars is provable given the current --- assumptions -mrProvable :: Term -> MRM Bool -mrProvable bool_tm = - do assumps <- mrAssumptions <$> get - prop <- liftSC2 scImplies assumps bool_tm >>= liftSC1 scEqTrue - prop_inst <- flip instantiateUVarsM prop $ \nm tp -> - liftSC1 scWhnf tp >>= \case - (asBVVecType -> Just (n, len, a)) -> - -- For variables of type BVVec, create a Vec n Bool -> a function as an - -- ExtCns and apply genBVVec to it - do - ec_tp <- - liftSC1 completeOpenTerm $ - arrowOpenTerm "_" (applyOpenTermMulti (globalOpenTerm "Prelude.Vec") - [closedOpenTerm n, boolTypeOpenTerm]) - (closedOpenTerm a) - ec <- liftSC2 scFreshEC nm ec_tp >>= liftSC1 scExtCns - liftSC4 genBVVecTerm n len a ec - tp' -> liftSC2 scFreshEC nm tp' >>= liftSC1 scExtCns - normSMTProp prop_inst >>= mrProvableRaw - --- | Build a Boolean 'Term' stating that two 'Term's are equal. This is like --- 'scEq' except that it works on open terms. -mrEq :: Term -> Term -> MRM Term -mrEq t1 t2 = mrTypeOf t1 >>= \tp -> mrEq' tp t1 t2 - --- | Build a Boolean 'Term' stating that the second and third 'Term' arguments --- are equal, where the first 'Term' gives their type (which we assume is the --- same for both). This is like 'scEq' except that it works on open terms. -mrEq' :: Term -> Term -> Term -> MRM Term -mrEq' (asDataType -> Just (pn, [])) t1 t2 - | primName pn == "Prelude.Nat" = liftSC2 scEqualNat t1 t2 -mrEq' (asBoolType -> Just _) t1 t2 = liftSC2 scBoolEq t1 t2 -mrEq' (asIntegerType -> Just _) t1 t2 = liftSC2 scIntEq t1 t2 -mrEq' (asVectorType -> Just (n, asBoolType -> Just ())) t1 t2 = - liftSC3 scBvEq n t1 t2 -mrEq' _ _ _ = error "mrEq': unsupported type" - --- | A 'Term' in an extended context of universal variables, which are listed --- "outside in", meaning the highest deBruijn index comes first -data TermInCtx = TermInCtx [(LocalName,Term)] Term - --- | Conjoin two 'TermInCtx's, assuming they both have Boolean type -andTermInCtx :: TermInCtx -> TermInCtx -> MRM TermInCtx -andTermInCtx (TermInCtx ctx1 t1) (TermInCtx ctx2 t2) = - do - -- Insert the variables in ctx2 into the context of t1 starting at index 0, - -- by lifting its variables starting at 0 by length ctx2 - t1' <- liftTermLike 0 (length ctx2) t1 - -- Insert the variables in ctx1 into the context of t1 starting at index - -- length ctx2, by lifting its variables starting at length ctx2 by length - -- ctx1 - t2' <- liftTermLike (length ctx2) (length ctx1) t2 - TermInCtx (ctx1++ctx2) <$> liftSC2 scAnd t1' t2' - --- | Extend the context of a 'TermInCtx' with additional universal variables --- bound "outside" the 'TermInCtx' -extTermInCtx :: [(LocalName,Term)] -> TermInCtx -> TermInCtx -extTermInCtx ctx (TermInCtx ctx' t) = TermInCtx (ctx++ctx') t - --- | Run an 'MRM' computation in the context of a 'TermInCtx', passing in the --- 'Term' -withTermInCtx :: TermInCtx -> (Term -> MRM a) -> MRM a -withTermInCtx (TermInCtx [] tm) f = f tm -withTermInCtx (TermInCtx ((nm,tp):ctx) tm) f = - withUVar nm (Type tp) $ const $ withTermInCtx (TermInCtx ctx tm) f - --- | A "simple" strategy for proving equality between two terms, which we assume --- are of the same type, which builds an equality proposition by applying the --- supplied function to both sides and passes this proposition to an SMT solver. -mrProveEqSimple :: (Term -> Term -> MRM Term) -> Term -> Term -> - MRM TermInCtx --- NOTE: The use of mrSubstEVars instead of mrSubstEVarsStrict means that we --- allow evars in the terms we send to the SMT solver, but we treat them as --- uvars. -mrProveEqSimple eqf t1 t2 = - do t1' <- mrSubstEVars t1 - t2' <- mrSubstEVars t2 - TermInCtx [] <$> eqf t1' t2' - - --- | Prove that two terms are equal, instantiating evars if necessary, or --- throwing an error if this is not possible -mrProveEq :: Term -> Term -> MRM () -mrProveEq t1 t2 = - do mrDebugPPPrefixSep 1 "mrProveEq" t1 "==" t2 - tp <- mrTypeOf t1 - varmap <- mrVars <$> get - cond_in_ctx <- mrProveEqH varmap tp t1 t2 - success <- withTermInCtx cond_in_ctx mrProvable - if success then return () else - throwError (TermsNotEq t1 t2) - --- | The main workhorse for 'prProveEq'. Build a Boolean term expressing that --- the third and fourth arguments, whose type is given by the second. This is --- done in a continuation monad so that the output term can be in a context with --- additional universal variables. -mrProveEqH :: Map MRVar MRVarInfo -> Term -> Term -> Term -> MRM TermInCtx - -{- -mrProveEqH _ _ t1 t2 - | trace ("mrProveEqH:\n" ++ showTerm t1 ++ "\n==\n" ++ showTerm t2) False = undefined --} - --- If t1 is an instantiated evar, substitute and recurse -mrProveEqH var_map tp (asEVarApp var_map -> Just (_, args, Just f)) t2 = - mrApplyAll f args >>= \t1' -> mrProveEqH var_map tp t1' t2 - --- If t1 is an uninstantiated evar, instantiate it with t2 -mrProveEqH var_map _tp (asEVarApp var_map -> Just (evar, args, Nothing)) t2 = - do t2' <- mrSubstEVars t2 - success <- mrTrySetAppliedEVar evar args t2' - TermInCtx [] <$> liftSC1 scBool success - --- If t2 is an instantiated evar, substitute and recurse -mrProveEqH var_map tp t1 (asEVarApp var_map -> Just (_, args, Just f)) = - mrApplyAll f args >>= \t2' -> mrProveEqH var_map tp t1 t2' - --- If t2 is an uninstantiated evar, instantiate it with t1 -mrProveEqH var_map _tp t1 (asEVarApp var_map -> Just (evar, args, Nothing)) = - do t1' <- mrSubstEVars t1 - success <- mrTrySetAppliedEVar evar args t1' - TermInCtx [] <$> liftSC1 scBool success - --- For the nat, bitvector, Boolean, and integer types, call mrProveEqSimple -mrProveEqH _ (asDataType -> Just (pn, [])) t1 t2 - | primName pn == "Prelude.Nat" = - mrProveEqSimple (liftSC2 scEqualNat) t1 t2 -mrProveEqH _ (asVectorType -> Just (n, asBoolType -> Just ())) t1 t2 = - -- FIXME: make a better solver for bitvector equalities - mrProveEqSimple (liftSC3 scBvEq n) t1 t2 -mrProveEqH _ (asBoolType -> Just _) t1 t2 = - mrProveEqSimple (liftSC2 scBoolEq) t1 t2 -mrProveEqH _ (asIntegerType -> Just _) t1 t2 = - mrProveEqSimple (liftSC2 scIntEq) t1 t2 - --- For pair types, prove both the left and right projections are equal -mrProveEqH var_map (asPairType -> Just (tpL, tpR)) t1 t2 = - do t1L <- liftSC1 scPairLeft t1 - t2L <- liftSC1 scPairLeft t2 - t1R <- liftSC1 scPairRight t1 - t2R <- liftSC1 scPairRight t2 - condL <- mrProveEqH var_map tpL t1L t2L - condR <- mrProveEqH var_map tpR t1R t2R - andTermInCtx condL condR - --- For non-bitvector vector types, prove all projections are equal by --- quantifying over a universal index variable and proving equality at that --- index -mrProveEqH _ (asBVVecType -> Just (n, len, tp)) t1 t2 = - liftSC0 scBoolType >>= \bool_tp -> - liftSC2 scVecType n bool_tp >>= \ix_tp -> - withUVarLift "eq_ix" (Type ix_tp) (n,(len,(tp,(t1,t2)))) $ - \ix' (n',(len',(tp',(t1',t2')))) -> - liftSC2 scGlobalApply "Prelude.is_bvult" [n', ix', len'] >>= \pf_tp -> - withUVarLift "eq_pf" (Type pf_tp) (n',(len',(tp',(ix',(t1',t2'))))) $ - \pf'' (n'',(len'',(tp'',(ix'',(t1'',t2''))))) -> - do t1_prj <- liftSC2 scGlobalApply "Prelude.atBVVec" [n'', len'', tp'', - t1'', ix'', pf''] - t2_prj <- liftSC2 scGlobalApply "Prelude.atBVVec" [n'', len'', tp'', - t2'', ix'', pf''] - var_map <- mrVars <$> get - extTermInCtx [("eq_ix",ix_tp),("eq_pf",pf_tp)] <$> - mrProveEqH var_map tp'' t1_prj t2_prj - --- As a fallback, for types we can't handle, just check convertibility -mrProveEqH _ _ t1 t2 = - do success <- mrConvertible t1 t2 - TermInCtx [] <$> liftSC1 scBool success - - ----------------------------------------------------------------------- --- * Normalizing and Matching on Terms ----------------------------------------------------------------------- - --- | Match a type as being of the form @CompM a@ for some @a@ -asCompM :: Term -> Maybe Term -asCompM (asApp -> Just (isGlobalDef "Prelude.CompM" -> Just (), tp)) = - return tp -asCompM _ = fail "not a CompM type!" - --- | Test if a type normalizes to a monadic function type of 0 or more arguments -isCompFunType :: SharedContext -> Term -> IO Bool -isCompFunType sc t = scWhnf sc t >>= \case - (asPiList -> (_, asCompM -> Just _)) -> return True - _ -> return False - --- | Pattern-match on a @LetRecTypes@ list in normal form and return a list of --- the types it specifies, each in normal form and with uvars abstracted out -asLRTList :: Term -> MRM [Term] -asLRTList (asCtor -> Just (primName -> "Prelude.LRT_Nil", [])) = - return [] -asLRTList (asCtor -> Just (primName -> "Prelude.LRT_Cons", [lrt, lrts])) = - do tp <- liftSC2 scGlobalApply "Prelude.lrtToType" [lrt] - tp_norm_closed <- liftSC1 scWhnf tp >>= piUVarsM - (tp_norm_closed :) <$> asLRTList lrts -asLRTList t = throwError (MalformedLetRecTypes t) - --- | Match a right-nested series of pairs. This is similar to 'asTupleValue' --- except that it expects a unit value to always be at the end. -asNestedPairs :: Recognizer Term [Term] -asNestedPairs (asPairValue -> Just (x, asNestedPairs -> Just xs)) = Just (x:xs) -asNestedPairs (asFTermF -> Just UnitValue) = Just [] -asNestedPairs _ = Nothing - --- | Syntactically project then @i@th element of the body of a lambda. That is, --- assuming the input 'Term' has the form --- --- > \ (x1:T1) ... (xn:Tn) -> (e1, (e2, ... (en, ()))) --- --- return the bindings @x1:T1,...,xn:Tn@ and @ei@ -synProjFunBody :: Int -> Term -> Maybe ([(LocalName, Term)], Term) -synProjFunBody i (asLambdaList -> (vars, asTupleValue -> Just es)) = - -- NOTE: we are doing 1-based indexing instead of 0-based, thus the -1 - Just $ (vars, es !! (i-1)) -synProjFunBody _ _ = Nothing - --- | Bind fresh function variables for a @letRecM@ or @multiFixM@ with the given --- @LetRecTypes@ and definitions for the function bodies as a lambda -mrFreshLetRecVars :: Term -> Term -> MRM [Term] -mrFreshLetRecVars lrts defs_f = - do - -- First, make fresh function constants for all the bound functions, using - -- the names bound by defs_f and just "F" if those run out - let fun_var_names = - map fst (fst $ asLambdaList defs_f) ++ repeat "F" - fun_tps <- asLRTList lrts - funs <- zipWithM mrFreshVar fun_var_names fun_tps - fun_tms <- mapM mrVarTerm funs - - -- Next, apply the definition function defs_f to our function vars, yielding - -- the definitions of the individual letrec-bound functions in terms of the - -- new function constants - defs_tm <- mrApplyAll defs_f fun_tms - defs <- case asNestedPairs defs_tm of - Just defs -> return defs - Nothing -> throwError (MalformedDefsFun defs_f) - - -- Remember the body associated with each fresh function constant - zipWithM_ (\f body -> - lambdaUVarsM body >>= \cl_body -> - mrSetVarInfo f (FunVarInfo cl_body)) funs defs - - -- Finally, return the terms for the fresh function variables - return fun_tms - - --- | Normalize a 'Term' of monadic type to monadic normal form -normCompTerm :: Term -> MRM NormComp -normCompTerm = normComp . CompTerm - --- | Normalize a computation to monadic normal form, assuming any 'Term's it --- contains have already been normalized with respect to beta and projections --- (but constants need not be unfolded) -normComp :: Comp -> MRM NormComp -normComp (CompReturn t) = return $ ReturnM t -normComp (CompBind m f) = - do norm <- normComp m - normBind norm f -normComp (CompTerm t) = - withFailureCtx (FailCtxMNF t) $ - case asApplyAll t of - (isGlobalDef "Prelude.returnM" -> Just (), [_, x]) -> - return $ ReturnM x - (isGlobalDef "Prelude.bindM" -> Just (), [_, _, m, f]) -> - do norm <- normComp (CompTerm m) - normBind norm (CompFunTerm f) - (isGlobalDef "Prelude.errorM" -> Just (), [_, str]) -> - return (ErrorM str) - (isGlobalDef "Prelude.ite" -> Just (), [_, cond, then_tm, else_tm]) -> - return $ Ite cond (CompTerm then_tm) (CompTerm else_tm) - (isGlobalDef "Prelude.either" -> Just (), [_, _, _, f, g, eith]) -> - return $ Either (CompFunTerm f) (CompFunTerm g) eith - (isGlobalDef "Prelude.maybe" -> Just (), [tp, _, m, f, mayb]) -> - return $ MaybeElim (Type tp) (CompTerm m) (CompFunTerm f) mayb - (isGlobalDef "Prelude.orM" -> Just (), [_, m1, m2]) -> - return $ OrM (CompTerm m1) (CompTerm m2) - (isGlobalDef "Prelude.existsM" -> Just (), [tp, _, body_tm]) -> - return $ ExistsM (Type tp) (CompFunTerm body_tm) - (isGlobalDef "Prelude.forallM" -> Just (), [tp, _, body_tm]) -> - return $ ForallM (Type tp) (CompFunTerm body_tm) - (isGlobalDef "Prelude.letRecM" -> Just (), [lrts, _, defs_f, body_f]) -> - do - -- Bind fresh function vars for the letrec-bound functions - fun_tms <- mrFreshLetRecVars lrts defs_f - -- Apply the body function to our function vars and recursively - -- normalize the resulting computation - body_tm <- mrApplyAll body_f fun_tms - normComp (CompTerm body_tm) - - -- Only unfold constants that are not recursive functions, i.e., whose - -- bodies do not contain letrecs - {- FIXME: this should be handled by mrRefines; we want it to be handled there - so that we use refinement assumptions before unfolding constants, to give - the user control over refinement proofs - ((asConstant -> Just (_, body)), args) - | not (containsLetRecM body) -> - mrApplyAll body args >>= normCompTerm - -} - - -- Recognize (multiFixM lrts (\ f1 ... fn -> (body1, ..., bodyn))).i args - (asTupleSelector -> - Just (asApplyAll -> (isGlobalDef "Prelude.multiFixM" -> Just (), - [lrts, defs_f]), - i), args) - -- Extract out the function \f1 ... fn -> bodyi - | Just (vars, body_i) <- synProjFunBody i defs_f -> - do - -- Bind fresh function variables for the functions f1 ... fn - fun_tms <- mrFreshLetRecVars lrts defs_f - -- Re-abstract the body - body_f <- liftSC2 scLambdaList vars body_i - -- Apply body_f to f1 ... fn and the top-level arguments - body_tm <- mrApplyAll body_f (fun_tms ++ args) - normComp (CompTerm body_tm) - - - -- For an ExtCns, we have to check what sort of variable it is - -- FIXME: substitute for evars if they have been instantiated - ((asExtCns -> Just ec), args) -> - do fun_name <- extCnsToFunName ec - return $ FunBind fun_name args CompFunReturn - - ((asGlobalFunName -> Just f), args) -> - return $ FunBind f args CompFunReturn - - _ -> throwError (MalformedComp t) - - --- | Bind a computation in whnf with a function, and normalize -normBind :: NormComp -> CompFun -> MRM NormComp -normBind (ReturnM t) k = applyNormCompFun k t -normBind (ErrorM msg) _ = return (ErrorM msg) -normBind (Ite cond comp1 comp2) k = - return $ Ite cond (CompBind comp1 k) (CompBind comp2 k) -normBind (Either f g t) k = - return $ Either (compFunComp f k) (compFunComp g k) t -normBind (MaybeElim tp m f t) k = - return $ MaybeElim tp (CompBind m k) (compFunComp f k) t -normBind (OrM comp1 comp2) k = - return $ OrM (CompBind comp1 k) (CompBind comp2 k) -normBind (ExistsM tp f) k = return $ ExistsM tp (compFunComp f k) -normBind (ForallM tp f) k = return $ ForallM tp (compFunComp f k) -normBind (FunBind f args k1) k2 = - return $ FunBind f args (compFunComp k1 k2) - --- | Bind a 'Term' for a computation with a function and normalize -normBindTerm :: Term -> CompFun -> MRM NormComp -normBindTerm t f = normCompTerm t >>= \m -> normBind m f - --- | Apply a computation function to a term argument to get a computation -applyCompFun :: CompFun -> Term -> MRM Comp -applyCompFun (CompFunComp f g) t = - -- (f >=> g) t == f t >>= g - do comp <- applyCompFun f t - return $ CompBind comp g -applyCompFun CompFunReturn t = - return $ CompReturn t -applyCompFun (CompFunTerm f) t = CompTerm <$> mrApplyAll f [t] - --- | Apply a 'CompFun' to a term and normalize the resulting computation -applyNormCompFun :: CompFun -> Term -> MRM NormComp -applyNormCompFun f arg = applyCompFun f arg >>= normComp - --- | Apply a 'Comp - -{- FIXME: do these go away? --- | Lookup the definition of a function or throw a 'CannotLookupFunDef' if this is --- not allowed, either because it is a global function we are treating as opaque --- or because it is a locally-bound function variable -mrLookupFunDef :: FunName -> MRM Term -mrLookupFunDef f@(GlobalName _) = throwError (CannotLookupFunDef f) -mrLookupFunDef f@(LocalName var) = - mrVarInfo var >>= \case - Just (FunVarInfo body) -> return body - Just _ -> throwError (CannotLookupFunDef f) - Nothing -> error "mrLookupFunDef: unknown variable!" - --- | Unfold a call to function @f@ in term @f args >>= g@ -mrUnfoldFunBind :: FunName -> [Term] -> Mark -> CompFun -> MRM Comp -mrUnfoldFunBind f _ mark _ | inMark f mark = throwError (RecursiveUnfold f) -mrUnfoldFunBind f args mark g = - do f_def <- mrLookupFunDef f - CompBind <$> - (CompMark <$> (CompTerm <$> liftSC2 scApplyAll f_def args) - <*> (return $ singleMark f `mappend` mark)) - <*> return g --} - -{- -FIXME HERE NOW: maybe each FunName should stipulate whether it is recursive or -not, so that mrRefines can unfold the non-recursive ones early but wait on -handling the recursive ones --} - ----------------------------------------------------------------------- --- * Mr Solver Himself (He Identifies as Male) ----------------------------------------------------------------------- - --- | An object that can be converted to a normalized computation -class ToNormComp a where - toNormComp :: a -> MRM NormComp - -instance ToNormComp NormComp where - toNormComp = return -instance ToNormComp Comp where - toNormComp = normComp -instance ToNormComp Term where - toNormComp = normComp . CompTerm - --- | Prove that the left-hand computation refines the right-hand one. See the --- rules described at the beginning of this module. -mrRefines :: (ToNormComp a, ToNormComp b) => a -> b -> MRM () -mrRefines t1 t2 = - do m1 <- toNormComp t1 - m2 <- toNormComp t2 - mrDebugPPPrefixSep 1 "mrRefines" m1 "|=" m2 - withFailureCtx (FailCtxRefines m1 m2) $ mrRefines' m1 m2 - --- | The main implementation of 'mrRefines' -mrRefines' :: NormComp -> NormComp -> MRM () -mrRefines' (ReturnM e1) (ReturnM e2) = mrProveEq e1 e2 -mrRefines' (ErrorM _) (ErrorM _) = return () -mrRefines' (ReturnM e) (ErrorM _) = throwError (ReturnNotError e) -mrRefines' (ErrorM _) (ReturnM e) = throwError (ReturnNotError e) -mrRefines' (MaybeElim (Type (asEq -> Just (tp,e1,e2))) m1 f1 _) m2 = - do cond <- mrEq' tp e1 e2 - not_cond <- liftSC1 scNot cond - cond_pf <- - liftSC1 scEqTrue cond >>= piUVarsM >>= mrFreshVar "pf" >>= mrVarTerm - m1' <- applyNormCompFun f1 cond_pf - cond_holds <- mrProvable cond - if cond_holds then mrRefines m1' m2 else - withAssumption cond (mrRefines m1' m2) >> - withAssumption not_cond (mrRefines m1 m2) -mrRefines' m1 (MaybeElim (Type (asEq -> Just (tp,e1,e2))) m2 f2 _) = - do cond <- mrEq' tp e1 e2 - not_cond <- liftSC1 scNot cond - cond_pf <- - liftSC1 scEqTrue cond >>= piUVarsM >>= mrFreshVar "pf" >>= mrVarTerm - m2' <- applyNormCompFun f2 cond_pf - cond_holds <- mrProvable cond - if cond_holds then mrRefines m1 m2' else - withAssumption cond (mrRefines m1 m2') >> - withAssumption not_cond (mrRefines m1 m2) -mrRefines' (Ite cond1 m1 m1') m2_all@(Ite cond2 m2 m2') = - liftSC1 scNot cond1 >>= \not_cond1 -> - (mrEq cond1 cond2 >>= mrProvable) >>= \case - True -> - -- If we can prove cond1 == cond2, then we just need to prove m1 |= m2 and - -- m1' |= m2'; further, we need only add assumptions about cond1, because it - -- is provably equal to cond2 - withAssumption cond1 (mrRefines m1 m2) >> - withAssumption not_cond1 (mrRefines m1' m2') - False -> - -- Otherwise, prove each branch of the LHS refines the whole RHS - withAssumption cond1 (mrRefines m1 m2_all) >> - withAssumption not_cond1 (mrRefines m1' m2_all) -mrRefines' (Ite cond1 m1 m1') m2 = - do not_cond1 <- liftSC1 scNot cond1 - withAssumption cond1 (mrRefines m1 m2) - withAssumption not_cond1 (mrRefines m1' m2) -mrRefines' m1 (Ite cond2 m2 m2') = - do not_cond2 <- liftSC1 scNot cond2 - withAssumption cond2 (mrRefines m1 m2) - withAssumption not_cond2 (mrRefines m1 m2') --- FIXME: handle sum elimination --- mrRefines (Either f1 g1 e1) (Either f2 g2 e2) = -mrRefines' m1 (ForallM tp f2) = - let nm = maybe "x" id (compFunVarName f2) in - withUVarLift nm tp (m1,f2) $ \x (m1',f2') -> - applyNormCompFun f2' x >>= \m2' -> - mrRefines m1' m2' -mrRefines' (ExistsM tp f1) m2 = - let nm = maybe "x" id (compFunVarName f1) in - withUVarLift nm tp (f1,m2) $ \x (f1',m2') -> - applyNormCompFun f1' x >>= \m1' -> - mrRefines m1' m2' -mrRefines' m1 (OrM m2 m2') = - mrOr (mrRefines m1 m2) (mrRefines m1 m2') -mrRefines' (OrM m1 m1') m2 = - mrRefines m1 m2 >> mrRefines m1' m2 - --- FIXME: the following cases don't work unless we either allow evars to be set --- to NormComps or we can turn NormComps back into terms -mrRefines' m1@(FunBind (EVarFunName _) _ _) m2 = - throwError (CompsDoNotRefine m1 m2) -mrRefines' m1 m2@(FunBind (EVarFunName _) _ _) = - throwError (CompsDoNotRefine m1 m2) -{- -mrRefines' (FunBind (EVarFunName evar) args CompFunReturn) m2 = - mrGetEVar evar >>= \case - Just f -> - (mrApplyAll f args >>= normCompTerm) >>= \m1' -> - mrRefines m1' m2 - Nothing -> mrTrySetAppliedEVar evar args m2 --} - -mrRefines' (FunBind (LetRecName f) args1 k1) (FunBind (LetRecName f') args2 k2) - | f == f' && length args1 == length args2 = - zipWithM_ mrProveEq args1 args2 >> - mrRefinesFun k1 k2 - -mrRefines' m1@(FunBind f1 args1 k1) m2@(FunBind f2 args2 k2) = - mrFunOutType f1 args1 >>= \tp1 -> - mrFunOutType f2 args2 >>= \tp2 -> - mrConvertible tp1 tp2 >>= \tps_eq -> - mrFunBodyRecInfo f1 args1 >>= \maybe_f1_body -> - mrFunBodyRecInfo f2 args2 >>= \maybe_f2_body -> - mrGetFunAssump f1 >>= \case - - -- If we have an assumption that f1 args' refines some rhs, then prove that - -- args1 = args' and then that rhs refines m2 - Just fassump -> - do (assump_args, assump_rhs) <- instantiateFunAssump fassump - zipWithM_ mrProveEq assump_args args1 - m1' <- normBind assump_rhs k1 - mrRefines m1' m2 - - -- If f1 unfolds and is not recursive in itself, unfold it and recurse - _ | Just (f1_body, False) <- maybe_f1_body -> - normBindTerm f1_body k1 >>= \m1' -> mrRefines m1' m2 - - -- If f2 unfolds and is not recursive in itself, unfold it and recurse - _ | Just (f2_body, False) <- maybe_f2_body -> - normBindTerm f2_body k2 >>= \m2' -> mrRefines m1 m2' - - -- If we do not already have an assumption that f1 refines some specification, - -- and both f1 and f2 are recursive but have the same return type, then try to - -- coinductively prove that f1 args1 |= f2 args2 under the assumption that f1 - -- args1 |= f2 args2, and then try to prove that k1 |= k2 - Nothing - | tps_eq - , Just (f1_body, _) <- maybe_f1_body - , Just (f2_body, _) <- maybe_f2_body -> - do withFunAssump f1 args1 (FunBind f2 args2 CompFunReturn) $ - mrRefines f1_body f2_body - mrRefinesFun k1 k2 - - -- If we cannot line up f1 and f2, then making progress here would require us - -- to somehow split either m1 or m2 into some bind m' >>= k' such that m' is - -- related to the function call on the other side and k' is related to the - -- continuation on the other side, but we don't know how to do that, so give - -- up - Nothing -> - throwError (CompsDoNotRefine m1 m2) - -{- FIXME: handle FunBind on just one side -mrRefines' m1@(FunBind f@(GlobalName _) args k1) m2 = - mrGetFunAssump f >>= \case - Just fassump -> - -- If we have an assumption that f args' refines some rhs, then prove that - -- args = args' and then that rhs refines m2 - do (assump_args, assump_rhs) <- instantiateFunAssump fassump - zipWithM_ mrProveEq assump_args args - m1' <- normBind assump_rhs k1 - mrRefines m1' m2 - Nothing -> - -- We don't want to do inter-procedural proofs, so if we don't know anything - -- about f already then give up - throwError (CompsDoNotRefine m1 m2) --} - - -mrRefines' m1@(FunBind f1 args1 k1) m2 = - mrGetFunAssump f1 >>= \case - - -- If we have an assumption that f1 args' refines some rhs, then prove that - -- args1 = args' and then that rhs refines m2 - Just fassump -> - do (assump_args, assump_rhs) <- instantiateFunAssump fassump - zipWithM_ mrProveEq assump_args args1 - m1' <- normBind assump_rhs k1 - mrRefines m1' m2 - - -- Otherwise, see if we can unfold f1 - Nothing -> - mrFunBodyRecInfo f1 args1 >>= \case - - -- If f1 unfolds and is not recursive in itself, unfold it and recurse - Just (f1_body, False) -> - normBindTerm f1_body k1 >>= \m1' -> mrRefines m1' m2 - - -- Otherwise we would have to somehow split m2 into some computation of the - -- form m2' >>= k2 where f1 args1 |= m2' and k1 |= k2, but we don't know how - -- to do this splitting, so give up - _ -> - throwError (CompsDoNotRefine m1 m2) - - -mrRefines' m1 m2@(FunBind f2 args2 k2) = - mrFunBodyRecInfo f2 args2 >>= \case - - -- If f2 unfolds and is not recursive in itself, unfold it and recurse - Just (f2_body, False) -> - normBindTerm f2_body k2 >>= \m2' -> mrRefines m1 m2' - - -- If f2 unfolds but is recursive, and k2 is the trivial continuation, meaning - -- m2 is just f2 args2, use the law of coinduction to prove m1 |= f2 args2 by - -- proving m1 |= f2_body under the assumption that m1 |= f2 args2 - {- FIXME: implement something like this - Just (f2_body, True) - | CompFunReturn <- k2 -> - withFunAssumpR m1 f2 args2 $ - -} - - -- Otherwise we would have to somehow split m1 into some computation of the - -- form m1' >>= k1 where m1' |= f2 args2 and k1 |= k2, but we don't know how - -- to do this splitting, so give up - _ -> - throwError (CompsDoNotRefine m1 m2) - - --- NOTE: the rules that introduce existential variables need to go last, so that --- they can quantify over as many universals as possible -mrRefines' m1 (ExistsM tp f2) = - do let nm = maybe "x" id (compFunVarName f2) - evar <- mrFreshEVar nm tp - m2' <- applyNormCompFun f2 evar - mrRefines m1 m2' -mrRefines' (ForallM tp f1) m2 = - do let nm = maybe "x" id (compFunVarName f1) - evar <- mrFreshEVar nm tp - m1' <- applyNormCompFun f1 evar - mrRefines m1' m2 - --- If none of the above cases match, then fail -mrRefines' m1 m2 = throwError (CompsDoNotRefine m1 m2) - - --- | Prove that one function refines another for all inputs -mrRefinesFun :: CompFun -> CompFun -> MRM () -mrRefinesFun CompFunReturn CompFunReturn = return () -mrRefinesFun f1 f2 - | Just nm <- compFunVarName f1 `mplus` compFunVarName f2 - , Just tp <- compFunInputType f1 `mplus` compFunInputType f2 = - withUVarLift nm tp (f1,f2) $ \x (f1', f2') -> - do m1' <- applyNormCompFun f1' x - m2' <- applyNormCompFun f2' x - mrRefines m1' m2' -mrRefinesFun _ _ = error "mrRefinesFun: unreachable!" - - ----------------------------------------------------------------------- --- * External Entrypoints ----------------------------------------------------------------------- - --- | Test two monadic, recursive terms for equivalence -askMRSolver :: - SharedContext -> - Int {- ^ The debug level -} -> - Maybe Integer {- ^ Timeout in milliseconds for each SMT call -} -> - Term -> Term -> IO (Maybe MRFailure) - -askMRSolver sc dlvl timeout t1 t2 = - do tp1 <- scTypeOf sc t1 >>= scWhnf sc - tp2 <- scTypeOf sc t2 >>= scWhnf sc - init_st <- mkMRState sc Map.empty timeout dlvl - case asPiList tp1 of - (uvar_ctx, asCompM -> Just _) -> - fmap (either Just (const Nothing)) $ runMRM init_st $ - withUVars uvar_ctx $ \vars -> - do tps_are_eq <- mrConvertible tp1 tp2 - if tps_are_eq then return () else - throwError (TypesNotEq (Type tp1) (Type tp2)) - mrDebugPPPrefixSep 1 "mr_solver" t1 "|=" t2 - m1 <- mrApplyAll t1 vars >>= normCompTerm - m2 <- mrApplyAll t2 vars >>= normCompTerm - mrRefines m1 m2 - _ -> return $ Just $ NotCompFunType tp1 +import SAWScript.Prover.MRSolver.Term +import SAWScript.Prover.MRSolver.Monad +import SAWScript.Prover.MRSolver.Solver diff --git a/src/SAWScript/Prover/MRSolver/Monad.hs b/src/SAWScript/Prover/MRSolver/Monad.hs new file mode 100644 index 0000000000..b89e3ae1c1 --- /dev/null +++ b/src/SAWScript/Prover/MRSolver/Monad.hs @@ -0,0 +1,695 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} + +{- | +Module : SAWScript.Prover.MRSolver.Monad +Copyright : Galois, Inc. 2022 +License : BSD3 +Maintainer : westbrook@galois.com +Stability : experimental +Portability : non-portable (language extensions) + +This module defines the monad used by Mr. Solver ('MRM') as well as the core +monadic combinators for operating on terms. +-} + +module SAWScript.Prover.MRSolver.Monad where + +import Data.List (find, findIndex) +import qualified Data.Text as T +import System.IO (hPutStrLn, stderr) +import Control.Monad.Reader +import Control.Monad.State +import Control.Monad.Except +import Control.Monad.Trans.Maybe + +import Data.Map (Map) +import qualified Data.Map as Map + +import Prettyprinter + +import Verifier.SAW.Term.Functor +import Verifier.SAW.Term.CtxTerm (MonadTerm(..)) +import Verifier.SAW.Term.Pretty +import Verifier.SAW.SCTypeCheck +import Verifier.SAW.SharedTerm +import Verifier.SAW.Recognizer +import Verifier.SAW.Cryptol.Monadify + +import SAWScript.Prover.MRSolver.Term + + +---------------------------------------------------------------------- +-- * MR Solver Errors +---------------------------------------------------------------------- + +-- | The context in which a failure occurred +data FailCtx + = FailCtxRefines NormComp NormComp + | FailCtxMNF Term + deriving Show + +-- | That's MR. Failure to you +data MRFailure + = TermsNotEq Term Term + | TypesNotEq Type Type + | CompsDoNotRefine NormComp NormComp + | ReturnNotError Term + | FunsNotEq FunName FunName + | CannotLookupFunDef FunName + | RecursiveUnfold FunName + | MalformedLetRecTypes Term + | MalformedDefsFun Term + | MalformedComp Term + | NotCompFunType Term + -- | A local variable binding + | MRFailureLocalVar LocalName MRFailure + -- | Information about the context of the failure + | MRFailureCtx FailCtx MRFailure + -- | Records a disjunctive branch we took, where both cases failed + | MRFailureDisj MRFailure MRFailure + deriving Show + +-- | Pretty-print an object prefixed with a 'String' that describes it +ppWithPrefix :: PrettyInCtx a => String -> a -> PPInCtxM SawDoc +ppWithPrefix str a = (pretty str <>) <$> nest 2 <$> (line <>) <$> prettyInCtx a + +-- | Pretty-print two objects, prefixed with a 'String' and with a separator +ppWithPrefixSep :: PrettyInCtx a => String -> a -> String -> a -> + PPInCtxM SawDoc +ppWithPrefixSep d1 t2 d3 t4 = + prettyInCtx t2 >>= \d2 -> prettyInCtx t4 >>= \d4 -> + return $ group (pretty d1 <> nest 2 (line <> d2) <> line <> + pretty d3 <> nest 2 (line <> d4)) + +-- | Apply 'vsep' to a list of pretty-printing computations +vsepM :: [PPInCtxM SawDoc] -> PPInCtxM SawDoc +vsepM = fmap vsep . sequence + +instance PrettyInCtx FailCtx where + prettyInCtx (FailCtxRefines m1 m2) = + group <$> nest 2 <$> + ppWithPrefixSep "When proving refinement:" m1 "|=" m2 + prettyInCtx (FailCtxMNF t) = + group <$> nest 2 <$> vsepM [return "When normalizing computation:", + prettyInCtx t] + +instance PrettyInCtx MRFailure where + prettyInCtx (TermsNotEq t1 t2) = + ppWithPrefixSep "Could not prove terms equal:" t1 "and" t2 + prettyInCtx (TypesNotEq tp1 tp2) = + ppWithPrefixSep "Types not equal:" tp1 "and" tp2 + prettyInCtx (CompsDoNotRefine m1 m2) = + ppWithPrefixSep "Could not prove refinement: " m1 "|=" m2 + prettyInCtx (ReturnNotError t) = + ppWithPrefix "errorM computation not equal to:" (ReturnM t) + prettyInCtx (FunsNotEq nm1 nm2) = + vsepM [return "Named functions not equal:", + prettyInCtx nm1, prettyInCtx nm2] + prettyInCtx (CannotLookupFunDef nm) = + ppWithPrefix "Could not find definition for function:" nm + prettyInCtx (RecursiveUnfold nm) = + ppWithPrefix "Recursive unfolding of function inside its own body:" nm + prettyInCtx (MalformedLetRecTypes t) = + ppWithPrefix "Not a ground LetRecTypes list:" t + prettyInCtx (MalformedDefsFun t) = + ppWithPrefix "Cannot handle letRecM recursive definitions term:" t + prettyInCtx (MalformedComp t) = + ppWithPrefix "Could not handle computation:" t + prettyInCtx (NotCompFunType tp) = + ppWithPrefix "Not a computation or computational function type:" tp + prettyInCtx (MRFailureLocalVar x err) = + local (x:) $ prettyInCtx err + prettyInCtx (MRFailureCtx ctx err) = + do pp1 <- prettyInCtx ctx + pp2 <- prettyInCtx err + return (pp1 <> line <> pp2) + prettyInCtx (MRFailureDisj err1 err2) = + ppWithPrefixSep "Tried two comparisons:" err1 "Backtracking..." err2 + +-- | Render a 'MRFailure' to a 'String' +showMRFailure :: MRFailure -> String +showMRFailure = showInCtx [] + + +---------------------------------------------------------------------- +-- * MR Monad +---------------------------------------------------------------------- + +-- | Classification info for what sort of variable an 'MRVar' is +data MRVarInfo + -- | An existential variable, that might be instantiated + = EVarInfo (Maybe Term) + -- | A letrec-bound function, with its body + | FunVarInfo Term + +-- | A map from 'MRVar's to their info +type MRVarMap = Map MRVar MRVarInfo + +-- | Test if a 'Term' is an application of an 'ExtCns' to some arguments +asExtCnsApp :: Recognizer Term (ExtCns Term, [Term]) +asExtCnsApp (asApplyAll -> (asExtCns -> Just ec, args)) = + return (ec, args) +asExtCnsApp _ = Nothing + +-- | Recognize an evar applied to 0 or more arguments relative to a 'MRVarMap' +-- along with its instantiation, if any +asEVarApp :: MRVarMap -> Recognizer Term (MRVar, [Term], Maybe Term) +asEVarApp var_map (asExtCnsApp -> Just (ec, args)) + | Just (EVarInfo maybe_inst) <- Map.lookup (MRVar ec) var_map = + Just (MRVar ec, args, maybe_inst) +asEVarApp _ _ = Nothing + +-- | An assumption that a named function refines some specificaiton. This has +-- the form +-- +-- > forall x1, ..., xn. F e1 ... ek |= m +-- +-- for some universal context @x1:T1, .., xn:Tn@, some list of argument +-- expressions @ei@ over the universal @xj@ variables, and some right-hand side +-- computation expression @m@. +data FunAssump = FunAssump { + -- | The uvars that were in scope when this assmption was created, in order + -- from outermost to innermost; that is, the uvars as "seen from outside their + -- scope", which is the reverse of the order of 'mrUVars', below + fassumpCtx :: [(LocalName,Term)], + -- | The argument expressions @e1, ..., en@ over the 'fassumpCtx' uvars + fassumpArgs :: [Term], + -- | The right-hand side upper bound @m@ over the 'fassumpCtx' uvars + fassumpRHS :: NormComp } + +-- | State maintained by MR. Solver +data MRState = MRState { + -- | Global shared context for building terms, etc. + mrSC :: SharedContext, + -- | SMT timeout for SMT calls made by Mr. Solver + mrSMTTimeout :: Maybe Integer, + -- | The context of universal variables, which are free SAW core variables, in + -- order from innermost to outermost, i.e., where element @0@ corresponds to + -- deBruijn index @0@ + mrUVars :: [(LocalName,Type)], + -- | The existential and letrec-bound variables + mrVars :: MRVarMap, + -- | The current assumptions of function refinement + mrFunAssumps :: Map FunName FunAssump, + -- | The current assumptions, which are conjoined into a single Boolean term; + -- note that these have the current UVars free + mrAssumptions :: Term, + -- | The debug level, which controls debug printing + mrDebugLevel :: Int +} + +-- | Build a default, empty state from SMT configuration parameters and a set of +-- function refinement assumptions +mkMRState :: SharedContext -> Map FunName FunAssump -> + Maybe Integer -> Int -> IO MRState +mkMRState sc fun_assumps timeout dlvl = + scBool sc True >>= \true_tm -> + return $ MRState { mrSC = sc, + mrSMTTimeout = timeout, mrUVars = [], mrVars = Map.empty, + mrFunAssumps = fun_assumps, mrAssumptions = true_tm, + mrDebugLevel = dlvl } + +-- | Mr. Monad, the monad used by MR. Solver, which is the state-exception monad +newtype MRM a = MRM { unMRM :: StateT MRState (ExceptT MRFailure IO) a } + deriving (Functor, Applicative, Monad, MonadIO, + MonadState MRState, MonadError MRFailure) + +instance MonadTerm MRM where + mkTermF = liftSC1 scTermF + liftTerm = liftSC3 incVars + whnfTerm = liftSC1 scWhnf + substTerm = liftSC3 instantiateVarList + +-- | Run an 'MRM' computation and return a result or an error +runMRM :: MRState -> MRM a -> IO (Either MRFailure a) +runMRM init_st m = runExceptT $ flip evalStateT init_st $ unMRM m + +-- | Apply a function to any failure thrown by an 'MRM' computation +mapFailure :: (MRFailure -> MRFailure) -> MRM a -> MRM a +mapFailure f m = catchError m (throwError . f) + +-- | Try two different 'MRM' computations, combining their failures if needed. +-- Note that the 'MRState' will reset if the first computation fails. +mrOr :: MRM a -> MRM a -> MRM a +mrOr m1 m2 = + catchError m1 $ \err1 -> + catchError m2 $ \err2 -> + throwError $ MRFailureDisj err1 err2 + +-- | Run an 'MRM' computation in an extended failure context +withFailureCtx :: FailCtx -> MRM a -> MRM a +withFailureCtx ctx = mapFailure (MRFailureCtx ctx) + +{- +-- | Catch any errors thrown by a computation and coerce them to a 'Left' +catchErrorEither :: MonadError e m => m a -> m (Either e a) +catchErrorEither m = catchError (Right <$> m) (return . Left) +-} + +-- FIXME: replace these individual lifting functions with a more general +-- typeclass like LiftTCM + +-- | Lift a nullary SharedTerm computation into 'MRM' +liftSC0 :: (SharedContext -> IO a) -> MRM a +liftSC0 f = (mrSC <$> get) >>= \sc -> liftIO (f sc) + +-- | Lift a unary SharedTerm computation into 'MRM' +liftSC1 :: (SharedContext -> a -> IO b) -> a -> MRM b +liftSC1 f a = (mrSC <$> get) >>= \sc -> liftIO (f sc a) + +-- | Lift a binary SharedTerm computation into 'MRM' +liftSC2 :: (SharedContext -> a -> b -> IO c) -> a -> b -> MRM c +liftSC2 f a b = (mrSC <$> get) >>= \sc -> liftIO (f sc a b) + +-- | Lift a ternary SharedTerm computation into 'MRM' +liftSC3 :: (SharedContext -> a -> b -> c -> IO d) -> a -> b -> c -> MRM d +liftSC3 f a b c = (mrSC <$> get) >>= \sc -> liftIO (f sc a b c) + +-- | Lift a quaternary SharedTerm computation into 'MRM' +liftSC4 :: (SharedContext -> a -> b -> c -> d -> IO e) -> a -> b -> c -> d -> + MRM e +liftSC4 f a b c d = (mrSC <$> get) >>= \sc -> liftIO (f sc a b c d) + +-- | Lift a quinary SharedTerm computation into 'MRM' +liftSC5 :: (SharedContext -> a -> b -> c -> d -> e -> IO f) -> + a -> b -> c -> d -> e -> MRM f +liftSC5 f a b c d e = (mrSC <$> get) >>= \sc -> liftIO (f sc a b c d e) + + +---------------------------------------------------------------------- +-- * Monadic Operations on Terms +---------------------------------------------------------------------- + +-- | Apply a 'TermProj' to perform a projection on a 'Term' +doTermProj :: Term -> TermProj -> MRM Term +doTermProj t TermProjLeft = liftSC1 scPairLeft t +doTermProj t TermProjRight = liftSC1 scPairRight t +doTermProj t (TermProjRecord fld) = liftSC2 scRecordSelect t fld + +-- | Apply a 'TermProj' to a type to get the output type of the projection, +-- assuming that the type is already normalized +doTypeProj :: Term -> TermProj -> MRM Term +doTypeProj (asPairType -> Just (tp1, _)) TermProjLeft = return tp1 +doTypeProj (asPairType -> Just (_, tp2)) TermProjRight = return tp2 +doTypeProj (asRecordType -> Just tp_map) (TermProjRecord fld) + | Just tp <- Map.lookup fld tp_map + = return tp +doTypeProj _ _ = + -- FIXME: better error message? This is an error and not an MRFailure because + -- we should only be projecting types for terms that we have already seen... + error "doTypeProj" + +-- | Get and normalize the type of a 'FunName' +funNameType :: FunName -> MRM Term +funNameType (LetRecName var) = liftSC1 scWhnf $ mrVarType var +funNameType (EVarFunName var) = liftSC1 scWhnf $ mrVarType var +funNameType (GlobalName gd projs) = + liftSC1 scWhnf (globalDefType gd) >>= \gd_tp -> + foldM doTypeProj gd_tp projs + +-- | Apply a 'Term' to a list of arguments and beta-reduce in Mr. Monad +mrApplyAll :: Term -> [Term] -> MRM Term +mrApplyAll f args = liftSC2 scApplyAll f args >>= liftSC1 betaNormalize + +-- | Get the current context of uvars as a list of variable names and their +-- types as SAW core 'Term's, with the least recently bound uvar first, i.e., in +-- the order as seen "from the outside" +mrUVarCtx :: MRM [(LocalName,Term)] +mrUVarCtx = reverse <$> map (\(nm,Type tp) -> (nm,tp)) <$> mrUVars <$> get + +-- | Get the type of a 'Term' in the current uvar context +mrTypeOf :: Term -> MRM Term +mrTypeOf t = mrUVarCtx >>= \ctx -> liftSC2 scTypeOf' (map snd ctx) t + +-- | Check if two 'Term's are convertible in the 'MRM' monad +mrConvertible :: Term -> Term -> MRM Bool +mrConvertible = liftSC4 scConvertibleEval scTypeCheckWHNF True + +-- | Take a 'FunName' @f@ for a monadic function of type @vars -> CompM a@ and +-- compute the type @CompM [args/vars]a@ of @f@ applied to @args@. Return the +-- type @[args/vars]a@ that @CompM@ is applied to. +mrFunOutType :: FunName -> [Term] -> MRM Term +mrFunOutType fname args = + funNameType fname >>= \case + (asPiList -> (vars, asCompM -> Just tp)) + | length vars == length args -> substTermLike 0 args tp + ftype@(asPiList -> (vars, _)) -> + do pp_ftype <- mrPPInCtx ftype + pp_fname <- mrPPInCtx fname + debugPrint 0 "mrFunOutType: function applied to the wrong number of args" + debugPrint 0 ("Expected: " ++ show (length vars) ++ + ", found: " ++ show (length args)) + debugPretty 0 ("For function: " <> pp_fname <> " with type: " <> pp_ftype) + error"mrFunOutType" + +-- | Turn a 'LocalName' into one not in a list, adding a suffix if necessary +uniquifyName :: LocalName -> [LocalName] -> LocalName +uniquifyName nm nms | notElem nm nms = nm +uniquifyName nm nms = + case find (flip notElem nms) $ + map (T.append nm . T.pack . show) [(0::Int) ..] of + Just nm' -> nm' + Nothing -> error "uniquifyName" + +-- | Run a MR Solver computation in a context extended with a universal +-- variable, which is passed as a 'Term' to the sub-computation. Note that any +-- assumptions made in the sub-computation will be lost when it completes. +withUVar :: LocalName -> Type -> (Term -> MRM a) -> MRM a +withUVar nm tp m = + do st <- get + let nm' = uniquifyName nm (map fst $ mrUVars st) + assumps' <- liftTerm 0 1 $ mrAssumptions st + put (st { mrUVars = (nm',tp) : mrUVars st, + mrAssumptions = assumps' }) + ret <- mapFailure (MRFailureLocalVar nm') (liftSC1 scLocalVar 0 >>= m) + modify (\st' -> st' { mrUVars = mrUVars st, + mrAssumptions = mrAssumptions st }) + return ret + +-- | Run a MR Solver computation in a context extended with a universal variable +-- and pass it the lifting (in the sense of 'incVars') of an MR Solver term +withUVarLift :: TermLike tm => LocalName -> Type -> tm -> + (Term -> tm -> MRM a) -> MRM a +withUVarLift nm tp t m = + withUVar nm tp (\x -> liftTermLike 0 1 t >>= m x) + +-- | Run a MR Solver computation in a context extended with a list of universal +-- variables, passing 'Term's for those variables to the supplied computation. +-- The variables are bound "outside in", meaning the first variable in the list +-- is bound outermost, and so will have the highest deBruijn index. +withUVars :: [(LocalName,Term)] -> ([Term] -> MRM a) -> MRM a +withUVars = helper [] where + -- The extra input list gives the variables that have already been bound, in + -- order from most to least recently bound + helper :: [Term] -> [(LocalName,Term)] -> ([Term] -> MRM a) -> MRM a + helper vars [] m = m $ reverse vars + helper vars ((nm,tp):ctx) m = + -- FIXME: I think substituting here is wrong, but works on closed terms, so + -- it's fine to use at the top level at least... + substTerm 0 vars tp >>= \tp' -> + withUVarLift nm (Type tp') vars $ \var vars' -> helper (var:vars') ctx m + +-- | Build 'Term's for all the uvars currently in scope, ordered from least to +-- most recently bound +getAllUVarTerms :: MRM [Term] +getAllUVarTerms = + (length <$> mrUVars <$> get) >>= \len -> + mapM (liftSC1 scLocalVar) [len-1, len-2 .. 0] + +-- | Lambda-abstract all the current uvars out of a 'Term', with the least +-- recently bound variable being abstracted first +lambdaUVarsM :: Term -> MRM Term +lambdaUVarsM t = mrUVarCtx >>= \ctx -> liftSC2 scLambdaList ctx t + +-- | Pi-abstract all the current uvars out of a 'Term', with the least recently +-- bound variable being abstracted first +piUVarsM :: Term -> MRM Term +piUVarsM t = mrUVarCtx >>= \ctx -> liftSC2 scPiList ctx t + +-- | Instantiate all uvars in a term using the supplied function +instantiateUVarsM :: TermLike a => (LocalName -> Term -> MRM Term) -> a -> MRM a +instantiateUVarsM f a = + do ctx <- mrUVarCtx + -- Remember: the uvar context is outermost to innermost, so we bind + -- variables from left to right, substituting earlier ones into the types + -- of later ones, but all substitutions are in reverse order, since + -- substTerm and friends like innermost bindings first + let helper :: [Term] -> [(LocalName,Term)] -> MRM [Term] + helper tms [] = return tms + helper tms ((nm,tp):vars) = + do tp' <- substTerm 0 tms tp + tm <- f nm tp' + helper (tm:tms) vars + ecs <- helper [] ctx + substTermLike 0 ecs a + +-- | Convert an 'MRVar' to a 'Term', applying it to all the uvars in scope +mrVarTerm :: MRVar -> MRM Term +mrVarTerm (MRVar ec) = + do var_tm <- liftSC1 scExtCns ec + vars <- getAllUVarTerms + liftSC2 scApplyAll var_tm vars + +-- | Get the 'VarInfo' associated with a 'MRVar' +mrVarInfo :: MRVar -> MRM (Maybe MRVarInfo) +mrVarInfo var = Map.lookup var <$> mrVars <$> get + +-- | Convert an 'ExtCns' to a 'FunName' +extCnsToFunName :: ExtCns Term -> MRM FunName +extCnsToFunName ec = let var = MRVar ec in mrVarInfo var >>= \case + Just (EVarInfo _) -> return $ EVarFunName var + Just (FunVarInfo _) -> return $ LetRecName var + Nothing + | Just glob <- asTypedGlobalDef (Unshared $ FTermF $ ExtCns ec) -> + return $ GlobalName glob [] + _ -> error "extCnsToFunName: unreachable" + +-- | Get the body of a function @f@ if it has one +mrFunNameBody :: FunName -> MRM (Maybe Term) +mrFunNameBody (LetRecName var) = + mrVarInfo var >>= \case + Just (FunVarInfo body) -> return $ Just body + _ -> error "mrFunBody: unknown letrec var" +mrFunNameBody (GlobalName glob projs) + | Just body <- globalDefBody glob + = Just <$> foldM doTermProj body projs +mrFunNameBody (GlobalName _ _) = return Nothing +mrFunNameBody (EVarFunName _) = return Nothing + +-- | Get the body of a function @f@ applied to some arguments, if possible +mrFunBody :: FunName -> [Term] -> MRM (Maybe Term) +mrFunBody f args = mrFunNameBody f >>= \case + Just body -> Just <$> mrApplyAll body args + Nothing -> return Nothing + +-- | Get the body of a function @f@ applied to some arguments, as per +-- 'mrFunBody', and also return whether its body recursively calls itself, as +-- per 'mrCallsFun' +mrFunBodyRecInfo :: FunName -> [Term] -> MRM (Maybe (Term, Bool)) +mrFunBodyRecInfo f args = + mrFunBody f args >>= \case + Just f_body -> Just <$> (f_body,) <$> mrCallsFun f f_body + Nothing -> return Nothing + +-- | Test if a 'Term' contains, after possibly unfolding some functions, a call +-- to a given function @f@ again +mrCallsFun :: FunName -> Term -> MRM Bool +mrCallsFun f = memoFixTermFun $ \recurse t -> case t of + (asExtCns -> Just ec) -> + do g <- extCnsToFunName ec + maybe_body <- mrFunNameBody g + case maybe_body of + _ | f == g -> return True + Just body -> recurse body + Nothing -> return False + (asTypedGlobalProj -> Just (gdef, projs)) -> + case globalDefBody gdef of + _ | f == GlobalName gdef projs -> return True + Just body -> recurse body + Nothing -> return False + (unwrapTermF -> tf) -> + foldM (\b t' -> if b then return b else recurse t') False tf + +-- | Make a fresh 'MRVar' of a given type, which must be closed, i.e., have no +-- free uvars +mrFreshVar :: LocalName -> Term -> MRM MRVar +mrFreshVar nm tp = MRVar <$> liftSC2 scFreshEC nm tp + +-- | Set the info associated with an 'MRVar', assuming it has not been set +mrSetVarInfo :: MRVar -> MRVarInfo -> MRM () +mrSetVarInfo var info = + modify $ \st -> + st { mrVars = + Map.alter (\case + Just _ -> error "mrSetVarInfo" + Nothing -> Just info) + var (mrVars st) } + +-- | Make a fresh existential variable of the given type, abstracting out all +-- the current uvars and returning the new evar applied to all current uvars +mrFreshEVar :: LocalName -> Type -> MRM Term +mrFreshEVar nm (Type tp) = + do tp' <- piUVarsM tp + var <- mrFreshVar nm tp' + mrSetVarInfo var (EVarInfo Nothing) + mrVarTerm var + +-- | Return a fresh sequence of existential variables for a context of variable +-- names and types, assuming each variable is free in the types that occur after +-- it in the list. Return the new evars all applied to the current uvars. +mrFreshEVars :: [(LocalName,Term)] -> MRM [Term] +mrFreshEVars = helper [] where + -- Return fresh evars for the suffix of a context of variable names and types, + -- where the supplied Terms are evars that have already been generated for the + -- earlier part of the context, and so must be substituted into the remaining + -- types in the context + helper :: [Term] -> [(LocalName,Term)] -> MRM [Term] + helper evars [] = return evars + helper evars ((nm,tp):ctx) = + do evar <- substTerm 0 evars tp >>= mrFreshEVar nm . Type + helper (evar:evars) ctx + +-- | Set the value of an evar to a closed term +mrSetEVarClosed :: MRVar -> Term -> MRM () +mrSetEVarClosed var val = + do val_tp <- mrTypeOf val + -- NOTE: need to instantiate any evars in the type of var, to ensure the + -- following subtyping check will succeed + var_tp <- mrSubstEVars $ mrVarType var + -- FIXME: catch subtyping errors and report them as being evar failures + liftSC3 scCheckSubtype Nothing (TypedTerm val val_tp) var_tp + modify $ \st -> + st { mrVars = + Map.alter + (\case + Just (EVarInfo Nothing) -> Just $ EVarInfo (Just val) + Just (EVarInfo (Just _)) -> + error "Setting existential variable: variable already set!" + _ -> error "Setting existential variable: not an evar!") + var (mrVars st) } + + +-- | Try to set the value of the application @X e1 .. en@ of evar @X@ to an +-- expression @e@ by trying to set @X@ to @\ x1 ... xn -> e@. This only works if +-- each free uvar @xi@ in @e@ is one of the arguments @ej@ to @X@ (though it +-- need not be the case that @i=j@). Return whether this succeeded. +mrTrySetAppliedEVar :: MRVar -> [Term] -> Term -> MRM Bool +mrTrySetAppliedEVar evar args t = + -- Get the complete list of argument variables of the type of evar + let (evar_vars, _) = asPiList (mrVarType evar) in + -- Get all the free variables of t + let free_vars = bitSetElems (looseVars t) in + -- For each free var of t, find an arg equal to it + case mapM (\i -> findIndex (\case + (asLocalVar -> Just j) -> i == j + _ -> False) args) free_vars of + Just fv_arg_ixs + -- Check to make sure we have the right number of args + | length args == length evar_vars -> do + -- Build a list of the input vars x1 ... xn as terms, noting that the + -- first variable is the least recently bound and so has the highest + -- deBruijn index + let arg_ixs = [length args - 1, length args - 2 .. 0] + arg_vars <- mapM (liftSC1 scLocalVar) arg_ixs + + -- For free variable of t, we substitute the corresponding variable + -- xi, substituting error terms for the variables that are not free + -- (since we have nothing else to substitute for them) + let var_map = zip free_vars fv_arg_ixs + let subst = flip map [0 .. length args - 1] $ \i -> + maybe (error "mrTrySetAppliedEVar: unexpected free variable") + (arg_vars !!) (lookup i var_map) + body <- substTerm 0 subst t + + -- Now instantiate evar to \x1 ... xn -> body + evar_inst <- liftSC2 scLambdaList evar_vars body + mrSetEVarClosed evar evar_inst + return True + + _ -> return False + + +-- | Replace all evars in a 'Term' with their instantiations when they have one +mrSubstEVars :: Term -> MRM Term +mrSubstEVars = memoFixTermFun $ \recurse t -> + do var_map <- mrVars <$> get + case t of + -- If t is an instantiated evar, recurse on its instantiation + (asEVarApp var_map -> Just (_, args, Just t')) -> + mrApplyAll t' args >>= recurse + -- If t is anything else, recurse on its immediate subterms + _ -> traverseSubterms recurse t + +-- | Replace all evars in a 'Term' with their instantiations, returning +-- 'Nothing' if we hit an uninstantiated evar +mrSubstEVarsStrict :: Term -> MRM (Maybe Term) +mrSubstEVarsStrict top_t = + runMaybeT $ flip memoFixTermFun top_t $ \recurse t -> + do var_map <- mrVars <$> get + case t of + -- If t is an instantiated evar, recurse on its instantiation + (asEVarApp var_map -> Just (_, args, Just t')) -> + lift (mrApplyAll t' args) >>= recurse + -- If t is an uninstantiated evar, return Nothing + (asEVarApp var_map -> Just (_, _, Nothing)) -> + mzero + -- If t is anything else, recurse on its immediate subterms + _ -> traverseSubterms recurse t + +-- | Makes 'mrSubstEVarsStrict' be marked as used +_mrSubstEVarsStrict :: Term -> MRM (Maybe Term) +_mrSubstEVarsStrict = mrSubstEVarsStrict + +-- | Look up the 'FunAssump' for a 'FunName', if there is one +mrGetFunAssump :: FunName -> MRM (Maybe FunAssump) +mrGetFunAssump nm = Map.lookup nm <$> mrFunAssumps <$> get + +-- | Run a computation under the additional assumption that a named function +-- applied to a list of arguments refines a given right-hand side, all of which +-- are 'Term's that can have the current uvars free +withFunAssump :: FunName -> [Term] -> NormComp -> MRM a -> MRM a +withFunAssump fname args rhs m = + do mrDebugPPPrefixSep 1 "withFunAssump" (FunBind + fname args CompFunReturn) "|=" rhs + ctx <- mrUVarCtx + assumps <- mrFunAssumps <$> get + let assumps' = Map.insert fname (FunAssump ctx args rhs) assumps + modify (\s -> s { mrFunAssumps = assumps' }) + ret <- m + modify (\s -> s { mrFunAssumps = assumps }) + return ret + +-- | Generate fresh evars for the context of a 'FunAssump' and substitute them +-- into its arguments and right-hand side +instantiateFunAssump :: FunAssump -> MRM ([Term], NormComp) +instantiateFunAssump fassump = + do evars <- mrFreshEVars $ fassumpCtx fassump + args <- substTermLike 0 evars $ fassumpArgs fassump + rhs <- substTermLike 0 evars $ fassumpRHS fassump + return (args, rhs) + +-- | Add an assumption of type @Bool@ to the current path condition while +-- executing a sub-computation +withAssumption :: Term -> MRM a -> MRM a +withAssumption phi m = + do assumps <- mrAssumptions <$> get + assumps' <- liftSC2 scAnd phi assumps + modify (\s -> s { mrAssumptions = assumps' }) + ret <- m + modify (\s -> s { mrAssumptions = assumps }) + return ret + +-- | Print a 'String' if the debug level is at least the supplied 'Int' +debugPrint :: Int -> String -> MRM () +debugPrint i str = + (mrDebugLevel <$> get) >>= \lvl -> + if lvl >= i then liftIO (hPutStrLn stderr str) else return () + +-- | Print a document if the debug level is at least the supplied 'Int' +debugPretty :: Int -> SawDoc -> MRM () +debugPretty i pp = debugPrint i $ renderSawDoc defaultPPOpts pp + +-- | Pretty-print an object in the current context if the current debug level is +-- at least the supplied 'Int' +debugPrettyInCtx :: PrettyInCtx a => Int -> a -> MRM () +debugPrettyInCtx i a = + (mrUVars <$> get) >>= \ctx -> debugPrint i (showInCtx (map fst ctx) a) + +-- | Pretty-print an object relative to the current context +mrPPInCtx :: PrettyInCtx a => a -> MRM SawDoc +mrPPInCtx a = + runReader (prettyInCtx a) <$> map fst <$> mrUVars <$> get + +-- | Pretty-print the result of 'ppWithPrefixSep' relative to the current uvar +-- context to 'stderr' if the debug level is at least the 'Int' provided +mrDebugPPPrefixSep :: PrettyInCtx a => Int -> String -> a -> String -> a -> + MRM () +mrDebugPPPrefixSep i pre a1 sp a2 = + (mrUVars <$> get) >>= \ctx -> + debugPretty i $ + flip runReader (map fst ctx) (group <$> nest 2 <$> + ppWithPrefixSep pre a1 sp a2) diff --git a/src/SAWScript/Prover/MRSolver/SMT.hs b/src/SAWScript/Prover/MRSolver/SMT.hs new file mode 100644 index 0000000000..ed318a1455 --- /dev/null +++ b/src/SAWScript/Prover/MRSolver/SMT.hs @@ -0,0 +1,353 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} + +{- | +Module : SAWScript.Prover.MRSolver.SMT +Copyright : Galois, Inc. 2022 +License : BSD3 +Maintainer : westbrook@galois.com +Stability : experimental +Portability : non-portable (language extensions) + +This module implements the interface between Mr. Solver and an SMT solver, +namely 'mrProvable' and 'mrProveEq'. +-} + +module SAWScript.Prover.MRSolver.SMT where + +import qualified Data.Vector as V +import Control.Monad.Reader +import Control.Monad.State +import Control.Monad.Except + +import Data.Map (Map) +import qualified Data.Map as Map +import qualified Data.Set as Set + +import Verifier.SAW.Term.Functor +import Verifier.SAW.Term.Pretty +import Verifier.SAW.SharedTerm +import Verifier.SAW.Recognizer +import Verifier.SAW.OpenTerm + +import qualified Verifier.SAW.Prim as Prim +import Verifier.SAW.Simulator.TermModel +import Verifier.SAW.Simulator.Prims +import Verifier.SAW.Simulator.MonadLazy + +import SAWScript.Proof (termToProp, propToTerm, prettyProp) +import What4.Solver +import SAWScript.Prover.What4 + +import SAWScript.Prover.MRSolver.Term +import SAWScript.Prover.MRSolver.Monad + + +---------------------------------------------------------------------- +-- * Various SMT-specific Functions on Terms +---------------------------------------------------------------------- + +-- | Test if a 'Term' is a 'BVVec' type +asBVVecType :: Recognizer Term (Term, Term, Term) +asBVVecType (asApplyAll -> + (isGlobalDef "Prelude.Vec" -> Just _, + [(asApplyAll -> + (isGlobalDef "Prelude.bvToNat" -> Just _, [n, len])), a])) = + Just (n, len, a) +asBVVecType _ = Nothing + +-- | Apply @genBVVec@ to arguments @n@, @len@, and @a@, along with a function of +-- type @Vec n Bool -> a@ +genBVVecTerm :: SharedContext -> Term -> Term -> Term -> Term -> IO Term +genBVVecTerm sc n_tm len_tm a_tm f_tm = + let n = closedOpenTerm n_tm + len = closedOpenTerm len_tm + a = closedOpenTerm a_tm + f = closedOpenTerm f_tm in + completeOpenTerm sc $ + applyOpenTermMulti (globalOpenTerm "Prelude.genBVVec") + [n, len, a, + lambdaOpenTerm "i" (vectorTypeOpenTerm n boolTypeOpenTerm) $ \i -> + lambdaOpenTerm "_" (applyGlobalOpenTerm "Prelude.is_bvult" [n, i, len]) $ \_ -> + applyOpenTerm f i] + +-- | Match a term of the form @genBVVec n len a (\ i _ -> e)@, i.e., where @e@ +-- does not have the proof variable (the underscore) free +asGenBVVecTerm :: Recognizer Term (Term, Term, Term, Term) +asGenBVVecTerm (asApplyAll -> + (isGlobalDef "Prelude.genBVVec" -> Just _, + [n, len, a, + (asLambdaList -> ([_,_], e))])) + | not $ inBitSet 0 $ looseVars e + = Just (n, len, a, e) +asGenBVVecTerm _ = Nothing + +type TmPrim = Prim TermModel + +-- | Convert a Boolean value to a 'Term'; like 'readBackValue' but that function +-- requires a 'SimulatorConfig' which we cannot easily generate here... +boolValToTerm :: SharedContext -> Value TermModel -> IO Term +boolValToTerm _ (VBool (Left tm)) = return tm +boolValToTerm sc (VBool (Right b)) = scBool sc b +boolValToTerm _ (VExtra (VExtraTerm _tp tm)) = return tm +boolValToTerm _ v = error ("boolValToTerm: unexpected value: " ++ show v) + +-- | An implementation of a primitive function that expects a @genBVVec@ term +primGenBVVec :: SharedContext -> (Term -> TmPrim) -> TmPrim +primGenBVVec sc f = + PrimFilterFun "genBVVecPrim" + (\case + VExtra (VExtraTerm _ (asGenBVVecTerm -> Just (n, _, _, e))) -> + -- Generate the function \i -> [i/1,error/0]e + lift $ + do i_tp <- scBoolType sc >>= scVecType sc n + let err_tm = error "primGenBVVec: unexpected variable occurrence" + i_tm <- scLocalVar sc 0 + body <- instantiateVarList sc 0 [err_tm,i_tm] e + scLambda sc "i" i_tp body + _ -> mzero) + f + +-- | An implementation of a primitive function that expects a bitvector term +primBVTermFun :: SharedContext -> (Term -> TmPrim) -> TmPrim +primBVTermFun sc = + PrimFilterFun "primBVTermFun" $ + \case + VExtra (VExtraTerm _ w_tm) -> return w_tm + VWord (Left (_,w_tm)) -> return w_tm + VWord (Right bv) -> + lift $ scBvConst sc (fromIntegral (Prim.width bv)) (Prim.unsigned bv) + VVector vs -> + lift $ + do tms <- traverse (boolValToTerm sc <=< force) (V.toList vs) + tp <- scBoolType sc + scVectorReduced sc tp tms + v -> lift (putStrLn ("primBVTermFun: unhandled value: " ++ show v)) >> mzero + +-- | Implementations of primitives for normalizing SMT terms +smtNormPrims :: SharedContext -> Map Ident TmPrim +smtNormPrims sc = Map.fromList + [ + ("Prelude.genBVVec", + Prim (do tp <- scTypeOfGlobal sc "Prelude.genBVVec" + VExtra <$> VExtraTerm (VTyTerm (mkSort 1) tp) <$> + scGlobalDef sc "Prelude.genBVVec")), + + ("Prelude.atBVVec", + PrimFun $ \_n -> PrimFun $ \_len -> tvalFun $ \a -> + primGenBVVec sc $ \f -> primBVTermFun sc $ \ix -> PrimFun $ \_pf -> + Prim (VExtra <$> VExtraTerm a <$> scApply sc f ix) + ) + ] + +-- | Normalize a 'Term' before building an SMT query for it +normSMTProp :: Term -> MRM Term +normSMTProp t = + debugPrint 2 "Normalizing term:" >> + debugPrettyInCtx 2 t >> + liftSC0 return >>= \sc -> + liftSC0 scGetModuleMap >>= \modmap -> + liftSC5 normalizeSharedTerm modmap (smtNormPrims sc) Map.empty Set.empty t + + +---------------------------------------------------------------------- +-- * Checking Provability with SMT +---------------------------------------------------------------------- + +-- | Test if a closed Boolean term is "provable", i.e., its negation is +-- unsatisfiable, using an SMT solver. By "closed" we mean that it contains no +-- uvars or 'MRVar's. +-- +-- FIXME: use the timeout! +mrProvableRaw :: Term -> MRM Bool +mrProvableRaw prop_term = + do sc <- mrSC <$> get + prop <- liftSC1 termToProp prop_term + unints <- Set.map ecVarIndex <$> getAllExtSet <$> liftSC1 propToTerm prop + debugPrint 2 ("Calling SMT solver with proposition: " ++ + prettyProp defaultPPOpts prop) + sym <- liftIO $ setupWhat4_sym True + (smt_res, _) <- + liftIO $ proveWhat4_solver z3Adapter sym unints sc prop (return ()) + case smt_res of + Just _ -> + debugPrint 2 "SMT solver response: not provable" >> return False + Nothing -> + debugPrint 2 "SMT solver response: provable" >> return True + +-- | Test if a Boolean term over the current uvars is provable given the current +-- assumptions +mrProvable :: Term -> MRM Bool +mrProvable bool_tm = + do assumps <- mrAssumptions <$> get + prop <- liftSC2 scImplies assumps bool_tm >>= liftSC1 scEqTrue + prop_inst <- flip instantiateUVarsM prop $ \nm tp -> + liftSC1 scWhnf tp >>= \case + (asBVVecType -> Just (n, len, a)) -> + -- For variables of type BVVec, create a Vec n Bool -> a function as an + -- ExtCns and apply genBVVec to it + do + ec_tp <- + liftSC1 completeOpenTerm $ + arrowOpenTerm "_" (applyOpenTermMulti (globalOpenTerm "Prelude.Vec") + [closedOpenTerm n, boolTypeOpenTerm]) + (closedOpenTerm a) + ec <- liftSC2 scFreshEC nm ec_tp >>= liftSC1 scExtCns + liftSC4 genBVVecTerm n len a ec + tp' -> liftSC2 scFreshEC nm tp' >>= liftSC1 scExtCns + normSMTProp prop_inst >>= mrProvableRaw + + +---------------------------------------------------------------------- +-- * Checking Equality with SMT +---------------------------------------------------------------------- + +-- | Build a Boolean 'Term' stating that two 'Term's are equal. This is like +-- 'scEq' except that it works on open terms. +mrEq :: Term -> Term -> MRM Term +mrEq t1 t2 = mrTypeOf t1 >>= \tp -> mrEq' tp t1 t2 + +-- | Build a Boolean 'Term' stating that the second and third 'Term' arguments +-- are equal, where the first 'Term' gives their type (which we assume is the +-- same for both). This is like 'scEq' except that it works on open terms. +mrEq' :: Term -> Term -> Term -> MRM Term +mrEq' (asDataType -> Just (pn, [])) t1 t2 + | primName pn == "Prelude.Nat" = liftSC2 scEqualNat t1 t2 +mrEq' (asBoolType -> Just _) t1 t2 = liftSC2 scBoolEq t1 t2 +mrEq' (asIntegerType -> Just _) t1 t2 = liftSC2 scIntEq t1 t2 +mrEq' (asVectorType -> Just (n, asBoolType -> Just ())) t1 t2 = + liftSC3 scBvEq n t1 t2 +mrEq' _ _ _ = error "mrEq': unsupported type" + +-- | A 'Term' in an extended context of universal variables, which are listed +-- "outside in", meaning the highest deBruijn index comes first +data TermInCtx = TermInCtx [(LocalName,Term)] Term + +-- | Conjoin two 'TermInCtx's, assuming they both have Boolean type +andTermInCtx :: TermInCtx -> TermInCtx -> MRM TermInCtx +andTermInCtx (TermInCtx ctx1 t1) (TermInCtx ctx2 t2) = + do + -- Insert the variables in ctx2 into the context of t1 starting at index 0, + -- by lifting its variables starting at 0 by length ctx2 + t1' <- liftTermLike 0 (length ctx2) t1 + -- Insert the variables in ctx1 into the context of t1 starting at index + -- length ctx2, by lifting its variables starting at length ctx2 by length + -- ctx1 + t2' <- liftTermLike (length ctx2) (length ctx1) t2 + TermInCtx (ctx1++ctx2) <$> liftSC2 scAnd t1' t2' + +-- | Extend the context of a 'TermInCtx' with additional universal variables +-- bound "outside" the 'TermInCtx' +extTermInCtx :: [(LocalName,Term)] -> TermInCtx -> TermInCtx +extTermInCtx ctx (TermInCtx ctx' t) = TermInCtx (ctx++ctx') t + +-- | Run an 'MRM' computation in the context of a 'TermInCtx', passing in the +-- 'Term' +withTermInCtx :: TermInCtx -> (Term -> MRM a) -> MRM a +withTermInCtx (TermInCtx [] tm) f = f tm +withTermInCtx (TermInCtx ((nm,tp):ctx) tm) f = + withUVar nm (Type tp) $ const $ withTermInCtx (TermInCtx ctx tm) f + +-- | A "simple" strategy for proving equality between two terms, which we assume +-- are of the same type, which builds an equality proposition by applying the +-- supplied function to both sides and passes this proposition to an SMT solver. +mrProveEqSimple :: (Term -> Term -> MRM Term) -> Term -> Term -> + MRM TermInCtx +-- NOTE: The use of mrSubstEVars instead of mrSubstEVarsStrict means that we +-- allow evars in the terms we send to the SMT solver, but we treat them as +-- uvars. +mrProveEqSimple eqf t1 t2 = + do t1' <- mrSubstEVars t1 + t2' <- mrSubstEVars t2 + TermInCtx [] <$> eqf t1' t2' + + +-- | Prove that two terms are equal, instantiating evars if necessary, or +-- throwing an error if this is not possible +mrProveEq :: Term -> Term -> MRM () +mrProveEq t1 t2 = + do mrDebugPPPrefixSep 1 "mrProveEq" t1 "==" t2 + tp <- mrTypeOf t1 + varmap <- mrVars <$> get + cond_in_ctx <- mrProveEqH varmap tp t1 t2 + success <- withTermInCtx cond_in_ctx mrProvable + if success then return () else + throwError (TermsNotEq t1 t2) + +-- | The main workhorse for 'prProveEq'. Build a Boolean term expressing that +-- the third and fourth arguments, whose type is given by the second. This is +-- done in a continuation monad so that the output term can be in a context with +-- additional universal variables. +mrProveEqH :: Map MRVar MRVarInfo -> Term -> Term -> Term -> MRM TermInCtx + +{- +mrProveEqH _ _ t1 t2 + | trace ("mrProveEqH:\n" ++ showTerm t1 ++ "\n==\n" ++ showTerm t2) False = undefined +-} + +-- If t1 is an instantiated evar, substitute and recurse +mrProveEqH var_map tp (asEVarApp var_map -> Just (_, args, Just f)) t2 = + mrApplyAll f args >>= \t1' -> mrProveEqH var_map tp t1' t2 + +-- If t1 is an uninstantiated evar, instantiate it with t2 +mrProveEqH var_map _tp (asEVarApp var_map -> Just (evar, args, Nothing)) t2 = + do t2' <- mrSubstEVars t2 + success <- mrTrySetAppliedEVar evar args t2' + TermInCtx [] <$> liftSC1 scBool success + +-- If t2 is an instantiated evar, substitute and recurse +mrProveEqH var_map tp t1 (asEVarApp var_map -> Just (_, args, Just f)) = + mrApplyAll f args >>= \t2' -> mrProveEqH var_map tp t1 t2' + +-- If t2 is an uninstantiated evar, instantiate it with t1 +mrProveEqH var_map _tp t1 (asEVarApp var_map -> Just (evar, args, Nothing)) = + do t1' <- mrSubstEVars t1 + success <- mrTrySetAppliedEVar evar args t1' + TermInCtx [] <$> liftSC1 scBool success + +-- For the nat, bitvector, Boolean, and integer types, call mrProveEqSimple +mrProveEqH _ (asDataType -> Just (pn, [])) t1 t2 + | primName pn == "Prelude.Nat" = + mrProveEqSimple (liftSC2 scEqualNat) t1 t2 +mrProveEqH _ (asVectorType -> Just (n, asBoolType -> Just ())) t1 t2 = + -- FIXME: make a better solver for bitvector equalities + mrProveEqSimple (liftSC3 scBvEq n) t1 t2 +mrProveEqH _ (asBoolType -> Just _) t1 t2 = + mrProveEqSimple (liftSC2 scBoolEq) t1 t2 +mrProveEqH _ (asIntegerType -> Just _) t1 t2 = + mrProveEqSimple (liftSC2 scIntEq) t1 t2 + +-- For pair types, prove both the left and right projections are equal +mrProveEqH var_map (asPairType -> Just (tpL, tpR)) t1 t2 = + do t1L <- liftSC1 scPairLeft t1 + t2L <- liftSC1 scPairLeft t2 + t1R <- liftSC1 scPairRight t1 + t2R <- liftSC1 scPairRight t2 + condL <- mrProveEqH var_map tpL t1L t2L + condR <- mrProveEqH var_map tpR t1R t2R + andTermInCtx condL condR + +-- For non-bitvector vector types, prove all projections are equal by +-- quantifying over a universal index variable and proving equality at that +-- index +mrProveEqH _ (asBVVecType -> Just (n, len, tp)) t1 t2 = + liftSC0 scBoolType >>= \bool_tp -> + liftSC2 scVecType n bool_tp >>= \ix_tp -> + withUVarLift "eq_ix" (Type ix_tp) (n,(len,(tp,(t1,t2)))) $ + \ix' (n',(len',(tp',(t1',t2')))) -> + liftSC2 scGlobalApply "Prelude.is_bvult" [n', ix', len'] >>= \pf_tp -> + withUVarLift "eq_pf" (Type pf_tp) (n',(len',(tp',(ix',(t1',t2'))))) $ + \pf'' (n'',(len'',(tp'',(ix'',(t1'',t2''))))) -> + do t1_prj <- liftSC2 scGlobalApply "Prelude.atBVVec" [n'', len'', tp'', + t1'', ix'', pf''] + t2_prj <- liftSC2 scGlobalApply "Prelude.atBVVec" [n'', len'', tp'', + t2'', ix'', pf''] + var_map <- mrVars <$> get + extTermInCtx [("eq_ix",ix_tp),("eq_pf",pf_tp)] <$> + mrProveEqH var_map tp'' t1_prj t2_prj + +-- As a fallback, for types we can't handle, just check convertibility +mrProveEqH _ _ t1 t2 = + do success <- mrConvertible t1 t2 + TermInCtx [] <$> liftSC1 scBool success diff --git a/src/SAWScript/Prover/MRSolver/Solver.hs b/src/SAWScript/Prover/MRSolver/Solver.hs new file mode 100644 index 0000000000..2f55d31c02 --- /dev/null +++ b/src/SAWScript/Prover/MRSolver/Solver.hs @@ -0,0 +1,617 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} + +{- | +Module : SAWScript.Prover.MRSolver.Solver +Copyright : Galois, Inc. 2022 +License : BSD3 +Maintainer : westbrook@galois.com +Stability : experimental +Portability : non-portable (language extensions) + +This module implements a monadic-recursive solver, for proving that one monadic +term refines another. The algorithm works on the "monadic normal form" of +computations, which uses the following laws to simplify binds in computations, +where either is the sum elimination function defined in the SAW core prelude: + +returnM x >>= k = k x +errorM str >>= k = errorM +(m >>= k1) >>= k2 = m >>= \x -> k1 x >>= k2 +(existsM f) >>= k = existsM (\x -> f x >>= k) +(forallM f) >>= k = forallM (\x -> f x >>= k) +(orM m1 m2) >>= k = orM (m1 >>= k) (m2 >>= k) +(if b then m1 else m2) >>= k = if b then m1 >>= k else m2 >>1 k +(either f1 f2 e) >>= k = either (\x -> f1 x >= k) (\x -> f2 x >= k) e +(letrecM funs body) >>= k = letrecM funs (\F1 ... Fn -> body F1 ... Fn >>= k) + +The resulting computations of one of the following forms: + +returnM e | errorM str | existsM f | forallM f | orM m1 m2 | +if b then m1 else m2 | either f1 f2 e | F e1 ... en | F e1 ... en >>= k | +letrecM lrts B (\F1 ... Fn -> (f1, ..., fn)) (\F1 ... Fn -> m) + +The form F e1 ... en refers to a recursively-defined function or a function +variable that has been locally bound by a letrecM. Either way, monadic +normalization does not attempt to normalize these functions. + +The algorithm maintains a context of three sorts of variables: letrec-bound +variables, existential variables, and universal variables. Universal variables +are represented as free SAW core variables, while the other two forms of +variable are represented as SAW core 'ExtCns's terms, which are essentially +axioms that have been generated internally. These 'ExtCns's are Skolemized, +meaning that they take in as arguments all universal variables that were in +scope when they were created. The context also maintains a partial substitution +for the existential variables, as they become instantiated with values, and it +additionally remembers the bodies / unfoldings of the letrec-bound variables. + +The goal of the solver at any point is of the form C |- m1 |= m2, meaning that +we are trying to prove m1 refines m2 in context C. This proceed by cases: + +C |- returnM e1 |= returnM e2: prove C |- e1 = e2 + +C |- errorM str1 |= errorM str2: vacuously true + +C |- if b then m1' else m1'' |= m2: prove C,b=true |- m1' |= m2 and +C,b=false |- m1'' |= m2, skipping either case where C,b=X is unsatisfiable; + +C |- m1 |= if b then m2' else m2'': similar to the above + +C |- either T U (CompM V) f1 f2 e |= m: prove C,x:T,e=inl x |- f1 x |= m and +C,y:U,e=inl y |- f2 y |= m, again skippping any case with unsatisfiable context; + +C |- m |= either T U (CompM V) f1 f2 e: similar to previous + +C |- m |= forallM f: make a new universal variable x and recurse + +C |- existsM f |= m: make a new universal variable x and recurse (existential +elimination uses universal variables and vice-versa) + +C |- m |= existsM f: make a new existential variable x and recurse + +C |- forall f |= m: make a new existential variable x and recurse + +C |- m |= orM m1 m2: try to prove C |- m |= m1, and if that fails, backtrack and +prove C |- m |= m2 + +C |- orM m1 m2 |= m: prove both C |- m1 |= m and C |- m2 |= m + +C |- letrec (\F1 ... Fn -> (f1, ..., fn)) (\F1 ... Fn -> body) |= m: create +letrec-bound variables F1 through Fn in the context bound to their unfoldings f1 +through fn, respectively, and recurse on body |= m + +C |- m |= letrec (\F1 ... Fn -> (f1, ..., fn)) (\F1 ... Fn -> body): similar to +previous case + +C |- F e1 ... en >>= k |= F e1' ... en' >>= k': prove C |- ei = ei' for each i +and then prove k x |= k' x for new universal variable x + +C |- F e1 ... en >>= k |= F' e1' ... em' >>= k': + +* If we have an assumption that forall x1 ... xj, F a1 ... an |= F' a1' .. am', + prove ei = ai and ei' = ai' and then that C |- k x |= k' x for fresh uvar x + +* If we have an assumption that forall x1, ..., xn, F e1'' ... en'' |= m' for + some ei'' and m', match the ei'' against the ei by instantiating the xj with + fresh evars, and if this succeeds then recursively prove C |- m' >>= k |= RHS + +(We don't do this one right now) +* If we have an assumption that forall x1', ..., xn', m |= F e1'' ... en'' for + some ei'' and m', match the ei'' against the ei by instantiating the xj with + fresh evars, and if this succeeds then recursively prove C |- LHS |= m' >>= k' + +* If either side is a definition whose unfolding does not contain letrecM, fixM, + or any related operations, unfold it + +* If F and F' have the same return type, add an assumption forall uvars in scope + that F e1 ... en |= F' e1' ... em' and unfold both sides, recursively proving + that F_body e1 ... en |= F_body' e1' ... em'. Then also prove k x |= k' x for + fresh uvar x. + +* Otherwise we don't know to "split" one of the sides into a bind whose + components relate to the two components on the other side, so just fail +-} + +module SAWScript.Prover.MRSolver.Solver where + +import Control.Monad.Reader +import Control.Monad.Except +import qualified Data.Map as Map + +import Verifier.SAW.Term.Functor +import Verifier.SAW.SharedTerm +import Verifier.SAW.Recognizer + +import SAWScript.Prover.MRSolver.Term +import SAWScript.Prover.MRSolver.Monad +import SAWScript.Prover.MRSolver.SMT + + +---------------------------------------------------------------------- +-- * Normalizing and Matching on Terms +---------------------------------------------------------------------- + +-- | Pattern-match on a @LetRecTypes@ list in normal form and return a list of +-- the types it specifies, each in normal form and with uvars abstracted out +asLRTList :: Term -> MRM [Term] +asLRTList (asCtor -> Just (primName -> "Prelude.LRT_Nil", [])) = + return [] +asLRTList (asCtor -> Just (primName -> "Prelude.LRT_Cons", [lrt, lrts])) = + do tp <- liftSC2 scGlobalApply "Prelude.lrtToType" [lrt] + tp_norm_closed <- liftSC1 scWhnf tp >>= piUVarsM + (tp_norm_closed :) <$> asLRTList lrts +asLRTList t = throwError (MalformedLetRecTypes t) + +-- | Match a right-nested series of pairs. This is similar to 'asTupleValue' +-- except that it expects a unit value to always be at the end. +asNestedPairs :: Recognizer Term [Term] +asNestedPairs (asPairValue -> Just (x, asNestedPairs -> Just xs)) = Just (x:xs) +asNestedPairs (asFTermF -> Just UnitValue) = Just [] +asNestedPairs _ = Nothing + +-- | Syntactically project then @i@th element of the body of a lambda. That is, +-- assuming the input 'Term' has the form +-- +-- > \ (x1:T1) ... (xn:Tn) -> (e1, (e2, ... (en, ()))) +-- +-- return the bindings @x1:T1,...,xn:Tn@ and @ei@ +synProjFunBody :: Int -> Term -> Maybe ([(LocalName, Term)], Term) +synProjFunBody i (asLambdaList -> (vars, asTupleValue -> Just es)) = + -- NOTE: we are doing 1-based indexing instead of 0-based, thus the -1 + Just $ (vars, es !! (i-1)) +synProjFunBody _ _ = Nothing + +-- | Bind fresh function variables for a @letRecM@ or @multiFixM@ with the given +-- @LetRecTypes@ and definitions for the function bodies as a lambda +mrFreshLetRecVars :: Term -> Term -> MRM [Term] +mrFreshLetRecVars lrts defs_f = + do + -- First, make fresh function constants for all the bound functions, using + -- the names bound by defs_f and just "F" if those run out + let fun_var_names = + map fst (fst $ asLambdaList defs_f) ++ repeat "F" + fun_tps <- asLRTList lrts + funs <- zipWithM mrFreshVar fun_var_names fun_tps + fun_tms <- mapM mrVarTerm funs + + -- Next, apply the definition function defs_f to our function vars, yielding + -- the definitions of the individual letrec-bound functions in terms of the + -- new function constants + defs_tm <- mrApplyAll defs_f fun_tms + defs <- case asNestedPairs defs_tm of + Just defs -> return defs + Nothing -> throwError (MalformedDefsFun defs_f) + + -- Remember the body associated with each fresh function constant + zipWithM_ (\f body -> + lambdaUVarsM body >>= \cl_body -> + mrSetVarInfo f (FunVarInfo cl_body)) funs defs + + -- Finally, return the terms for the fresh function variables + return fun_tms + + +-- | Normalize a 'Term' of monadic type to monadic normal form +normCompTerm :: Term -> MRM NormComp +normCompTerm = normComp . CompTerm + +-- | Normalize a computation to monadic normal form, assuming any 'Term's it +-- contains have already been normalized with respect to beta and projections +-- (but constants need not be unfolded) +normComp :: Comp -> MRM NormComp +normComp (CompReturn t) = return $ ReturnM t +normComp (CompBind m f) = + do norm <- normComp m + normBind norm f +normComp (CompTerm t) = + withFailureCtx (FailCtxMNF t) $ + case asApplyAll t of + (isGlobalDef "Prelude.returnM" -> Just (), [_, x]) -> + return $ ReturnM x + (isGlobalDef "Prelude.bindM" -> Just (), [_, _, m, f]) -> + do norm <- normComp (CompTerm m) + normBind norm (CompFunTerm f) + (isGlobalDef "Prelude.errorM" -> Just (), [_, str]) -> + return (ErrorM str) + (isGlobalDef "Prelude.ite" -> Just (), [_, cond, then_tm, else_tm]) -> + return $ Ite cond (CompTerm then_tm) (CompTerm else_tm) + (isGlobalDef "Prelude.either" -> Just (), [_, _, _, f, g, eith]) -> + return $ Either (CompFunTerm f) (CompFunTerm g) eith + (isGlobalDef "Prelude.maybe" -> Just (), [tp, _, m, f, mayb]) -> + return $ MaybeElim (Type tp) (CompTerm m) (CompFunTerm f) mayb + (isGlobalDef "Prelude.orM" -> Just (), [_, m1, m2]) -> + return $ OrM (CompTerm m1) (CompTerm m2) + (isGlobalDef "Prelude.existsM" -> Just (), [tp, _, body_tm]) -> + return $ ExistsM (Type tp) (CompFunTerm body_tm) + (isGlobalDef "Prelude.forallM" -> Just (), [tp, _, body_tm]) -> + return $ ForallM (Type tp) (CompFunTerm body_tm) + (isGlobalDef "Prelude.letRecM" -> Just (), [lrts, _, defs_f, body_f]) -> + do + -- Bind fresh function vars for the letrec-bound functions + fun_tms <- mrFreshLetRecVars lrts defs_f + -- Apply the body function to our function vars and recursively + -- normalize the resulting computation + body_tm <- mrApplyAll body_f fun_tms + normComp (CompTerm body_tm) + + -- Only unfold constants that are not recursive functions, i.e., whose + -- bodies do not contain letrecs + {- FIXME: this should be handled by mrRefines; we want it to be handled there + so that we use refinement assumptions before unfolding constants, to give + the user control over refinement proofs + ((asConstant -> Just (_, body)), args) + | not (containsLetRecM body) -> + mrApplyAll body args >>= normCompTerm + -} + + -- Recognize (multiFixM lrts (\ f1 ... fn -> (body1, ..., bodyn))).i args + (asTupleSelector -> + Just (asApplyAll -> (isGlobalDef "Prelude.multiFixM" -> Just (), + [lrts, defs_f]), + i), args) + -- Extract out the function \f1 ... fn -> bodyi + | Just (vars, body_i) <- synProjFunBody i defs_f -> + do + -- Bind fresh function variables for the functions f1 ... fn + fun_tms <- mrFreshLetRecVars lrts defs_f + -- Re-abstract the body + body_f <- liftSC2 scLambdaList vars body_i + -- Apply body_f to f1 ... fn and the top-level arguments + body_tm <- mrApplyAll body_f (fun_tms ++ args) + normComp (CompTerm body_tm) + + + -- For an ExtCns, we have to check what sort of variable it is + -- FIXME: substitute for evars if they have been instantiated + ((asExtCns -> Just ec), args) -> + do fun_name <- extCnsToFunName ec + return $ FunBind fun_name args CompFunReturn + + ((asGlobalFunName -> Just f), args) -> + return $ FunBind f args CompFunReturn + + _ -> throwError (MalformedComp t) + + +-- | Bind a computation in whnf with a function, and normalize +normBind :: NormComp -> CompFun -> MRM NormComp +normBind (ReturnM t) k = applyNormCompFun k t +normBind (ErrorM msg) _ = return (ErrorM msg) +normBind (Ite cond comp1 comp2) k = + return $ Ite cond (CompBind comp1 k) (CompBind comp2 k) +normBind (Either f g t) k = + return $ Either (compFunComp f k) (compFunComp g k) t +normBind (MaybeElim tp m f t) k = + return $ MaybeElim tp (CompBind m k) (compFunComp f k) t +normBind (OrM comp1 comp2) k = + return $ OrM (CompBind comp1 k) (CompBind comp2 k) +normBind (ExistsM tp f) k = return $ ExistsM tp (compFunComp f k) +normBind (ForallM tp f) k = return $ ForallM tp (compFunComp f k) +normBind (FunBind f args k1) k2 = + return $ FunBind f args (compFunComp k1 k2) + +-- | Bind a 'Term' for a computation with a function and normalize +normBindTerm :: Term -> CompFun -> MRM NormComp +normBindTerm t f = normCompTerm t >>= \m -> normBind m f + +-- | Apply a computation function to a term argument to get a computation +applyCompFun :: CompFun -> Term -> MRM Comp +applyCompFun (CompFunComp f g) t = + -- (f >=> g) t == f t >>= g + do comp <- applyCompFun f t + return $ CompBind comp g +applyCompFun CompFunReturn t = + return $ CompReturn t +applyCompFun (CompFunTerm f) t = CompTerm <$> mrApplyAll f [t] + +-- | Apply a 'CompFun' to a term and normalize the resulting computation +applyNormCompFun :: CompFun -> Term -> MRM NormComp +applyNormCompFun f arg = applyCompFun f arg >>= normComp + +-- | Apply a 'Comp + +{- FIXME: do these go away? +-- | Lookup the definition of a function or throw a 'CannotLookupFunDef' if this is +-- not allowed, either because it is a global function we are treating as opaque +-- or because it is a locally-bound function variable +mrLookupFunDef :: FunName -> MRM Term +mrLookupFunDef f@(GlobalName _) = throwError (CannotLookupFunDef f) +mrLookupFunDef f@(LocalName var) = + mrVarInfo var >>= \case + Just (FunVarInfo body) -> return body + Just _ -> throwError (CannotLookupFunDef f) + Nothing -> error "mrLookupFunDef: unknown variable!" + +-- | Unfold a call to function @f@ in term @f args >>= g@ +mrUnfoldFunBind :: FunName -> [Term] -> Mark -> CompFun -> MRM Comp +mrUnfoldFunBind f _ mark _ | inMark f mark = throwError (RecursiveUnfold f) +mrUnfoldFunBind f args mark g = + do f_def <- mrLookupFunDef f + CompBind <$> + (CompMark <$> (CompTerm <$> liftSC2 scApplyAll f_def args) + <*> (return $ singleMark f `mappend` mark)) + <*> return g +-} + +{- +FIXME HERE NOW: maybe each FunName should stipulate whether it is recursive or +not, so that mrRefines can unfold the non-recursive ones early but wait on +handling the recursive ones +-} + + +---------------------------------------------------------------------- +-- * Mr Solver Himself (He Identifies as Male) +---------------------------------------------------------------------- + +-- | An object that can be converted to a normalized computation +class ToNormComp a where + toNormComp :: a -> MRM NormComp + +instance ToNormComp NormComp where + toNormComp = return +instance ToNormComp Comp where + toNormComp = normComp +instance ToNormComp Term where + toNormComp = normComp . CompTerm + +-- | Prove that the left-hand computation refines the right-hand one. See the +-- rules described at the beginning of this module. +mrRefines :: (ToNormComp a, ToNormComp b) => a -> b -> MRM () +mrRefines t1 t2 = + do m1 <- toNormComp t1 + m2 <- toNormComp t2 + mrDebugPPPrefixSep 1 "mrRefines" m1 "|=" m2 + withFailureCtx (FailCtxRefines m1 m2) $ mrRefines' m1 m2 + +-- | The main implementation of 'mrRefines' +mrRefines' :: NormComp -> NormComp -> MRM () +mrRefines' (ReturnM e1) (ReturnM e2) = mrProveEq e1 e2 +mrRefines' (ErrorM _) (ErrorM _) = return () +mrRefines' (ReturnM e) (ErrorM _) = throwError (ReturnNotError e) +mrRefines' (ErrorM _) (ReturnM e) = throwError (ReturnNotError e) +mrRefines' (MaybeElim (Type (asEq -> Just (tp,e1,e2))) m1 f1 _) m2 = + do cond <- mrEq' tp e1 e2 + not_cond <- liftSC1 scNot cond + cond_pf <- + liftSC1 scEqTrue cond >>= piUVarsM >>= mrFreshVar "pf" >>= mrVarTerm + m1' <- applyNormCompFun f1 cond_pf + cond_holds <- mrProvable cond + if cond_holds then mrRefines m1' m2 else + withAssumption cond (mrRefines m1' m2) >> + withAssumption not_cond (mrRefines m1 m2) +mrRefines' m1 (MaybeElim (Type (asEq -> Just (tp,e1,e2))) m2 f2 _) = + do cond <- mrEq' tp e1 e2 + not_cond <- liftSC1 scNot cond + cond_pf <- + liftSC1 scEqTrue cond >>= piUVarsM >>= mrFreshVar "pf" >>= mrVarTerm + m2' <- applyNormCompFun f2 cond_pf + cond_holds <- mrProvable cond + if cond_holds then mrRefines m1 m2' else + withAssumption cond (mrRefines m1 m2') >> + withAssumption not_cond (mrRefines m1 m2) +mrRefines' (Ite cond1 m1 m1') m2_all@(Ite cond2 m2 m2') = + liftSC1 scNot cond1 >>= \not_cond1 -> + (mrEq cond1 cond2 >>= mrProvable) >>= \case + True -> + -- If we can prove cond1 == cond2, then we just need to prove m1 |= m2 and + -- m1' |= m2'; further, we need only add assumptions about cond1, because it + -- is provably equal to cond2 + withAssumption cond1 (mrRefines m1 m2) >> + withAssumption not_cond1 (mrRefines m1' m2') + False -> + -- Otherwise, prove each branch of the LHS refines the whole RHS + withAssumption cond1 (mrRefines m1 m2_all) >> + withAssumption not_cond1 (mrRefines m1' m2_all) +mrRefines' (Ite cond1 m1 m1') m2 = + do not_cond1 <- liftSC1 scNot cond1 + withAssumption cond1 (mrRefines m1 m2) + withAssumption not_cond1 (mrRefines m1' m2) +mrRefines' m1 (Ite cond2 m2 m2') = + do not_cond2 <- liftSC1 scNot cond2 + withAssumption cond2 (mrRefines m1 m2) + withAssumption not_cond2 (mrRefines m1 m2') +-- FIXME: handle sum elimination +-- mrRefines (Either f1 g1 e1) (Either f2 g2 e2) = +mrRefines' m1 (ForallM tp f2) = + let nm = maybe "x" id (compFunVarName f2) in + withUVarLift nm tp (m1,f2) $ \x (m1',f2') -> + applyNormCompFun f2' x >>= \m2' -> + mrRefines m1' m2' +mrRefines' (ExistsM tp f1) m2 = + let nm = maybe "x" id (compFunVarName f1) in + withUVarLift nm tp (f1,m2) $ \x (f1',m2') -> + applyNormCompFun f1' x >>= \m1' -> + mrRefines m1' m2' +mrRefines' m1 (OrM m2 m2') = + mrOr (mrRefines m1 m2) (mrRefines m1 m2') +mrRefines' (OrM m1 m1') m2 = + mrRefines m1 m2 >> mrRefines m1' m2 + +-- FIXME: the following cases don't work unless we either allow evars to be set +-- to NormComps or we can turn NormComps back into terms +mrRefines' m1@(FunBind (EVarFunName _) _ _) m2 = + throwError (CompsDoNotRefine m1 m2) +mrRefines' m1 m2@(FunBind (EVarFunName _) _ _) = + throwError (CompsDoNotRefine m1 m2) +{- +mrRefines' (FunBind (EVarFunName evar) args CompFunReturn) m2 = + mrGetEVar evar >>= \case + Just f -> + (mrApplyAll f args >>= normCompTerm) >>= \m1' -> + mrRefines m1' m2 + Nothing -> mrTrySetAppliedEVar evar args m2 +-} + +mrRefines' (FunBind (LetRecName f) args1 k1) (FunBind (LetRecName f') args2 k2) + | f == f' && length args1 == length args2 = + zipWithM_ mrProveEq args1 args2 >> + mrRefinesFun k1 k2 + +mrRefines' m1@(FunBind f1 args1 k1) m2@(FunBind f2 args2 k2) = + mrFunOutType f1 args1 >>= \tp1 -> + mrFunOutType f2 args2 >>= \tp2 -> + mrConvertible tp1 tp2 >>= \tps_eq -> + mrFunBodyRecInfo f1 args1 >>= \maybe_f1_body -> + mrFunBodyRecInfo f2 args2 >>= \maybe_f2_body -> + mrGetFunAssump f1 >>= \case + + -- If we have an assumption that f1 args' refines some rhs, then prove that + -- args1 = args' and then that rhs refines m2 + Just fassump -> + do (assump_args, assump_rhs) <- instantiateFunAssump fassump + zipWithM_ mrProveEq assump_args args1 + m1' <- normBind assump_rhs k1 + mrRefines m1' m2 + + -- If f1 unfolds and is not recursive in itself, unfold it and recurse + _ | Just (f1_body, False) <- maybe_f1_body -> + normBindTerm f1_body k1 >>= \m1' -> mrRefines m1' m2 + + -- If f2 unfolds and is not recursive in itself, unfold it and recurse + _ | Just (f2_body, False) <- maybe_f2_body -> + normBindTerm f2_body k2 >>= \m2' -> mrRefines m1 m2' + + -- If we do not already have an assumption that f1 refines some specification, + -- and both f1 and f2 are recursive but have the same return type, then try to + -- coinductively prove that f1 args1 |= f2 args2 under the assumption that f1 + -- args1 |= f2 args2, and then try to prove that k1 |= k2 + Nothing + | tps_eq + , Just (f1_body, _) <- maybe_f1_body + , Just (f2_body, _) <- maybe_f2_body -> + do withFunAssump f1 args1 (FunBind f2 args2 CompFunReturn) $ + mrRefines f1_body f2_body + mrRefinesFun k1 k2 + + -- If we cannot line up f1 and f2, then making progress here would require us + -- to somehow split either m1 or m2 into some bind m' >>= k' such that m' is + -- related to the function call on the other side and k' is related to the + -- continuation on the other side, but we don't know how to do that, so give + -- up + Nothing -> + throwError (CompsDoNotRefine m1 m2) + +{- FIXME: handle FunBind on just one side +mrRefines' m1@(FunBind f@(GlobalName _) args k1) m2 = + mrGetFunAssump f >>= \case + Just fassump -> + -- If we have an assumption that f args' refines some rhs, then prove that + -- args = args' and then that rhs refines m2 + do (assump_args, assump_rhs) <- instantiateFunAssump fassump + zipWithM_ mrProveEq assump_args args + m1' <- normBind assump_rhs k1 + mrRefines m1' m2 + Nothing -> + -- We don't want to do inter-procedural proofs, so if we don't know anything + -- about f already then give up + throwError (CompsDoNotRefine m1 m2) +-} + + +mrRefines' m1@(FunBind f1 args1 k1) m2 = + mrGetFunAssump f1 >>= \case + + -- If we have an assumption that f1 args' refines some rhs, then prove that + -- args1 = args' and then that rhs refines m2 + Just fassump -> + do (assump_args, assump_rhs) <- instantiateFunAssump fassump + zipWithM_ mrProveEq assump_args args1 + m1' <- normBind assump_rhs k1 + mrRefines m1' m2 + + -- Otherwise, see if we can unfold f1 + Nothing -> + mrFunBodyRecInfo f1 args1 >>= \case + + -- If f1 unfolds and is not recursive in itself, unfold it and recurse + Just (f1_body, False) -> + normBindTerm f1_body k1 >>= \m1' -> mrRefines m1' m2 + + -- Otherwise we would have to somehow split m2 into some computation of the + -- form m2' >>= k2 where f1 args1 |= m2' and k1 |= k2, but we don't know how + -- to do this splitting, so give up + _ -> + throwError (CompsDoNotRefine m1 m2) + + +mrRefines' m1 m2@(FunBind f2 args2 k2) = + mrFunBodyRecInfo f2 args2 >>= \case + + -- If f2 unfolds and is not recursive in itself, unfold it and recurse + Just (f2_body, False) -> + normBindTerm f2_body k2 >>= \m2' -> mrRefines m1 m2' + + -- If f2 unfolds but is recursive, and k2 is the trivial continuation, meaning + -- m2 is just f2 args2, use the law of coinduction to prove m1 |= f2 args2 by + -- proving m1 |= f2_body under the assumption that m1 |= f2 args2 + {- FIXME: implement something like this + Just (f2_body, True) + | CompFunReturn <- k2 -> + withFunAssumpR m1 f2 args2 $ + -} + + -- Otherwise we would have to somehow split m1 into some computation of the + -- form m1' >>= k1 where m1' |= f2 args2 and k1 |= k2, but we don't know how + -- to do this splitting, so give up + _ -> + throwError (CompsDoNotRefine m1 m2) + + +-- NOTE: the rules that introduce existential variables need to go last, so that +-- they can quantify over as many universals as possible +mrRefines' m1 (ExistsM tp f2) = + do let nm = maybe "x" id (compFunVarName f2) + evar <- mrFreshEVar nm tp + m2' <- applyNormCompFun f2 evar + mrRefines m1 m2' +mrRefines' (ForallM tp f1) m2 = + do let nm = maybe "x" id (compFunVarName f1) + evar <- mrFreshEVar nm tp + m1' <- applyNormCompFun f1 evar + mrRefines m1' m2 + +-- If none of the above cases match, then fail +mrRefines' m1 m2 = throwError (CompsDoNotRefine m1 m2) + + +-- | Prove that one function refines another for all inputs +mrRefinesFun :: CompFun -> CompFun -> MRM () +mrRefinesFun CompFunReturn CompFunReturn = return () +mrRefinesFun f1 f2 + | Just nm <- compFunVarName f1 `mplus` compFunVarName f2 + , Just tp <- compFunInputType f1 `mplus` compFunInputType f2 = + withUVarLift nm tp (f1,f2) $ \x (f1', f2') -> + do m1' <- applyNormCompFun f1' x + m2' <- applyNormCompFun f2' x + mrRefines m1' m2' +mrRefinesFun _ _ = error "mrRefinesFun: unreachable!" + + +---------------------------------------------------------------------- +-- * External Entrypoints +---------------------------------------------------------------------- + +-- | Test two monadic, recursive terms for equivalence +askMRSolver :: + SharedContext -> + Int {- ^ The debug level -} -> + Maybe Integer {- ^ Timeout in milliseconds for each SMT call -} -> + Term -> Term -> IO (Maybe MRFailure) + +askMRSolver sc dlvl timeout t1 t2 = + do tp1 <- scTypeOf sc t1 >>= scWhnf sc + tp2 <- scTypeOf sc t2 >>= scWhnf sc + init_st <- mkMRState sc Map.empty timeout dlvl + case asPiList tp1 of + (uvar_ctx, asCompM -> Just _) -> + fmap (either Just (const Nothing)) $ runMRM init_st $ + withUVars uvar_ctx $ \vars -> + do tps_are_eq <- mrConvertible tp1 tp2 + if tps_are_eq then return () else + throwError (TypesNotEq (Type tp1) (Type tp2)) + mrDebugPPPrefixSep 1 "mr_solver" t1 "|=" t2 + m1 <- mrApplyAll t1 vars >>= normCompTerm + m2 <- mrApplyAll t2 vars >>= normCompTerm + mrRefines m1 m2 + _ -> return $ Just $ NotCompFunType tp1 diff --git a/src/SAWScript/Prover/MRSolver/Term.hs b/src/SAWScript/Prover/MRSolver/Term.hs new file mode 100644 index 0000000000..4c8dd86991 --- /dev/null +++ b/src/SAWScript/Prover/MRSolver/Term.hs @@ -0,0 +1,341 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} + +{- | +Module : SAWScript.Prover.MRSolver.Term +Copyright : Galois, Inc. 2022 +License : BSD3 +Maintainer : westbrook@galois.com +Stability : experimental +Portability : non-portable (language extensions) + +This module defines the representation of terms used in Mr. Solver and various +utility functions for operating on terms and term representations. The main +datatype is 'NormComp', which represents the result of one step of monadic +normalization - see @Solver.hs@ for the description of this normalization. +-} + +module SAWScript.Prover.MRSolver.Term where + +import Data.IORef +import Control.Monad.Reader +import qualified Data.IntMap as IntMap + +import Prettyprinter + +import Verifier.SAW.Term.Functor +import Verifier.SAW.Term.CtxTerm (MonadTerm(..)) +import Verifier.SAW.Term.Pretty +import Verifier.SAW.SharedTerm +import Verifier.SAW.Recognizer +import Verifier.SAW.Cryptol.Monadify + + +---------------------------------------------------------------------- +-- * MR Solver Term Representation +---------------------------------------------------------------------- + +-- | A variable used by the MR solver +newtype MRVar = MRVar { unMRVar :: ExtCns Term } deriving (Eq, Show, Ord) + +-- | Get the type of an 'MRVar' +mrVarType :: MRVar -> Term +mrVarType = ecType . unMRVar + +-- | A tuple or record projection of a 'Term' +data TermProj = TermProjLeft | TermProjRight | TermProjRecord FieldName + deriving (Eq, Ord, Show) + +-- | Recognize a 'Term' as 0 or more projections +asProjAll :: Term -> (Term, [TermProj]) +asProjAll (asRecordSelector -> Just ((asProjAll -> (t, projs)), fld)) = + (t, TermProjRecord fld:projs) +asProjAll (asPairSelector -> Just ((asProjAll -> (t, projs)), isRight)) + | isRight = (t, TermProjRight:projs) + | not isRight = (t, TermProjLeft:projs) +asProjAll t = (t, []) + +-- | Names of functions to be used in computations, which are either names bound +-- by letrec to for recursive calls to fixed-points, existential variables, or +-- (possibly projections of) of global named constants +data FunName + = LetRecName MRVar | EVarFunName MRVar | GlobalName GlobalDef [TermProj] + deriving (Eq, Ord, Show) + +-- | Recognize a 'Term' as (possibly a projection of) a global name +asTypedGlobalProj :: Recognizer Term (GlobalDef, [TermProj]) +asTypedGlobalProj (asProjAll -> ((asTypedGlobalDef -> Just glob), projs)) = + Just (glob, projs) +asTypedGlobalProj _ = Nothing + +-- | Recognize a 'Term' as (possibly a projection of) a global name +asGlobalFunName :: Recognizer Term FunName +asGlobalFunName (asTypedGlobalProj -> Just (glob, projs)) = + Just $ GlobalName glob projs +asGlobalFunName _ = Nothing + +-- | A term specifically known to be of type @sort i@ for some @i@ +newtype Type = Type Term deriving Show + +-- | A Haskell representation of a @CompM@ in "monadic normal form" +data NormComp + = ReturnM Term -- ^ A term @returnM a x@ + | ErrorM Term -- ^ A term @errorM a str@ + | Ite Term Comp Comp -- ^ If-then-else computation + | Either CompFun CompFun Term -- ^ A sum elimination + | MaybeElim Type Comp CompFun Term -- ^ A maybe elimination + | OrM Comp Comp -- ^ an @orM@ computation + | ExistsM Type CompFun -- ^ an @existsM@ computation + | ForallM Type CompFun -- ^ a @forallM@ computation + | FunBind FunName [Term] CompFun + -- ^ Bind a monadic function with @N@ arguments in an @a -> CompM b@ term + deriving Show + +-- | A computation function of type @a -> CompM b@ for some @a@ and @b@ +data CompFun + -- | An arbitrary term + = CompFunTerm Term + -- | A special case for the term @\ (x:a) -> returnM a x@ + | CompFunReturn + -- | The monadic composition @f >=> g@ + | CompFunComp CompFun CompFun + deriving Show + +-- | Compose two 'CompFun's, simplifying if one is a 'CompFunReturn' +compFunComp :: CompFun -> CompFun -> CompFun +compFunComp CompFunReturn f = f +compFunComp f CompFunReturn = f +compFunComp f g = CompFunComp f g + +-- | If a 'CompFun' contains an explicit lambda-abstraction, then return the +-- textual name bound by that lambda +compFunVarName :: CompFun -> Maybe LocalName +compFunVarName (CompFunTerm (asLambda -> Just (nm, _, _))) = Just nm +compFunVarName (CompFunComp f _) = compFunVarName f +compFunVarName _ = Nothing + +-- | If a 'CompFun' contains an explicit lambda-abstraction, then return the +-- input type for it +compFunInputType :: CompFun -> Maybe Type +compFunInputType (CompFunTerm (asLambda -> Just (_, tp, _))) = Just $ Type tp +compFunInputType (CompFunComp f _) = compFunInputType f +compFunInputType _ = Nothing + +-- | A computation of type @CompM a@ for some @a@ +data Comp = CompTerm Term | CompBind Comp CompFun | CompReturn Term + deriving Show + +-- | Match a type as being of the form @CompM a@ for some @a@ +asCompM :: Term -> Maybe Term +asCompM (asApp -> Just (isGlobalDef "Prelude.CompM" -> Just (), tp)) = + return tp +asCompM _ = fail "not a CompM type!" + +-- | Test if a type normalizes to a monadic function type of 0 or more arguments +isCompFunType :: SharedContext -> Term -> IO Bool +isCompFunType sc t = scWhnf sc t >>= \case + (asPiList -> (_, asCompM -> Just _)) -> return True + _ -> return False + + +---------------------------------------------------------------------- +-- * Utility Functions for Transforming 'Term's +---------------------------------------------------------------------- + +-- | Transform the immediate subterms of a term using the supplied function +traverseSubterms :: MonadTerm m => (Term -> m Term) -> Term -> m Term +traverseSubterms f (unwrapTermF -> tf) = traverse f tf >>= mkTermF + +-- | Build a recursive memoized function for tranforming 'Term's. Take in a +-- function @f@ that intuitively performs one step of the transformation and +-- allow it to recursively call the memoized function being defined by passing +-- it as the first argument to @f@. +memoFixTermFun :: MonadIO m => ((Term -> m a) -> Term -> m a) -> Term -> m a +memoFixTermFun f term_top = + do table_ref <- liftIO $ newIORef IntMap.empty + let go t@(STApp { stAppIndex = ix }) = + liftIO (readIORef table_ref) >>= \table -> + case IntMap.lookup ix table of + Just ret -> return ret + Nothing -> + do ret <- f go t + liftIO $ modifyIORef' table_ref (IntMap.insert ix ret) + return ret + go t = f go t + go term_top + + +---------------------------------------------------------------------- +-- * Lifting MR Solver Terms +---------------------------------------------------------------------- + +-- | A term-like object is one that supports lifting and substitution +class TermLike a where + liftTermLike :: MonadTerm m => DeBruijnIndex -> DeBruijnIndex -> a -> m a + substTermLike :: MonadTerm m => DeBruijnIndex -> [Term] -> a -> m a + +instance (TermLike a, TermLike b) => TermLike (a,b) where + liftTermLike n i (a,b) = (,) <$> liftTermLike n i a <*> liftTermLike n i b + substTermLike n s (a,b) = (,) <$> substTermLike n s a <*> substTermLike n s b + +instance TermLike a => TermLike [a] where + liftTermLike n i l = mapM (liftTermLike n i) l + substTermLike n s l = mapM (substTermLike n s) l + +instance TermLike Term where + liftTermLike = liftTerm + substTermLike = substTerm + +instance TermLike Type where + liftTermLike n i (Type tp) = Type <$> liftTerm n i tp + substTermLike n s (Type tp) = Type <$> substTerm n s tp + +instance TermLike NormComp where + liftTermLike n i (ReturnM t) = ReturnM <$> liftTermLike n i t + liftTermLike n i (ErrorM str) = ErrorM <$> liftTermLike n i str + liftTermLike n i (Ite cond t1 t2) = + Ite <$> liftTermLike n i cond <*> liftTermLike n i t1 <*> liftTermLike n i t2 + liftTermLike n i (Either f g eith) = + Either <$> liftTermLike n i f <*> liftTermLike n i g <*> liftTermLike n i eith + liftTermLike n i (MaybeElim tp m f mayb) = + MaybeElim <$> liftTermLike n i tp <*> liftTermLike n i m + <*> liftTermLike n i f <*> liftTermLike n i mayb + liftTermLike n i (OrM t1 t2) = + OrM <$> liftTermLike n i t1 <*> liftTermLike n i t2 + liftTermLike n i (ExistsM tp f) = + ExistsM <$> liftTermLike n i tp <*> liftTermLike n i f + liftTermLike n i (ForallM tp f) = + ForallM <$> liftTermLike n i tp <*> liftTermLike n i f + liftTermLike n i (FunBind nm args f) = + FunBind nm <$> mapM (liftTermLike n i) args <*> liftTermLike n i f + + substTermLike n s (ReturnM t) = ReturnM <$> substTermLike n s t + substTermLike n s (ErrorM str) = ErrorM <$> substTermLike n s str + substTermLike n s (Ite cond t1 t2) = + Ite <$> substTermLike n s cond <*> substTermLike n s t1 + <*> substTermLike n s t2 + substTermLike n s (Either f g eith) = + Either <$> substTermLike n s f <*> substTermLike n s g + <*> substTermLike n s eith + substTermLike n s (MaybeElim tp m f mayb) = + MaybeElim <$> substTermLike n s tp <*> substTermLike n s m + <*> substTermLike n s f <*> substTermLike n s mayb + substTermLike n s (OrM t1 t2) = + OrM <$> substTermLike n s t1 <*> substTermLike n s t2 + substTermLike n s (ExistsM tp f) = + ExistsM <$> substTermLike n s tp <*> substTermLike n s f + substTermLike n s (ForallM tp f) = + ForallM <$> substTermLike n s tp <*> substTermLike n s f + substTermLike n s (FunBind nm args f) = + FunBind nm <$> mapM (substTermLike n s) args <*> substTermLike n s f + +instance TermLike CompFun where + liftTermLike n i (CompFunTerm t) = CompFunTerm <$> liftTermLike n i t + liftTermLike _ _ CompFunReturn = return CompFunReturn + liftTermLike n i (CompFunComp f g) = + CompFunComp <$> liftTermLike n i f <*> liftTermLike n i g + + substTermLike n s (CompFunTerm t) = CompFunTerm <$> substTermLike n s t + substTermLike _ _ CompFunReturn = return CompFunReturn + substTermLike n s (CompFunComp f g) = + CompFunComp <$> substTermLike n s f <*> substTermLike n s g + +instance TermLike Comp where + liftTermLike n i (CompTerm t) = CompTerm <$> liftTermLike n i t + liftTermLike n i (CompBind m f) = + CompBind <$> liftTermLike n i m <*> liftTermLike n i f + liftTermLike n i (CompReturn t) = CompReturn <$> liftTermLike n i t + substTermLike n s (CompTerm t) = CompTerm <$> substTermLike n s t + substTermLike n s (CompBind m f) = + CompBind <$> substTermLike n s m <*> substTermLike n s f + substTermLike n s (CompReturn t) = CompReturn <$> substTermLike n s t + + +---------------------------------------------------------------------- +-- * Pretty-Printing MR Solver Terms +---------------------------------------------------------------------- + +-- | The monad for pretty-printing in a context of SAW core variables +type PPInCtxM = Reader [LocalName] + +-- | Pretty-print an object in a SAW core context and render to a 'String' +showInCtx :: PrettyInCtx a => [LocalName] -> a -> String +showInCtx ctx a = + renderSawDoc defaultPPOpts $ runReader (prettyInCtx a) ctx + +-- | A generic function for pretty-printing an object in a SAW core context of +-- locally-bound names +class PrettyInCtx a where + prettyInCtx :: a -> PPInCtxM SawDoc + +instance PrettyInCtx Term where + prettyInCtx t = flip (ppTermInCtx defaultPPOpts) t <$> ask + +-- | Combine a list of pretty-printed documents that represent an application +prettyAppList :: [PPInCtxM SawDoc] -> PPInCtxM SawDoc +prettyAppList = fmap (group . hang 2 . vsep) . sequence + +instance PrettyInCtx Type where + prettyInCtx (Type t) = prettyInCtx t + +instance PrettyInCtx MRVar where + prettyInCtx (MRVar ec) = return $ ppName $ ecName ec + +instance PrettyInCtx TermProj where + prettyInCtx TermProjLeft = return (pretty '.' <> "1") + prettyInCtx TermProjRight = return (pretty '.' <> "2") + prettyInCtx (TermProjRecord fld) = return (pretty '.' <> pretty fld) + +instance PrettyInCtx FunName where + prettyInCtx (LetRecName var) = prettyInCtx var + prettyInCtx (EVarFunName var) = prettyInCtx var + prettyInCtx (GlobalName g projs) = + foldM (\pp proj -> (pp <>) <$> prettyInCtx proj) (viaShow g) projs + +instance PrettyInCtx Comp where + prettyInCtx (CompTerm t) = prettyInCtx t + prettyInCtx (CompBind c f) = + prettyAppList [prettyInCtx c, return ">>=", prettyInCtx f] + prettyInCtx (CompReturn t) = + prettyAppList [ return "returnM", return "_", parens <$> prettyInCtx t] + +instance PrettyInCtx CompFun where + prettyInCtx (CompFunTerm t) = prettyInCtx t + prettyInCtx CompFunReturn = return "returnM" + prettyInCtx (CompFunComp f g) = + prettyAppList [prettyInCtx f, return ">=>", prettyInCtx g] + +instance PrettyInCtx NormComp where + prettyInCtx (ReturnM t) = + prettyAppList [return "returnM", return "_", parens <$> prettyInCtx t] + prettyInCtx (ErrorM str) = + prettyAppList [return "errorM", return "_", parens <$> prettyInCtx str] + prettyInCtx (Ite cond t1 t2) = + prettyAppList [return "ite", return "_", parens <$> prettyInCtx cond, + parens <$> prettyInCtx t1, parens <$> prettyInCtx t2] + prettyInCtx (Either f g eith) = + prettyAppList [return "either", return "_", return "_", return "_", + parens <$> prettyInCtx f, parens <$> prettyInCtx g, + parens <$> prettyInCtx eith] + prettyInCtx (MaybeElim tp m f mayb) = + prettyAppList [return "maybe", parens <$> prettyInCtx tp, + return (parens "CompM _"), parens <$> prettyInCtx m, + parens <$> prettyInCtx f, parens <$> prettyInCtx mayb] + prettyInCtx (OrM t1 t2) = + prettyAppList [return "orM", return "_", + parens <$> prettyInCtx t1, parens <$> prettyInCtx t2] + prettyInCtx (ExistsM tp f) = + prettyAppList [return "existsM", prettyInCtx tp, return "_", + parens <$> prettyInCtx f] + prettyInCtx (ForallM tp f) = + prettyAppList [return "forallM", prettyInCtx tp, return "_", + parens <$> prettyInCtx f] + prettyInCtx (FunBind f args CompFunReturn) = + prettyAppList (prettyInCtx f : map prettyInCtx args) + prettyInCtx (FunBind f [] k) = + prettyAppList [prettyInCtx f, return ">>=", prettyInCtx k] + prettyInCtx (FunBind f args k) = + prettyAppList + [parens <$> prettyAppList (prettyInCtx f : map prettyInCtx args), + return ">>=", prettyInCtx k] From d31f778e4ad4b54e72287adec70f6a6318c60663 Mon Sep 17 00:00:00 2001 From: Matthew Yacavone Date: Tue, 22 Feb 2022 17:59:05 -0500 Subject: [PATCH 047/105] CI for Cryptol monadification and Mr. Solver (#1593) * add CI for Cryptol monadification and Mr. Solver * add `is_convertible`, check terms against expected in monadify tests * remove outdated comment --- .github/workflows/ci.yml | 34 +++++++++ examples/mr_solver/monadify.saw | 123 ++++++++++++++++++++++++-------- src/SAWScript/Builtins.hs | 16 +++-- src/SAWScript/Interpreter.hs | 7 +- 4 files changed, 142 insertions(+), 38 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 5f08806864..5e88f61ad0 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -197,6 +197,40 @@ jobs: name: "saw-${{ runner.os }}-${{ matrix.ghc }}" path: "dist/bin/saw" + mr-solver-tests: + needs: [build] + strategy: + fail-fast: false + matrix: + os: [ubuntu-latest, macos-10.15] + runs-on: ${{ matrix.os }} + steps: + - uses: actions/checkout@v2 + with: + submodules: true + + - shell: bash + run: .github/ci.sh install_system_deps + env: + BUILD_TARGET_OS: ${{ matrix.os }} + + - uses: actions/download-artifact@v2 + with: + name: "${{ runner.os }}-bins" + path: dist/bin + + - name: Update PATH to include SAW + shell: bash + run: | + chmod +x dist/bin/* + echo $GITHUB_WORKSPACE/dist/bin >> $GITHUB_PATH + + - working-directory: examples/mr_solver + shell: bash + run: | + saw monadify.saw + saw mr_solver_unit_tests.saw + heapster-tests: needs: [build] strategy: diff --git a/examples/mr_solver/monadify.saw b/examples/mr_solver/monadify.saw index 5b5ba8974e..37e0e54d28 100644 --- a/examples/mr_solver/monadify.saw +++ b/examples/mr_solver/monadify.saw @@ -2,50 +2,113 @@ enable_experimental; import "SpecPrims.cry" as SpecPrims; import "monadify.cry"; +load_sawcore_from_file "../../cryptol-saw-core/saw/CryptolM.sawcore"; set_monadification "SpecPrims::exists" "Prelude.existsM"; set_monadification "SpecPrims::forall" "Prelude.forallM"; +let run_test name cry_term mon_term_expected = + do { print (str_concat "Test: " name); + print "Original term:"; + print_term cry_term; + mon_term <- monadify_term cry_term; + print "Monadified term:"; + print_term mon_term; + success <- is_convertible mon_term mon_term_expected; + if success then print "Success - monadified term matched expected\n" else + do { print "Test failed - did not match expected monadified term:"; + print_term mon_term_expected; + exit 1; }; }; + my_abs <- unfold_term ["my_abs"] {{ my_abs }}; -print "[my_abs] original term:"; -print_term my_abs; -my_absM <- monadify_term my_abs; -print "[my_abs] monadified term:"; -print_term my_absM; +my_abs_M <- parse_core_mod "CryptolM" "\ +\ \\(x : (mseq (TCNum 64) Bool)) -> \ +\ bindM (isFinite (TCNum 64)) (mseq (TCNum 64) Bool) (assertFiniteM (TCNum 64)) \ +\ (\\(x' : (isFinite (TCNum 64))) -> \ +\ bindM (isFinite (TCNum 64)) (mseq (TCNum 64) Bool) (assertFiniteM (TCNum 64)) \ +\ (\\(x'' : (isFinite (TCNum 64))) -> \ +\ ite (CompM (mseq (TCNum 64) Bool)) \ +\ (ecLt (mseq (TCNum 64) Bool) (PCmpMSeqBool (TCNum 64) x') x \ +\ (ecNumber (TCNum 0) (mseq (TCNum 64) Bool) (PLiteralSeqBoolM (TCNum 64) x''))) \ +\ (bindM (isFinite (TCNum 64)) (mseq (TCNum 64) Bool) (assertFiniteM (TCNum 64)) \ +\ (\\(x''' : (isFinite (TCNum 64))) -> \ +\ returnM (mseq (TCNum 64) Bool) (ecNeg (mseq (TCNum 64) Bool) (PRingMSeqBool (TCNum 64) x''') x))) \ +\ (returnM (mseq (TCNum 64) Bool) x)))"; +run_test "my_abs" my_abs my_abs_M; -/* err_if_lt0 <- unfold_term ["err_if_lt0"] {{ err_if_lt0 }}; -print "[err_if_lt0] original term:"; -err_if_lt0M <- monadify_term err_if_lt0; -print "[err_if_lt0] monadified term:"; -print_term err_if_lt0M; -*/ +err_if_lt0_M <- parse_core_mod "CryptolM" "\ +\ \\(x : (mseq (TCNum 64) Bool)) -> \ +\ bindM (isFinite (TCNum 64)) (mseq (TCNum 64) Bool) (assertFiniteM (TCNum 64)) \ +\ (\\(x' : (isFinite (TCNum 64))) -> \ +\ bindM (isFinite (TCNum 64)) (mseq (TCNum 64) Bool) (assertFiniteM (TCNum 64)) \ +\ (\\(x'' : (isFinite (TCNum 64))) -> \ +\ ite (CompM (mseq (TCNum 64) Bool)) \ +\ (ecLt (mseq (TCNum 64) Bool) (PCmpMSeqBool (TCNum 64) x') x \ +\ (ecNumber (TCNum 0) (mseq (TCNum 64) Bool) (PLiteralSeqBoolM (TCNum 64) x''))) \ +\ (bindM (isFinite (TCNum 8)) (mseq (TCNum 64) Bool) (assertFiniteM (TCNum 8)) \ +\ (\\(x''' : (isFinite (TCNum 8))) -> \ +\ ecErrorM (mseq (TCNum 64) Bool) (TCNum 5) \ +\ (seqToMseq (TCNum 5) (mseq (TCNum 8) Bool) \ +\ [ ecNumber (TCNum 120) (mseq (TCNum 8) Bool) (PLiteralSeqBoolM (TCNum 8) x''') \ +\ , (ecNumber (TCNum 32) (mseq (TCNum 8) Bool) (PLiteralSeqBoolM (TCNum 8) x''')) \ +\ , ecNumber (TCNum 60) (mseq (TCNum 8) Bool) (PLiteralSeqBoolM (TCNum 8) x''') \ +\ , (ecNumber (TCNum 32) (mseq (TCNum 8) Bool) (PLiteralSeqBoolM (TCNum 8) x''')) \ +\ , ecNumber (TCNum 48) (mseq (TCNum 8) Bool) (PLiteralSeqBoolM (TCNum 8) x''') ]))) \ +\ (returnM (mseq (TCNum 64) Bool) x)))"; +run_test "err_if_lt0" err_if_lt0 err_if_lt0_M; /* sha1 <- {{ sha1 }}; -print "[SHA1] original term:"; +print "Test: sha1"; +print "Original term:"; print_term sha1; -mtrm <- monadify_term sha1; -print "[SHA1] monadified term:"; -print_term mtrm; +sha1M <- monadify_term sha1; +print "Monadified term:"; +print_term sha1M; */ fib <- unfold_term ["fib"] {{ fib }}; -print "[fib] original term:"; -print_term fib; -fibM <- monadify_term fib; -print "[fib] monadified term:"; -print_term fibM; +fibM <- parse_core_mod "CryptolM" "\ +\ \\(_x : (mseq (TCNum 64) Bool)) -> \ +\ multiArgFixM (LRT_Fun (mseq (TCNum 64) Bool) (\\(_ : (mseq (TCNum 64) Bool)) -> LRT_Ret (mseq (TCNum 64) Bool))) \ +\ (\\(fib : ((mseq (TCNum 64) Bool) -> (CompM (mseq (TCNum 64) Bool)))) -> \ +\ \\(x : (mseq (TCNum 64) Bool)) -> \ +\ bindM (isFinite (TCNum 64)) (mseq (TCNum 64) Bool) (assertFiniteM (TCNum 64)) \ +\ (\\(x' : (isFinite (TCNum 64))) -> \ +\ bindM (isFinite (TCNum 64)) (mseq (TCNum 64) Bool) (assertFiniteM (TCNum 64)) \ +\ (\\(x'' : (isFinite (TCNum 64))) -> \ +\ ite (CompM (mseq (TCNum 64) Bool)) \ +\ (ecEq (mseq (TCNum 64) Bool) (PEqMSeqBool (TCNum 64) x') x \ +\ (ecNumber (TCNum 0) (mseq (TCNum 64) Bool) (PLiteralSeqBoolM (TCNum 64) x''))) \ +\ (bindM (isFinite (TCNum 64)) (mseq (TCNum 64) Bool) (assertFiniteM (TCNum 64)) \ +\ (\\(x''' : (isFinite (TCNum 64))) -> \ +\ returnM (mseq (TCNum 64) Bool) \ +\ (ecNumber (TCNum 1) (mseq (TCNum 64) Bool) \ +\ (PLiteralSeqBoolM (TCNum 64) x''')))) \ +\ (bindM (isFinite (TCNum 64)) (mseq (TCNum 64) Bool) (assertFiniteM (TCNum 64)) \ +\ (\\(x''' : (isFinite (TCNum 64))) -> \ +\ bindM (isFinite (TCNum 64)) (mseq (TCNum 64) Bool) (assertFiniteM (TCNum 64)) \ +\ (\\(x'''' : (isFinite (TCNum 64))) -> \ +\ bindM (mseq (TCNum 64) Bool) (mseq (TCNum 64) Bool) \ +\ (fib \ +\ (ecMinus (mseq (TCNum 64) Bool) (PRingMSeqBool (TCNum 64) x''') x \ +\ (ecNumber (TCNum 1) (mseq (TCNum 64) Bool) \ +\ (PLiteralSeqBoolM (TCNum 64) x'''')))) \ +\ (\\(x''''' : (mseq (TCNum 64) Bool)) -> \ +\ returnM (mseq (TCNum 64) Bool) \ +\ (ecMul (mseq (TCNum 64) Bool) (PRingMSeqBool (TCNum 64) x''') x \ +\ x''''')))))))) \ +\ _x"; +run_test "fib" fib fibM; noErrors <- unfold_term ["noErrors"] {{ SpecPrims::noErrors }}; -print "[noErrors] original term:"; -print_term noErrors; -noErrorsM <- monadify_term noErrors; -print "[noErrors] monadified term:"; -print_term noErrorsM; +noErrorsM <- parse_core_mod "CryptolM" "\\(a : sort 0) -> existsM a a (\\(x : a) -> returnM a x)"; +run_test "noErrors" noErrors noErrorsM; fibSpecNoErrors <- unfold_term ["fibSpecNoErrors"] {{ fibSpecNoErrors }}; -print "[fibSpecNoErrors] original term:"; -print_term fibSpecNoErrors; -fibSpecNoErrorsM <- monadify_term fibSpecNoErrors; -print "[fibSpecNoErrors] monadified term:"; -print_term fibSpecNoErrorsM; +fibSpecNoErrorsM <- parse_core_mod "CryptolM" "\ +\ \\(__p1 : (mseq (TCNum 64) Bool)) -> \ +\ existsM (mseq (TCNum 64) Bool) (mseq (TCNum 64) Bool) \ +\ (\\(x : (mseq (TCNum 64) Bool)) -> \ +\ returnM (mseq (TCNum 64) Bool) x)"; +run_test "fibSpecNoErrors" fibSpecNoErrors fibSpecNoErrorsM; diff --git a/src/SAWScript/Builtins.hs b/src/SAWScript/Builtins.hs index 22e4565920..9454f86a72 100644 --- a/src/SAWScript/Builtins.hs +++ b/src/SAWScript/Builtins.hs @@ -323,15 +323,17 @@ hoistIfsPrim t = do return t{ ttTerm = t' } +isConvertiblePrim :: TypedTerm -> TypedTerm -> TopLevel Bool +isConvertiblePrim x y = do + sc <- getSharedContext + io $ scConvertible sc False (ttTerm x) (ttTerm y) + checkConvertiblePrim :: TypedTerm -> TypedTerm -> TopLevel () checkConvertiblePrim x y = do - sc <- getSharedContext - str <- io $ do - c <- scConvertible sc False (ttTerm x) (ttTerm y) - pure (if c - then "Convertible" - else "Not convertible") - printOutLnTop Info str + c <- isConvertiblePrim x y + printOutLnTop Info (if c + then "Convertible" + else "Not convertible") readCore :: FilePath -> TopLevel TypedTerm diff --git a/src/SAWScript/Interpreter.hs b/src/SAWScript/Interpreter.hs index 6d5dd09139..e53db153db 100644 --- a/src/SAWScript/Interpreter.hs +++ b/src/SAWScript/Interpreter.hs @@ -1071,10 +1071,15 @@ primitives = Map.fromList , "object that can be passed to 'read_sbv'." ] + , prim "is_convertible" "Term -> Term -> TopLevel Bool" + (pureVal isConvertiblePrim) + Current + [ "Returns true iff the two terms are convertible." ] + , prim "check_convertible" "Term -> Term -> TopLevel ()" (pureVal checkConvertiblePrim) Current - [ "Check if two terms are convertible." ] + [ "Check if two terms are convertible and print the result." ] , prim "replace" "Term -> Term -> Term -> TopLevel Term" (pureVal replacePrim) From a27cdc79486fa44e11daeaa641737c03fecade67 Mon Sep 17 00:00:00 2001 From: Matthew Yacavone Date: Wed, 23 Feb 2022 13:13:29 -0800 Subject: [PATCH 048/105] move unchanging bits of MRState to new MRInfo, add CoIndHyp --- src/SAWScript/Prover/MRSolver/Monad.hs | 126 +++++++++++++++++------- src/SAWScript/Prover/MRSolver/SMT.hs | 2 +- src/SAWScript/Prover/MRSolver/Solver.hs | 4 +- 3 files changed, 93 insertions(+), 39 deletions(-) diff --git a/src/SAWScript/Prover/MRSolver/Monad.hs b/src/SAWScript/Prover/MRSolver/Monad.hs index b89e3ae1c1..2a67b74955 100644 --- a/src/SAWScript/Prover/MRSolver/Monad.hs +++ b/src/SAWScript/Prover/MRSolver/Monad.hs @@ -1,6 +1,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-} @@ -163,6 +164,26 @@ asEVarApp var_map (asExtCnsApp -> Just (ec, args)) Just (MRVar ec, args, maybe_inst) asEVarApp _ _ = Nothing +-- | A co-inductive hypothesis of the form: +-- +-- > forall x1, ..., xn. F y1 ... ym |= G z1 ... zl +-- +-- for some universal context @x1:T1, ..., xn:Tn@ and some lists of argument +-- expressions @y1, ..., ym@ and @z1, ..., zl@ over the universal context. +data CoIndHyp = CoIndHyp { + -- | The uvars that were in scope when this assmption was created, in order + -- from outermost to innermost; that is, the uvars as "seen from outside their + -- scope", which is the reverse of the order of 'mrUVars', below + coIndHypCtx :: [(LocalName,Term)], + -- | The LHS argument expressions @y1, ..., ym@ over the 'coIndHypCtx' uvars + coIndHypLHS :: [Term], + -- | The RHS argument expressions @y1, ..., ym@ over the 'coIndHypCtx' uvars + coIndHypRHS :: [Term] } + +-- | A map from pairs of function names to co-inductive hypotheses over those +-- names +type CoIndHyps = Map (FunName, FunName) CoIndHyp + -- | An assumption that a named function refines some specificaiton. This has -- the form -- @@ -181,42 +202,45 @@ data FunAssump = FunAssump { -- | The right-hand side upper bound @m@ over the 'fassumpCtx' uvars fassumpRHS :: NormComp } --- | State maintained by MR. Solver -data MRState = MRState { +-- | A map from function names to function refinement assumptions over that +-- name +type FunAssumps = Map FunName FunAssump + +-- | Parameters for MR. Solver +data MRInfo = MRInfo { -- | Global shared context for building terms, etc. mrSC :: SharedContext, -- | SMT timeout for SMT calls made by Mr. Solver mrSMTTimeout :: Maybe Integer, + -- | The debug level, which controls debug printing + mrDebugLevel :: Int, + -- | The set of function refinements to be assumed by to Mr. Solver + mrFunAssumps :: FunAssumps +} + +-- | State maintained by MR. Solver +data MRState = MRState { -- | The context of universal variables, which are free SAW core variables, in -- order from innermost to outermost, i.e., where element @0@ corresponds to -- deBruijn index @0@ mrUVars :: [(LocalName,Type)], -- | The existential and letrec-bound variables mrVars :: MRVarMap, - -- | The current assumptions of function refinement - mrFunAssumps :: Map FunName FunAssump, + -- | The current set of co-inductive hypotheses + mrCoIndHyps :: CoIndHyps, -- | The current assumptions, which are conjoined into a single Boolean term; -- note that these have the current UVars free - mrAssumptions :: Term, - -- | The debug level, which controls debug printing - mrDebugLevel :: Int + mrAssumptions :: Term } --- | Build a default, empty state from SMT configuration parameters and a set of --- function refinement assumptions -mkMRState :: SharedContext -> Map FunName FunAssump -> - Maybe Integer -> Int -> IO MRState -mkMRState sc fun_assumps timeout dlvl = - scBool sc True >>= \true_tm -> - return $ MRState { mrSC = sc, - mrSMTTimeout = timeout, mrUVars = [], mrVars = Map.empty, - mrFunAssumps = fun_assumps, mrAssumptions = true_tm, - mrDebugLevel = dlvl } - --- | Mr. Monad, the monad used by MR. Solver, which is the state-exception monad -newtype MRM a = MRM { unMRM :: StateT MRState (ExceptT MRFailure IO) a } +-- | Mr. Monad, the monad used by MR. Solver, which has 'MRInfo' as as a +-- shared environment, 'MRState' as state, and 'MRFailure' as an exception +-- type, all over an 'IO' monad +newtype MRM a = MRM { unMRM :: ReaderT MRInfo (StateT MRState + (ExceptT MRFailure IO)) a } deriving (Functor, Applicative, Monad, MonadIO, - MonadState MRState, MonadError MRFailure) + MonadReader MRInfo, MonadState MRState, + MonadError MRFailure) instance MonadTerm MRM where mkTermF = liftSC1 scTermF @@ -225,8 +249,12 @@ instance MonadTerm MRM where substTerm = liftSC3 instantiateVarList -- | Run an 'MRM' computation and return a result or an error -runMRM :: MRState -> MRM a -> IO (Either MRFailure a) -runMRM init_st m = runExceptT $ flip evalStateT init_st $ unMRM m +runMRM :: MRInfo -> MRM a -> IO (Either MRFailure a) +runMRM init_info m = + do true_tm <- scBool (mrSC init_info) True + let init_st = MRState { mrUVars = [], mrVars = Map.empty, + mrAssumptions = true_tm, mrCoIndHyps = Map.empty } + runExceptT $ flip evalStateT init_st $ flip runReaderT init_info $ unMRM m -- | Apply a function to any failure thrown by an 'MRM' computation mapFailure :: (MRFailure -> MRFailure) -> MRM a -> MRM a @@ -255,29 +283,29 @@ catchErrorEither m = catchError (Right <$> m) (return . Left) -- | Lift a nullary SharedTerm computation into 'MRM' liftSC0 :: (SharedContext -> IO a) -> MRM a -liftSC0 f = (mrSC <$> get) >>= \sc -> liftIO (f sc) +liftSC0 f = (mrSC <$> ask) >>= \sc -> liftIO (f sc) -- | Lift a unary SharedTerm computation into 'MRM' liftSC1 :: (SharedContext -> a -> IO b) -> a -> MRM b -liftSC1 f a = (mrSC <$> get) >>= \sc -> liftIO (f sc a) +liftSC1 f a = (mrSC <$> ask) >>= \sc -> liftIO (f sc a) -- | Lift a binary SharedTerm computation into 'MRM' liftSC2 :: (SharedContext -> a -> b -> IO c) -> a -> b -> MRM c -liftSC2 f a b = (mrSC <$> get) >>= \sc -> liftIO (f sc a b) +liftSC2 f a b = (mrSC <$> ask) >>= \sc -> liftIO (f sc a b) -- | Lift a ternary SharedTerm computation into 'MRM' liftSC3 :: (SharedContext -> a -> b -> c -> IO d) -> a -> b -> c -> MRM d -liftSC3 f a b c = (mrSC <$> get) >>= \sc -> liftIO (f sc a b c) +liftSC3 f a b c = (mrSC <$> ask) >>= \sc -> liftIO (f sc a b c) -- | Lift a quaternary SharedTerm computation into 'MRM' liftSC4 :: (SharedContext -> a -> b -> c -> d -> IO e) -> a -> b -> c -> d -> MRM e -liftSC4 f a b c d = (mrSC <$> get) >>= \sc -> liftIO (f sc a b c d) +liftSC4 f a b c d = (mrSC <$> ask) >>= \sc -> liftIO (f sc a b c d) -- | Lift a quinary SharedTerm computation into 'MRM' liftSC5 :: (SharedContext -> a -> b -> c -> d -> e -> IO f) -> a -> b -> c -> d -> e -> MRM f -liftSC5 f a b c d e = (mrSC <$> get) >>= \sc -> liftIO (f sc a b c d e) +liftSC5 f a b c d e = (mrSC <$> ask) >>= \sc -> liftIO (f sc a b c d e) ---------------------------------------------------------------------- @@ -624,9 +652,38 @@ mrSubstEVarsStrict top_t = _mrSubstEVarsStrict :: Term -> MRM (Maybe Term) _mrSubstEVarsStrict = mrSubstEVarsStrict +-- | Get the 'CoIndHyp' for a pair of 'FunName's, if there is one +mrGetCoIndHyp :: FunName -> FunName -> MRM (Maybe CoIndHyp) +mrGetCoIndHyp nm1 nm2 = Map.lookup (nm1, nm2) <$> mrCoIndHyps <$> get + +-- | Run a computation under the additional co-inductive assumption that a +-- named function applied to some arguments refines another named function +-- applied some arguments, where all the aforementioned arguments are 'Term's +-- that can have the current uvars free +withCoIndHyp :: FunName -> [Term] -> FunName -> [Term] -> MRM a -> MRM a +withCoIndHyp nm1 args1 nm2 args2 m = + do mrDebugPPPrefixSep 1 "withCoIndHyp" (FunBind nm1 args1 CompFunReturn) + "|=" (FunBind nm2 args2 CompFunReturn) + ctx <- mrUVarCtx + hyps <- mrCoIndHyps <$> get + let hyps' = Map.insert (nm1, nm2) (CoIndHyp ctx args1 args2) hyps + modify (\s -> s { mrCoIndHyps = hyps' }) + ret <- m + modify (\s -> s { mrCoIndHyps = hyps }) + return ret + +-- | Generate fresh evars for the context of a 'CoIndHyp' and +-- substitute them into its arguments and right-hand side +instantiateCoIndHyp :: CoIndHyp -> MRM ([Term], [Term]) +instantiateCoIndHyp (CoIndHyp {..}) = + do evars <- mrFreshEVars coIndHypCtx + lhs <- substTermLike 0 evars coIndHypLHS + rhs <- substTermLike 0 evars coIndHypRHS + return (lhs, rhs) + -- | Look up the 'FunAssump' for a 'FunName', if there is one mrGetFunAssump :: FunName -> MRM (Maybe FunAssump) -mrGetFunAssump nm = Map.lookup nm <$> mrFunAssumps <$> get +mrGetFunAssump nm = Map.lookup nm <$> mrFunAssumps <$> ask -- | Run a computation under the additional assumption that a named function -- applied to a list of arguments refines a given right-hand side, all of which @@ -636,12 +693,9 @@ withFunAssump fname args rhs m = do mrDebugPPPrefixSep 1 "withFunAssump" (FunBind fname args CompFunReturn) "|=" rhs ctx <- mrUVarCtx - assumps <- mrFunAssumps <$> get + assumps <- mrFunAssumps <$> ask let assumps' = Map.insert fname (FunAssump ctx args rhs) assumps - modify (\s -> s { mrFunAssumps = assumps' }) - ret <- m - modify (\s -> s { mrFunAssumps = assumps }) - return ret + local (\info -> info { mrFunAssumps = assumps' }) m -- | Generate fresh evars for the context of a 'FunAssump' and substitute them -- into its arguments and right-hand side @@ -666,7 +720,7 @@ withAssumption phi m = -- | Print a 'String' if the debug level is at least the supplied 'Int' debugPrint :: Int -> String -> MRM () debugPrint i str = - (mrDebugLevel <$> get) >>= \lvl -> + (mrDebugLevel <$> ask) >>= \lvl -> if lvl >= i then liftIO (hPutStrLn stderr str) else return () -- | Print a document if the debug level is at least the supplied 'Int' diff --git a/src/SAWScript/Prover/MRSolver/SMT.hs b/src/SAWScript/Prover/MRSolver/SMT.hs index ed318a1455..c528714506 100644 --- a/src/SAWScript/Prover/MRSolver/SMT.hs +++ b/src/SAWScript/Prover/MRSolver/SMT.hs @@ -162,7 +162,7 @@ normSMTProp t = -- FIXME: use the timeout! mrProvableRaw :: Term -> MRM Bool mrProvableRaw prop_term = - do sc <- mrSC <$> get + do sc <- mrSC <$> ask prop <- liftSC1 termToProp prop_term unints <- Set.map ecVarIndex <$> getAllExtSet <$> liftSC1 propToTerm prop debugPrint 2 ("Calling SMT solver with proposition: " ++ diff --git a/src/SAWScript/Prover/MRSolver/Solver.hs b/src/SAWScript/Prover/MRSolver/Solver.hs index 2f55d31c02..3cffd15b4f 100644 --- a/src/SAWScript/Prover/MRSolver/Solver.hs +++ b/src/SAWScript/Prover/MRSolver/Solver.hs @@ -602,10 +602,10 @@ askMRSolver :: askMRSolver sc dlvl timeout t1 t2 = do tp1 <- scTypeOf sc t1 >>= scWhnf sc tp2 <- scTypeOf sc t2 >>= scWhnf sc - init_st <- mkMRState sc Map.empty timeout dlvl + let init_info = MRInfo sc timeout dlvl Map.empty case asPiList tp1 of (uvar_ctx, asCompM -> Just _) -> - fmap (either Just (const Nothing)) $ runMRM init_st $ + fmap (either Just (const Nothing)) $ runMRM init_info $ withUVars uvar_ctx $ \vars -> do tps_are_eq <- mrConvertible tp1 tp2 if tps_are_eq then return () else From 31e3891cbc999e213bc8c9423b823ceb076fbf62 Mon Sep 17 00:00:00 2001 From: Matthew Yacavone Date: Wed, 23 Feb 2022 13:30:38 -0800 Subject: [PATCH 049/105] use CoIndHyps instead of FunAssumps for co-induction in mrRefines' --- src/SAWScript/Prover/MRSolver/Solver.hs | 31 ++++++++++++++++--------- 1 file changed, 20 insertions(+), 11 deletions(-) diff --git a/src/SAWScript/Prover/MRSolver/Solver.hs b/src/SAWScript/Prover/MRSolver/Solver.hs index 3cffd15b4f..1299e8ef75 100644 --- a/src/SAWScript/Prover/MRSolver/Solver.hs +++ b/src/SAWScript/Prover/MRSolver/Solver.hs @@ -454,11 +454,21 @@ mrRefines' m1@(FunBind f1 args1 k1) m2@(FunBind f2 args2 k2) = mrConvertible tp1 tp2 >>= \tps_eq -> mrFunBodyRecInfo f1 args1 >>= \maybe_f1_body -> mrFunBodyRecInfo f2 args2 >>= \maybe_f2_body -> - mrGetFunAssump f1 >>= \case + mrGetCoIndHyp f1 f2 >>= \maybe_coIndHyp -> + mrGetFunAssump f1 >>= \maybe_fassump -> + case (maybe_coIndHyp, maybe_fassump) of + + -- If we have a co-inductive assumption that f1 args1' |= f2 args2', then + -- prove that args1 = args1' and args2 = args2', and then that k1 |= k2 + (Just coIndHyp, _) -> + do (args1', args2') <- instantiateCoIndHyp coIndHyp + zipWithM_ mrProveEq args1' args1 + zipWithM_ mrProveEq args2' args2 + mrRefinesFun k1 k2 -- If we have an assumption that f1 args' refines some rhs, then prove that -- args1 = args' and then that rhs refines m2 - Just fassump -> + (_, Just fassump) -> do (assump_args, assump_rhs) <- instantiateFunAssump fassump zipWithM_ mrProveEq assump_args args1 m1' <- normBind assump_rhs k1 @@ -472,16 +482,15 @@ mrRefines' m1@(FunBind f1 args1 k1) m2@(FunBind f2 args2 k2) = _ | Just (f2_body, False) <- maybe_f2_body -> normBindTerm f2_body k2 >>= \m2' -> mrRefines m1 m2' - -- If we do not already have an assumption that f1 refines some specification, - -- and both f1 and f2 are recursive but have the same return type, then try to - -- coinductively prove that f1 args1 |= f2 args2 under the assumption that f1 - -- args1 |= f2 args2, and then try to prove that k1 |= k2 - Nothing - | tps_eq + -- If we don't have a co-inducitve hypothesis for f1 and f2, don't have an + -- assumption that f1 refines some specification, and both f1 and f2 are + -- recursive and have the same return type, then try to coinductively prove + -- that f1 args1 |= f2 args2 under the assumption that f1 args1 |= f2 args2, + -- and then try to prove that k1 |= k2 + _ | tps_eq , Just (f1_body, _) <- maybe_f1_body , Just (f2_body, _) <- maybe_f2_body -> - do withFunAssump f1 args1 (FunBind f2 args2 CompFunReturn) $ - mrRefines f1_body f2_body + do withCoIndHyp f1 args1 f2 args2 $ mrRefines f1_body f2_body mrRefinesFun k1 k2 -- If we cannot line up f1 and f2, then making progress here would require us @@ -489,7 +498,7 @@ mrRefines' m1@(FunBind f1 args1 k1) m2@(FunBind f2 args2 k2) = -- related to the function call on the other side and k' is related to the -- continuation on the other side, but we don't know how to do that, so give -- up - Nothing -> + _ -> throwError (CompsDoNotRefine m1 m2) {- FIXME: handle FunBind on just one side From c078db1067fc4ccb1242d9c966003c2c2428bd39 Mon Sep 17 00:00:00 2001 From: Matthew Yacavone Date: Wed, 23 Feb 2022 15:26:42 -0800 Subject: [PATCH 050/105] add mrAssertProveEq, add CoIndMismatch failures --- src/SAWScript/Prover/MRSolver/Monad.hs | 15 +++++++++++++-- src/SAWScript/Prover/MRSolver/SMT.hs | 15 ++++++++++----- src/SAWScript/Prover/MRSolver/Solver.hs | 19 +++++++++++-------- 3 files changed, 34 insertions(+), 15 deletions(-) diff --git a/src/SAWScript/Prover/MRSolver/Monad.hs b/src/SAWScript/Prover/MRSolver/Monad.hs index 2a67b74955..d72856636a 100644 --- a/src/SAWScript/Prover/MRSolver/Monad.hs +++ b/src/SAWScript/Prover/MRSolver/Monad.hs @@ -66,6 +66,8 @@ data MRFailure | MalformedDefsFun Term | MalformedComp Term | NotCompFunType Term + | CoIndHypMismatchWidened FunName FunName CoIndHyp + | CoIndHypMismatchFailure (NormComp, NormComp) (NormComp, NormComp) -- | A local variable binding | MRFailureLocalVar LocalName MRFailure -- | Information about the context of the failure @@ -122,6 +124,13 @@ instance PrettyInCtx MRFailure where ppWithPrefix "Could not handle computation:" t prettyInCtx (NotCompFunType tp) = ppWithPrefix "Not a computation or computational function type:" tp + prettyInCtx (CoIndHypMismatchWidened nm1 nm2 _) = + ppWithPrefixSep "[Internal] Trying to widen co-inductive hypothesis on:" nm1 "," nm2 + prettyInCtx (CoIndHypMismatchFailure (tm1, tm2) (tm1', tm2')) = + vsepM [return "Could not match co-inductive hypotheis:", + ppWithPrefixSep "" tm1' "|=" tm2', + return "with goal:", + ppWithPrefixSep "" tm1 "|=" tm2] prettyInCtx (MRFailureLocalVar x err) = local (x:) $ prettyInCtx err prettyInCtx (MRFailureCtx ctx err) = @@ -178,7 +187,8 @@ data CoIndHyp = CoIndHyp { -- | The LHS argument expressions @y1, ..., ym@ over the 'coIndHypCtx' uvars coIndHypLHS :: [Term], -- | The RHS argument expressions @y1, ..., ym@ over the 'coIndHypCtx' uvars - coIndHypRHS :: [Term] } + coIndHypRHS :: [Term] +} deriving Show -- | A map from pairs of function names to co-inductive hypotheses over those -- names @@ -200,7 +210,8 @@ data FunAssump = FunAssump { -- | The argument expressions @e1, ..., en@ over the 'fassumpCtx' uvars fassumpArgs :: [Term], -- | The right-hand side upper bound @m@ over the 'fassumpCtx' uvars - fassumpRHS :: NormComp } + fassumpRHS :: NormComp +} -- | A map from function names to function refinement assumptions over that -- name diff --git a/src/SAWScript/Prover/MRSolver/SMT.hs b/src/SAWScript/Prover/MRSolver/SMT.hs index c528714506..78ffc14420 100644 --- a/src/SAWScript/Prover/MRSolver/SMT.hs +++ b/src/SAWScript/Prover/MRSolver/SMT.hs @@ -262,16 +262,21 @@ mrProveEqSimple eqf t1 t2 = t2' <- mrSubstEVars t2 TermInCtx [] <$> eqf t1' t2' - --- | Prove that two terms are equal, instantiating evars if necessary, or --- throwing an error if this is not possible -mrProveEq :: Term -> Term -> MRM () +-- | Prove that two terms are equal, instantiating evars if necessary, +-- returning true on success +mrProveEq :: Term -> Term -> MRM Bool mrProveEq t1 t2 = do mrDebugPPPrefixSep 1 "mrProveEq" t1 "==" t2 tp <- mrTypeOf t1 varmap <- mrVars <$> get cond_in_ctx <- mrProveEqH varmap tp t1 t2 - success <- withTermInCtx cond_in_ctx mrProvable + withTermInCtx cond_in_ctx mrProvable + +-- | Prove that two terms are equal, instantiating evars if necessary, or +-- throwing an error if this is not possible +mrAssertProveEq :: Term -> Term -> MRM () +mrAssertProveEq t1 t2 = + do success <- mrProveEq t1 t2 if success then return () else throwError (TermsNotEq t1 t2) diff --git a/src/SAWScript/Prover/MRSolver/Solver.hs b/src/SAWScript/Prover/MRSolver/Solver.hs index 1299e8ef75..ffa8b41086 100644 --- a/src/SAWScript/Prover/MRSolver/Solver.hs +++ b/src/SAWScript/Prover/MRSolver/Solver.hs @@ -366,7 +366,7 @@ mrRefines t1 t2 = -- | The main implementation of 'mrRefines' mrRefines' :: NormComp -> NormComp -> MRM () -mrRefines' (ReturnM e1) (ReturnM e2) = mrProveEq e1 e2 +mrRefines' (ReturnM e1) (ReturnM e2) = mrAssertProveEq e1 e2 mrRefines' (ErrorM _) (ErrorM _) = return () mrRefines' (ReturnM e) (ErrorM _) = throwError (ReturnNotError e) mrRefines' (ErrorM _) (ReturnM e) = throwError (ReturnNotError e) @@ -445,7 +445,7 @@ mrRefines' (FunBind (EVarFunName evar) args CompFunReturn) m2 = mrRefines' (FunBind (LetRecName f) args1 k1) (FunBind (LetRecName f') args2 k2) | f == f' && length args1 == length args2 = - zipWithM_ mrProveEq args1 args2 >> + zipWithM_ mrAssertProveEq args1 args2 >> mrRefinesFun k1 k2 mrRefines' m1@(FunBind f1 args1 k1) m2@(FunBind f2 args2 k2) = @@ -462,15 +462,18 @@ mrRefines' m1@(FunBind f1 args1 k1) m2@(FunBind f2 args2 k2) = -- prove that args1 = args1' and args2 = args2', and then that k1 |= k2 (Just coIndHyp, _) -> do (args1', args2') <- instantiateCoIndHyp coIndHyp - zipWithM_ mrProveEq args1' args1 - zipWithM_ mrProveEq args2' args2 - mrRefinesFun k1 k2 + eq1 <- and <$> zipWithM mrProveEq args1' args1 + eq2 <- and <$> zipWithM mrProveEq args2' args2 + if eq1 && eq2 then mrRefinesFun k1 k2 + else let m1' = FunBind f1 args1' CompFunReturn + m2' = FunBind f2 args2' CompFunReturn + in throwError (CoIndHypMismatchFailure (m1, m2) (m1', m2')) -- If we have an assumption that f1 args' refines some rhs, then prove that -- args1 = args' and then that rhs refines m2 (_, Just fassump) -> do (assump_args, assump_rhs) <- instantiateFunAssump fassump - zipWithM_ mrProveEq assump_args args1 + zipWithM_ mrAssertProveEq assump_args args1 m1' <- normBind assump_rhs k1 mrRefines m1' m2 @@ -508,7 +511,7 @@ mrRefines' m1@(FunBind f@(GlobalName _) args k1) m2 = -- If we have an assumption that f args' refines some rhs, then prove that -- args = args' and then that rhs refines m2 do (assump_args, assump_rhs) <- instantiateFunAssump fassump - zipWithM_ mrProveEq assump_args args + zipWithM_ mrAssertProveEq assump_args args m1' <- normBind assump_rhs k1 mrRefines m1' m2 Nothing -> @@ -525,7 +528,7 @@ mrRefines' m1@(FunBind f1 args1 k1) m2 = -- args1 = args' and then that rhs refines m2 Just fassump -> do (assump_args, assump_rhs) <- instantiateFunAssump fassump - zipWithM_ mrProveEq assump_args args1 + zipWithM_ mrAssertProveEq assump_args args1 m1' <- normBind assump_rhs k1 mrRefines m1' m2 From 82a8b0dd7eb8f32f1440d1383384e0da60b0545a Mon Sep 17 00:00:00 2001 From: Matthew Yacavone Date: Thu, 24 Feb 2022 10:56:31 -0800 Subject: [PATCH 051/105] move all but mrVars to MRInfo, make withCoIndHyp catch errs and recurse --- src/SAWScript/Prover/MRSolver/Monad.hs | 105 +++++++++++++----------- src/SAWScript/Prover/MRSolver/SMT.hs | 2 +- src/SAWScript/Prover/MRSolver/Solver.hs | 4 +- 3 files changed, 60 insertions(+), 51 deletions(-) diff --git a/src/SAWScript/Prover/MRSolver/Monad.hs b/src/SAWScript/Prover/MRSolver/Monad.hs index d72856636a..de89c8c0a9 100644 --- a/src/SAWScript/Prover/MRSolver/Monad.hs +++ b/src/SAWScript/Prover/MRSolver/Monad.hs @@ -217,7 +217,7 @@ data FunAssump = FunAssump { -- name type FunAssumps = Map FunName FunAssump --- | Parameters for MR. Solver +-- | Parameters and locals for MR. Solver data MRInfo = MRInfo { -- | Global shared context for building terms, etc. mrSC :: SharedContext, @@ -226,17 +226,11 @@ data MRInfo = MRInfo { -- | The debug level, which controls debug printing mrDebugLevel :: Int, -- | The set of function refinements to be assumed by to Mr. Solver - mrFunAssumps :: FunAssumps -} - --- | State maintained by MR. Solver -data MRState = MRState { - -- | The context of universal variables, which are free SAW core variables, in - -- order from innermost to outermost, i.e., where element @0@ corresponds to - -- deBruijn index @0@ + mrFunAssumps :: FunAssumps, + -- | The current context of universal variables, which are free SAW core + -- variables, in order from innermost to outermost, i.e., where element @0@ + -- corresponds to deBruijn index @0@ mrUVars :: [(LocalName,Type)], - -- | The existential and letrec-bound variables - mrVars :: MRVarMap, -- | The current set of co-inductive hypotheses mrCoIndHyps :: CoIndHyps, -- | The current assumptions, which are conjoined into a single Boolean term; @@ -244,6 +238,12 @@ data MRState = MRState { mrAssumptions :: Term } +-- | State maintained by MR. Solver +data MRState = MRState { + -- | The existential and letrec-bound variables + mrVars :: MRVarMap +} + -- | Mr. Monad, the monad used by MR. Solver, which has 'MRInfo' as as a -- shared environment, 'MRState' as state, and 'MRFailure' as an exception -- type, all over an 'IO' monad @@ -260,11 +260,15 @@ instance MonadTerm MRM where substTerm = liftSC3 instantiateVarList -- | Run an 'MRM' computation and return a result or an error -runMRM :: MRInfo -> MRM a -> IO (Either MRFailure a) -runMRM init_info m = - do true_tm <- scBool (mrSC init_info) True - let init_st = MRState { mrUVars = [], mrVars = Map.empty, - mrAssumptions = true_tm, mrCoIndHyps = Map.empty } +runMRM :: SharedContext -> Maybe Integer -> Int -> FunAssumps -> + MRM a -> IO (Either MRFailure a) +runMRM sc timeout debug assumps m = + do true_tm <- scBool sc True + let init_info = MRInfo { mrSC = sc, mrSMTTimeout = timeout, + mrDebugLevel = debug, mrFunAssumps = assumps, + mrUVars = [], mrCoIndHyps = Map.empty, + mrAssumptions = true_tm } + let init_st = MRState { mrVars = Map.empty } runExceptT $ flip evalStateT init_st $ flip runReaderT init_info $ unMRM m -- | Apply a function to any failure thrown by an 'MRM' computation @@ -358,7 +362,7 @@ mrApplyAll f args = liftSC2 scApplyAll f args >>= liftSC1 betaNormalize -- types as SAW core 'Term's, with the least recently bound uvar first, i.e., in -- the order as seen "from the outside" mrUVarCtx :: MRM [(LocalName,Term)] -mrUVarCtx = reverse <$> map (\(nm,Type tp) -> (nm,tp)) <$> mrUVars <$> get +mrUVarCtx = reverse <$> map (\(nm,Type tp) -> (nm,tp)) <$> mrUVars <$> ask -- | Get the type of a 'Term' in the current uvar context mrTypeOf :: Term -> MRM Term @@ -399,15 +403,12 @@ uniquifyName nm nms = -- assumptions made in the sub-computation will be lost when it completes. withUVar :: LocalName -> Type -> (Term -> MRM a) -> MRM a withUVar nm tp m = - do st <- get - let nm' = uniquifyName nm (map fst $ mrUVars st) - assumps' <- liftTerm 0 1 $ mrAssumptions st - put (st { mrUVars = (nm',tp) : mrUVars st, - mrAssumptions = assumps' }) - ret <- mapFailure (MRFailureLocalVar nm') (liftSC1 scLocalVar 0 >>= m) - modify (\st' -> st' { mrUVars = mrUVars st, - mrAssumptions = mrAssumptions st }) - return ret + do info <- ask + let nm' = uniquifyName nm (map fst $ mrUVars info) + assumps' <- liftTerm 0 1 $ mrAssumptions info + local (\_ -> info { mrUVars = (nm',tp) : mrUVars info, + mrAssumptions = assumps' }) $ + mapFailure (MRFailureLocalVar nm') (liftSC1 scLocalVar 0 >>= m) -- | Run a MR Solver computation in a context extended with a universal variable -- and pass it the lifting (in the sense of 'incVars') of an MR Solver term @@ -436,7 +437,7 @@ withUVars = helper [] where -- most recently bound getAllUVarTerms :: MRM [Term] getAllUVarTerms = - (length <$> mrUVars <$> get) >>= \len -> + (length <$> mrUVars <$> ask) >>= \len -> mapM (liftSC1 scLocalVar) [len-1, len-2 .. 0] -- | Lambda-abstract all the current uvars out of a 'Term', with the least @@ -665,23 +666,34 @@ _mrSubstEVarsStrict = mrSubstEVarsStrict -- | Get the 'CoIndHyp' for a pair of 'FunName's, if there is one mrGetCoIndHyp :: FunName -> FunName -> MRM (Maybe CoIndHyp) -mrGetCoIndHyp nm1 nm2 = Map.lookup (nm1, nm2) <$> mrCoIndHyps <$> get - --- | Run a computation under the additional co-inductive assumption that a --- named function applied to some arguments refines another named function --- applied some arguments, where all the aforementioned arguments are 'Term's --- that can have the current uvars free +mrGetCoIndHyp nm1 nm2 = Map.lookup (nm1, nm2) <$> mrCoIndHyps <$> ask + +-- | Run a compuation under the additional co-inductive assumption that +-- @forall x1, ..., xn. F y1 ... ym |= G z1 ... zl@, where @F@ and @G@ are +-- the given 'FunName's, @y1, ..., ym@ and @z1, ..., zl@ are the given +-- argument lists, and @x1, ..., xn@ is the current context of uvars. If +-- while running the given computation a 'CoIndHypMismatchWidened' error is +-- reached with the given names, the state is restored and the computation is +-- re-run with the widened hypothesis. This is done recursively, meaning this +-- function will only return once no 'CoIndHypMismatchWidened' errors are +-- raised with the given names. withCoIndHyp :: FunName -> [Term] -> FunName -> [Term] -> MRM a -> MRM a withCoIndHyp nm1 args1 nm2 args2 m = + do ctx <- mrUVarCtx + withCoIndHyp' (nm1, nm2) (CoIndHyp ctx args1 args2) m + +-- | The main loop of 'withCoIndHyp' +withCoIndHyp' :: (FunName, FunName) -> CoIndHyp -> MRM a -> MRM a +withCoIndHyp' (nm1, nm2) hyp@(CoIndHyp _ args1 args2) m = do mrDebugPPPrefixSep 1 "withCoIndHyp" (FunBind nm1 args1 CompFunReturn) "|=" (FunBind nm2 args2 CompFunReturn) - ctx <- mrUVarCtx - hyps <- mrCoIndHyps <$> get - let hyps' = Map.insert (nm1, nm2) (CoIndHyp ctx args1 args2) hyps - modify (\s -> s { mrCoIndHyps = hyps' }) - ret <- m - modify (\s -> s { mrCoIndHyps = hyps }) - return ret + st <- get + hyps' <- Map.insert (nm1, nm2) hyp <$> mrCoIndHyps <$> ask + (local (\info -> info { mrCoIndHyps = hyps' }) m) `catchError` \case + CoIndHypMismatchWidened nm1' nm2' hyp' | nm1 == nm1' && nm2 == nm2' + -> -- FIXME: Could restoring the state here cause any problems? + put st >> withCoIndHyp' (nm1, nm2) hyp' m + e -> throwError e -- | Generate fresh evars for the context of a 'CoIndHyp' and -- substitute them into its arguments and right-hand side @@ -721,12 +733,9 @@ instantiateFunAssump fassump = -- executing a sub-computation withAssumption :: Term -> MRM a -> MRM a withAssumption phi m = - do assumps <- mrAssumptions <$> get + do assumps <- mrAssumptions <$> ask assumps' <- liftSC2 scAnd phi assumps - modify (\s -> s { mrAssumptions = assumps' }) - ret <- m - modify (\s -> s { mrAssumptions = assumps }) - return ret + local (\info -> info { mrAssumptions = assumps' }) m -- | Print a 'String' if the debug level is at least the supplied 'Int' debugPrint :: Int -> String -> MRM () @@ -742,19 +751,19 @@ debugPretty i pp = debugPrint i $ renderSawDoc defaultPPOpts pp -- at least the supplied 'Int' debugPrettyInCtx :: PrettyInCtx a => Int -> a -> MRM () debugPrettyInCtx i a = - (mrUVars <$> get) >>= \ctx -> debugPrint i (showInCtx (map fst ctx) a) + (mrUVars <$> ask) >>= \ctx -> debugPrint i (showInCtx (map fst ctx) a) -- | Pretty-print an object relative to the current context mrPPInCtx :: PrettyInCtx a => a -> MRM SawDoc mrPPInCtx a = - runReader (prettyInCtx a) <$> map fst <$> mrUVars <$> get + runReader (prettyInCtx a) <$> map fst <$> mrUVars <$> ask -- | Pretty-print the result of 'ppWithPrefixSep' relative to the current uvar -- context to 'stderr' if the debug level is at least the 'Int' provided mrDebugPPPrefixSep :: PrettyInCtx a => Int -> String -> a -> String -> a -> MRM () mrDebugPPPrefixSep i pre a1 sp a2 = - (mrUVars <$> get) >>= \ctx -> + (mrUVars <$> ask) >>= \ctx -> debugPretty i $ flip runReader (map fst ctx) (group <$> nest 2 <$> ppWithPrefixSep pre a1 sp a2) diff --git a/src/SAWScript/Prover/MRSolver/SMT.hs b/src/SAWScript/Prover/MRSolver/SMT.hs index 78ffc14420..363309b620 100644 --- a/src/SAWScript/Prover/MRSolver/SMT.hs +++ b/src/SAWScript/Prover/MRSolver/SMT.hs @@ -180,7 +180,7 @@ mrProvableRaw prop_term = -- assumptions mrProvable :: Term -> MRM Bool mrProvable bool_tm = - do assumps <- mrAssumptions <$> get + do assumps <- mrAssumptions <$> ask prop <- liftSC2 scImplies assumps bool_tm >>= liftSC1 scEqTrue prop_inst <- flip instantiateUVarsM prop $ \nm tp -> liftSC1 scWhnf tp >>= \case diff --git a/src/SAWScript/Prover/MRSolver/Solver.hs b/src/SAWScript/Prover/MRSolver/Solver.hs index ffa8b41086..66defa2ded 100644 --- a/src/SAWScript/Prover/MRSolver/Solver.hs +++ b/src/SAWScript/Prover/MRSolver/Solver.hs @@ -614,10 +614,10 @@ askMRSolver :: askMRSolver sc dlvl timeout t1 t2 = do tp1 <- scTypeOf sc t1 >>= scWhnf sc tp2 <- scTypeOf sc t2 >>= scWhnf sc - let init_info = MRInfo sc timeout dlvl Map.empty case asPiList tp1 of (uvar_ctx, asCompM -> Just _) -> - fmap (either Just (const Nothing)) $ runMRM init_info $ + fmap (either Just (const Nothing)) $ + runMRM sc timeout dlvl Map.empty $ withUVars uvar_ctx $ \vars -> do tps_are_eq <- mrConvertible tp1 tp2 if tps_are_eq then return () else From becee3bda3d3cc2f4d9f0dd285d60358e88e5b2e Mon Sep 17 00:00:00 2001 From: Matthew Yacavone Date: Thu, 24 Feb 2022 11:04:44 -0800 Subject: [PATCH 052/105] refactor MRInfo, MRState to make ask/get interface nicer --- src/SAWScript/Prover/MRSolver/Monad.hs | 122 +++++++++++++++---------- src/SAWScript/Prover/MRSolver/SMT.hs | 9 +- 2 files changed, 80 insertions(+), 51 deletions(-) diff --git a/src/SAWScript/Prover/MRSolver/Monad.hs b/src/SAWScript/Prover/MRSolver/Monad.hs index de89c8c0a9..2b6804f7e4 100644 --- a/src/SAWScript/Prover/MRSolver/Monad.hs +++ b/src/SAWScript/Prover/MRSolver/Monad.hs @@ -220,28 +220,28 @@ type FunAssumps = Map FunName FunAssump -- | Parameters and locals for MR. Solver data MRInfo = MRInfo { -- | Global shared context for building terms, etc. - mrSC :: SharedContext, + mriSC :: SharedContext, -- | SMT timeout for SMT calls made by Mr. Solver - mrSMTTimeout :: Maybe Integer, + mriSMTTimeout :: Maybe Integer, -- | The debug level, which controls debug printing - mrDebugLevel :: Int, + mriDebugLevel :: Int, -- | The set of function refinements to be assumed by to Mr. Solver - mrFunAssumps :: FunAssumps, + mriFunAssumps :: FunAssumps, -- | The current context of universal variables, which are free SAW core -- variables, in order from innermost to outermost, i.e., where element @0@ -- corresponds to deBruijn index @0@ - mrUVars :: [(LocalName,Type)], + mriUVars :: [(LocalName,Type)], -- | The current set of co-inductive hypotheses - mrCoIndHyps :: CoIndHyps, + mriCoIndHyps :: CoIndHyps, -- | The current assumptions, which are conjoined into a single Boolean term; -- note that these have the current UVars free - mrAssumptions :: Term + mriAssumptions :: Term } -- | State maintained by MR. Solver data MRState = MRState { -- | The existential and letrec-bound variables - mrVars :: MRVarMap + mrsVars :: MRVarMap } -- | Mr. Monad, the monad used by MR. Solver, which has 'MRInfo' as as a @@ -253,6 +253,38 @@ newtype MRM a = MRM { unMRM :: ReaderT MRInfo (StateT MRState MonadReader MRInfo, MonadState MRState, MonadError MRFailure) +-- | Get the current value of 'mriSC' +mrSC :: MRM SharedContext +mrSC = mriSC <$> ask + +-- | Get the current value of 'mrSMTTimeout' +mrSMTTimeout :: MRM (Maybe Integer) +mrSMTTimeout = mriSMTTimeout <$> ask + +-- | Get the current value of 'mrDebugLevel' +mrDebugLevel :: MRM Int +mrDebugLevel = mriDebugLevel <$> ask + +-- | Get the current value of 'mrFunAssumps' +mrFunAssumps :: MRM FunAssumps +mrFunAssumps = mriFunAssumps <$> ask + +-- | Get the current value of 'mrUVars' +mrUVars :: MRM [(LocalName,Type)] +mrUVars = mriUVars <$> ask + +-- | Get the current value of 'mrCoIndHyps' +mrCoIndHyps :: MRM CoIndHyps +mrCoIndHyps = mriCoIndHyps <$> ask + +-- | Get the current value of 'mrAssumptions' +mrAssumptions :: MRM Term +mrAssumptions = mriAssumptions <$> ask + +-- | Get the current value of 'mrVars' +mrVars :: MRM MRVarMap +mrVars = mrsVars <$> get + instance MonadTerm MRM where mkTermF = liftSC1 scTermF liftTerm = liftSC3 incVars @@ -264,11 +296,11 @@ runMRM :: SharedContext -> Maybe Integer -> Int -> FunAssumps -> MRM a -> IO (Either MRFailure a) runMRM sc timeout debug assumps m = do true_tm <- scBool sc True - let init_info = MRInfo { mrSC = sc, mrSMTTimeout = timeout, - mrDebugLevel = debug, mrFunAssumps = assumps, - mrUVars = [], mrCoIndHyps = Map.empty, - mrAssumptions = true_tm } - let init_st = MRState { mrVars = Map.empty } + let init_info = MRInfo { mriSC = sc, mriSMTTimeout = timeout, + mriDebugLevel = debug, mriFunAssumps = assumps, + mriUVars = [], mriCoIndHyps = Map.empty, + mriAssumptions = true_tm } + let init_st = MRState { mrsVars = Map.empty } runExceptT $ flip evalStateT init_st $ flip runReaderT init_info $ unMRM m -- | Apply a function to any failure thrown by an 'MRM' computation @@ -298,29 +330,29 @@ catchErrorEither m = catchError (Right <$> m) (return . Left) -- | Lift a nullary SharedTerm computation into 'MRM' liftSC0 :: (SharedContext -> IO a) -> MRM a -liftSC0 f = (mrSC <$> ask) >>= \sc -> liftIO (f sc) +liftSC0 f = mrSC >>= \sc -> liftIO (f sc) -- | Lift a unary SharedTerm computation into 'MRM' liftSC1 :: (SharedContext -> a -> IO b) -> a -> MRM b -liftSC1 f a = (mrSC <$> ask) >>= \sc -> liftIO (f sc a) +liftSC1 f a = mrSC >>= \sc -> liftIO (f sc a) -- | Lift a binary SharedTerm computation into 'MRM' liftSC2 :: (SharedContext -> a -> b -> IO c) -> a -> b -> MRM c -liftSC2 f a b = (mrSC <$> ask) >>= \sc -> liftIO (f sc a b) +liftSC2 f a b = mrSC >>= \sc -> liftIO (f sc a b) -- | Lift a ternary SharedTerm computation into 'MRM' liftSC3 :: (SharedContext -> a -> b -> c -> IO d) -> a -> b -> c -> MRM d -liftSC3 f a b c = (mrSC <$> ask) >>= \sc -> liftIO (f sc a b c) +liftSC3 f a b c = mrSC >>= \sc -> liftIO (f sc a b c) -- | Lift a quaternary SharedTerm computation into 'MRM' liftSC4 :: (SharedContext -> a -> b -> c -> d -> IO e) -> a -> b -> c -> d -> MRM e -liftSC4 f a b c d = (mrSC <$> ask) >>= \sc -> liftIO (f sc a b c d) +liftSC4 f a b c d = mrSC >>= \sc -> liftIO (f sc a b c d) -- | Lift a quinary SharedTerm computation into 'MRM' liftSC5 :: (SharedContext -> a -> b -> c -> d -> e -> IO f) -> a -> b -> c -> d -> e -> MRM f -liftSC5 f a b c d e = (mrSC <$> ask) >>= \sc -> liftIO (f sc a b c d e) +liftSC5 f a b c d e = mrSC >>= \sc -> liftIO (f sc a b c d e) ---------------------------------------------------------------------- @@ -362,7 +394,7 @@ mrApplyAll f args = liftSC2 scApplyAll f args >>= liftSC1 betaNormalize -- types as SAW core 'Term's, with the least recently bound uvar first, i.e., in -- the order as seen "from the outside" mrUVarCtx :: MRM [(LocalName,Term)] -mrUVarCtx = reverse <$> map (\(nm,Type tp) -> (nm,tp)) <$> mrUVars <$> ask +mrUVarCtx = reverse <$> map (\(nm,Type tp) -> (nm,tp)) <$> mrUVars -- | Get the type of a 'Term' in the current uvar context mrTypeOf :: Term -> MRM Term @@ -403,11 +435,10 @@ uniquifyName nm nms = -- assumptions made in the sub-computation will be lost when it completes. withUVar :: LocalName -> Type -> (Term -> MRM a) -> MRM a withUVar nm tp m = - do info <- ask - let nm' = uniquifyName nm (map fst $ mrUVars info) - assumps' <- liftTerm 0 1 $ mrAssumptions info - local (\_ -> info { mrUVars = (nm',tp) : mrUVars info, - mrAssumptions = assumps' }) $ + do nm' <- uniquifyName nm <$> map fst <$> mrUVars + assumps' <- mrAssumptions >>= liftTerm 0 1 + local (\info -> info { mriUVars = (nm',tp) : mriUVars info, + mriAssumptions = assumps' }) $ mapFailure (MRFailureLocalVar nm') (liftSC1 scLocalVar 0 >>= m) -- | Run a MR Solver computation in a context extended with a universal variable @@ -437,7 +468,7 @@ withUVars = helper [] where -- most recently bound getAllUVarTerms :: MRM [Term] getAllUVarTerms = - (length <$> mrUVars <$> ask) >>= \len -> + (length <$> mrUVars) >>= \len -> mapM (liftSC1 scLocalVar) [len-1, len-2 .. 0] -- | Lambda-abstract all the current uvars out of a 'Term', with the least @@ -476,7 +507,7 @@ mrVarTerm (MRVar ec) = -- | Get the 'VarInfo' associated with a 'MRVar' mrVarInfo :: MRVar -> MRM (Maybe MRVarInfo) -mrVarInfo var = Map.lookup var <$> mrVars <$> get +mrVarInfo var = Map.lookup var <$> mrVars -- | Convert an 'ExtCns' to a 'FunName' extCnsToFunName :: ExtCns Term -> MRM FunName @@ -543,11 +574,11 @@ mrFreshVar nm tp = MRVar <$> liftSC2 scFreshEC nm tp mrSetVarInfo :: MRVar -> MRVarInfo -> MRM () mrSetVarInfo var info = modify $ \st -> - st { mrVars = + st { mrsVars = Map.alter (\case Just _ -> error "mrSetVarInfo" Nothing -> Just info) - var (mrVars st) } + var (mrsVars st) } -- | Make a fresh existential variable of the given type, abstracting out all -- the current uvars and returning the new evar applied to all current uvars @@ -583,14 +614,14 @@ mrSetEVarClosed var val = -- FIXME: catch subtyping errors and report them as being evar failures liftSC3 scCheckSubtype Nothing (TypedTerm val val_tp) var_tp modify $ \st -> - st { mrVars = + st { mrsVars = Map.alter (\case Just (EVarInfo Nothing) -> Just $ EVarInfo (Just val) Just (EVarInfo (Just _)) -> error "Setting existential variable: variable already set!" _ -> error "Setting existential variable: not an evar!") - var (mrVars st) } + var (mrsVars st) } -- | Try to set the value of the application @X e1 .. en@ of evar @X@ to an @@ -636,7 +667,7 @@ mrTrySetAppliedEVar evar args t = -- | Replace all evars in a 'Term' with their instantiations when they have one mrSubstEVars :: Term -> MRM Term mrSubstEVars = memoFixTermFun $ \recurse t -> - do var_map <- mrVars <$> get + do var_map <- mrVars case t of -- If t is an instantiated evar, recurse on its instantiation (asEVarApp var_map -> Just (_, args, Just t')) -> @@ -649,7 +680,7 @@ mrSubstEVars = memoFixTermFun $ \recurse t -> mrSubstEVarsStrict :: Term -> MRM (Maybe Term) mrSubstEVarsStrict top_t = runMaybeT $ flip memoFixTermFun top_t $ \recurse t -> - do var_map <- mrVars <$> get + do var_map <- lift mrVars case t of -- If t is an instantiated evar, recurse on its instantiation (asEVarApp var_map -> Just (_, args, Just t')) -> @@ -666,7 +697,7 @@ _mrSubstEVarsStrict = mrSubstEVarsStrict -- | Get the 'CoIndHyp' for a pair of 'FunName's, if there is one mrGetCoIndHyp :: FunName -> FunName -> MRM (Maybe CoIndHyp) -mrGetCoIndHyp nm1 nm2 = Map.lookup (nm1, nm2) <$> mrCoIndHyps <$> ask +mrGetCoIndHyp nm1 nm2 = Map.lookup (nm1, nm2) <$> mrCoIndHyps -- | Run a compuation under the additional co-inductive assumption that -- @forall x1, ..., xn. F y1 ... ym |= G z1 ... zl@, where @F@ and @G@ are @@ -688,8 +719,8 @@ withCoIndHyp' (nm1, nm2) hyp@(CoIndHyp _ args1 args2) m = do mrDebugPPPrefixSep 1 "withCoIndHyp" (FunBind nm1 args1 CompFunReturn) "|=" (FunBind nm2 args2 CompFunReturn) st <- get - hyps' <- Map.insert (nm1, nm2) hyp <$> mrCoIndHyps <$> ask - (local (\info -> info { mrCoIndHyps = hyps' }) m) `catchError` \case + hyps' <- Map.insert (nm1, nm2) hyp <$> mrCoIndHyps + (local (\info -> info { mriCoIndHyps = hyps' }) m) `catchError` \case CoIndHypMismatchWidened nm1' nm2' hyp' | nm1 == nm1' && nm2 == nm2' -> -- FIXME: Could restoring the state here cause any problems? put st >> withCoIndHyp' (nm1, nm2) hyp' m @@ -706,7 +737,7 @@ instantiateCoIndHyp (CoIndHyp {..}) = -- | Look up the 'FunAssump' for a 'FunName', if there is one mrGetFunAssump :: FunName -> MRM (Maybe FunAssump) -mrGetFunAssump nm = Map.lookup nm <$> mrFunAssumps <$> ask +mrGetFunAssump nm = Map.lookup nm <$> mrFunAssumps -- | Run a computation under the additional assumption that a named function -- applied to a list of arguments refines a given right-hand side, all of which @@ -716,9 +747,9 @@ withFunAssump fname args rhs m = do mrDebugPPPrefixSep 1 "withFunAssump" (FunBind fname args CompFunReturn) "|=" rhs ctx <- mrUVarCtx - assumps <- mrFunAssumps <$> ask + assumps <- mrFunAssumps let assumps' = Map.insert fname (FunAssump ctx args rhs) assumps - local (\info -> info { mrFunAssumps = assumps' }) m + local (\info -> info { mriFunAssumps = assumps' }) m -- | Generate fresh evars for the context of a 'FunAssump' and substitute them -- into its arguments and right-hand side @@ -733,14 +764,13 @@ instantiateFunAssump fassump = -- executing a sub-computation withAssumption :: Term -> MRM a -> MRM a withAssumption phi m = - do assumps <- mrAssumptions <$> ask - assumps' <- liftSC2 scAnd phi assumps - local (\info -> info { mrAssumptions = assumps' }) m + do assumps' <- mrAssumptions >>= liftSC2 scAnd phi + local (\info -> info { mriAssumptions = assumps' }) m -- | Print a 'String' if the debug level is at least the supplied 'Int' debugPrint :: Int -> String -> MRM () debugPrint i str = - (mrDebugLevel <$> ask) >>= \lvl -> + mrDebugLevel >>= \lvl -> if lvl >= i then liftIO (hPutStrLn stderr str) else return () -- | Print a document if the debug level is at least the supplied 'Int' @@ -751,19 +781,19 @@ debugPretty i pp = debugPrint i $ renderSawDoc defaultPPOpts pp -- at least the supplied 'Int' debugPrettyInCtx :: PrettyInCtx a => Int -> a -> MRM () debugPrettyInCtx i a = - (mrUVars <$> ask) >>= \ctx -> debugPrint i (showInCtx (map fst ctx) a) + mrUVars >>= \ctx -> debugPrint i (showInCtx (map fst ctx) a) -- | Pretty-print an object relative to the current context mrPPInCtx :: PrettyInCtx a => a -> MRM SawDoc mrPPInCtx a = - runReader (prettyInCtx a) <$> map fst <$> mrUVars <$> ask + runReader (prettyInCtx a) <$> map fst <$> mrUVars -- | Pretty-print the result of 'ppWithPrefixSep' relative to the current uvar -- context to 'stderr' if the debug level is at least the 'Int' provided mrDebugPPPrefixSep :: PrettyInCtx a => Int -> String -> a -> String -> a -> MRM () mrDebugPPPrefixSep i pre a1 sp a2 = - (mrUVars <$> ask) >>= \ctx -> + mrUVars >>= \ctx -> debugPretty i $ flip runReader (map fst ctx) (group <$> nest 2 <$> ppWithPrefixSep pre a1 sp a2) diff --git a/src/SAWScript/Prover/MRSolver/SMT.hs b/src/SAWScript/Prover/MRSolver/SMT.hs index 363309b620..608f4ae9bd 100644 --- a/src/SAWScript/Prover/MRSolver/SMT.hs +++ b/src/SAWScript/Prover/MRSolver/SMT.hs @@ -18,7 +18,6 @@ module SAWScript.Prover.MRSolver.SMT where import qualified Data.Vector as V import Control.Monad.Reader -import Control.Monad.State import Control.Monad.Except import Data.Map (Map) @@ -162,7 +161,7 @@ normSMTProp t = -- FIXME: use the timeout! mrProvableRaw :: Term -> MRM Bool mrProvableRaw prop_term = - do sc <- mrSC <$> ask + do sc <- mrSC prop <- liftSC1 termToProp prop_term unints <- Set.map ecVarIndex <$> getAllExtSet <$> liftSC1 propToTerm prop debugPrint 2 ("Calling SMT solver with proposition: " ++ @@ -180,7 +179,7 @@ mrProvableRaw prop_term = -- assumptions mrProvable :: Term -> MRM Bool mrProvable bool_tm = - do assumps <- mrAssumptions <$> ask + do assumps <- mrAssumptions prop <- liftSC2 scImplies assumps bool_tm >>= liftSC1 scEqTrue prop_inst <- flip instantiateUVarsM prop $ \nm tp -> liftSC1 scWhnf tp >>= \case @@ -268,7 +267,7 @@ mrProveEq :: Term -> Term -> MRM Bool mrProveEq t1 t2 = do mrDebugPPPrefixSep 1 "mrProveEq" t1 "==" t2 tp <- mrTypeOf t1 - varmap <- mrVars <$> get + varmap <- mrVars cond_in_ctx <- mrProveEqH varmap tp t1 t2 withTermInCtx cond_in_ctx mrProvable @@ -348,7 +347,7 @@ mrProveEqH _ (asBVVecType -> Just (n, len, tp)) t1 t2 = t1'', ix'', pf''] t2_prj <- liftSC2 scGlobalApply "Prelude.atBVVec" [n'', len'', tp'', t2'', ix'', pf''] - var_map <- mrVars <$> get + var_map <- mrVars extTermInCtx [("eq_ix",ix_tp),("eq_pf",pf_tp)] <$> mrProveEqH var_map tp'' t1_prj t2_prj From e786da4479acfe6c1adbca1649a89c2d15f4a169 Mon Sep 17 00:00:00 2001 From: Matthew Yacavone Date: Thu, 24 Feb 2022 11:13:41 -0800 Subject: [PATCH 053/105] minor cleanup and refactoring --- src/SAWScript/Prover/MRSolver/Monad.hs | 39 +++++++++++++------------- 1 file changed, 20 insertions(+), 19 deletions(-) diff --git a/src/SAWScript/Prover/MRSolver/Monad.hs b/src/SAWScript/Prover/MRSolver/Monad.hs index 2b6804f7e4..116965fa66 100644 --- a/src/SAWScript/Prover/MRSolver/Monad.hs +++ b/src/SAWScript/Prover/MRSolver/Monad.hs @@ -223,19 +223,19 @@ data MRInfo = MRInfo { mriSC :: SharedContext, -- | SMT timeout for SMT calls made by Mr. Solver mriSMTTimeout :: Maybe Integer, - -- | The debug level, which controls debug printing - mriDebugLevel :: Int, - -- | The set of function refinements to be assumed by to Mr. Solver - mriFunAssumps :: FunAssumps, -- | The current context of universal variables, which are free SAW core -- variables, in order from innermost to outermost, i.e., where element @0@ -- corresponds to deBruijn index @0@ mriUVars :: [(LocalName,Type)], + -- | The set of function refinements to be assumed by to Mr. Solver + mriFunAssumps :: FunAssumps, -- | The current set of co-inductive hypotheses mriCoIndHyps :: CoIndHyps, -- | The current assumptions, which are conjoined into a single Boolean term; -- note that these have the current UVars free - mriAssumptions :: Term + mriAssumptions :: Term, + -- | The debug level, which controls debug printing + mriDebugLevel :: Int } -- | State maintained by MR. Solver @@ -253,6 +253,12 @@ newtype MRM a = MRM { unMRM :: ReaderT MRInfo (StateT MRState MonadReader MRInfo, MonadState MRState, MonadError MRFailure) +instance MonadTerm MRM where + mkTermF = liftSC1 scTermF + liftTerm = liftSC3 incVars + whnfTerm = liftSC1 scWhnf + substTerm = liftSC3 instantiateVarList + -- | Get the current value of 'mriSC' mrSC :: MRM SharedContext mrSC = mriSC <$> ask @@ -261,18 +267,14 @@ mrSC = mriSC <$> ask mrSMTTimeout :: MRM (Maybe Integer) mrSMTTimeout = mriSMTTimeout <$> ask --- | Get the current value of 'mrDebugLevel' -mrDebugLevel :: MRM Int -mrDebugLevel = mriDebugLevel <$> ask +-- | Get the current value of 'mrUVars' +mrUVars :: MRM [(LocalName,Type)] +mrUVars = mriUVars <$> ask -- | Get the current value of 'mrFunAssumps' mrFunAssumps :: MRM FunAssumps mrFunAssumps = mriFunAssumps <$> ask --- | Get the current value of 'mrUVars' -mrUVars :: MRM [(LocalName,Type)] -mrUVars = mriUVars <$> ask - -- | Get the current value of 'mrCoIndHyps' mrCoIndHyps :: MRM CoIndHyps mrCoIndHyps = mriCoIndHyps <$> ask @@ -281,16 +283,14 @@ mrCoIndHyps = mriCoIndHyps <$> ask mrAssumptions :: MRM Term mrAssumptions = mriAssumptions <$> ask +-- | Get the current value of 'mrDebugLevel' +mrDebugLevel :: MRM Int +mrDebugLevel = mriDebugLevel <$> ask + -- | Get the current value of 'mrVars' mrVars :: MRM MRVarMap mrVars = mrsVars <$> get -instance MonadTerm MRM where - mkTermF = liftSC1 scTermF - liftTerm = liftSC3 incVars - whnfTerm = liftSC1 scWhnf - substTerm = liftSC3 instantiateVarList - -- | Run an 'MRM' computation and return a result or an error runMRM :: SharedContext -> Maybe Integer -> Int -> FunAssumps -> MRM a -> IO (Either MRFailure a) @@ -764,7 +764,8 @@ instantiateFunAssump fassump = -- executing a sub-computation withAssumption :: Term -> MRM a -> MRM a withAssumption phi m = - do assumps' <- mrAssumptions >>= liftSC2 scAnd phi + do assumps <- mrAssumptions + assumps' <- liftSC2 scAnd phi assumps local (\info -> info { mriAssumptions = assumps' }) m -- | Print a 'String' if the debug level is at least the supplied 'Int' From 74dd8a4916bf8b7c4d6395e1ddfe70b5aea95d7d Mon Sep 17 00:00:00 2001 From: Matthew Yacavone Date: Thu, 24 Feb 2022 11:46:12 -0800 Subject: [PATCH 054/105] add partially implemented mrWidenCoIndHyp, some minor cleanup --- src/SAWScript/Prover/MRSolver/Monad.hs | 8 ++--- src/SAWScript/Prover/MRSolver/SMT.hs | 1 - src/SAWScript/Prover/MRSolver/Solver.hs | 46 +++++++++++++++++++------ 3 files changed, 39 insertions(+), 16 deletions(-) diff --git a/src/SAWScript/Prover/MRSolver/Monad.hs b/src/SAWScript/Prover/MRSolver/Monad.hs index 116965fa66..fd4ce458c2 100644 --- a/src/SAWScript/Prover/MRSolver/Monad.hs +++ b/src/SAWScript/Prover/MRSolver/Monad.hs @@ -127,10 +127,10 @@ instance PrettyInCtx MRFailure where prettyInCtx (CoIndHypMismatchWidened nm1 nm2 _) = ppWithPrefixSep "[Internal] Trying to widen co-inductive hypothesis on:" nm1 "," nm2 prettyInCtx (CoIndHypMismatchFailure (tm1, tm2) (tm1', tm2')) = - vsepM [return "Could not match co-inductive hypotheis:", - ppWithPrefixSep "" tm1' "|=" tm2', - return "with goal:", - ppWithPrefixSep "" tm1 "|=" tm2] + do pp <- ppWithPrefixSep "" tm1 "|=" tm2 + pp' <- ppWithPrefixSep "" tm1' "|=" tm2' + return $ "Could not match co-inductive hypothesis:" <> pp' <> line <> + "with goal:" <> pp prettyInCtx (MRFailureLocalVar x err) = local (x:) $ prettyInCtx err prettyInCtx (MRFailureCtx ctx err) = diff --git a/src/SAWScript/Prover/MRSolver/SMT.hs b/src/SAWScript/Prover/MRSolver/SMT.hs index 608f4ae9bd..f597b35756 100644 --- a/src/SAWScript/Prover/MRSolver/SMT.hs +++ b/src/SAWScript/Prover/MRSolver/SMT.hs @@ -17,7 +17,6 @@ namely 'mrProvable' and 'mrProveEq'. module SAWScript.Prover.MRSolver.SMT where import qualified Data.Vector as V -import Control.Monad.Reader import Control.Monad.Except import Data.Map (Map) diff --git a/src/SAWScript/Prover/MRSolver/Solver.hs b/src/SAWScript/Prover/MRSolver/Solver.hs index 66defa2ded..49452fe4d6 100644 --- a/src/SAWScript/Prover/MRSolver/Solver.hs +++ b/src/SAWScript/Prover/MRSolver/Solver.hs @@ -114,7 +114,6 @@ C |- F e1 ... en >>= k |= F' e1' ... em' >>= k': module SAWScript.Prover.MRSolver.Solver where -import Control.Monad.Reader import Control.Monad.Except import qualified Data.Map as Map @@ -458,16 +457,21 @@ mrRefines' m1@(FunBind f1 args1 k1) m2@(FunBind f2 args2 k2) = mrGetFunAssump f1 >>= \maybe_fassump -> case (maybe_coIndHyp, maybe_fassump) of - -- If we have a co-inductive assumption that f1 args1' |= f2 args2', then - -- prove that args1 = args1' and args2 = args2', and then that k1 |= k2 - (Just coIndHyp, _) -> - do (args1', args2') <- instantiateCoIndHyp coIndHyp - eq1 <- and <$> zipWithM mrProveEq args1' args1 - eq2 <- and <$> zipWithM mrProveEq args2' args2 - if eq1 && eq2 then mrRefinesFun k1 k2 - else let m1' = FunBind f1 args1' CompFunReturn - m2' = FunBind f2 args2' CompFunReturn - in throwError (CoIndHypMismatchFailure (m1, m2) (m1', m2')) + -- If we have a co-inductive assumption that f1 args1' |= f2 args2': + -- * If it is convertible to our goal, continue and prove that k1 |= k2 + -- * If it can be widened with our goal, restart the current proof branch + -- with the widened hypothesis (done by throwing a + -- 'CoIndHypMismatchWidened' error for 'withCoIndHyp' to catch) + -- * Otherwise, throw a 'CoIndHypMismatchFailure' error. + (Just hyp, _) -> + do (args1', args2') <- instantiateCoIndHyp hyp + mrWidenCoIndHyp f1 f2 args1 args2 args1' args2' >>= \case + Convertible -> mrRefinesFun k1 k2 + Widened hyp' -> throwError (CoIndHypMismatchWidened f1 f2 hyp') + CouldNotWiden -> + let m1' = FunBind f1 args1' CompFunReturn + m2' = FunBind f2 args2' CompFunReturn + in throwError (CoIndHypMismatchFailure (m1, m2) (m1', m2')) -- If we have an assumption that f1 args' refines some rhs, then prove that -- args1 = args' and then that rhs refines m2 @@ -600,6 +604,26 @@ mrRefinesFun f1 f2 mrRefinesFun _ _ = error "mrRefinesFun: unreachable!" +-- | The result type of 'mrWidenCoIndHyp' +data WidenCoIndHypResult = Convertible | Widened CoIndHyp | CouldNotWiden + +-- | Given a goal and a co-inductive hypothesis over the same pair of function +-- names, try to widen them into a more general co-inductive hypothesis which +-- implies both the given goal and the given co-inductive hypothesis. Returns +-- 'Convertible' if the goal and co-inductive hypothesis are convertible (and +-- therefore no widening needs to be done), 'Widened' if widening was +-- successful, and 'CouldNotWiden' if the terms are neither convertible nor +-- able to be widened. +-- FIXME: Finish implementing this function! +mrWidenCoIndHyp :: FunName -> FunName -> + [Term] -> [Term] -> [Term] -> [Term] -> + MRM WidenCoIndHypResult +mrWidenCoIndHyp _f1 _f2 args1 args2 args1' args2' = + do eq1 <- and <$> zipWithM mrProveEq args1' args1 + eq2 <- and <$> zipWithM mrProveEq args2' args2 + return $ if eq1 && eq2 then Convertible else CouldNotWiden + + ---------------------------------------------------------------------- -- * External Entrypoints ---------------------------------------------------------------------- From ae0a7747d19d52af50f1101ca80a995278f9eb48 Mon Sep 17 00:00:00 2001 From: Matthew Yacavone Date: Thu, 24 Feb 2022 18:54:11 -0500 Subject: [PATCH 055/105] raise sn2-tests timeout to 2h --- .github/workflows/ci.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 5e88f61ad0..08e80fc9a2 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -498,7 +498,7 @@ jobs: s2n-tests: name: "Test s2n proofs" - timeout-minutes: 60 + timeout-minutes: 120 needs: build runs-on: ubuntu-18.04 strategy: From 0959890d55244f568fca5448d76e164ab48f1435 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Mon, 28 Feb 2022 16:40:40 -0800 Subject: [PATCH 056/105] wrote the logic to generalize coinductive hypotheses --- src/SAWScript/Prover/MRSolver/Monad.hs | 122 +++++++++++---------- src/SAWScript/Prover/MRSolver/SMT.hs | 13 ++- src/SAWScript/Prover/MRSolver/Solver.hs | 136 ++++++++++++++++-------- 3 files changed, 167 insertions(+), 104 deletions(-) diff --git a/src/SAWScript/Prover/MRSolver/Monad.hs b/src/SAWScript/Prover/MRSolver/Monad.hs index fd4ce458c2..a22f8be5f5 100644 --- a/src/SAWScript/Prover/MRSolver/Monad.hs +++ b/src/SAWScript/Prover/MRSolver/Monad.hs @@ -66,8 +66,6 @@ data MRFailure | MalformedDefsFun Term | MalformedComp Term | NotCompFunType Term - | CoIndHypMismatchWidened FunName FunName CoIndHyp - | CoIndHypMismatchFailure (NormComp, NormComp) (NormComp, NormComp) -- | A local variable binding | MRFailureLocalVar LocalName MRFailure -- | Information about the context of the failure @@ -124,13 +122,6 @@ instance PrettyInCtx MRFailure where ppWithPrefix "Could not handle computation:" t prettyInCtx (NotCompFunType tp) = ppWithPrefix "Not a computation or computational function type:" tp - prettyInCtx (CoIndHypMismatchWidened nm1 nm2 _) = - ppWithPrefixSep "[Internal] Trying to widen co-inductive hypothesis on:" nm1 "," nm2 - prettyInCtx (CoIndHypMismatchFailure (tm1, tm2) (tm1', tm2')) = - do pp <- ppWithPrefixSep "" tm1 "|=" tm2 - pp' <- ppWithPrefixSep "" tm1' "|=" tm2' - return $ "Could not match co-inductive hypothesis:" <> pp' <> line <> - "with goal:" <> pp prettyInCtx (MRFailureLocalVar x err) = local (x:) $ prettyInCtx err prettyInCtx (MRFailureCtx ctx err) = @@ -244,14 +235,20 @@ data MRState = MRState { mrsVars :: MRVarMap } +-- | The exception type for MR. Solver, which is either a 'MRFailure' or a +-- widening request +data MRExn = MRExnFailure MRFailure + | MRExnWiden FunName FunName [Either Int Int] + deriving Show + -- | Mr. Monad, the monad used by MR. Solver, which has 'MRInfo' as as a -- shared environment, 'MRState' as state, and 'MRFailure' as an exception -- type, all over an 'IO' monad newtype MRM a = MRM { unMRM :: ReaderT MRInfo (StateT MRState - (ExceptT MRFailure IO)) a } + (ExceptT MRExn IO)) a } deriving (Functor, Applicative, Monad, MonadIO, MonadReader MRInfo, MonadState MRState, - MonadError MRFailure) + MonadError MRExn) instance MonadTerm MRM where mkTermF = liftSC1 scTermF @@ -301,23 +298,41 @@ runMRM sc timeout debug assumps m = mriUVars = [], mriCoIndHyps = Map.empty, mriAssumptions = true_tm } let init_st = MRState { mrsVars = Map.empty } - runExceptT $ flip evalStateT init_st $ flip runReaderT init_info $ unMRM m + res <- runExceptT $ flip evalStateT init_st $ + flip runReaderT init_info $ unMRM m + case res of + Right a -> return $ Right a + Left (MRExnFailure failure) -> return $ Left failure + Left exn -> fail ("runMRM: unexpected internal exception: " ++ show exn) + +-- | Throw an 'MRFailure' +throwMRFailure :: MRFailure -> MRM a +throwMRFailure = throwError . MRExnFailure -- | Apply a function to any failure thrown by an 'MRM' computation -mapFailure :: (MRFailure -> MRFailure) -> MRM a -> MRM a -mapFailure f m = catchError m (throwError . f) +mapMRFailure :: (MRFailure -> MRFailure) -> MRM a -> MRM a +mapMRFailure f m = catchError m $ \case + MRExnFailure failure -> throwError $ MRExnFailure $ f failure + e -> throwError e + +-- | Catch any 'MRFailure' raised by a computation +catchFailure :: MRM a -> (MRFailure -> MRM a) -> MRM a +catchFailure m f = + m `catchError` \case + MRExnFailure failure -> f failure + e -> throwError e -- | Try two different 'MRM' computations, combining their failures if needed. -- Note that the 'MRState' will reset if the first computation fails. mrOr :: MRM a -> MRM a -> MRM a mrOr m1 m2 = - catchError m1 $ \err1 -> - catchError m2 $ \err2 -> - throwError $ MRFailureDisj err1 err2 + catchFailure m1 $ \err1 -> + catchFailure m2 $ \err2 -> + throwMRFailure $ MRFailureDisj err1 err2 -- | Run an 'MRM' computation in an extended failure context withFailureCtx :: FailCtx -> MRM a -> MRM a -withFailureCtx ctx = mapFailure (MRFailureCtx ctx) +withFailureCtx ctx = mapMRFailure (MRFailureCtx ctx) {- -- | Catch any errors thrown by a computation and coerce them to a 'Left' @@ -430,16 +445,19 @@ uniquifyName nm nms = Just nm' -> nm' Nothing -> error "uniquifyName" +-- | Turn a list of 'LocalName's into one names not in a list, adding suffixes +-- if necessary +uniquifyNames :: [LocalName] -> [LocalName] -> [LocalName] +uniquifyNames [] _ = [] +uniquifyNames (nm:nms) nms_other = + let nm' = uniquifyName nm nms_other in + nm' : uniquifyNames nms (nm' : nms_other) + -- | Run a MR Solver computation in a context extended with a universal -- variable, which is passed as a 'Term' to the sub-computation. Note that any -- assumptions made in the sub-computation will be lost when it completes. withUVar :: LocalName -> Type -> (Term -> MRM a) -> MRM a -withUVar nm tp m = - do nm' <- uniquifyName nm <$> map fst <$> mrUVars - assumps' <- mrAssumptions >>= liftTerm 0 1 - local (\info -> info { mriUVars = (nm',tp) : mriUVars info, - mriAssumptions = assumps' }) $ - mapFailure (MRFailureLocalVar nm') (liftSC1 scLocalVar 0 >>= m) +withUVar nm (Type tp) m = withUVars [(nm,tp)] (\[v] -> m v) -- | Run a MR Solver computation in a context extended with a universal variable -- and pass it the lifting (in the sense of 'incVars') of an MR Solver term @@ -453,16 +471,25 @@ withUVarLift nm tp t m = -- The variables are bound "outside in", meaning the first variable in the list -- is bound outermost, and so will have the highest deBruijn index. withUVars :: [(LocalName,Term)] -> ([Term] -> MRM a) -> MRM a -withUVars = helper [] where - -- The extra input list gives the variables that have already been bound, in - -- order from most to least recently bound - helper :: [Term] -> [(LocalName,Term)] -> ([Term] -> MRM a) -> MRM a - helper vars [] m = m $ reverse vars - helper vars ((nm,tp):ctx) m = - -- FIXME: I think substituting here is wrong, but works on closed terms, so - -- it's fine to use at the top level at least... - substTerm 0 vars tp >>= \tp' -> - withUVarLift nm (Type tp') vars $ \var vars' -> helper (var:vars') ctx m +withUVars [] f = f [] +withUVars ctx f = + do nms <- uniquifyNames (map fst ctx) <$> map fst <$> mrUVars + let ctx_u = zip nms $ map (Type . snd) ctx + assumps' <- mrAssumptions >>= liftTerm 0 (length ctx) + vars <- reverse <$> mapM (liftSC1 scLocalVar) [0 .. length ctx - 1] + local (\info -> info { mriUVars = reverse ctx_u ++ mriUVars info, + mriAssumptions = assumps' }) $ + foldr (\nm m -> mapMRFailure (MRFailureLocalVar nm) m) (f vars) nms + +-- | Run a MR Solver in a top-level context, i.e., with no uvars or assumptions +withNoUVars :: MRM a -> MRM a +withNoUVars m = + do true_tm <- liftSC1 scBool True + local (\info -> info { mriUVars = [], mriAssumptions = true_tm }) m + +-- | Run a MR Solver in a context of only the specified UVars, no others +withOnlyUVars :: [(LocalName,Term)] -> MRM a -> MRM a +withOnlyUVars vars m = withNoUVars $ withUVars vars $ const m -- | Build 'Term's for all the uvars currently in scope, ordered from least to -- most recently bound @@ -699,32 +726,13 @@ _mrSubstEVarsStrict = mrSubstEVarsStrict mrGetCoIndHyp :: FunName -> FunName -> MRM (Maybe CoIndHyp) mrGetCoIndHyp nm1 nm2 = Map.lookup (nm1, nm2) <$> mrCoIndHyps --- | Run a compuation under the additional co-inductive assumption that --- @forall x1, ..., xn. F y1 ... ym |= G z1 ... zl@, where @F@ and @G@ are --- the given 'FunName's, @y1, ..., ym@ and @z1, ..., zl@ are the given --- argument lists, and @x1, ..., xn@ is the current context of uvars. If --- while running the given computation a 'CoIndHypMismatchWidened' error is --- reached with the given names, the state is restored and the computation is --- re-run with the widened hypothesis. This is done recursively, meaning this --- function will only return once no 'CoIndHypMismatchWidened' errors are --- raised with the given names. -withCoIndHyp :: FunName -> [Term] -> FunName -> [Term] -> MRM a -> MRM a -withCoIndHyp nm1 args1 nm2 args2 m = - do ctx <- mrUVarCtx - withCoIndHyp' (nm1, nm2) (CoIndHyp ctx args1 args2) m - --- | The main loop of 'withCoIndHyp' -withCoIndHyp' :: (FunName, FunName) -> CoIndHyp -> MRM a -> MRM a -withCoIndHyp' (nm1, nm2) hyp@(CoIndHyp _ args1 args2) m = +-- | Run a compuation under an additional co-inductive assumption +withCoIndHypRaw :: FunName -> FunName -> CoIndHyp -> MRM a -> MRM a +withCoIndHypRaw nm1 nm2 hyp@(CoIndHyp _ args1 args2) m = do mrDebugPPPrefixSep 1 "withCoIndHyp" (FunBind nm1 args1 CompFunReturn) "|=" (FunBind nm2 args2 CompFunReturn) - st <- get hyps' <- Map.insert (nm1, nm2) hyp <$> mrCoIndHyps - (local (\info -> info { mriCoIndHyps = hyps' }) m) `catchError` \case - CoIndHypMismatchWidened nm1' nm2' hyp' | nm1 == nm1' && nm2 == nm2' - -> -- FIXME: Could restoring the state here cause any problems? - put st >> withCoIndHyp' (nm1, nm2) hyp' m - e -> throwError e + local (\info -> info { mriCoIndHyps = hyps' }) m -- | Generate fresh evars for the context of a 'CoIndHyp' and -- substitute them into its arguments and right-hand side diff --git a/src/SAWScript/Prover/MRSolver/SMT.hs b/src/SAWScript/Prover/MRSolver/SMT.hs index f597b35756..7043c9f565 100644 --- a/src/SAWScript/Prover/MRSolver/SMT.hs +++ b/src/SAWScript/Prover/MRSolver/SMT.hs @@ -177,6 +177,7 @@ mrProvableRaw prop_term = -- | Test if a Boolean term over the current uvars is provable given the current -- assumptions mrProvable :: Term -> MRM Bool +mrProvable (asBool -> Just b) = return b mrProvable bool_tm = do assumps <- mrAssumptions prop <- liftSC2 scImplies assumps bool_tm >>= liftSC1 scEqTrue @@ -276,12 +277,10 @@ mrAssertProveEq :: Term -> Term -> MRM () mrAssertProveEq t1 t2 = do success <- mrProveEq t1 t2 if success then return () else - throwError (TermsNotEq t1 t2) + throwMRFailure (TermsNotEq t1 t2) --- | The main workhorse for 'prProveEq'. Build a Boolean term expressing that --- the third and fourth arguments, whose type is given by the second. This is --- done in a continuation monad so that the output term can be in a context with --- additional universal variables. +-- | The main workhorse for 'mrProveEq'. Build a Boolean term expressing that +-- the third and fourth arguments, whose type is given by the second. mrProveEqH :: Map MRVar MRVarInfo -> Term -> Term -> Term -> MRM TermInCtx {- @@ -309,6 +308,10 @@ mrProveEqH var_map _tp t1 (asEVarApp var_map -> Just (evar, args, Nothing)) = success <- mrTrySetAppliedEVar evar args t1' TermInCtx [] <$> liftSC1 scBool success +-- For unit types, always return true +mrProveEqH _ (asTupleType -> Just []) _ _ = + TermInCtx [] <$> liftSC1 scBool True + -- For the nat, bitvector, Boolean, and integer types, call mrProveEqSimple mrProveEqH _ (asDataType -> Just (pn, [])) t1 t2 | primName pn == "Prelude.Nat" = diff --git a/src/SAWScript/Prover/MRSolver/Solver.hs b/src/SAWScript/Prover/MRSolver/Solver.hs index 49452fe4d6..d6e135626e 100644 --- a/src/SAWScript/Prover/MRSolver/Solver.hs +++ b/src/SAWScript/Prover/MRSolver/Solver.hs @@ -114,6 +114,8 @@ C |- F e1 ... en >>= k |= F' e1' ... em' >>= k': module SAWScript.Prover.MRSolver.Solver where +import Data.Either +import Data.List (findIndices) import Control.Monad.Except import qualified Data.Map as Map @@ -139,7 +141,7 @@ asLRTList (asCtor -> Just (primName -> "Prelude.LRT_Cons", [lrt, lrts])) = do tp <- liftSC2 scGlobalApply "Prelude.lrtToType" [lrt] tp_norm_closed <- liftSC1 scWhnf tp >>= piUVarsM (tp_norm_closed :) <$> asLRTList lrts -asLRTList t = throwError (MalformedLetRecTypes t) +asLRTList t = throwMRFailure (MalformedLetRecTypes t) -- | Match a right-nested series of pairs. This is similar to 'asTupleValue' -- except that it expects a unit value to always be at the end. @@ -179,7 +181,7 @@ mrFreshLetRecVars lrts defs_f = defs_tm <- mrApplyAll defs_f fun_tms defs <- case asNestedPairs defs_tm of Just defs -> return defs - Nothing -> throwError (MalformedDefsFun defs_f) + Nothing -> throwMRFailure (MalformedDefsFun defs_f) -- Remember the body associated with each fresh function constant zipWithM_ (\f body -> @@ -269,7 +271,7 @@ normComp (CompTerm t) = ((asGlobalFunName -> Just f), args) -> return $ FunBind f args CompFunReturn - _ -> throwError (MalformedComp t) + _ -> throwMRFailure (MalformedComp t) -- | Bind a computation in whnf with a function, and normalize @@ -314,16 +316,16 @@ applyNormCompFun f arg = applyCompFun f arg >>= normComp -- not allowed, either because it is a global function we are treating as opaque -- or because it is a locally-bound function variable mrLookupFunDef :: FunName -> MRM Term -mrLookupFunDef f@(GlobalName _) = throwError (CannotLookupFunDef f) +mrLookupFunDef f@(GlobalName _) = throwMRFailure (CannotLookupFunDef f) mrLookupFunDef f@(LocalName var) = mrVarInfo var >>= \case Just (FunVarInfo body) -> return body - Just _ -> throwError (CannotLookupFunDef f) + Just _ -> throwMRFailure (CannotLookupFunDef f) Nothing -> error "mrLookupFunDef: unknown variable!" -- | Unfold a call to function @f@ in term @f args >>= g@ mrUnfoldFunBind :: FunName -> [Term] -> Mark -> CompFun -> MRM Comp -mrUnfoldFunBind f _ mark _ | inMark f mark = throwError (RecursiveUnfold f) +mrUnfoldFunBind f _ mark _ | inMark f mark = throwMRFailure (RecursiveUnfold f) mrUnfoldFunBind f args mark g = do f_def <- mrLookupFunDef f CompBind <$> @@ -367,8 +369,8 @@ mrRefines t1 t2 = mrRefines' :: NormComp -> NormComp -> MRM () mrRefines' (ReturnM e1) (ReturnM e2) = mrAssertProveEq e1 e2 mrRefines' (ErrorM _) (ErrorM _) = return () -mrRefines' (ReturnM e) (ErrorM _) = throwError (ReturnNotError e) -mrRefines' (ErrorM _) (ReturnM e) = throwError (ReturnNotError e) +mrRefines' (ReturnM e) (ErrorM _) = throwMRFailure (ReturnNotError e) +mrRefines' (ErrorM _) (ReturnM e) = throwMRFailure (ReturnNotError e) mrRefines' (MaybeElim (Type (asEq -> Just (tp,e1,e2))) m1 f1 _) m2 = do cond <- mrEq' tp e1 e2 not_cond <- liftSC1 scNot cond @@ -430,9 +432,9 @@ mrRefines' (OrM m1 m1') m2 = -- FIXME: the following cases don't work unless we either allow evars to be set -- to NormComps or we can turn NormComps back into terms mrRefines' m1@(FunBind (EVarFunName _) _ _) m2 = - throwError (CompsDoNotRefine m1 m2) + throwMRFailure (CompsDoNotRefine m1 m2) mrRefines' m1 m2@(FunBind (EVarFunName _) _ _) = - throwError (CompsDoNotRefine m1 m2) + throwMRFailure (CompsDoNotRefine m1 m2) {- mrRefines' (FunBind (EVarFunName evar) args CompFunReturn) m2 = mrGetEVar evar >>= \case @@ -464,14 +466,8 @@ mrRefines' m1@(FunBind f1 args1 k1) m2@(FunBind f2 args2 k2) = -- 'CoIndHypMismatchWidened' error for 'withCoIndHyp' to catch) -- * Otherwise, throw a 'CoIndHypMismatchFailure' error. (Just hyp, _) -> - do (args1', args2') <- instantiateCoIndHyp hyp - mrWidenCoIndHyp f1 f2 args1 args2 args1' args2' >>= \case - Convertible -> mrRefinesFun k1 k2 - Widened hyp' -> throwError (CoIndHypMismatchWidened f1 f2 hyp') - CouldNotWiden -> - let m1' = FunBind f1 args1' CompFunReturn - m2' = FunBind f2 args2' CompFunReturn - in throwError (CoIndHypMismatchFailure (m1, m2) (m1', m2')) + matchCoIndHyp f1 f2 hyp args1 args2 >> + mrRefinesFun k1 k2 -- If we have an assumption that f1 args' refines some rhs, then prove that -- args1 = args' and then that rhs refines m2 @@ -506,7 +502,7 @@ mrRefines' m1@(FunBind f1 args1 k1) m2@(FunBind f2 args2 k2) = -- continuation on the other side, but we don't know how to do that, so give -- up _ -> - throwError (CompsDoNotRefine m1 m2) + throwMRFailure (CompsDoNotRefine m1 m2) {- FIXME: handle FunBind on just one side mrRefines' m1@(FunBind f@(GlobalName _) args k1) m2 = @@ -521,7 +517,7 @@ mrRefines' m1@(FunBind f@(GlobalName _) args k1) m2 = Nothing -> -- We don't want to do inter-procedural proofs, so if we don't know anything -- about f already then give up - throwError (CompsDoNotRefine m1 m2) + throwMRFailure (CompsDoNotRefine m1 m2) -} @@ -548,7 +544,7 @@ mrRefines' m1@(FunBind f1 args1 k1) m2 = -- form m2' >>= k2 where f1 args1 |= m2' and k1 |= k2, but we don't know how -- to do this splitting, so give up _ -> - throwError (CompsDoNotRefine m1 m2) + throwMRFailure (CompsDoNotRefine m1 m2) mrRefines' m1 m2@(FunBind f2 args2 k2) = @@ -571,7 +567,7 @@ mrRefines' m1 m2@(FunBind f2 args2 k2) = -- form m1' >>= k1 where m1' |= f2 args2 and k1 |= k2, but we don't know how -- to do this splitting, so give up _ -> - throwError (CompsDoNotRefine m1 m2) + throwMRFailure (CompsDoNotRefine m1 m2) -- NOTE: the rules that introduce existential variables need to go last, so that @@ -588,7 +584,7 @@ mrRefines' (ForallM tp f1) m2 = mrRefines m1' m2 -- If none of the above cases match, then fail -mrRefines' m1 m2 = throwError (CompsDoNotRefine m1 m2) +mrRefines' m1 m2 = throwMRFailure (CompsDoNotRefine m1 m2) -- | Prove that one function refines another for all inputs @@ -604,24 +600,80 @@ mrRefinesFun f1 f2 mrRefinesFun _ _ = error "mrRefinesFun: unreachable!" --- | The result type of 'mrWidenCoIndHyp' -data WidenCoIndHypResult = Convertible | Widened CoIndHyp | CouldNotWiden - --- | Given a goal and a co-inductive hypothesis over the same pair of function --- names, try to widen them into a more general co-inductive hypothesis which --- implies both the given goal and the given co-inductive hypothesis. Returns --- 'Convertible' if the goal and co-inductive hypothesis are convertible (and --- therefore no widening needs to be done), 'Widened' if widening was --- successful, and 'CouldNotWiden' if the terms are neither convertible nor --- able to be widened. --- FIXME: Finish implementing this function! -mrWidenCoIndHyp :: FunName -> FunName -> - [Term] -> [Term] -> [Term] -> [Term] -> - MRM WidenCoIndHypResult -mrWidenCoIndHyp _f1 _f2 args1 args2 args1' args2' = - do eq1 <- and <$> zipWithM mrProveEq args1' args1 - eq2 <- and <$> zipWithM mrProveEq args2' args2 - return $ if eq1 && eq2 then Convertible else CouldNotWiden +-- | Run a compuation under the additional co-inductive assumption that +-- @forall x1, ..., xn. F y1 ... ym |= G z1 ... zl@, where @F@ and @G@ are +-- the given 'FunName's, @y1, ..., ym@ and @z1, ..., zl@ are the given +-- argument lists, and @x1, ..., xn@ is the current context of uvars. If +-- while running the given computation a 'CoIndHypMismatchWidened' error is +-- reached with the given names, the state is restored and the computation is +-- re-run with the widened hypothesis. +withCoIndHyp :: FunName -> [Term] -> FunName -> [Term] -> MRM a -> MRM a +withCoIndHyp nm1 args1 nm2 args2 m = + do ctx <- mrUVarCtx + withCoIndHyp' nm1 nm2 (CoIndHyp ctx args1 args2) m + +-- | Test if a 'MRFailure' contains a widening + +-- | The main loop of 'withCoIndHyp' +withCoIndHyp' :: FunName -> FunName -> CoIndHyp -> MRM a -> MRM a +withCoIndHyp' nm1 nm2 hyp m = + withCoIndHypRaw nm1 nm2 hyp m `catchError` \case + MRExnWiden nm1' nm2' new_vars + | nm1 == nm1' && nm2 == nm2' -> + -- NOTE: the state gets reset here because we defined MRM with ExceptT + -- at a lower level than StateT + do hyp' <- generalizeCoIndHyp hyp new_vars + withCoIndHyp' nm1 nm2 hyp' m + e -> throwError e + +-- | Test that a coinductive hypothesis for the given function names matches the +-- given arguments, otherwise throw an exception saying that widening is needed +matchCoIndHyp :: FunName -> FunName -> CoIndHyp -> [Term] -> [Term] -> MRM () +matchCoIndHyp f1 f2 hyp args1 args2 = + do (args1', args2') <- instantiateCoIndHyp hyp + eqs1 <- zipWithM mrProveEq args1' args1 + eqs2 <- zipWithM mrProveEq args2' args2 + if and (eqs1 ++ eqs2) then return () else + throwError $ MRExnWiden f1 f2 + (map Left (findIndices not eqs1) ++ map Right (findIndices not eqs1)) + +coIndHypArg :: CoIndHyp -> Either Int Int -> Term +coIndHypArg (CoIndHyp _ args1 _) (Left i) = args1 !! i +coIndHypArg (CoIndHyp _ _ args2) (Right i) = args2 !! i + +-- | Generalize some of the arguments of a coinductive hypothesis +generalizeCoIndHyp :: CoIndHyp -> [Either Int Int] -> MRM CoIndHyp +generalizeCoIndHyp hyp [] = return hyp +generalizeCoIndHyp hyp (arg_spec:arg_specs) = + withOnlyUVars (coIndHypCtx hyp) $ do + -- Get the arg and type associated with arg_spec + let arg = coIndHypArg hyp arg_spec + arg_tp <- mrTypeOf arg + -- Sort out the other args that equal arg + eq_uneq_specs <- forM arg_specs $ \spec' -> + do let arg' = coIndHypArg hyp spec' + tp' <- mrTypeOf arg' + tps_eq <- mrConvertible arg_tp tp' + args_eq <- if tps_eq then mrProveEq arg arg' else return False + return $ if args_eq then Left spec' else Right spec' + let (eq_specs, uneq_specs) = partitionEithers eq_uneq_specs + -- Add a new variable of type arg_tp, set all eq_specs to it, and recurse + hyp' <- generalizeCoIndHypArgs hyp arg_tp eq_specs + generalizeCoIndHyp hyp' uneq_specs + +-- | Add a new variable of the given type to the context of a coinductive +-- hypothesis and set the specified arguments to that new variable +generalizeCoIndHypArgs :: CoIndHyp -> Term -> [Either Int Int] -> MRM CoIndHyp +generalizeCoIndHypArgs (CoIndHyp ctx args1 args2) tp specs = + do let set_arg i args = + take i args ++ (Unshared $ LocalVar 0) : drop (i+1) args + let (specs1, specs2) = partitionEithers specs + -- NOTE: need to lift the arguments because we are adding a variable + args1' <- liftTermLike 0 1 args1 + args2' <- liftTermLike 0 1 args2 + let args1'' = foldr set_arg args1' specs1 + args2'' = foldr set_arg args2' specs2 + return $ CoIndHyp (ctx ++ [("z",tp)]) args1'' args2'' ---------------------------------------------------------------------- @@ -645,7 +697,7 @@ askMRSolver sc dlvl timeout t1 t2 = withUVars uvar_ctx $ \vars -> do tps_are_eq <- mrConvertible tp1 tp2 if tps_are_eq then return () else - throwError (TypesNotEq (Type tp1) (Type tp2)) + throwMRFailure (TypesNotEq (Type tp1) (Type tp2)) mrDebugPPPrefixSep 1 "mr_solver" t1 "|=" t2 m1 <- mrApplyAll t1 vars >>= normCompTerm m2 <- mrApplyAll t2 vars >>= normCompTerm From 7df316cb4e9f6ce3fe1f3dcc936e119801d1a33b Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Tue, 1 Mar 2022 06:48:59 -0800 Subject: [PATCH 057/105] fixed a bug in mrTypeOf, which was using the type context in the wrong order; fixed generalizeCoIndHyp, which was not generalizing the arg_spec itself that was being generalized; added FunNames to and a PrettyInCtx instance for CoIndHyp --- src/SAWScript/Prover/MRSolver/Monad.hs | 45 ++++++++++++++++------- src/SAWScript/Prover/MRSolver/Solver.hs | 47 ++++++++++++++----------- src/SAWScript/Prover/MRSolver/Term.hs | 23 ++++++++++++ 3 files changed, 82 insertions(+), 33 deletions(-) diff --git a/src/SAWScript/Prover/MRSolver/Monad.hs b/src/SAWScript/Prover/MRSolver/Monad.hs index a22f8be5f5..fe93b073c5 100644 --- a/src/SAWScript/Prover/MRSolver/Monad.hs +++ b/src/SAWScript/Prover/MRSolver/Monad.hs @@ -79,8 +79,8 @@ ppWithPrefix :: PrettyInCtx a => String -> a -> PPInCtxM SawDoc ppWithPrefix str a = (pretty str <>) <$> nest 2 <$> (line <>) <$> prettyInCtx a -- | Pretty-print two objects, prefixed with a 'String' and with a separator -ppWithPrefixSep :: PrettyInCtx a => String -> a -> String -> a -> - PPInCtxM SawDoc +ppWithPrefixSep :: (PrettyInCtx a, PrettyInCtx b) => + String -> a -> String -> b -> PPInCtxM SawDoc ppWithPrefixSep d1 t2 d3 t4 = prettyInCtx t2 >>= \d2 -> prettyInCtx t4 >>= \d4 -> return $ group (pretty d1 <> nest 2 (line <> d2) <> line <> @@ -175,6 +175,10 @@ data CoIndHyp = CoIndHyp { -- from outermost to innermost; that is, the uvars as "seen from outside their -- scope", which is the reverse of the order of 'mrUVars', below coIndHypCtx :: [(LocalName,Term)], + -- | The LHS function name + coIndHypLHSFun :: FunName, + -- | The RHS function name + coIndHypRHSFun :: FunName, -- | The LHS argument expressions @y1, ..., ym@ over the 'coIndHypCtx' uvars coIndHypLHS :: [Term], -- | The RHS argument expressions @y1, ..., ym@ over the 'coIndHypCtx' uvars @@ -185,6 +189,14 @@ data CoIndHyp = CoIndHyp { -- names type CoIndHyps = Map (FunName, FunName) CoIndHyp +instance PrettyInCtx CoIndHyp where + prettyInCtx (CoIndHyp ctx f1 f2 args1 args2) = + local (const $ map fst $ reverse ctx) $ + prettyAppList [return (ppCtx ctx <> "."), + prettyInCtx (FunBind f1 args1 CompFunReturn), + return "|=", + prettyInCtx (FunBind f2 args2 CompFunReturn)] + -- | An assumption that a named function refines some specificaiton. This has -- the form -- @@ -409,11 +421,20 @@ mrApplyAll f args = liftSC2 scApplyAll f args >>= liftSC1 betaNormalize -- types as SAW core 'Term's, with the least recently bound uvar first, i.e., in -- the order as seen "from the outside" mrUVarCtx :: MRM [(LocalName,Term)] -mrUVarCtx = reverse <$> map (\(nm,Type tp) -> (nm,tp)) <$> mrUVars +mrUVarCtx = reverse <$> mrUVarCtxRev + +-- | Get the current context of uvars as a list of variable names and their +-- types as SAW core 'Term's, with the most recently bound uvar first, i.e., in +-- the order as seen "from the inside" +mrUVarCtxRev :: MRM [(LocalName,Term)] +mrUVarCtxRev = map (\(nm,Type tp) -> (nm,tp)) <$> mrUVars -- | Get the type of a 'Term' in the current uvar context mrTypeOf :: Term -> MRM Term -mrTypeOf t = mrUVarCtx >>= \ctx -> liftSC2 scTypeOf' (map snd ctx) t +mrTypeOf t = + -- NOTE: scTypeOf' wants the type context in the most recently bound var + -- first, i.e., in the mrUVarCtxRev order + mrUVarCtxRev >>= \ctx -> liftSC2 scTypeOf' (map snd $ reverse ctx) t -- | Check if two 'Term's are convertible in the 'MRM' monad mrConvertible :: Term -> Term -> MRM Bool @@ -434,7 +455,7 @@ mrFunOutType fname args = debugPrint 0 ("Expected: " ++ show (length vars) ++ ", found: " ++ show (length args)) debugPretty 0 ("For function: " <> pp_fname <> " with type: " <> pp_ftype) - error"mrFunOutType" + error "mrFunOutType" -- | Turn a 'LocalName' into one not in a list, adding a suffix if necessary uniquifyName :: LocalName -> [LocalName] -> LocalName @@ -727,11 +748,11 @@ mrGetCoIndHyp :: FunName -> FunName -> MRM (Maybe CoIndHyp) mrGetCoIndHyp nm1 nm2 = Map.lookup (nm1, nm2) <$> mrCoIndHyps -- | Run a compuation under an additional co-inductive assumption -withCoIndHypRaw :: FunName -> FunName -> CoIndHyp -> MRM a -> MRM a -withCoIndHypRaw nm1 nm2 hyp@(CoIndHyp _ args1 args2) m = - do mrDebugPPPrefixSep 1 "withCoIndHyp" (FunBind nm1 args1 CompFunReturn) - "|=" (FunBind nm2 args2 CompFunReturn) - hyps' <- Map.insert (nm1, nm2) hyp <$> mrCoIndHyps +withCoIndHypRaw :: CoIndHyp -> MRM a -> MRM a +withCoIndHypRaw hyp m = + do debugPretty 1 ("withCoIndHyp" <+> ppInEmptyCtx hyp) + hyps' <- Map.insert (coIndHypLHSFun hyp, + coIndHypRHSFun hyp) hyp <$> mrCoIndHyps local (\info -> info { mriCoIndHyps = hyps' }) m -- | Generate fresh evars for the context of a 'CoIndHyp' and @@ -799,8 +820,8 @@ mrPPInCtx a = -- | Pretty-print the result of 'ppWithPrefixSep' relative to the current uvar -- context to 'stderr' if the debug level is at least the 'Int' provided -mrDebugPPPrefixSep :: PrettyInCtx a => Int -> String -> a -> String -> a -> - MRM () +mrDebugPPPrefixSep :: (PrettyInCtx a, PrettyInCtx b) => + Int -> String -> a -> String -> b -> MRM () mrDebugPPPrefixSep i pre a1 sp a2 = mrUVars >>= \ctx -> debugPretty i $ diff --git a/src/SAWScript/Prover/MRSolver/Solver.hs b/src/SAWScript/Prover/MRSolver/Solver.hs index d6e135626e..39b05c4d12 100644 --- a/src/SAWScript/Prover/MRSolver/Solver.hs +++ b/src/SAWScript/Prover/MRSolver/Solver.hs @@ -122,6 +122,7 @@ import qualified Data.Map as Map import Verifier.SAW.Term.Functor import Verifier.SAW.SharedTerm import Verifier.SAW.Recognizer +import Verifier.SAW.Term.Pretty import SAWScript.Prover.MRSolver.Term import SAWScript.Prover.MRSolver.Monad @@ -466,7 +467,7 @@ mrRefines' m1@(FunBind f1 args1 k1) m2@(FunBind f2 args2 k2) = -- 'CoIndHypMismatchWidened' error for 'withCoIndHyp' to catch) -- * Otherwise, throw a 'CoIndHypMismatchFailure' error. (Just hyp, _) -> - matchCoIndHyp f1 f2 hyp args1 args2 >> + matchCoIndHyp hyp args1 args2 >> mrRefinesFun k1 k2 -- If we have an assumption that f1 args' refines some rhs, then prove that @@ -608,44 +609,47 @@ mrRefinesFun _ _ = error "mrRefinesFun: unreachable!" -- reached with the given names, the state is restored and the computation is -- re-run with the widened hypothesis. withCoIndHyp :: FunName -> [Term] -> FunName -> [Term] -> MRM a -> MRM a -withCoIndHyp nm1 args1 nm2 args2 m = +withCoIndHyp f1 args1 f2 args2 m = do ctx <- mrUVarCtx - withCoIndHyp' nm1 nm2 (CoIndHyp ctx args1 args2) m + withCoIndHyp' (CoIndHyp ctx f1 f2 args1 args2) m -- | Test if a 'MRFailure' contains a widening -- | The main loop of 'withCoIndHyp' -withCoIndHyp' :: FunName -> FunName -> CoIndHyp -> MRM a -> MRM a -withCoIndHyp' nm1 nm2 hyp m = - withCoIndHypRaw nm1 nm2 hyp m `catchError` \case +withCoIndHyp' :: CoIndHyp -> MRM a -> MRM a +withCoIndHyp' hyp m = + withCoIndHypRaw hyp m `catchError` \case MRExnWiden nm1' nm2' new_vars - | nm1 == nm1' && nm2 == nm2' -> - -- NOTE: the state gets reset here because we defined MRM with ExceptT - -- at a lower level than StateT - do hyp' <- generalizeCoIndHyp hyp new_vars - withCoIndHyp' nm1 nm2 hyp' m + | coIndHypLHSFun hyp == nm1' && coIndHypRHSFun hyp == nm2' -> + -- NOTE: the state automatically gets reset here because we defined MRM + -- with ExceptT at a lower level than StateT + do mrDebugPPPrefixSep 1 "Widening recursive assumption for" nm1' "|=" nm2' + hyp' <- generalizeCoIndHyp hyp new_vars + withCoIndHyp' hyp' m e -> throwError e -- | Test that a coinductive hypothesis for the given function names matches the -- given arguments, otherwise throw an exception saying that widening is needed -matchCoIndHyp :: FunName -> FunName -> CoIndHyp -> [Term] -> [Term] -> MRM () -matchCoIndHyp f1 f2 hyp args1 args2 = +matchCoIndHyp :: CoIndHyp -> [Term] -> [Term] -> MRM () +matchCoIndHyp hyp args1 args2 = do (args1', args2') <- instantiateCoIndHyp hyp eqs1 <- zipWithM mrProveEq args1' args1 eqs2 <- zipWithM mrProveEq args2' args2 if and (eqs1 ++ eqs2) then return () else - throwError $ MRExnWiden f1 f2 + throwError $ MRExnWiden (coIndHypLHSFun hyp) (coIndHypRHSFun hyp) (map Left (findIndices not eqs1) ++ map Right (findIndices not eqs1)) coIndHypArg :: CoIndHyp -> Either Int Int -> Term -coIndHypArg (CoIndHyp _ args1 _) (Left i) = args1 !! i -coIndHypArg (CoIndHyp _ _ args2) (Right i) = args2 !! i +coIndHypArg (CoIndHyp _ _ _ args1 _) (Left i) = args1 !! i +coIndHypArg (CoIndHyp _ _ _ _ args2) (Right i) = args2 !! i + -- | Generalize some of the arguments of a coinductive hypothesis generalizeCoIndHyp :: CoIndHyp -> [Either Int Int] -> MRM CoIndHyp generalizeCoIndHyp hyp [] = return hyp -generalizeCoIndHyp hyp (arg_spec:arg_specs) = +generalizeCoIndHyp hyp all_specs@(arg_spec:arg_specs) = withOnlyUVars (coIndHypCtx hyp) $ do + mrDebugPPPrefixSep 2 "generalizeCoIndHyp" hyp "with arg specs" (show all_specs) -- Get the arg and type associated with arg_spec let arg = coIndHypArg hyp arg_spec arg_tp <- mrTypeOf arg @@ -657,14 +661,15 @@ generalizeCoIndHyp hyp (arg_spec:arg_specs) = args_eq <- if tps_eq then mrProveEq arg arg' else return False return $ if args_eq then Left spec' else Right spec' let (eq_specs, uneq_specs) = partitionEithers eq_uneq_specs - -- Add a new variable of type arg_tp, set all eq_specs to it, and recurse - hyp' <- generalizeCoIndHypArgs hyp arg_tp eq_specs + -- Add a new variable of type arg_tp, set all eq_specs plus our original + -- arg_spec to it, and recurse + hyp' <- generalizeCoIndHypArgs hyp arg_tp (arg_spec:eq_specs) generalizeCoIndHyp hyp' uneq_specs -- | Add a new variable of the given type to the context of a coinductive -- hypothesis and set the specified arguments to that new variable generalizeCoIndHypArgs :: CoIndHyp -> Term -> [Either Int Int] -> MRM CoIndHyp -generalizeCoIndHypArgs (CoIndHyp ctx args1 args2) tp specs = +generalizeCoIndHypArgs (CoIndHyp ctx f1 f2 args1 args2) tp specs = do let set_arg i args = take i args ++ (Unshared $ LocalVar 0) : drop (i+1) args let (specs1, specs2) = partitionEithers specs @@ -673,7 +678,7 @@ generalizeCoIndHypArgs (CoIndHyp ctx args1 args2) tp specs = args2' <- liftTermLike 0 1 args2 let args1'' = foldr set_arg args1' specs1 args2'' = foldr set_arg args2' specs2 - return $ CoIndHyp (ctx ++ [("z",tp)]) args1'' args2'' + return $ CoIndHyp (ctx ++ [("z",tp)]) f1 f2 args1'' args2'' ---------------------------------------------------------------------- diff --git a/src/SAWScript/Prover/MRSolver/Term.hs b/src/SAWScript/Prover/MRSolver/Term.hs index 4c8dd86991..21669abb60 100644 --- a/src/SAWScript/Prover/MRSolver/Term.hs +++ b/src/SAWScript/Prover/MRSolver/Term.hs @@ -1,6 +1,8 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} {- | Module : SAWScript.Prover.MRSolver.Term @@ -18,6 +20,7 @@ normalization - see @Solver.hs@ for the description of this normalization. module SAWScript.Prover.MRSolver.Term where +import Data.String import Data.IORef import Control.Monad.Reader import qualified Data.IntMap as IntMap @@ -264,6 +267,10 @@ showInCtx :: PrettyInCtx a => [LocalName] -> a -> String showInCtx ctx a = renderSawDoc defaultPPOpts $ runReader (prettyInCtx a) ctx +-- | Pretty-print an object in the empty SAW core context +ppInEmptyCtx :: PrettyInCtx a => a -> SawDoc +ppInEmptyCtx a = runReader (prettyInCtx a) [] + -- | A generic function for pretty-printing an object in a SAW core context of -- locally-bound names class PrettyInCtx a where @@ -276,6 +283,22 @@ instance PrettyInCtx Term where prettyAppList :: [PPInCtxM SawDoc] -> PPInCtxM SawDoc prettyAppList = fmap (group . hang 2 . vsep) . sequence +-- | FIXME: move this helper function somewhere better... +ppCtx :: [(LocalName,Term)] -> SawDoc +ppCtx = helper [] where + helper :: [LocalName] -> [(LocalName,Term)] -> SawDoc + helper _ [] = "" + helper ns ((n,tp):ctx) = + let ns' = n:ns in + ppTermInCtx defaultPPOpts ns' (Unshared $ LocalVar 0) <> ":" <> + ppTermInCtx defaultPPOpts ns tp <> ", " <> helper ns' ctx + +instance PrettyInCtx String where + prettyInCtx str = return $ fromString str + +instance PrettyInCtx SawDoc where + prettyInCtx pp = return pp + instance PrettyInCtx Type where prettyInCtx (Type t) = prettyInCtx t From 1f4ebc2d34d280d26a8b86a24a7462d4a16bcd25 Mon Sep 17 00:00:00 2001 From: Matthew Yacavone Date: Tue, 1 Mar 2022 11:56:21 -0800 Subject: [PATCH 058/105] resolve warning, remove old comment --- src/SAWScript/Prover/MRSolver/Solver.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/SAWScript/Prover/MRSolver/Solver.hs b/src/SAWScript/Prover/MRSolver/Solver.hs index 39b05c4d12..ecf5db66e8 100644 --- a/src/SAWScript/Prover/MRSolver/Solver.hs +++ b/src/SAWScript/Prover/MRSolver/Solver.hs @@ -122,7 +122,6 @@ import qualified Data.Map as Map import Verifier.SAW.Term.Functor import Verifier.SAW.SharedTerm import Verifier.SAW.Recognizer -import Verifier.SAW.Term.Pretty import SAWScript.Prover.MRSolver.Term import SAWScript.Prover.MRSolver.Monad @@ -613,8 +612,6 @@ withCoIndHyp f1 args1 f2 args2 m = do ctx <- mrUVarCtx withCoIndHyp' (CoIndHyp ctx f1 f2 args1 args2) m --- | Test if a 'MRFailure' contains a widening - -- | The main loop of 'withCoIndHyp' withCoIndHyp' :: CoIndHyp -> MRM a -> MRM a withCoIndHyp' hyp m = @@ -628,6 +625,7 @@ withCoIndHyp' hyp m = withCoIndHyp' hyp' m e -> throwError e + -- | Test that a coinductive hypothesis for the given function names matches the -- given arguments, otherwise throw an exception saying that widening is needed matchCoIndHyp :: CoIndHyp -> [Term] -> [Term] -> MRM () From 3c1393e716fd442e1cfcf01fa99293ab4c2ff7ed Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Tue, 1 Mar 2022 12:40:05 -0800 Subject: [PATCH 059/105] whoops, fixed a bug that was accidentally introduced in mrTypeOf by the previous commit; also reorganized some of the coinductive hypothesis code in Solver.hs --- src/SAWScript/Prover/MRSolver/Monad.hs | 8 +- src/SAWScript/Prover/MRSolver/Solver.hs | 161 ++++++++++++------------ 2 files changed, 89 insertions(+), 80 deletions(-) diff --git a/src/SAWScript/Prover/MRSolver/Monad.hs b/src/SAWScript/Prover/MRSolver/Monad.hs index fe93b073c5..5ad6828834 100644 --- a/src/SAWScript/Prover/MRSolver/Monad.hs +++ b/src/SAWScript/Prover/MRSolver/Monad.hs @@ -185,6 +185,12 @@ data CoIndHyp = CoIndHyp { coIndHypRHS :: [Term] } deriving Show +-- | Extract the @i@th argument on either the left- or right-hand side of a +-- coinductive hypothesis +coIndHypArg :: CoIndHyp -> Either Int Int -> Term +coIndHypArg (CoIndHyp _ _ _ args1 _) (Left i) = args1 !! i +coIndHypArg (CoIndHyp _ _ _ _ args2) (Right i) = args2 !! i + -- | A map from pairs of function names to co-inductive hypotheses over those -- names type CoIndHyps = Map (FunName, FunName) CoIndHyp @@ -434,7 +440,7 @@ mrTypeOf :: Term -> MRM Term mrTypeOf t = -- NOTE: scTypeOf' wants the type context in the most recently bound var -- first, i.e., in the mrUVarCtxRev order - mrUVarCtxRev >>= \ctx -> liftSC2 scTypeOf' (map snd $ reverse ctx) t + mrUVarCtxRev >>= \ctx -> liftSC2 scTypeOf' (map snd ctx) t -- | Check if two 'Term's are convertible in the 'MRM' monad mrConvertible :: Term -> Term -> MRM Bool diff --git a/src/SAWScript/Prover/MRSolver/Solver.hs b/src/SAWScript/Prover/MRSolver/Solver.hs index ecf5db66e8..84b4a2febb 100644 --- a/src/SAWScript/Prover/MRSolver/Solver.hs +++ b/src/SAWScript/Prover/MRSolver/Solver.hs @@ -341,6 +341,88 @@ handling the recursive ones -} +---------------------------------------------------------------------- +-- * Handling Coinductive Hypotheses +---------------------------------------------------------------------- + +-- | Run a compuation under the additional co-inductive assumption that +-- @forall x1, ..., xn. F y1 ... ym |= G z1 ... zl@, where @F@ and @G@ are +-- the given 'FunName's, @y1, ..., ym@ and @z1, ..., zl@ are the given +-- argument lists, and @x1, ..., xn@ is the current context of uvars. If +-- while running the given computation a 'CoIndHypMismatchWidened' error is +-- reached with the given names, the state is restored and the computation is +-- re-run with the widened hypothesis. +withCoIndHyp :: FunName -> [Term] -> FunName -> [Term] -> MRM a -> MRM a +withCoIndHyp f1 args1 f2 args2 m = + do ctx <- mrUVarCtx + withCoIndHyp' (CoIndHyp ctx f1 f2 args1 args2) m + +-- | The main loop of 'withCoIndHyp' +withCoIndHyp' :: CoIndHyp -> MRM a -> MRM a +withCoIndHyp' hyp m = + withCoIndHypRaw hyp m `catchError` \case + MRExnWiden nm1' nm2' new_vars + | coIndHypLHSFun hyp == nm1' && coIndHypRHSFun hyp == nm2' -> + -- NOTE: the state automatically gets reset here because we defined MRM + -- with ExceptT at a lower level than StateT + do mrDebugPPPrefixSep 1 "Widening recursive assumption for" nm1' "|=" nm2' + hyp' <- generalizeCoIndHyp hyp new_vars + withCoIndHyp' hyp' m + e -> throwError e + + +-- | Test that a coinductive hypothesis for the given function names matches the +-- given arguments, otherwise throw an exception saying that widening is needed +matchCoIndHyp :: CoIndHyp -> [Term] -> [Term] -> MRM () +matchCoIndHyp hyp args1 args2 = + do (args1', args2') <- instantiateCoIndHyp hyp + eqs1 <- zipWithM mrProveEq args1' args1 + eqs2 <- zipWithM mrProveEq args2' args2 + if and (eqs1 ++ eqs2) then return () else + throwError $ MRExnWiden (coIndHypLHSFun hyp) (coIndHypRHSFun hyp) + (map Left (findIndices not eqs1) ++ map Right (findIndices not eqs1)) + +-- | Generalize some of the arguments of a coinductive hypothesis +generalizeCoIndHyp :: CoIndHyp -> [Either Int Int] -> MRM CoIndHyp +generalizeCoIndHyp hyp [] = return hyp +generalizeCoIndHyp hyp all_specs@(arg_spec:arg_specs) = + withOnlyUVars (coIndHypCtx hyp) $ do + mrDebugPPPrefixSep 2 "generalizeCoIndHyp" hyp "with arg specs" (show all_specs) + -- Get the arg and type associated with arg_spec + let arg = coIndHypArg hyp arg_spec + arg_tp <- mrTypeOf arg + ctx <- mrUVarCtx + debugPretty 2 ("Current context: " <> ppCtx ctx) + -- Sort out the other args that equal arg + eq_uneq_specs <- forM arg_specs $ \spec' -> + do let arg' = coIndHypArg hyp spec' + tp' <- mrTypeOf arg' + mrDebugPPPrefixSep 2 "generalizeCoIndHyp: the type of" arg' "is" tp' + debugPrint 2 ("arg' = " ++ show arg') + tps_eq <- mrConvertible arg_tp tp' + args_eq <- if tps_eq then mrProveEq arg arg' else return False + return $ if args_eq then Left spec' else Right spec' + let (eq_specs, uneq_specs) = partitionEithers eq_uneq_specs + -- Add a new variable of type arg_tp, set all eq_specs plus our original + -- arg_spec to it, and recurse + hyp' <- generalizeCoIndHypArgs hyp arg_tp (arg_spec:eq_specs) + generalizeCoIndHyp hyp' uneq_specs + +-- | Add a new variable of the given type to the context of a coinductive +-- hypothesis and set the specified arguments to that new variable +generalizeCoIndHypArgs :: CoIndHyp -> Term -> [Either Int Int] -> MRM CoIndHyp +generalizeCoIndHypArgs (CoIndHyp ctx f1 f2 args1 args2) tp specs = + do let set_arg i args = + take i args ++ (Unshared $ LocalVar 0) : drop (i+1) args + let (specs1, specs2) = partitionEithers specs + -- NOTE: need to lift the arguments because we are adding a variable + args1' <- liftTermLike 0 1 args1 + args2' <- liftTermLike 0 1 args2 + let args1'' = foldr set_arg args1' specs1 + args2'' = foldr set_arg args2' specs2 + return $ CoIndHyp (ctx ++ [("z",tp)]) f1 f2 args1'' args2'' + + ---------------------------------------------------------------------- -- * Mr Solver Himself (He Identifies as Male) ---------------------------------------------------------------------- @@ -600,85 +682,6 @@ mrRefinesFun f1 f2 mrRefinesFun _ _ = error "mrRefinesFun: unreachable!" --- | Run a compuation under the additional co-inductive assumption that --- @forall x1, ..., xn. F y1 ... ym |= G z1 ... zl@, where @F@ and @G@ are --- the given 'FunName's, @y1, ..., ym@ and @z1, ..., zl@ are the given --- argument lists, and @x1, ..., xn@ is the current context of uvars. If --- while running the given computation a 'CoIndHypMismatchWidened' error is --- reached with the given names, the state is restored and the computation is --- re-run with the widened hypothesis. -withCoIndHyp :: FunName -> [Term] -> FunName -> [Term] -> MRM a -> MRM a -withCoIndHyp f1 args1 f2 args2 m = - do ctx <- mrUVarCtx - withCoIndHyp' (CoIndHyp ctx f1 f2 args1 args2) m - --- | The main loop of 'withCoIndHyp' -withCoIndHyp' :: CoIndHyp -> MRM a -> MRM a -withCoIndHyp' hyp m = - withCoIndHypRaw hyp m `catchError` \case - MRExnWiden nm1' nm2' new_vars - | coIndHypLHSFun hyp == nm1' && coIndHypRHSFun hyp == nm2' -> - -- NOTE: the state automatically gets reset here because we defined MRM - -- with ExceptT at a lower level than StateT - do mrDebugPPPrefixSep 1 "Widening recursive assumption for" nm1' "|=" nm2' - hyp' <- generalizeCoIndHyp hyp new_vars - withCoIndHyp' hyp' m - e -> throwError e - - --- | Test that a coinductive hypothesis for the given function names matches the --- given arguments, otherwise throw an exception saying that widening is needed -matchCoIndHyp :: CoIndHyp -> [Term] -> [Term] -> MRM () -matchCoIndHyp hyp args1 args2 = - do (args1', args2') <- instantiateCoIndHyp hyp - eqs1 <- zipWithM mrProveEq args1' args1 - eqs2 <- zipWithM mrProveEq args2' args2 - if and (eqs1 ++ eqs2) then return () else - throwError $ MRExnWiden (coIndHypLHSFun hyp) (coIndHypRHSFun hyp) - (map Left (findIndices not eqs1) ++ map Right (findIndices not eqs1)) - -coIndHypArg :: CoIndHyp -> Either Int Int -> Term -coIndHypArg (CoIndHyp _ _ _ args1 _) (Left i) = args1 !! i -coIndHypArg (CoIndHyp _ _ _ _ args2) (Right i) = args2 !! i - - --- | Generalize some of the arguments of a coinductive hypothesis -generalizeCoIndHyp :: CoIndHyp -> [Either Int Int] -> MRM CoIndHyp -generalizeCoIndHyp hyp [] = return hyp -generalizeCoIndHyp hyp all_specs@(arg_spec:arg_specs) = - withOnlyUVars (coIndHypCtx hyp) $ do - mrDebugPPPrefixSep 2 "generalizeCoIndHyp" hyp "with arg specs" (show all_specs) - -- Get the arg and type associated with arg_spec - let arg = coIndHypArg hyp arg_spec - arg_tp <- mrTypeOf arg - -- Sort out the other args that equal arg - eq_uneq_specs <- forM arg_specs $ \spec' -> - do let arg' = coIndHypArg hyp spec' - tp' <- mrTypeOf arg' - tps_eq <- mrConvertible arg_tp tp' - args_eq <- if tps_eq then mrProveEq arg arg' else return False - return $ if args_eq then Left spec' else Right spec' - let (eq_specs, uneq_specs) = partitionEithers eq_uneq_specs - -- Add a new variable of type arg_tp, set all eq_specs plus our original - -- arg_spec to it, and recurse - hyp' <- generalizeCoIndHypArgs hyp arg_tp (arg_spec:eq_specs) - generalizeCoIndHyp hyp' uneq_specs - --- | Add a new variable of the given type to the context of a coinductive --- hypothesis and set the specified arguments to that new variable -generalizeCoIndHypArgs :: CoIndHyp -> Term -> [Either Int Int] -> MRM CoIndHyp -generalizeCoIndHypArgs (CoIndHyp ctx f1 f2 args1 args2) tp specs = - do let set_arg i args = - take i args ++ (Unshared $ LocalVar 0) : drop (i+1) args - let (specs1, specs2) = partitionEithers specs - -- NOTE: need to lift the arguments because we are adding a variable - args1' <- liftTermLike 0 1 args1 - args2' <- liftTermLike 0 1 args2 - let args1'' = foldr set_arg args1' specs1 - args2'' = foldr set_arg args2' specs2 - return $ CoIndHyp (ctx ++ [("z",tp)]) f1 f2 args1'' args2'' - - ---------------------------------------------------------------------- -- * External Entrypoints ---------------------------------------------------------------------- From b648dd0e3ea514493741f3002bf05f8b09944ddf Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Tue, 1 Mar 2022 12:53:58 -0800 Subject: [PATCH 060/105] added the new Mr Solver arrays example to the CI --- heapster-saw/examples/Makefile | 11 ++++++++++- heapster-saw/examples/arrays_mr_solver.saw | 18 +++++++++++++++++- 2 files changed, 27 insertions(+), 2 deletions(-) diff --git a/heapster-saw/examples/Makefile b/heapster-saw/examples/Makefile index dee6e52df7..dc91dd7a13 100644 --- a/heapster-saw/examples/Makefile +++ b/heapster-saw/examples/Makefile @@ -1,4 +1,4 @@ -all: Makefile.coq +all: Makefile.coq mr-solver-tests Makefile.coq: _CoqProject coq_makefile -f _CoqProject -o Makefile.coq @@ -32,3 +32,12 @@ rust_data.bc: rust_data.rs rust_lifetimes.bc: rust_lifetimes.rs rustc --crate-type=lib --emit=llvm-bc rust_lifetimes.rs + +# Lists all the Mr Solver tests, without their ".saw" suffix +MR_SOLVER_TESTS = arrays_mr_solver + +.PHONY: mr-solver-tests $(MR_SOLVER_TESTS) +mr-solver-tests: $(MR_SOLVER_TESTS) + +$(MR_SOLVER_TESTS): + $(SAW) $@.saw diff --git a/heapster-saw/examples/arrays_mr_solver.saw b/heapster-saw/examples/arrays_mr_solver.saw index 0326bac2ec..838e1d2874 100644 --- a/heapster-saw/examples/arrays_mr_solver.saw +++ b/heapster-saw/examples/arrays_mr_solver.saw @@ -1,3 +1,19 @@ include "arrays.saw"; + +let eq_bool b1 b2 = + if b1 then + if b2 then true else false + else + if b2 then false else true; + +let fail = do { print "Test failed"; exit 1; }; +let run_test name test expected = + do { if expected then print (str_concat "Test: " name) else + print (str_concat (str_concat "Test: " name) " (expecting failure)"); + actual <- test; + if eq_bool actual expected then print "Success\n" else + do { print "Test failed\n"; exit 1; }; }; + +// Test that contains0 |= contains0 contains0 <- parse_core_mod "arrays" "contains0"; -mr_solver_debug 1 contains0 contains0; +run_test "contains0 |= contains0" (mr_solver contains0 contains0) true; From fab742793d03114dab6b0990957d27a411eb003c Mon Sep 17 00:00:00 2001 From: Matthew Yacavone Date: Tue, 1 Mar 2022 13:19:49 -0800 Subject: [PATCH 061/105] add types to NormComp's Either, add parens in prettyInCtx --- src/SAWScript/Prover/MRSolver/Monad.hs | 14 +++++------ src/SAWScript/Prover/MRSolver/Solver.hs | 14 ++++++++--- src/SAWScript/Prover/MRSolver/Term.hs | 33 ++++++++++++++----------- 3 files changed, 36 insertions(+), 25 deletions(-) diff --git a/src/SAWScript/Prover/MRSolver/Monad.hs b/src/SAWScript/Prover/MRSolver/Monad.hs index 5ad6828834..a9c0914e61 100644 --- a/src/SAWScript/Prover/MRSolver/Monad.hs +++ b/src/SAWScript/Prover/MRSolver/Monad.hs @@ -278,31 +278,31 @@ instance MonadTerm MRM where mrSC :: MRM SharedContext mrSC = mriSC <$> ask --- | Get the current value of 'mrSMTTimeout' +-- | Get the current value of 'mriSMTTimeout' mrSMTTimeout :: MRM (Maybe Integer) mrSMTTimeout = mriSMTTimeout <$> ask --- | Get the current value of 'mrUVars' +-- | Get the current value of 'mriUVars' mrUVars :: MRM [(LocalName,Type)] mrUVars = mriUVars <$> ask --- | Get the current value of 'mrFunAssumps' +-- | Get the current value of 'mriFunAssumps' mrFunAssumps :: MRM FunAssumps mrFunAssumps = mriFunAssumps <$> ask --- | Get the current value of 'mrCoIndHyps' +-- | Get the current value of 'mriCoIndHyps' mrCoIndHyps :: MRM CoIndHyps mrCoIndHyps = mriCoIndHyps <$> ask --- | Get the current value of 'mrAssumptions' +-- | Get the current value of 'mriAssumptions' mrAssumptions :: MRM Term mrAssumptions = mriAssumptions <$> ask --- | Get the current value of 'mrDebugLevel' +-- | Get the current value of 'mriDebugLevel' mrDebugLevel :: MRM Int mrDebugLevel = mriDebugLevel <$> ask --- | Get the current value of 'mrVars' +-- | Get the current value of 'mrsVars' mrVars :: MRM MRVarMap mrVars = mrsVars <$> get diff --git a/src/SAWScript/Prover/MRSolver/Solver.hs b/src/SAWScript/Prover/MRSolver/Solver.hs index 84b4a2febb..e29339bfa8 100644 --- a/src/SAWScript/Prover/MRSolver/Solver.hs +++ b/src/SAWScript/Prover/MRSolver/Solver.hs @@ -216,8 +216,8 @@ normComp (CompTerm t) = return (ErrorM str) (isGlobalDef "Prelude.ite" -> Just (), [_, cond, then_tm, else_tm]) -> return $ Ite cond (CompTerm then_tm) (CompTerm else_tm) - (isGlobalDef "Prelude.either" -> Just (), [_, _, _, f, g, eith]) -> - return $ Either (CompFunTerm f) (CompFunTerm g) eith + (isGlobalDef "Prelude.either" -> Just (), [ltp, rtp, _, f, g, eith]) -> + return $ Either (Type ltp) (Type rtp) (CompFunTerm f) (CompFunTerm g) eith (isGlobalDef "Prelude.maybe" -> Just (), [tp, _, m, f, mayb]) -> return $ MaybeElim (Type tp) (CompTerm m) (CompFunTerm f) mayb (isGlobalDef "Prelude.orM" -> Just (), [_, m1, m2]) -> @@ -280,8 +280,8 @@ normBind (ReturnM t) k = applyNormCompFun k t normBind (ErrorM msg) _ = return (ErrorM msg) normBind (Ite cond comp1 comp2) k = return $ Ite cond (CompBind comp1 k) (CompBind comp2 k) -normBind (Either f g t) k = - return $ Either (compFunComp f k) (compFunComp g k) t +normBind (Either ltp rtp f g t) k = + return $ Either ltp rtp (compFunComp f k) (compFunComp g k) t normBind (MaybeElim tp m f t) k = return $ MaybeElim tp (CompBind m k) (compFunComp f k) t normBind (OrM comp1 comp2) k = @@ -449,10 +449,12 @@ mrRefines t1 t2 = -- | The main implementation of 'mrRefines' mrRefines' :: NormComp -> NormComp -> MRM () + mrRefines' (ReturnM e1) (ReturnM e2) = mrAssertProveEq e1 e2 mrRefines' (ErrorM _) (ErrorM _) = return () mrRefines' (ReturnM e) (ErrorM _) = throwMRFailure (ReturnNotError e) mrRefines' (ErrorM _) (ReturnM e) = throwMRFailure (ReturnNotError e) + mrRefines' (MaybeElim (Type (asEq -> Just (tp,e1,e2))) m1 f1 _) m2 = do cond <- mrEq' tp e1 e2 not_cond <- liftSC1 scNot cond @@ -473,6 +475,7 @@ mrRefines' m1 (MaybeElim (Type (asEq -> Just (tp,e1,e2))) m2 f2 _) = if cond_holds then mrRefines m1 m2' else withAssumption cond (mrRefines m1 m2') >> withAssumption not_cond (mrRefines m1 m2) + mrRefines' (Ite cond1 m1 m1') m2_all@(Ite cond2 m2 m2') = liftSC1 scNot cond1 >>= \not_cond1 -> (mrEq cond1 cond2 >>= mrProvable) >>= \case @@ -494,8 +497,10 @@ mrRefines' m1 (Ite cond2 m2 m2') = do not_cond2 <- liftSC1 scNot cond2 withAssumption cond2 (mrRefines m1 m2) withAssumption not_cond2 (mrRefines m1 m2') + -- FIXME: handle sum elimination -- mrRefines (Either f1 g1 e1) (Either f2 g2 e2) = + mrRefines' m1 (ForallM tp f2) = let nm = maybe "x" id (compFunVarName f2) in withUVarLift nm tp (m1,f2) $ \x (m1',f2') -> @@ -506,6 +511,7 @@ mrRefines' (ExistsM tp f1) m2 = withUVarLift nm tp (f1,m2) $ \x (f1',m2') -> applyNormCompFun f1' x >>= \m1' -> mrRefines m1' m2' + mrRefines' m1 (OrM m2 m2') = mrOr (mrRefines m1 m2) (mrRefines m1 m2') mrRefines' (OrM m1 m1') m2 = diff --git a/src/SAWScript/Prover/MRSolver/Term.hs b/src/SAWScript/Prover/MRSolver/Term.hs index 21669abb60..b84f5d39d2 100644 --- a/src/SAWScript/Prover/MRSolver/Term.hs +++ b/src/SAWScript/Prover/MRSolver/Term.hs @@ -86,7 +86,7 @@ data NormComp = ReturnM Term -- ^ A term @returnM a x@ | ErrorM Term -- ^ A term @errorM a str@ | Ite Term Comp Comp -- ^ If-then-else computation - | Either CompFun CompFun Term -- ^ A sum elimination + | Either Type Type CompFun CompFun Term -- ^ A sum elimination | MaybeElim Type Comp CompFun Term -- ^ A maybe elimination | OrM Comp Comp -- ^ an @orM@ computation | ExistsM Type CompFun -- ^ an @existsM@ computation @@ -198,9 +198,12 @@ instance TermLike NormComp where liftTermLike n i (ReturnM t) = ReturnM <$> liftTermLike n i t liftTermLike n i (ErrorM str) = ErrorM <$> liftTermLike n i str liftTermLike n i (Ite cond t1 t2) = - Ite <$> liftTermLike n i cond <*> liftTermLike n i t1 <*> liftTermLike n i t2 - liftTermLike n i (Either f g eith) = - Either <$> liftTermLike n i f <*> liftTermLike n i g <*> liftTermLike n i eith + Ite <$> liftTermLike n i cond <*> liftTermLike n i t1 + <*> liftTermLike n i t2 + liftTermLike n i (Either ltp rtp f g eith) = + Either <$> liftTermLike n i ltp <*> liftTermLike n i rtp + <*> liftTermLike n i f <*> liftTermLike n i g + <*> liftTermLike n i eith liftTermLike n i (MaybeElim tp m f mayb) = MaybeElim <$> liftTermLike n i tp <*> liftTermLike n i m <*> liftTermLike n i f <*> liftTermLike n i mayb @@ -217,10 +220,11 @@ instance TermLike NormComp where substTermLike n s (ErrorM str) = ErrorM <$> substTermLike n s str substTermLike n s (Ite cond t1 t2) = Ite <$> substTermLike n s cond <*> substTermLike n s t1 - <*> substTermLike n s t2 - substTermLike n s (Either f g eith) = - Either <$> substTermLike n s f <*> substTermLike n s g - <*> substTermLike n s eith + <*> substTermLike n s t2 + substTermLike n s (Either ltp rtp f g eith) = + Either <$> substTermLike n s ltp <*> substTermLike n s rtp + <*> substTermLike n s f <*> substTermLike n s g + <*> substTermLike n s eith substTermLike n s (MaybeElim tp m f mayb) = MaybeElim <$> substTermLike n s tp <*> substTermLike n s m <*> substTermLike n s f <*> substTermLike n s mayb @@ -337,8 +341,10 @@ instance PrettyInCtx NormComp where prettyInCtx (Ite cond t1 t2) = prettyAppList [return "ite", return "_", parens <$> prettyInCtx cond, parens <$> prettyInCtx t1, parens <$> prettyInCtx t2] - prettyInCtx (Either f g eith) = - prettyAppList [return "either", return "_", return "_", return "_", + prettyInCtx (Either ltp rtp f g eith) = + prettyAppList [return "either", + parens <$> prettyInCtx ltp, parens <$> prettyInCtx rtp, + return (parens "CompM _"), parens <$> prettyInCtx f, parens <$> prettyInCtx g, parens <$> prettyInCtx eith] prettyInCtx (MaybeElim tp m f mayb) = @@ -355,10 +361,9 @@ instance PrettyInCtx NormComp where prettyAppList [return "forallM", prettyInCtx tp, return "_", parens <$> prettyInCtx f] prettyInCtx (FunBind f args CompFunReturn) = - prettyAppList (prettyInCtx f : map prettyInCtx args) + prettyAppList (prettyInCtx f : map (fmap parens . prettyInCtx) args) prettyInCtx (FunBind f [] k) = prettyAppList [prettyInCtx f, return ">>=", prettyInCtx k] prettyInCtx (FunBind f args k) = - prettyAppList - [parens <$> prettyAppList (prettyInCtx f : map prettyInCtx args), - return ">>=", prettyInCtx k] + prettyAppList [prettyInCtx (FunBind f args CompFunReturn), + return ">>=", prettyInCtx k] From d90f299f20ee0c39ac1e1c21672af5dc4619c1c8 Mon Sep 17 00:00:00 2001 From: Matthew Yacavone Date: Tue, 1 Mar 2022 15:51:10 -0800 Subject: [PATCH 062/105] inital pass of adding eithers to mrRefines --- heapster-saw/examples/linked_list.bc | Bin 7056 -> 7856 bytes heapster-saw/examples/linked_list.c | 11 ++++ .../examples/linked_list_mr_solver.saw | 8 +++ src/SAWScript/Prover/MRSolver/Monad.hs | 51 +++++++++++++++++- src/SAWScript/Prover/MRSolver/Solver.hs | 26 ++++++++- 5 files changed, 92 insertions(+), 4 deletions(-) create mode 100644 heapster-saw/examples/linked_list_mr_solver.saw diff --git a/heapster-saw/examples/linked_list.bc b/heapster-saw/examples/linked_list.bc index bfa56aa2993cd9c415e7658f97d644402120d3b9..d8d8693240eedd7ba72825ed4a18d7d9558e7f01 100644 GIT binary patch literal 7856 zcmds6eRLC7c7LOhXJlKJWH3R-k{Dq^6&CFA2gYF2Xe^VMVm2}#S+h-!C2Scx@rNu4 z+j0mQS%z^~B^87u4$H~Ptdrwp(?$fEdQ*0fWEtWTC3Q$bU6$p@#jp+~)XAnP?Q*)k zZzLI$uswU)(|@YtnR)NcefPb&_jiBy&iHa@aXNxu797WP2+;@;6{gVTH822ev`fw| zfAOW)U;DRzc&7D}Q;+=aZ@&1|gR3iv!W6itmm{rxkAPudSz9rDBRkoUTIkAFW4J=>=1Ki9P~cRAhZOoh0Cf^nTGw+7nTk6!Rbohpg(It^+8{H z-%z#6?vw_M|D&uu)k2q_b{m9_ z0Npt*l=y|NVY-VE9E?!H2(F;uf_9VF-A}s%LJ3QEH+ef{bdQk^X+}NTYl9lzqZ#FN zH}%>}gBjO6x(im#gjIXdqMPA#m&4kR1~Vq%mQ{;-HRr9mQBE^CsJY1NM)lgs!Hlzd z%_JxxSix=)+yNVqcrZ)*LyHH{g9Hm%cNl7H)d-Q<0$igpBO7m6X~(vehjLh%O%?c|aX#U;%8T6D;2(*s;In%zj<; z__Zl*)T6r?(o9ZauOX+5?u1oPiD49@TFFbzMlE_eIORHk`%8P*iD>uye*!tir`Kht zo&O!EF6lLwtk_Vo!3>Cz8A3Z}D_K`Jz)5hG(p?4`to^hBFebR~ZFU?iylz^ri4nT< zVmN9@YTZ0IS#Z+OG#Ss2s_9WVE|fZ~*71>F!|~>CT0<)B2^C2nLi)PifAHFgOQ~ zHmI8()LbKKy&WN;G>Dn+6|2+p)(``QbxPjBr=mg#Rwb#@)4nk8}xd+ zw=_No(89PS_lCS>sK3W9xMj2xg7F?Sh>in0X&}TdhsD_OXfI>4Cz;J+;%;L^s-j_h zQ3Ca&O~A<{To?9QDwt~7fmDJ(3yUGR%5J5U1-vCPx|_%3gJS^zJb(kR6!tbut_^xK zUNt!#P+Lw5%?kH0mNSn9oPFu6&54p5#!VZ1x6?g#va?&TGeUMWQ*pzum|~S}tn$jNV%DrE zQjK9iKrS4$>KfT+%T9aCCQR#2k>#ho<$YvXbT+HgLO<0+uWf=@qSx}6pzRiLKizpN z1=M!&LLDRkH6T)O4|rDHoK@V6DgHI2xWSUU#&Ph(LkPlN15q*NfqY3_@SE0+o7N48 z=aES15mPB}_>o9HEPA`Q>{GHV7?Ho zul-7F0o@Z~PSR_kEZ9fjppELavsP;Res5_sQWi9A0E65fEuS`(^+Pw}JCg=aDs;hq zpx^+i8t^=JMWwhAQd~7Fe#_>D&vU>diy;$Sh7D9@mj%5WPI+_sBBeglx@e?)B)o1s z0?$|;tvb~KdBQ?>;0!8c|LUybhDG^B4B|w2l~rD4l;4;YZ7RhTRsr4L#;DI@ifOar z7HgWisK+JFEFtdPdf<~m)4Dzq`zshJ^F_*s$PGtG)3Yf+0ATfYiv)Bbk#Rm9d*v;9-DcSiK(`A+FDwg+n%&F)U`A_U3vBSJDi{= zzt!q;xvllq&h|E2K1gy~EAyS!uGP+ZN3-3P-(<7eoi3YWHH_ukx~;AD7Mqi^!#Z)>vopW8zP-VgXSLh&P3>(i zTbs+7Uy1kDZnrt|%`H|}W4oi(nZLza|H!u5JbPkbo(x!E?zXex$%G)Z{%_aG-{W-T zH@DTd>}jy&JKfIwI+xpSgG+OptE9NjmDiMLw6udjl)Q{%f0R+qKS*6r$U0Uw@q zVNW8&_L}v%vPTPh%@5?tK7&g^u53rqkwvV9hr3cM3%m$CC^H`SWo5iTQc}bNm$kzn zin7(jnus~|f;>|ESdm<9{gB;$rr1oVX%t1(pCU15q=8^a?omfo47n&IL7{TmNM#sM z3R^?gR%dtf*;rMmGQ+aYVi(^ql2e!Pm}}XHo!afEiZUeu3Zy2=E#{`(NYq-HF$)4s z0XX3~8B*%N1uB5>v?5tcjQS+ytlYHZ7`G%^DKlyiO`-QYH1EHX@@M@XwfL7~oDS`5 zv!q=&Dy|#pHl&=kD4Q%FdwkLrhTM{pzb$$B-L>zmf46XP(YwKuKd(t^y|O-kF&q6;6t8hlb2`B3zB=aG&mSAueLFh{s-lyQY?BQ{L4K*gg zdYhef5MB-FXG0_;5k%TDvJhchPVy|`cWyM&mZ0Y3!GI!UIn=m_)AHPv=*r$Qb2NwPeX0-;I03JGmlRZA2-+p$c#{xyeiZmCU{1zxo{H~Aiuzp0XY4h ztv4HXgHeneQ$(F{d`cksTB%GORcCG9N+b3Il`QPzPH5t4JgSh73ukpAbW(bzk1(2G z&c-X32;?e|$_nev#UE=CO5v;3$c1qCAGIiC_o{eM@o{Yz%#xFtp!vCNpt;3pNGG84 zeGhatn_*6b>N}4YAQrik3#7pU`?Dqp)WTYkbPU@78~@Lx76oqOpOrxfHuOL7m953r zn)H?TiHwzZ`^usfeHA(^`ii(F`ik_$eRVYMEARC=UvV$~FMU+D&0t3A3>0`bTC z8y9)Bd{|w2@*q-%Eb`MkH}bT_Or4{qd{kZ)e}5KIIlEfewbvBaZ887D=N@! z9I1OCvJv&P3WY{0hsjiVh{=$m0jA|MDRD9xvwd6d9kcJ^NQ}*oS%RvCun7{GjFjDF zM~sXTcKi;cB45BsIfLcF;ueP$$C6}UrwSqi> z^*4rQL|tYh=-Qv11#{yRqk{dVECFvN0TRate^>nPore#6AGmt>dAMSZ21ZJ7bS0Sz z?Z)P|hB`6w(Om4W@q5?I$A$}0Er5;Q^@uD1YyeezasV4KMJSXpvU8&y+)bYwsSJ2! z@(Zy!1_&=1@&FI@J$aO|WP#tg?{M`fm*i^md)SY&*zcAESD&DCalfmRey3j){Vp>0 zwS?cF3{ns*5MTA?V7Nx~yBhmF$lalUFh$4xuEBmk#bJ1e3|ow+jd+}*J2db6xGCyx z78v0=u}VgYRgQS}K<5Ki1@t{deIE>|$FbfX!cfRjZN{!TlamF|iMtAu^+wHO00YtO zW1a*locD2=^y7ECeZqxFVT^bIR%kIA37iQ!%+mylF34I)Ar3F(RLv*;d-1{y_%oTK z@w+t6(OI(3GNCE@eg$0PoFGm45ZcamhYQN(<~AslT@ITonWxMAWZ8WG12=RfxS=f0 z4aCwoH}FdEKX8L84g5b0{=bp%{~pNJTI~NT3#Jq^NIuJCAj}PJ;D!kriiwbP>i7y- z?HVrhR;r|v_%1%8mC_xiv^Z>n1ZPO1;QiMy3cUXUC*|h}6m&8aL_~xd^Uo#rAKXdo zLm-6{`(!u=a>RrRD7J$Z01|eSALrr@`dR3#GBHwcpjHE#5*0*)h)S`72qsYJq5mFa z`#BDZhsx~$pBM+I@N<)?q-Bz4C6a*x!))y5Bx0ogZ0|DV@iK(gOI|53d=(fW(abKH zy76paoV=<)ATFb@_*YmwupGoIln2WYpLZbiN~1h&gZU;x2QvDZWjwy~Dk%CPR`d-I z;_4FSRUS3U4{k7kRAcJFRFc;iVb-78XAv4tZ8#fYX8<9uBTF;oV%?NxFvc1QZua+Y|)7y(UwtqBq zw7~Emfpa7pXKny1wiv5KxIR4#a5blZai{1SK=&4m*?kzpPz~)YsW;#992U_nB{919 zVeyGYApWH&z7vZ-lMsIl7hKN-Kmr0QEC$xnatNfp6tFliiARY`TsDBG#G|BxhgruF z1!Osf1^Y+Uz@o4^q%L4l!vK6EozJxsr$w$kuKJunDmCVU{)$173;a;mgQ`HBgvAZ) zHp#eVenfmLnBr8U@3Bgi1vw^7q~Rd=g?W8K>Xo=iFqB zQe)KOZ^vj|TYFurwWX!KevYfRO?tP@k5%C6;RIK2k8^c+Wt^)mi^eUFW?mxHBfalf ztGvZk-YtCyKFWzzws%{V7hc@%muRaj_OxaO;*QiM;f!6gs(Yb@Xw>UKjw?&OloY#|Aj?+DUn60-6v4%Ez|)1vWwAUAm>E zvo)__*Y3Oq8+?dz*kBkJZ&2OO6>@iF^*CGHHFSqW;-9p-OH1lXidVxIs}|epR%?B` wv%7%JD_E0Pa@Xgyy2K9ZzP$x}1Mi^@Hc>aXi@LkljPK)HgLl{rKQTi81wJ3>aR2}S literal 7056 zcmai34OA27n*N3fGXX;w6g9{sPQbdcMc4O=9O}#zcq@_J>+r7oMd)K?$yPE(a>rGv1t(USKPpDp&+v9aJArLZZ5ZXf_v?#@hQowc@BwETp$&abFQ%v!u7l=O1 z1F7m9gX-CXV)oXQ$`=+@4lu>pWoq4y^x|Fp)y@%Pe$`^x&+sp#G>oawW^>kU{oKD2 z#k=}+51Jkf6dfJhf08>t27YUG2pxq!b4N_Kzk`c#qBIj}A%{er+!dg^O>#$w?i`a# z19I0Hx{H%toLtJuo9g_4jVOEsbA>MGysGkaF z%t(f-0y{3~C+&t=-f%6dzZA}xfF?nYdfCf@VTflZ!tA7I7&7W7!WpARb^@FbX4z?% zyG^ucmt8@*yNUD$WS36%1fgrvEy~cN3&p@#FkB?KNu@9Fa|vp~88^f1sARat8z$q1 z%Mv?F=usI`cX{z>yVY{1NiG%Tu4=j~B)bA~sfq5amOBv)?+X}wRDUg;5#tR*Vg1E$ zMtoX-IjWxxvp2#S7bX4WuzoV4hgnRD`in+3MsQQp`bkbd6=i4OEy6Gv(ho_7@jK&p z%3V$5;WKilD3^w0CqqN;-FHTgUytaAqOflN>+8PmYT4~n)_)uixGVUB%Z`Td$YB;k zgdq+KGR=N(Fe2UUr8{8yLApmRckH9%%b%KFK1%4X3Wixh|I`9-1P8zk3G7u^0YFVM zTol;ZX+12$NZ1gIvKL`(?S{+z%8NvV6k%Qg*=?eGntUCi+=Jp_c8WKA6$OX^U&Ey^ zI}5W513e61@ZicIZqU(3`^j>H&Qdy(yWI z=QH$Xr>`tg31&gEbRT&%;wwk}Jx&=sxM7Yzz)bX-0r&|czZO-7B zVkw|%lzJt4{Es>R4TY!GGjUu=A7p`1Hxz137*|eO4A;VjDT%!(0ejiYQOq#RK_befrn}F{9;dSY`{WLbd>C{T!k~1O$)$GObQq~!)p!aW z!2Bi>VDi}IQXR+voGeHT_3B|6fir*(Km$60t}*?L?AXF|M1_0qfb49-uDo9GPxqMU z?k1lL`f8#@m=4HCr;w1nVPq#^aggB}kVi6Lh(jz$buyd*2B2lo*HDyA&TVyyYYQabC)aV9oJZhY)DQ8>se?7g!31kxNB4MPHOP)LwA-wNf}rdHiJ>{f z%^G1;050$xpfn(_iS7!>N1gOtY$t(c&X5ela|LO8#wfA!^N4oB4nVA&;SG?P4D08l zjH`B#q&}u(fPPRv19iMB)BCn5eX>9tpKHR|JO1c9F65Ly9s#d+0f zT*EQdi+KZmaJ$|Y4rDK`IpJT_H&DYk-Kvn~b3^k9lknB@s?(lt|0aMcbC7!dHbkYQ z*ZPY*ClGq07%gr3iBYt)K99nWs??^JjC~gO^GLHRv^Zpbh^Zk0u(2&!e>6gt-%c$L z`AXHaSHwXP0}DG(5C?`b5ce5!qv*?U*tD(V+MYRWYe3s+p?mDKXPlZ5X<$?bM|;Pq zTO!>9K{Z6Xxn%464DAx>6-LcxYpY*phW~}Td}EPybsVOxhAAel<267?f=d+Ou6gRGs~+VuZ$02&Lm|<@iQ4X9 zhh_$4{+`i(Eow_Nl|TsCO4&wps$%BLjgec%tXur#mYCNMIzIxjrW!;@_c+N;uk7UH zoLH9jW*|a6h2#$at@*%;{Xnv;rLtpv0b<+oA#fQF%KC(PEm)&Wn zk2KL6aRi|^idaiH62X>vI~Ck^iEeXr-lom({FpruaM<~!SCy*DaaToc1Qnf-}JejCY#LMiwI1R2&DCF9<`UuC{E@ zy7?7fdCaydIT4VDm-Ys0YrYO-;uSFbm9n=P@uvP1f#ZA3sGk$4J;!`yvElMT>lRp$ zZ-**wSj+pNIP5>44l|XzU_2l*6YUC0`>!+Fn-T4AZQ4JW^P`txlbBvUF|EG_1E|g^ zAM|bcz?a)MT;{iKiVatsi*6blhB;PX=5%uioq?yzP|aEUH92Xn;%Y8m@}E5UaaD*h zHB=N8S3VywzOLqvrtHXHv)xCx+ZH|KW2zX0c317-_Bved=JvL#F2U8fP;eYPe2ClL z*4RE@(^cOjxa!=^Jr3J;D_7&_bhNZIw>{x#sB39@Or#0+n&IyjgYz5rq5R|EAF*Dkgxs;Jl5r_mzG?~HX9%)F-HY#qq3NH zt*`Mvgy0l_2H`M{A{uLUb&2Mr`6F``xnbCr^@+y!NENwM?0}|7RmL2CErf3|MvQ8R zVjHmv@@~{HD5luZk`3Y;eu)miSsS66D`?quJ;H9GAp(KePK9s*8g^b^x-Un>=YDgo z!VjGZw=CIUx$dQ20yErJqHYRNpQMgzhI39ub7EC$OD_5kg1yke%8T=i)IkpawV{*b zpu}{n*H* z{i9!OOM7RJQoKBNacXv3+7Lp23$Y1*)GSJOnLzWfuR4R)Eg;=N>!$JH-Whf@aqxs= ztWiI!XbF7`9L3Y5V-*9w@>f9MmB|#!De^2z9}8iE7(gFhwdz+1rrXk8FB^ zv*BexUz!nO;hFc)SfG{~Nx|Pw&F(r!i=!32JurNPjO@N;AsAFufNmrE-mHl95A6FV zIPHg9Pd}pSh;O*`PF|3Fce-(Dl=c4gdxFVVT;|)^hb9PfK~_Be<*8ydvhUA}5I5Ew z;!s32{n~2vzEtR=B+K&mfuS0eZQX!*N!Ff4Yc#n`WhKg|Xw++W?)eqoP`|~8!$Eu- z_VeK;CqlzimB>W;qlC!m*ropoEt&s}E#HCLcjkJV=@5JXT6nI6I`0}GkY=Mwt&8ch zcPyrn`PYm(>gUh02{#fG@$=Da7eeo=&i4@(E4;JydW=AxB9*$h-nRZ@Sd~< z&y-#9^F-@m06|qOAiqwB)V)!Ls)B)AYV;^FNPMYM;lfrZtmTUYG)|8Bd1ERJITySV zMM(K(eOwjKfF)EefkQ}y-2aDh9@r=tr;ntNKn|g;+v##NBr$&bzd|W@FdmT(>EAzL z(N^pLj9qa7Fbh5ugtZKEt3bX!LyPW}HAw7A&_^>p|#%hJOKoo7f62 z32q4$>E|)$R$;8{T7buC9q)_w5$0c;8K8u;35YaIjSOK{om>hKCp@13&*ztYMxelA z@O<__C-xlO{gE#FXN}5Wv1bW;UTe3gz;<*3MxM*qEC>pFp%7b~y@W!%2!lBQ^BaUd z83tk+7VqOKq=koa2^>N_kelZLZU?QOc^;lvSOfbY z1!4gG)Z6-^S%B;mqq74hef%AXXHm4`sg}iJ>gSE~s$7p>^GhX)7}*PczKFV4<$k^t zyW~{ZrC-_rg#^Au)Q=$?7_pWcB0v;?Xa|NUH76U$lE6A0BFM3v{eb-d?k6ZEMgNJP z7pMae3Q{G|a6UyrfE)KiWE{7x0UWoZ)H6_6Yvn*_sktn8O71pxg^hjq z^>~tvA5;GZw*5R0(yZD8aDKo88v^`98fl*p%_%9tBGY92WfF0!K#p%H<2Crc*qrim zk!dOvB+=|awXShAc-rKo%6BMdRt7| zrLbB>VphAc`S?;W=N0qEu(>B`{tDilJt43FK}8io=_^1$eW|eGSCZ=RDBT{$uOxzD z2M&f^h=O1`f(@slItY}|yWLJf)YJ#1`^5Gkfw$@|2I4TI!`htU1tkUqq!qX!lnA=Y z0M6?x!0##w57Qe-G&mR>)+PGb{I+b%!Cq$hy8`kL#pAP}xp{rwACL3qwMmUo%kS4_ zU0ZuytI*QYUZ0H3*L~&jyEF>1`N>3V{&ONWOT9{LCR2-pkEq=7=X&20%6ujFoWyR& zH7Q8v>I9-F+6jD^~v#u;WKxV`0q4>L}d?=PaOviX!|v z79V4ZeuoVrie~=|xlGX5%9{i}MB$};(wR7pQ5f+j15k(+t13aPUq=bp2&-`HT!~L( zusue>yvwT z;tUoV{750m&Jt+r-I#2PILWL5hz&&g1da{EcoR-Fl|gK{g1hUhtOCP_VRTzfIMN@` zNFLa{!=c0;pfF~usRCNEF%$b!tjg$Wl+nFr1FOX7w&T$agec(lDr^|2%uNX9DhMW! z!a~8ujDgAy+VRf!q7EM__;jo3R^6<%qN+IDs z=ItR1EJ0`^JYg+$W@K8a61HRo|4mg4@oWkzeniJB$r|M2bNPPZ# z%S!7?*RK=s?*r>vh5B~4x5!*jw4uO!&+iU($*$|}@4F5data == x) { + return 1; + } else { + return 0; + } +} + /* Test if a specific value is in a list, returning 1 if so and 0 otherwise */ int64_t is_elem (int64_t x, list64_t *l) { if (l == NULL) { diff --git a/heapster-saw/examples/linked_list_mr_solver.saw b/heapster-saw/examples/linked_list_mr_solver.saw new file mode 100644 index 0000000000..9cde0ac4c6 --- /dev/null +++ b/heapster-saw/examples/linked_list_mr_solver.saw @@ -0,0 +1,8 @@ +include "linked_list.saw"; + +heapster_typecheck_fun env "is_head" + "(). arg0:int64<>, arg1:List,always,R> -o \ + \ arg0:true, arg1:true, ret:int64<>"; + +is_head <- parse_core_mod "linked_list" "is_head"; +mr_solver_debug 2 is_head is_head; diff --git a/src/SAWScript/Prover/MRSolver/Monad.hs b/src/SAWScript/Prover/MRSolver/Monad.hs index a9c0914e61..3113f317db 100644 --- a/src/SAWScript/Prover/MRSolver/Monad.hs +++ b/src/SAWScript/Prover/MRSolver/Monad.hs @@ -30,6 +30,9 @@ import Control.Monad.Trans.Maybe import Data.Map (Map) import qualified Data.Map as Map +import Data.HashMap.Lazy (HashMap) +import qualified Data.HashMap.Lazy as HashMap + import Prettyprinter import Verifier.SAW.Term.Functor @@ -226,6 +229,23 @@ data FunAssump = FunAssump { -- name type FunAssumps = Map FunName FunAssump +-- | ... +data DataTypeAssump = IsLeft Term | IsRight Term + +instance PrettyInCtx DataTypeAssump where + prettyInCtx (IsLeft x) = prettyInCtx x >>= ppWithPrefix "Left _ _" + prettyInCtx (IsRight x) = prettyInCtx x >>= ppWithPrefix "Right _ _" + +-- | ... +asEither :: Recognizer Term (Either Term Term) +asEither (asCtor -> Just (c, [_, _, x])) + | primName c == "Prelude.Left" = return $ Left x + | primName c == "Prelude.Right" = return $ Right x +asEither _ = Nothing + +-- | ... +type DataTypeAssumps = HashMap Term DataTypeAssump + -- | Parameters and locals for MR. Solver data MRInfo = MRInfo { -- | Global shared context for building terms, etc. @@ -243,6 +263,8 @@ data MRInfo = MRInfo { -- | The current assumptions, which are conjoined into a single Boolean term; -- note that these have the current UVars free mriAssumptions :: Term, + -- | ... + mriDataTypeAssumps :: DataTypeAssumps, -- | The debug level, which controls debug printing mriDebugLevel :: Int } @@ -298,6 +320,10 @@ mrCoIndHyps = mriCoIndHyps <$> ask mrAssumptions :: MRM Term mrAssumptions = mriAssumptions <$> ask +-- | Get the current value of 'mriDataTypeAssumps' +mrDataTypeAssumps :: MRM DataTypeAssumps +mrDataTypeAssumps = mriDataTypeAssumps <$> ask + -- | Get the current value of 'mriDebugLevel' mrDebugLevel :: MRM Int mrDebugLevel = mriDebugLevel <$> ask @@ -314,7 +340,8 @@ runMRM sc timeout debug assumps m = let init_info = MRInfo { mriSC = sc, mriSMTTimeout = timeout, mriDebugLevel = debug, mriFunAssumps = assumps, mriUVars = [], mriCoIndHyps = Map.empty, - mriAssumptions = true_tm } + mriAssumptions = true_tm, + mriDataTypeAssumps = HashMap.empty } let init_st = MRState { mrsVars = Map.empty } res <- runExceptT $ flip evalStateT init_st $ flip runReaderT init_info $ unMRM m @@ -799,10 +826,22 @@ instantiateFunAssump fassump = -- executing a sub-computation withAssumption :: Term -> MRM a -> MRM a withAssumption phi m = - do assumps <- mrAssumptions + do mrDebugPPPrefix 1 "withAssumption" phi + assumps <- mrAssumptions assumps' <- liftSC2 scAnd phi assumps local (\info -> info { mriAssumptions = assumps' }) m +-- | ... +withDataTypeAssump :: Term -> DataTypeAssump -> MRM a -> MRM a +withDataTypeAssump x assump m = + do mrDebugPPPrefixSep 1 "withDataTypeAssump" x "==" assump + dataTypeAssumps' <- HashMap.insert x assump <$> mrDataTypeAssumps + local (\info -> info { mriDataTypeAssumps = dataTypeAssumps' }) m + +-- | ... +mrGetDataTypeAssump :: Term -> MRM (Maybe DataTypeAssump) +mrGetDataTypeAssump x = HashMap.lookup x <$> mrDataTypeAssumps + -- | Print a 'String' if the debug level is at least the supplied 'Int' debugPrint :: Int -> String -> MRM () debugPrint i str = @@ -824,6 +863,14 @@ mrPPInCtx :: PrettyInCtx a => a -> MRM SawDoc mrPPInCtx a = runReader (prettyInCtx a) <$> map fst <$> mrUVars +-- | Pretty-print the result of 'ppWithPrefix' relative to the current uvar +-- context to 'stderr' if the debug level is at least the 'Int' provided +mrDebugPPPrefix :: PrettyInCtx a => Int -> String -> a -> MRM () +mrDebugPPPrefix i pre a = + mrUVars >>= \ctx -> + debugPretty i $ + flip runReader (map fst ctx) (group <$> nest 2 <$> ppWithPrefix pre a) + -- | Pretty-print the result of 'ppWithPrefixSep' relative to the current uvar -- context to 'stderr' if the debug level is at least the 'Int' provided mrDebugPPPrefixSep :: (PrettyInCtx a, PrettyInCtx b) => diff --git a/src/SAWScript/Prover/MRSolver/Solver.hs b/src/SAWScript/Prover/MRSolver/Solver.hs index e29339bfa8..5ce59d570a 100644 --- a/src/SAWScript/Prover/MRSolver/Solver.hs +++ b/src/SAWScript/Prover/MRSolver/Solver.hs @@ -498,8 +498,30 @@ mrRefines' m1 (Ite cond2 m2 m2') = withAssumption cond2 (mrRefines m1 m2) withAssumption not_cond2 (mrRefines m1 m2') --- FIXME: handle sum elimination --- mrRefines (Either f1 g1 e1) (Either f2 g2 e2) = +-- FIXME: finish handling sum elimination +mrRefines' (Either (Type ltp1) (Type rtp1) f1 g1 t1) m2 = + -- FIXME: call `mrGetDataTypeAssump` like below + case asEither t1 of + Just (Left x) -> do m1' <- applyNormCompFun f1 x + mrRefines m1' m2 + Just (Right x) -> do m1' <- applyNormCompFun g1 x + mrRefines m1' m2 + Nothing -> do let lnm = maybe "x" id (compFunVarName f1) + rnm = maybe "x" id (compFunVarName f1) + xl <- piUVarsM ltp1 >>= mrFreshVar lnm >>= mrVarTerm + xr <- piUVarsM rtp1 >>= mrFreshVar rnm >>= mrVarTerm + lm1' <- applyNormCompFun f1 xl + rm1' <- applyNormCompFun g1 xr + withDataTypeAssump t1 (IsLeft xl) (mrRefines lm1' m2) + withDataTypeAssump t1 (IsRight xr) (mrRefines rm1' m2) +mrRefines' m1 (Either (Type ltp2) (Type rtp2) f2 g2 t2) = + -- FIXME: check `asEither` like above + mrGetDataTypeAssump t2 >>= \case + Just (IsLeft x) -> do m2' <- applyNormCompFun f2 x + mrRefines m1 m2' + Just (IsRight x) -> do m2' <- applyNormCompFun g2 x + mrRefines m1 m2' + Nothing -> undefined mrRefines' m1 (ForallM tp f2) = let nm = maybe "x" id (compFunVarName f2) in From aaa82c1622f76f0002ffb283ca5f5844457a54ae Mon Sep 17 00:00:00 2001 From: Matthew Yacavone Date: Wed, 2 Mar 2022 12:21:36 -0800 Subject: [PATCH 063/105] add generic defaults for TermLike, lift DataTypeAssumps --- src/SAWScript/Prover/MRSolver/Monad.hs | 18 ++- src/SAWScript/Prover/MRSolver/Term.hs | 158 ++++++++++++------------- 2 files changed, 91 insertions(+), 85 deletions(-) diff --git a/src/SAWScript/Prover/MRSolver/Monad.hs b/src/SAWScript/Prover/MRSolver/Monad.hs index 3113f317db..34c7e960c7 100644 --- a/src/SAWScript/Prover/MRSolver/Monad.hs +++ b/src/SAWScript/Prover/MRSolver/Monad.hs @@ -4,6 +4,9 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} {- | Module : SAWScript.Prover.MRSolver.Monad @@ -26,6 +29,7 @@ import Control.Monad.Reader import Control.Monad.State import Control.Monad.Except import Control.Monad.Trans.Maybe +import GHC.Generics import Data.Map (Map) import qualified Data.Map as Map @@ -231,6 +235,7 @@ type FunAssumps = Map FunName FunAssump -- | ... data DataTypeAssump = IsLeft Term | IsRight Term + deriving (Generic, Show, TermLike) instance PrettyInCtx DataTypeAssump where prettyInCtx (IsLeft x) = prettyInCtx x >>= ppWithPrefix "Left _ _" @@ -286,9 +291,9 @@ data MRExn = MRExnFailure MRFailure -- type, all over an 'IO' monad newtype MRM a = MRM { unMRM :: ReaderT MRInfo (StateT MRState (ExceptT MRExn IO)) a } - deriving (Functor, Applicative, Monad, MonadIO, - MonadReader MRInfo, MonadState MRState, - MonadError MRExn) + deriving newtype (Functor, Applicative, Monad, MonadIO, + MonadReader MRInfo, MonadState MRState, + MonadError MRExn) instance MonadTerm MRM where mkTermF = liftSC1 scTermF @@ -530,16 +535,19 @@ withUVars ctx f = do nms <- uniquifyNames (map fst ctx) <$> map fst <$> mrUVars let ctx_u = zip nms $ map (Type . snd) ctx assumps' <- mrAssumptions >>= liftTerm 0 (length ctx) + dataTypeAssumps' <- mrDataTypeAssumps >>= mapM (liftTermLike 0 (length ctx)) vars <- reverse <$> mapM (liftSC1 scLocalVar) [0 .. length ctx - 1] local (\info -> info { mriUVars = reverse ctx_u ++ mriUVars info, - mriAssumptions = assumps' }) $ + mriAssumptions = assumps', + mriDataTypeAssumps = dataTypeAssumps' }) $ foldr (\nm m -> mapMRFailure (MRFailureLocalVar nm) m) (f vars) nms -- | Run a MR Solver in a top-level context, i.e., with no uvars or assumptions withNoUVars :: MRM a -> MRM a withNoUVars m = do true_tm <- liftSC1 scBool True - local (\info -> info { mriUVars = [], mriAssumptions = true_tm }) m + local (\info -> info { mriUVars = [], mriAssumptions = true_tm, + mriDataTypeAssumps = HashMap.empty }) m -- | Run a MR Solver in a context of only the specified UVars, no others withOnlyUVars :: [(LocalName,Term)] -> MRM a -> MRM a diff --git a/src/SAWScript/Prover/MRSolver/Term.hs b/src/SAWScript/Prover/MRSolver/Term.hs index b84f5d39d2..c58f87016d 100644 --- a/src/SAWScript/Prover/MRSolver/Term.hs +++ b/src/SAWScript/Prover/MRSolver/Term.hs @@ -3,6 +3,15 @@ {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-} {- | Module : SAWScript.Prover.MRSolver.Term @@ -24,6 +33,7 @@ import Data.String import Data.IORef import Control.Monad.Reader import qualified Data.IntMap as IntMap +import GHC.Generics import Prettyprinter @@ -31,7 +41,7 @@ import Verifier.SAW.Term.Functor import Verifier.SAW.Term.CtxTerm (MonadTerm(..)) import Verifier.SAW.Term.Pretty import Verifier.SAW.SharedTerm -import Verifier.SAW.Recognizer +import Verifier.SAW.Recognizer hiding ((:*:)) import Verifier.SAW.Cryptol.Monadify @@ -79,7 +89,7 @@ asGlobalFunName (asTypedGlobalProj -> Just (glob, projs)) = asGlobalFunName _ = Nothing -- | A term specifically known to be of type @sort i@ for some @i@ -newtype Type = Type Term deriving Show +newtype Type = Type Term deriving (Generic, Show) -- | A Haskell representation of a @CompM@ in "monadic normal form" data NormComp @@ -93,7 +103,7 @@ data NormComp | ForallM Type CompFun -- ^ a @forallM@ computation | FunBind FunName [Term] CompFun -- ^ Bind a monadic function with @N@ arguments in an @a -> CompM b@ term - deriving Show + deriving (Generic, Show) -- | A computation function of type @a -> CompM b@ for some @a@ and @b@ data CompFun @@ -103,7 +113,7 @@ data CompFun | CompFunReturn -- | The monadic composition @f >=> g@ | CompFunComp CompFun CompFun - deriving Show + deriving (Generic, Show) -- | Compose two 'CompFun's, simplifying if one is a 'CompFunReturn' compFunComp :: CompFun -> CompFun -> CompFun @@ -127,7 +137,7 @@ compFunInputType _ = Nothing -- | A computation of type @CompM a@ for some @a@ data Comp = CompTerm Term | CompBind Comp CompFun | CompReturn Term - deriving Show + deriving (Generic, Show) -- | Match a type as being of the form @CompM a@ for some @a@ asCompM :: Term -> Maybe Term @@ -173,90 +183,78 @@ memoFixTermFun f term_top = -- * Lifting MR Solver Terms ---------------------------------------------------------------------- --- | A term-like object is one that supports lifting and substitution +-- | A term-like object is one that supports lifting and substitution. This +-- class can be derived using @DeriveAnyClass@. class TermLike a where liftTermLike :: MonadTerm m => DeBruijnIndex -> DeBruijnIndex -> a -> m a substTermLike :: MonadTerm m => DeBruijnIndex -> [Term] -> a -> m a -instance (TermLike a, TermLike b) => TermLike (a,b) where - liftTermLike n i (a,b) = (,) <$> liftTermLike n i a <*> liftTermLike n i b - substTermLike n s (a,b) = (,) <$> substTermLike n s a <*> substTermLike n s b - -instance TermLike a => TermLike [a] where - liftTermLike n i l = mapM (liftTermLike n i) l - substTermLike n s l = mapM (substTermLike n s) l + -- Default instances for @DeriveAnyClass@ + default liftTermLike :: (Generic a, GTermLike (Rep a), MonadTerm m) => + DeBruijnIndex -> DeBruijnIndex -> a -> m a + liftTermLike n i = fmap to . gLiftTermLike n i . from + default substTermLike :: (Generic a, GTermLike (Rep a), MonadTerm m) => + DeBruijnIndex -> [Term] -> a -> m a + substTermLike n i = fmap to . gSubstTermLike n i . from + +-- | A generic version of 'TermLike' for @DeriveAnyClass@, based on: +-- https://hackage.haskell.org/package/base-4.16.0.0/docs/GHC-Generics.html#g:12 +class GTermLike f where + gLiftTermLike :: MonadTerm m => DeBruijnIndex -> DeBruijnIndex -> f p -> m (f p) + gSubstTermLike :: MonadTerm m => DeBruijnIndex -> [Term] -> f p -> m (f p) + +-- | 'TermLike' on empty types +instance GTermLike V1 where + gLiftTermLike _ _ = \case {} + gSubstTermLike _ _ = \case {} + +-- | 'TermLike' on unary types +instance GTermLike U1 where + gLiftTermLike _ _ U1 = return U1 + gSubstTermLike _ _ U1 = return U1 + +-- | 'TermLike' on sums +instance (GTermLike f, GTermLike g) => GTermLike (f :+: g) where + gLiftTermLike n i (L1 a) = L1 <$> gLiftTermLike n i a + gLiftTermLike n i (R1 b) = R1 <$> gLiftTermLike n i b + gSubstTermLike n s (L1 a) = L1 <$> gSubstTermLike n s a + gSubstTermLike n s (R1 b) = R1 <$> gSubstTermLike n s b + +-- | 'TermLike' on products +instance (GTermLike f, GTermLike g) => GTermLike (f :*: g) where + gLiftTermLike n i (a :*: b) = (:*:) <$> gLiftTermLike n i a <*> gLiftTermLike n i b + gSubstTermLike n s (a :*: b) = (:*:) <$> gSubstTermLike n s a <*> gSubstTermLike n s b + +-- | 'TermLike' on fields +instance TermLike a => GTermLike (K1 i a) where + gLiftTermLike n i (K1 a) = K1 <$> liftTermLike n i a + gSubstTermLike n i (K1 a) = K1 <$> substTermLike n i a + +-- | 'GTermLike' ignores meta-information +instance GTermLike a => GTermLike (M1 i c a) where + gLiftTermLike n i (M1 a) = M1 <$> gLiftTermLike n i a + gSubstTermLike n i (M1 a) = M1 <$> gSubstTermLike n i a + +deriving instance _ => TermLike (a,b) +deriving instance _ => TermLike (a,b,c) +deriving instance _ => TermLike (a,b,c,d) +deriving instance _ => TermLike (a,b,c,d,e) +deriving instance _ => TermLike (a,b,c,d,e,f) +deriving instance _ => TermLike (a,b,c,d,e,f,g) +deriving instance _ => TermLike [a] instance TermLike Term where liftTermLike = liftTerm substTermLike = substTerm -instance TermLike Type where - liftTermLike n i (Type tp) = Type <$> liftTerm n i tp - substTermLike n s (Type tp) = Type <$> substTerm n s tp - -instance TermLike NormComp where - liftTermLike n i (ReturnM t) = ReturnM <$> liftTermLike n i t - liftTermLike n i (ErrorM str) = ErrorM <$> liftTermLike n i str - liftTermLike n i (Ite cond t1 t2) = - Ite <$> liftTermLike n i cond <*> liftTermLike n i t1 - <*> liftTermLike n i t2 - liftTermLike n i (Either ltp rtp f g eith) = - Either <$> liftTermLike n i ltp <*> liftTermLike n i rtp - <*> liftTermLike n i f <*> liftTermLike n i g - <*> liftTermLike n i eith - liftTermLike n i (MaybeElim tp m f mayb) = - MaybeElim <$> liftTermLike n i tp <*> liftTermLike n i m - <*> liftTermLike n i f <*> liftTermLike n i mayb - liftTermLike n i (OrM t1 t2) = - OrM <$> liftTermLike n i t1 <*> liftTermLike n i t2 - liftTermLike n i (ExistsM tp f) = - ExistsM <$> liftTermLike n i tp <*> liftTermLike n i f - liftTermLike n i (ForallM tp f) = - ForallM <$> liftTermLike n i tp <*> liftTermLike n i f - liftTermLike n i (FunBind nm args f) = - FunBind nm <$> mapM (liftTermLike n i) args <*> liftTermLike n i f - - substTermLike n s (ReturnM t) = ReturnM <$> substTermLike n s t - substTermLike n s (ErrorM str) = ErrorM <$> substTermLike n s str - substTermLike n s (Ite cond t1 t2) = - Ite <$> substTermLike n s cond <*> substTermLike n s t1 - <*> substTermLike n s t2 - substTermLike n s (Either ltp rtp f g eith) = - Either <$> substTermLike n s ltp <*> substTermLike n s rtp - <*> substTermLike n s f <*> substTermLike n s g - <*> substTermLike n s eith - substTermLike n s (MaybeElim tp m f mayb) = - MaybeElim <$> substTermLike n s tp <*> substTermLike n s m - <*> substTermLike n s f <*> substTermLike n s mayb - substTermLike n s (OrM t1 t2) = - OrM <$> substTermLike n s t1 <*> substTermLike n s t2 - substTermLike n s (ExistsM tp f) = - ExistsM <$> substTermLike n s tp <*> substTermLike n s f - substTermLike n s (ForallM tp f) = - ForallM <$> substTermLike n s tp <*> substTermLike n s f - substTermLike n s (FunBind nm args f) = - FunBind nm <$> mapM (substTermLike n s) args <*> substTermLike n s f - -instance TermLike CompFun where - liftTermLike n i (CompFunTerm t) = CompFunTerm <$> liftTermLike n i t - liftTermLike _ _ CompFunReturn = return CompFunReturn - liftTermLike n i (CompFunComp f g) = - CompFunComp <$> liftTermLike n i f <*> liftTermLike n i g - - substTermLike n s (CompFunTerm t) = CompFunTerm <$> substTermLike n s t - substTermLike _ _ CompFunReturn = return CompFunReturn - substTermLike n s (CompFunComp f g) = - CompFunComp <$> substTermLike n s f <*> substTermLike n s g - -instance TermLike Comp where - liftTermLike n i (CompTerm t) = CompTerm <$> liftTermLike n i t - liftTermLike n i (CompBind m f) = - CompBind <$> liftTermLike n i m <*> liftTermLike n i f - liftTermLike n i (CompReturn t) = CompReturn <$> liftTermLike n i t - substTermLike n s (CompTerm t) = CompTerm <$> substTermLike n s t - substTermLike n s (CompBind m f) = - CompBind <$> substTermLike n s m <*> substTermLike n s f - substTermLike n s (CompReturn t) = CompReturn <$> substTermLike n s t +instance TermLike FunName where + liftTermLike _ _ = return + substTermLike _ _ = return + +deriving instance TermLike Type +deriving instance TermLike NormComp +deriving instance TermLike CompFun +deriving instance TermLike Comp ---------------------------------------------------------------------- From ac958bdcf3428a2a6e67eb50c4410a8179012bc3 Mon Sep 17 00:00:00 2001 From: Matthew Yacavone Date: Wed, 2 Mar 2022 13:00:57 -0800 Subject: [PATCH 064/105] finish implementing mrRefines' for eithers --- .../examples/linked_list_mr_solver.saw | 17 +++++- src/SAWScript/Prover/MRSolver/SMT.hs | 41 ++++++++----- src/SAWScript/Prover/MRSolver/Solver.hs | 57 +++++++++++-------- 3 files changed, 76 insertions(+), 39 deletions(-) diff --git a/heapster-saw/examples/linked_list_mr_solver.saw b/heapster-saw/examples/linked_list_mr_solver.saw index 9cde0ac4c6..562b9bc560 100644 --- a/heapster-saw/examples/linked_list_mr_solver.saw +++ b/heapster-saw/examples/linked_list_mr_solver.saw @@ -1,8 +1,23 @@ include "linked_list.saw"; +let eq_bool b1 b2 = + if b1 then + if b2 then true else false + else + if b2 then false else true; + +let fail = do { print "Test failed"; exit 1; }; +let run_test name test expected = + do { if expected then print (str_concat "Test: " name) else + print (str_concat (str_concat "Test: " name) " (expecting failure)"); + actual <- test; + if eq_bool actual expected then print "Success\n" else + do { print "Test failed\n"; exit 1; }; }; + + heapster_typecheck_fun env "is_head" "(). arg0:int64<>, arg1:List,always,R> -o \ \ arg0:true, arg1:true, ret:int64<>"; is_head <- parse_core_mod "linked_list" "is_head"; -mr_solver_debug 2 is_head is_head; +run_test "is_head |= is_head" (mr_solver is_head is_head) true; diff --git a/src/SAWScript/Prover/MRSolver/SMT.hs b/src/SAWScript/Prover/MRSolver/SMT.hs index 7043c9f565..aa15ee784f 100644 --- a/src/SAWScript/Prover/MRSolver/SMT.hs +++ b/src/SAWScript/Prover/MRSolver/SMT.hs @@ -81,6 +81,11 @@ asGenBVVecTerm (asApplyAll -> = Just (n, len, a, e) asGenBVVecTerm _ = Nothing +-- | Build a pair of two terms +pairTerm :: SharedContext -> Term -> Term -> IO Term +pairTerm sc x y = + completeOpenTerm sc $ pairOpenTerm (closedOpenTerm x) (closedOpenTerm y) + type TmPrim = Prim TermModel -- | Convert a Boolean value to a 'Term'; like 'readBackValue' but that function @@ -181,21 +186,29 @@ mrProvable (asBool -> Just b) = return b mrProvable bool_tm = do assumps <- mrAssumptions prop <- liftSC2 scImplies assumps bool_tm >>= liftSC1 scEqTrue - prop_inst <- flip instantiateUVarsM prop $ \nm tp -> - liftSC1 scWhnf tp >>= \case - (asBVVecType -> Just (n, len, a)) -> - -- For variables of type BVVec, create a Vec n Bool -> a function as an - -- ExtCns and apply genBVVec to it - do - ec_tp <- - liftSC1 completeOpenTerm $ - arrowOpenTerm "_" (applyOpenTermMulti (globalOpenTerm "Prelude.Vec") - [closedOpenTerm n, boolTypeOpenTerm]) - (closedOpenTerm a) - ec <- liftSC2 scFreshEC nm ec_tp >>= liftSC1 scExtCns - liftSC4 genBVVecTerm n len a ec - tp' -> liftSC2 scFreshEC nm tp' >>= liftSC1 scExtCns + prop_inst <- instantiateUVarsM instUVar prop normSMTProp prop_inst >>= mrProvableRaw + where -- | Given a UVar name and type, generate a 'Term' to be passed to + -- SMT, with special cases for BVVec and pair types + instUVar :: LocalName -> Term -> MRM Term + instUVar nm tp = liftSC1 scWhnf tp >>= \case + -- For variables of type BVVec, create a @Vec n Bool -> a@ function + -- as an ExtCns and apply genBVVec to it + (asBVVecType -> Just (n, len, a)) -> do + ec_tp <- + liftSC1 completeOpenTerm $ + arrowOpenTerm "_" (applyOpenTermMulti (globalOpenTerm "Prelude.Vec") + [closedOpenTerm n, boolTypeOpenTerm]) + (closedOpenTerm a) + ec <- instUVar nm ec_tp + liftSC4 genBVVecTerm n len a ec + -- For pairs, recurse on both sides and combine the result as a pair + (asPairType -> Just (tp1, tp2)) -> do + e1 <- instUVar nm tp1 + e2 <- instUVar nm tp2 + liftSC2 pairTerm e1 e2 + -- Otherwise, create a global variable with the given name and type + tp' -> liftSC2 scFreshEC nm tp' >>= liftSC1 scExtCns ---------------------------------------------------------------------- diff --git a/src/SAWScript/Prover/MRSolver/Solver.hs b/src/SAWScript/Prover/MRSolver/Solver.hs index 5ce59d570a..44b3d65c5d 100644 --- a/src/SAWScript/Prover/MRSolver/Solver.hs +++ b/src/SAWScript/Prover/MRSolver/Solver.hs @@ -455,6 +455,7 @@ mrRefines' (ErrorM _) (ErrorM _) = return () mrRefines' (ReturnM e) (ErrorM _) = throwMRFailure (ReturnNotError e) mrRefines' (ErrorM _) (ReturnM e) = throwMRFailure (ReturnNotError e) +-- FIXME: Add support for arbitrary maybe asusmptions, like the either case mrRefines' (MaybeElim (Type (asEq -> Just (tp,e1,e2))) m1 f1 _) m2 = do cond <- mrEq' tp e1 e2 not_cond <- liftSC1 scNot cond @@ -498,30 +499,38 @@ mrRefines' m1 (Ite cond2 m2 m2') = withAssumption cond2 (mrRefines m1 m2) withAssumption not_cond2 (mrRefines m1 m2') --- FIXME: finish handling sum elimination -mrRefines' (Either (Type ltp1) (Type rtp1) f1 g1 t1) m2 = - -- FIXME: call `mrGetDataTypeAssump` like below - case asEither t1 of - Just (Left x) -> do m1' <- applyNormCompFun f1 x - mrRefines m1' m2 - Just (Right x) -> do m1' <- applyNormCompFun g1 x - mrRefines m1' m2 - Nothing -> do let lnm = maybe "x" id (compFunVarName f1) - rnm = maybe "x" id (compFunVarName f1) - xl <- piUVarsM ltp1 >>= mrFreshVar lnm >>= mrVarTerm - xr <- piUVarsM rtp1 >>= mrFreshVar rnm >>= mrVarTerm - lm1' <- applyNormCompFun f1 xl - rm1' <- applyNormCompFun g1 xr - withDataTypeAssump t1 (IsLeft xl) (mrRefines lm1' m2) - withDataTypeAssump t1 (IsRight xr) (mrRefines rm1' m2) -mrRefines' m1 (Either (Type ltp2) (Type rtp2) f2 g2 t2) = - -- FIXME: check `asEither` like above - mrGetDataTypeAssump t2 >>= \case - Just (IsLeft x) -> do m2' <- applyNormCompFun f2 x - mrRefines m1 m2' - Just (IsRight x) -> do m2' <- applyNormCompFun g2 x - mrRefines m1 m2' - Nothing -> undefined +mrRefines' (Either ltp1 rtp1 f1 g1 t1) m2 = + liftSC1 scWhnf t1 >>= \t1' -> + mrGetDataTypeAssump t1' >>= \mb_assump -> + case (mb_assump, asEither t1') of + (Just (IsLeft x), _) -> applyNormCompFun f1 x >>= flip mrRefines m2 + (Just (IsRight x), _) -> applyNormCompFun g1 x >>= flip mrRefines m2 + (_, Just (Left x)) -> applyNormCompFun f1 x >>= flip mrRefines m2 + (_, Just (Right x)) -> applyNormCompFun g1 x >>= flip mrRefines m2 + _ -> let lnm = maybe "x_left" id (compFunVarName f1) + rnm = maybe "x_right" id (compFunVarName g1) + in withUVarLift lnm ltp1 (f1, t1', m2) (\x (f1', t1'', m2') -> + applyNormCompFun f1' x >>= withDataTypeAssump t1'' (IsLeft x) + . flip mrRefines m2') >> + withUVarLift rnm rtp1 (g1, t1', m2) (\x (g1', t1'', m2') -> + applyNormCompFun g1' x >>= withDataTypeAssump t1'' (IsRight x) + . flip mrRefines m2') +mrRefines' m1 (Either ltp2 rtp2 f2 g2 t2) = + liftSC1 scWhnf t2 >>= \t2' -> + mrGetDataTypeAssump t2' >>= \mb_assump -> + case (mb_assump, asEither t2') of + (Just (IsLeft x), _) -> applyNormCompFun f2 x >>= mrRefines m1 + (Just (IsRight x), _) -> applyNormCompFun g2 x >>= mrRefines m1 + (_, Just (Left x)) -> applyNormCompFun f2 x >>= mrRefines m1 + (_, Just (Right x)) -> applyNormCompFun g2 x >>= mrRefines m1 + _ -> let lnm = maybe "x_left" id (compFunVarName f2) + rnm = maybe "x_right" id (compFunVarName g2) + in withUVarLift lnm ltp2 (f2, t2', m1) (\x (f2', t2'', m1') -> + applyNormCompFun f2' x >>= withDataTypeAssump t2'' (IsLeft x) + . mrRefines m1') >> + withUVarLift rnm rtp2 (g2, t2', m1) (\x (g2', t2'', m1') -> + applyNormCompFun g2' x >>= withDataTypeAssump t2'' (IsRight x) + . mrRefines m1') mrRefines' m1 (ForallM tp f2) = let nm = maybe "x" id (compFunVarName f2) in From 5d2d93bb7f1133628813c0f886a6f1bd3f6b99b4 Mon Sep 17 00:00:00 2001 From: Matthew Yacavone Date: Wed, 2 Mar 2022 14:56:54 -0800 Subject: [PATCH 065/105] improve Ite cases of mrRefines', get is_elem |= is_elem working --- heapster-saw/examples/Makefile | 2 +- .../examples/linked_list_mr_solver.saw | 3 ++ src/SAWScript/Prover/MRSolver/SMT.hs | 11 ++--- src/SAWScript/Prover/MRSolver/Solver.hs | 40 +++++++++---------- 4 files changed, 27 insertions(+), 29 deletions(-) diff --git a/heapster-saw/examples/Makefile b/heapster-saw/examples/Makefile index dc91dd7a13..d10f19fc5d 100644 --- a/heapster-saw/examples/Makefile +++ b/heapster-saw/examples/Makefile @@ -34,7 +34,7 @@ rust_lifetimes.bc: rust_lifetimes.rs rustc --crate-type=lib --emit=llvm-bc rust_lifetimes.rs # Lists all the Mr Solver tests, without their ".saw" suffix -MR_SOLVER_TESTS = arrays_mr_solver +MR_SOLVER_TESTS = arrays_mr_solver linked_list_mr_solver .PHONY: mr-solver-tests $(MR_SOLVER_TESTS) mr-solver-tests: $(MR_SOLVER_TESTS) diff --git a/heapster-saw/examples/linked_list_mr_solver.saw b/heapster-saw/examples/linked_list_mr_solver.saw index 562b9bc560..931e102351 100644 --- a/heapster-saw/examples/linked_list_mr_solver.saw +++ b/heapster-saw/examples/linked_list_mr_solver.saw @@ -21,3 +21,6 @@ heapster_typecheck_fun env "is_head" is_head <- parse_core_mod "linked_list" "is_head"; run_test "is_head |= is_head" (mr_solver is_head is_head) true; + +is_elem <- parse_core_mod "linked_list" "is_elem"; +run_test "is_elem |= is_elem" (mr_solver is_elem is_elem) true; diff --git a/src/SAWScript/Prover/MRSolver/SMT.hs b/src/SAWScript/Prover/MRSolver/SMT.hs index aa15ee784f..cb49875836 100644 --- a/src/SAWScript/Prover/MRSolver/SMT.hs +++ b/src/SAWScript/Prover/MRSolver/SMT.hs @@ -81,11 +81,6 @@ asGenBVVecTerm (asApplyAll -> = Just (n, len, a, e) asGenBVVecTerm _ = Nothing --- | Build a pair of two terms -pairTerm :: SharedContext -> Term -> Term -> IO Term -pairTerm sc x y = - completeOpenTerm sc $ pairOpenTerm (closedOpenTerm x) (closedOpenTerm y) - type TmPrim = Prim TermModel -- | Convert a Boolean value to a 'Term'; like 'readBackValue' but that function @@ -206,7 +201,7 @@ mrProvable bool_tm = (asPairType -> Just (tp1, tp2)) -> do e1 <- instUVar nm tp1 e2 <- instUVar nm tp2 - liftSC2 pairTerm e1 e2 + liftSC2 scPairValue e1 e2 -- Otherwise, create a global variable with the given name and type tp' -> liftSC2 scFreshEC nm tp' >>= liftSC1 scExtCns @@ -282,7 +277,9 @@ mrProveEq t1 t2 = tp <- mrTypeOf t1 varmap <- mrVars cond_in_ctx <- mrProveEqH varmap tp t1 t2 - withTermInCtx cond_in_ctx mrProvable + res <- withTermInCtx cond_in_ctx mrProvable + debugPrint 1 $ "mrProveEq: " ++ if res then "Success" else "Failure" + return res -- | Prove that two terms are equal, instantiating evars if necessary, or -- throwing an error if this is not possible diff --git a/src/SAWScript/Prover/MRSolver/Solver.hs b/src/SAWScript/Prover/MRSolver/Solver.hs index 44b3d65c5d..0413edc4f8 100644 --- a/src/SAWScript/Prover/MRSolver/Solver.hs +++ b/src/SAWScript/Prover/MRSolver/Solver.hs @@ -115,7 +115,7 @@ C |- F e1 ... en >>= k |= F' e1' ... em' >>= k': module SAWScript.Prover.MRSolver.Solver where import Data.Either -import Data.List (findIndices) +import Data.List (findIndices, intercalate) import Control.Monad.Except import qualified Data.Map as Map @@ -366,6 +366,7 @@ withCoIndHyp' hyp m = -- NOTE: the state automatically gets reset here because we defined MRM -- with ExceptT at a lower level than StateT do mrDebugPPPrefixSep 1 "Widening recursive assumption for" nm1' "|=" nm2' + debugPrint 2 $ "Widening indices: " ++ intercalate ", " (map show new_vars) hyp' <- generalizeCoIndHyp hyp new_vars withCoIndHyp' hyp' m e -> throwError e @@ -380,7 +381,7 @@ matchCoIndHyp hyp args1 args2 = eqs2 <- zipWithM mrProveEq args2' args2 if and (eqs1 ++ eqs2) then return () else throwError $ MRExnWiden (coIndHypLHSFun hyp) (coIndHypRHSFun hyp) - (map Left (findIndices not eqs1) ++ map Right (findIndices not eqs1)) + (map Left (findIndices not eqs1) ++ map Right (findIndices not eqs2)) -- | Generalize some of the arguments of a coinductive hypothesis generalizeCoIndHyp :: CoIndHyp -> [Either Int Int] -> MRM CoIndHyp @@ -477,27 +478,24 @@ mrRefines' m1 (MaybeElim (Type (asEq -> Just (tp,e1,e2))) m2 f2 _) = withAssumption cond (mrRefines m1 m2') >> withAssumption not_cond (mrRefines m1 m2) -mrRefines' (Ite cond1 m1 m1') m2_all@(Ite cond2 m2 m2') = - liftSC1 scNot cond1 >>= \not_cond1 -> - (mrEq cond1 cond2 >>= mrProvable) >>= \case - True -> - -- If we can prove cond1 == cond2, then we just need to prove m1 |= m2 and - -- m1' |= m2'; further, we need only add assumptions about cond1, because it - -- is provably equal to cond2 - withAssumption cond1 (mrRefines m1 m2) >> - withAssumption not_cond1 (mrRefines m1' m2') - False -> - -- Otherwise, prove each branch of the LHS refines the whole RHS - withAssumption cond1 (mrRefines m1 m2_all) >> - withAssumption not_cond1 (mrRefines m1' m2_all) mrRefines' (Ite cond1 m1 m1') m2 = - do not_cond1 <- liftSC1 scNot cond1 - withAssumption cond1 (mrRefines m1 m2) - withAssumption not_cond1 (mrRefines m1' m2) + liftSC1 scNot cond1 >>= \not_cond1 -> + mrProvable cond1 >>= \cond1_true_pv-> + mrProvable not_cond1 >>= \cond1_false_pv -> + case (cond1_true_pv, cond1_false_pv) of + (True, _) -> mrRefines m1 m2 + (_, True) -> mrRefines m1' m2 + _ -> withAssumption cond1 (mrRefines m1 m2) >> + withAssumption not_cond1 (mrRefines m1' m2) mrRefines' m1 (Ite cond2 m2 m2') = - do not_cond2 <- liftSC1 scNot cond2 - withAssumption cond2 (mrRefines m1 m2) - withAssumption not_cond2 (mrRefines m1 m2') + liftSC1 scNot cond2 >>= \not_cond2 -> + mrProvable cond2 >>= \cond2_true_pv-> + mrProvable not_cond2 >>= \cond2_false_pv -> + case (cond2_true_pv, cond2_false_pv) of + (True, _) -> mrRefines m1 m2 + (_, True) -> mrRefines m1 m2' + _ -> withAssumption cond2 (mrRefines m1 m2) >> + withAssumption not_cond2 (mrRefines m1 m2') mrRefines' (Either ltp1 rtp1 f1 g1 t1) m2 = liftSC1 scWhnf t1 >>= \t1' -> From 1be5ea2917e825ac62e2c777d240a0d4b4fa3f92 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Wed, 2 Mar 2022 15:03:39 -0800 Subject: [PATCH 066/105] printing fixes for Mr Solver; also fixed a context bug in mrOutType --- src/SAWScript/Prover/MRSolver/Monad.hs | 2 +- src/SAWScript/Prover/MRSolver/Solver.hs | 3 ++- src/SAWScript/Prover/MRSolver/Term.hs | 29 ++++++++++++++++++++----- 3 files changed, 26 insertions(+), 8 deletions(-) diff --git a/src/SAWScript/Prover/MRSolver/Monad.hs b/src/SAWScript/Prover/MRSolver/Monad.hs index 5ad6828834..5a2b199aac 100644 --- a/src/SAWScript/Prover/MRSolver/Monad.hs +++ b/src/SAWScript/Prover/MRSolver/Monad.hs @@ -453,7 +453,7 @@ mrFunOutType :: FunName -> [Term] -> MRM Term mrFunOutType fname args = funNameType fname >>= \case (asPiList -> (vars, asCompM -> Just tp)) - | length vars == length args -> substTermLike 0 args tp + | length vars == length args -> substTermLike 0 (reverse args) tp ftype@(asPiList -> (vars, _)) -> do pp_ftype <- mrPPInCtx ftype pp_fname <- mrPPInCtx fname diff --git a/src/SAWScript/Prover/MRSolver/Solver.hs b/src/SAWScript/Prover/MRSolver/Solver.hs index 84b4a2febb..b85821b7ea 100644 --- a/src/SAWScript/Prover/MRSolver/Solver.hs +++ b/src/SAWScript/Prover/MRSolver/Solver.hs @@ -380,7 +380,7 @@ matchCoIndHyp hyp args1 args2 = eqs2 <- zipWithM mrProveEq args2' args2 if and (eqs1 ++ eqs2) then return () else throwError $ MRExnWiden (coIndHypLHSFun hyp) (coIndHypRHSFun hyp) - (map Left (findIndices not eqs1) ++ map Right (findIndices not eqs1)) + (map Left (findIndices not eqs1) ++ map Right (findIndices not eqs2)) -- | Generalize some of the arguments of a coinductive hypothesis generalizeCoIndHyp :: CoIndHyp -> [Either Int Int] -> MRM CoIndHyp @@ -584,6 +584,7 @@ mrRefines' m1@(FunBind f1 args1 k1) m2@(FunBind f2 args2 k2) = -- continuation on the other side, but we don't know how to do that, so give -- up _ -> + mrDebugPPPrefixSep 1 "mrRefines: bind types not equal:" tp1 "/=" tp2 >> throwMRFailure (CompsDoNotRefine m1 m2) {- FIXME: handle FunBind on just one side diff --git a/src/SAWScript/Prover/MRSolver/Term.hs b/src/SAWScript/Prover/MRSolver/Term.hs index 21669abb60..895cbdd369 100644 --- a/src/SAWScript/Prover/MRSolver/Term.hs +++ b/src/SAWScript/Prover/MRSolver/Term.hs @@ -78,6 +78,18 @@ asGlobalFunName (asTypedGlobalProj -> Just (glob, projs)) = Just $ GlobalName glob projs asGlobalFunName _ = Nothing +-- | Convert a 'FunName' to an unshared term, for printing +funNameTerm :: FunName -> Term +funNameTerm (LetRecName var) = Unshared $ FTermF $ ExtCns $ unMRVar var +funNameTerm (EVarFunName var) = Unshared $ FTermF $ ExtCns $ unMRVar var +funNameTerm (GlobalName gdef []) = globalDefTerm gdef +funNameTerm (GlobalName gdef (TermProjLeft:projs)) = + Unshared $ FTermF $ PairLeft $ funNameTerm (GlobalName gdef projs) +funNameTerm (GlobalName gdef (TermProjRight:projs)) = + Unshared $ FTermF $ PairRight $ funNameTerm (GlobalName gdef projs) +funNameTerm (GlobalName gdef (TermProjRecord fname:projs)) = + Unshared $ FTermF $ RecordProj (funNameTerm (GlobalName gdef projs)) fname + -- | A term specifically known to be of type @sort i@ for some @i@ newtype Type = Type Term deriving Show @@ -279,10 +291,15 @@ class PrettyInCtx a where instance PrettyInCtx Term where prettyInCtx t = flip (ppTermInCtx defaultPPOpts) t <$> ask --- | Combine a list of pretty-printed documents that represent an application +-- | Combine a list of pretty-printed documents like applications are combined prettyAppList :: [PPInCtxM SawDoc] -> PPInCtxM SawDoc prettyAppList = fmap (group . hang 2 . vsep) . sequence +-- | Pretty-print the application of a 'Term' +prettyTermApp :: Term -> [Term] -> PPInCtxM SawDoc +prettyTermApp f_top args = + prettyInCtx $ foldl (\f arg -> Unshared $ App f arg) f_top args + -- | FIXME: move this helper function somewhere better... ppCtx :: [(LocalName,Term)] -> SawDoc ppCtx = helper [] where @@ -314,7 +331,8 @@ instance PrettyInCtx FunName where prettyInCtx (LetRecName var) = prettyInCtx var prettyInCtx (EVarFunName var) = prettyInCtx var prettyInCtx (GlobalName g projs) = - foldM (\pp proj -> (pp <>) <$> prettyInCtx proj) (viaShow g) projs + foldM (\pp proj -> (pp <>) <$> prettyInCtx proj) (ppName $ + globalDefName g) projs instance PrettyInCtx Comp where prettyInCtx (CompTerm t) = prettyInCtx t @@ -355,10 +373,9 @@ instance PrettyInCtx NormComp where prettyAppList [return "forallM", prettyInCtx tp, return "_", parens <$> prettyInCtx f] prettyInCtx (FunBind f args CompFunReturn) = - prettyAppList (prettyInCtx f : map prettyInCtx args) + prettyTermApp (funNameTerm f) args prettyInCtx (FunBind f [] k) = prettyAppList [prettyInCtx f, return ">>=", prettyInCtx k] prettyInCtx (FunBind f args k) = - prettyAppList - [parens <$> prettyAppList (prettyInCtx f : map prettyInCtx args), - return ">>=", prettyInCtx k] + prettyAppList [parens <$> prettyTermApp (funNameTerm f) args, + return ">>=", prettyInCtx k] From 9f198766d52441e7a8559f7689ab25d4b806142a Mon Sep 17 00:00:00 2001 From: Matthew Yacavone Date: Wed, 2 Mar 2022 15:27:01 -0800 Subject: [PATCH 067/105] fill in some documentation --- src/SAWScript/Prover/MRSolver/Monad.hs | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/src/SAWScript/Prover/MRSolver/Monad.hs b/src/SAWScript/Prover/MRSolver/Monad.hs index 35f2a76285..b5e4526a3c 100644 --- a/src/SAWScript/Prover/MRSolver/Monad.hs +++ b/src/SAWScript/Prover/MRSolver/Monad.hs @@ -233,7 +233,8 @@ data FunAssump = FunAssump { -- name type FunAssumps = Map FunName FunAssump --- | ... +-- | An assumption that something is equal to one of the constructors of a +-- datatype, e.g. equal to @Left@ of some 'Term' or @Right@ of some 'Term' data DataTypeAssump = IsLeft Term | IsRight Term deriving (Generic, Show, TermLike) @@ -241,14 +242,14 @@ instance PrettyInCtx DataTypeAssump where prettyInCtx (IsLeft x) = prettyInCtx x >>= ppWithPrefix "Left _ _" prettyInCtx (IsRight x) = prettyInCtx x >>= ppWithPrefix "Right _ _" --- | ... +-- | Recognize a term as a @Left@ or @Right@ asEither :: Recognizer Term (Either Term Term) asEither (asCtor -> Just (c, [_, _, x])) | primName c == "Prelude.Left" = return $ Left x | primName c == "Prelude.Right" = return $ Right x asEither _ = Nothing --- | ... +-- | A map from 'Term's to 'DataTypeAssump's over that term type DataTypeAssumps = HashMap Term DataTypeAssump -- | Parameters and locals for MR. Solver @@ -268,7 +269,7 @@ data MRInfo = MRInfo { -- | The current assumptions, which are conjoined into a single Boolean term; -- note that these have the current UVars free mriAssumptions :: Term, - -- | ... + -- | The current set of 'DataTypeAssump's mriDataTypeAssumps :: DataTypeAssumps, -- | The debug level, which controls debug printing mriDebugLevel :: Int @@ -839,14 +840,15 @@ withAssumption phi m = assumps' <- liftSC2 scAnd phi assumps local (\info -> info { mriAssumptions = assumps' }) m --- | ... +-- | Add a 'DataTypeAssump' to the current context while executing a +-- sub-computations withDataTypeAssump :: Term -> DataTypeAssump -> MRM a -> MRM a withDataTypeAssump x assump m = do mrDebugPPPrefixSep 1 "withDataTypeAssump" x "==" assump dataTypeAssumps' <- HashMap.insert x assump <$> mrDataTypeAssumps local (\info -> info { mriDataTypeAssumps = dataTypeAssumps' }) m --- | ... +-- | Get the 'DataTypeAssump' associated to the given term, if one exists mrGetDataTypeAssump :: Term -> MRM (Maybe DataTypeAssump) mrGetDataTypeAssump x = HashMap.lookup x <$> mrDataTypeAssumps From 13d7d1345607e30c96aaf19afc89477e9555b5bc Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Wed, 2 Mar 2022 16:52:02 -0800 Subject: [PATCH 068/105] small tweak to mrRefines on either eliminations to handle the constructor cases first --- src/SAWScript/Prover/MRSolver/Solver.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/SAWScript/Prover/MRSolver/Solver.hs b/src/SAWScript/Prover/MRSolver/Solver.hs index 8e233a8e94..8f25dc5d72 100644 --- a/src/SAWScript/Prover/MRSolver/Solver.hs +++ b/src/SAWScript/Prover/MRSolver/Solver.hs @@ -501,10 +501,10 @@ mrRefines' (Either ltp1 rtp1 f1 g1 t1) m2 = liftSC1 scWhnf t1 >>= \t1' -> mrGetDataTypeAssump t1' >>= \mb_assump -> case (mb_assump, asEither t1') of - (Just (IsLeft x), _) -> applyNormCompFun f1 x >>= flip mrRefines m2 - (Just (IsRight x), _) -> applyNormCompFun g1 x >>= flip mrRefines m2 (_, Just (Left x)) -> applyNormCompFun f1 x >>= flip mrRefines m2 (_, Just (Right x)) -> applyNormCompFun g1 x >>= flip mrRefines m2 + (Just (IsLeft x), _) -> applyNormCompFun f1 x >>= flip mrRefines m2 + (Just (IsRight x), _) -> applyNormCompFun g1 x >>= flip mrRefines m2 _ -> let lnm = maybe "x_left" id (compFunVarName f1) rnm = maybe "x_right" id (compFunVarName g1) in withUVarLift lnm ltp1 (f1, t1', m2) (\x (f1', t1'', m2') -> @@ -517,10 +517,10 @@ mrRefines' m1 (Either ltp2 rtp2 f2 g2 t2) = liftSC1 scWhnf t2 >>= \t2' -> mrGetDataTypeAssump t2' >>= \mb_assump -> case (mb_assump, asEither t2') of - (Just (IsLeft x), _) -> applyNormCompFun f2 x >>= mrRefines m1 - (Just (IsRight x), _) -> applyNormCompFun g2 x >>= mrRefines m1 (_, Just (Left x)) -> applyNormCompFun f2 x >>= mrRefines m1 (_, Just (Right x)) -> applyNormCompFun g2 x >>= mrRefines m1 + (Just (IsLeft x), _) -> applyNormCompFun f2 x >>= mrRefines m1 + (Just (IsRight x), _) -> applyNormCompFun g2 x >>= mrRefines m1 _ -> let lnm = maybe "x_left" id (compFunVarName f2) rnm = maybe "x_right" id (compFunVarName g2) in withUVarLift lnm ltp2 (f2, t2', m1) (\x (f2', t2'', m1') -> From 3a9fb918d9c63532bb4d869d300a5e6541b3e1c1 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Fri, 4 Mar 2022 12:34:59 -0800 Subject: [PATCH 069/105] added preconditions to Mr Solver --- src/SAWScript/Builtins.hs | 29 ++++++++- src/SAWScript/Interpreter.hs | 7 +++ src/SAWScript/Prover/MRSolver.hs | 3 +- src/SAWScript/Prover/MRSolver/Monad.hs | 80 +++++++++++++++++++++---- src/SAWScript/Prover/MRSolver/Solver.hs | 55 +++++++++++++---- src/SAWScript/Value.hs | 2 + 6 files changed, 147 insertions(+), 29 deletions(-) diff --git a/src/SAWScript/Builtins.hs b/src/SAWScript/Builtins.hs index 9454f86a72..a95569d946 100644 --- a/src/SAWScript/Builtins.hs +++ b/src/SAWScript/Builtins.hs @@ -71,6 +71,7 @@ import Verifier.SAW.SATQuery import Verifier.SAW.SCTypeCheck hiding (TypedTerm) import qualified Verifier.SAW.SCTypeCheck as TC (TypedTerm(..)) import Verifier.SAW.SharedTerm +import Verifier.SAW.Recognizer import Verifier.SAW.TypedTerm import qualified Verifier.SAW.Simulator.Concrete as Concrete import Verifier.SAW.Prim (rethrowEvalError) @@ -1560,15 +1561,39 @@ ensureMonadicTerm sc t False -> monadifyTypedTerm sc t ensureMonadicTerm sc t = monadifyTypedTerm sc t +-- | Run Mr Solver with the given debug level to prove that the first term +-- refines the second mrSolver :: SharedContext -> Int -> TypedTerm -> TypedTerm -> TopLevel Bool mrSolver sc dlvl t1 t2 = - do m1 <- ttTerm <$> ensureMonadicTerm sc t1 + do rw <- get + m1 <- ttTerm <$> ensureMonadicTerm sc t1 m2 <- ttTerm <$> ensureMonadicTerm sc t2 - res <- liftIO $ Prover.askMRSolver sc dlvl Nothing m1 m2 + let env = rwMRSolverEnv rw + res <- liftIO $ Prover.askMRSolver sc dlvl env Nothing m1 m2 case res of Just err -> io (putStrLn $ Prover.showMRFailure err) >> return False Nothing -> return True +-- | Set the precondition for a named function, given as a SAW core term +mrSolverSetPrecond :: SharedContext -> TypedTerm -> TypedTerm -> TopLevel () +mrSolverSetPrecond sc f pre = + do rw <- get + f_mon <- ttTerm <$> ensureMonadicTerm sc f + gdef <- case Monadify.asTypedGlobalDef f_mon of + Just gdef -> return gdef + Nothing -> fail "mr_solver_set_precond: Not an identifier" + -- NOTE: do not monadify pre, as it is supposed to be pure + (asPiList -> (f_args, _)) <- io $ scTypeOf sc f_mon + pre_tp <- io (scTypeOf sc $ ttTerm pre) + pre_tp_req <- io (scBoolType sc >>= scPiList sc f_args) + correct_tp <- io (scConvertible sc True pre_tp pre_tp_req) + if correct_tp then return () else + fail ("mr_solver_set_precond: incorrect type for precondition\n" ++ + "Expected: " ++ showTerm pre_tp_req ++ "\n" ++ + "Actual: " ++ showTerm pre_tp) + let env = rwMRSolverEnv rw + put (rw { rwMRSolverEnv = Prover.mrEnvAddPrecond gdef (ttTerm pre) env }) + setMonadification :: SharedContext -> String -> String -> TopLevel () setMonadification sc cry_str saw_str = do rw <- get diff --git a/src/SAWScript/Interpreter.hs b/src/SAWScript/Interpreter.hs index e53db153db..114ea7f32d 100644 --- a/src/SAWScript/Interpreter.hs +++ b/src/SAWScript/Interpreter.hs @@ -67,6 +67,7 @@ import SAWScript.Value import SAWScript.Proof (newTheoremDB) import SAWScript.Prover.Rewrite(basic_ss) import SAWScript.Prover.Exporter +import SAWScript.Prover.MRSolver (emptyMREnv) import Verifier.SAW.Conversion --import Verifier.SAW.PrettySExp import Verifier.SAW.Prim (rethrowEvalError) @@ -474,6 +475,7 @@ buildTopLevelEnv proxy opts = , rwDocs = primDocEnv primsAvail , rwCryptol = ce0 , rwMonadify = Monadify.defaultMonEnv + , rwMRSolverEnv = emptyMREnv , rwProofs = [] , rwPPOpts = SAWScript.Value.defaultPPOpts , rwJVMTrans = jvmTrans @@ -3167,6 +3169,11 @@ primitives = Map.fromList Experimental [ "Call the monadic-recursive solver at the supplied debug level" ] + , prim "mr_solver_set_precond" "Term -> Term -> TopLevel ()" + (scVal mrSolverSetPrecond) + Experimental + [ "Set the precondition for use in Mr Solver of a function to a function" ] + , prim "monadify_term" "Term -> TopLevel Term" (scVal monadifyTypedTerm) Experimental diff --git a/src/SAWScript/Prover/MRSolver.hs b/src/SAWScript/Prover/MRSolver.hs index 856f94a5a7..fb2589766d 100644 --- a/src/SAWScript/Prover/MRSolver.hs +++ b/src/SAWScript/Prover/MRSolver.hs @@ -9,7 +9,8 @@ Portability : non-portable (language extensions) -} module SAWScript.Prover.MRSolver - (askMRSolver, MRFailure(..), showMRFailure, isCompFunType) where + (askMRSolver, MRFailure(..), showMRFailure, isCompFunType, + MREnv(..), emptyMREnv, mrEnvAddPrecond) where import SAWScript.Prover.MRSolver.Term import SAWScript.Prover.MRSolver.Monad diff --git a/src/SAWScript/Prover/MRSolver/Monad.hs b/src/SAWScript/Prover/MRSolver/Monad.hs index b5e4526a3c..a379a3d0ef 100644 --- a/src/SAWScript/Prover/MRSolver/Monad.hs +++ b/src/SAWScript/Prover/MRSolver/Monad.hs @@ -73,6 +73,7 @@ data MRFailure | MalformedDefsFun Term | MalformedComp Term | NotCompFunType Term + | PrecondNotProvable FunName FunName Term -- | A local variable binding | MRFailureLocalVar LocalName MRFailure -- | Information about the context of the failure @@ -129,6 +130,10 @@ instance PrettyInCtx MRFailure where ppWithPrefix "Could not handle computation:" t prettyInCtx (NotCompFunType tp) = ppWithPrefix "Not a computation or computational function type:" tp + prettyInCtx (PrecondNotProvable f g pre) = + prettyAppList [return "Could not prove precondition for functions", + prettyInCtx f, return "and", prettyInCtx g, + return ":", prettyInCtx pre] prettyInCtx (MRFailureLocalVar x err) = local (x:) $ prettyInCtx err prettyInCtx (MRFailureCtx ctx err) = @@ -189,23 +194,31 @@ data CoIndHyp = CoIndHyp { -- | The LHS argument expressions @y1, ..., ym@ over the 'coIndHypCtx' uvars coIndHypLHS :: [Term], -- | The RHS argument expressions @y1, ..., ym@ over the 'coIndHypCtx' uvars - coIndHypRHS :: [Term] + coIndHypRHS :: [Term], + -- | The precondition for the left-hand arguments, as a closed function from + -- the left-hand arguments to @Bool@ + coIndHypPrecondLHS :: Term, + -- | The precondition for the right-hand arguments, as a closed function from + -- the left-hand arguments to @Bool@ + coIndHypPrecondRHS :: Term } deriving Show -- | Extract the @i@th argument on either the left- or right-hand side of a -- coinductive hypothesis coIndHypArg :: CoIndHyp -> Either Int Int -> Term -coIndHypArg (CoIndHyp _ _ _ args1 _) (Left i) = args1 !! i -coIndHypArg (CoIndHyp _ _ _ _ args2) (Right i) = args2 !! i +coIndHypArg hyp (Left i) = (coIndHypLHS hyp) !! i +coIndHypArg hyp (Right i) = (coIndHypRHS hyp) !! i -- | A map from pairs of function names to co-inductive hypotheses over those -- names type CoIndHyps = Map (FunName, FunName) CoIndHyp instance PrettyInCtx CoIndHyp where - prettyInCtx (CoIndHyp ctx f1 f2 args1 args2) = + prettyInCtx (CoIndHyp ctx f1 f2 args1 args2 pre1 pre2) = local (const $ map fst $ reverse ctx) $ prettyAppList [return (ppCtx ctx <> "."), + prettyTermApp pre1 args1, return "=>", + prettyTermApp pre2 args2, return "=>", prettyInCtx (FunBind f1 args1 CompFunReturn), return "|=", prettyInCtx (FunBind f2 args2 CompFunReturn)] @@ -231,6 +244,8 @@ data FunAssump = FunAssump { -- | A map from function names to function refinement assumptions over that -- name +-- +-- FIXME: this should probably be an 'IntMap' on the 'VarIndex' of globals type FunAssumps = Map FunName FunAssump -- | An assumption that something is equal to one of the constructors of a @@ -252,6 +267,26 @@ asEither _ = Nothing -- | A map from 'Term's to 'DataTypeAssump's over that term type DataTypeAssumps = HashMap Term DataTypeAssump +-- | A global MR Solver environment +data MREnv = MREnv { + -- | The set of function refinements to be assumed by to Mr. Solver (which + -- have hopefully been proved previously...) + mreFunAssumps :: FunAssumps, + -- | The preconditions associated with functions by the user + mrePreconditions :: Map FunName Term + } + +-- | The empty 'MREnv' +emptyMREnv :: MREnv +emptyMREnv = MREnv { mreFunAssumps = Map.empty, + mrePreconditions = Map.empty } + +-- | Add a precondition to an 'MREnv' +mrEnvAddPrecond :: GlobalDef -> Term -> MREnv -> MREnv +mrEnvAddPrecond gdef pre env = + env { mrePreconditions = + Map.insert (GlobalName gdef []) pre (mrePreconditions env) } + -- | Parameters and locals for MR. Solver data MRInfo = MRInfo { -- | Global shared context for building terms, etc. @@ -262,8 +297,8 @@ data MRInfo = MRInfo { -- variables, in order from innermost to outermost, i.e., where element @0@ -- corresponds to deBruijn index @0@ mriUVars :: [(LocalName,Type)], - -- | The set of function refinements to be assumed by to Mr. Solver - mriFunAssumps :: FunAssumps, + -- | The top-level Mr Solver environment + mriEnv :: MREnv, -- | The current set of co-inductive hypotheses mriCoIndHyps :: CoIndHyps, -- | The current assumptions, which are conjoined into a single Boolean term; @@ -314,9 +349,9 @@ mrSMTTimeout = mriSMTTimeout <$> ask mrUVars :: MRM [(LocalName,Type)] mrUVars = mriUVars <$> ask --- | Get the current value of 'mriFunAssumps' +-- | Get the current function assumptions mrFunAssumps :: MRM FunAssumps -mrFunAssumps = mriFunAssumps <$> ask +mrFunAssumps = mreFunAssumps <$> mriEnv <$> ask -- | Get the current value of 'mriCoIndHyps' mrCoIndHyps :: MRM CoIndHyps @@ -339,12 +374,12 @@ mrVars :: MRM MRVarMap mrVars = mrsVars <$> get -- | Run an 'MRM' computation and return a result or an error -runMRM :: SharedContext -> Maybe Integer -> Int -> FunAssumps -> +runMRM :: SharedContext -> Maybe Integer -> Int -> MREnv -> MRM a -> IO (Either MRFailure a) -runMRM sc timeout debug assumps m = +runMRM sc timeout debug env m = do true_tm <- scBool sc True let init_info = MRInfo { mriSC = sc, mriSMTTimeout = timeout, - mriDebugLevel = debug, mriFunAssumps = assumps, + mriDebugLevel = debug, mriEnv = env, mriUVars = [], mriCoIndHyps = Map.empty, mriAssumptions = true_tm, mriDataTypeAssumps = HashMap.empty } @@ -473,6 +508,7 @@ mrTypeOf :: Term -> MRM Term mrTypeOf t = -- NOTE: scTypeOf' wants the type context in the most recently bound var -- first, i.e., in the mrUVarCtxRev order + mrDebugPPPrefix 2 "mrTypeOf:" t >> mrUVarCtxRev >>= \ctx -> liftSC2 scTypeOf' (map snd ctx) t -- | Check if two 'Term's are convertible in the 'MRM' monad @@ -792,7 +828,7 @@ mrGetCoIndHyp nm1 nm2 = Map.lookup (nm1, nm2) <$> mrCoIndHyps -- | Run a compuation under an additional co-inductive assumption withCoIndHypRaw :: CoIndHyp -> MRM a -> MRM a withCoIndHypRaw hyp m = - do debugPretty 1 ("withCoIndHyp" <+> ppInEmptyCtx hyp) + do debugPretty 2 ("withCoIndHypRaw" <+> ppInEmptyCtx hyp) hyps' <- Map.insert (coIndHypLHSFun hyp, coIndHypRHSFun hyp) hyp <$> mrCoIndHyps local (\info -> info { mriCoIndHyps = hyps' }) m @@ -820,7 +856,9 @@ withFunAssump fname args rhs m = ctx <- mrUVarCtx assumps <- mrFunAssumps let assumps' = Map.insert fname (FunAssump ctx args rhs) assumps - local (\info -> info { mriFunAssumps = assumps' }) m + local (\info -> + let env' = (mriEnv info) { mreFunAssumps = assumps' } in + info { mriEnv = env' }) m -- | Generate fresh evars for the context of a 'FunAssump' and substitute them -- into its arguments and right-hand side @@ -831,6 +869,16 @@ instantiateFunAssump fassump = rhs <- substTermLike 0 evars $ fassumpRHS fassump return (args, rhs) +-- | Look up the precondition associated with a function name, returning the +-- trivial @True@ one if there is none +mrGetPrecond :: FunName -> MRM Term +mrGetPrecond nm = + (Map.lookup nm <$> mrePreconditions <$> mriEnv <$> ask) >>= \case + Just t -> return t + Nothing -> + do (nm_args, _) <- asPiList <$> funNameType nm + liftSC1 scBool True >>= liftSC2 scPiList nm_args + -- | Add an assumption of type @Bool@ to the current path condition while -- executing a sub-computation withAssumption :: Term -> MRM a -> MRM a @@ -840,6 +888,12 @@ withAssumption phi m = assumps' <- liftSC2 scAnd phi assumps local (\info -> info { mriAssumptions = assumps' }) m +-- | Remove any existing assumptions and replace them with a Boolean term +withOnlyAssumption :: Term -> MRM a -> MRM a +withOnlyAssumption phi m = + do mrDebugPPPrefix 1 "withOnlyAssumption" phi + local (\info -> info { mriAssumptions = phi }) m + -- | Add a 'DataTypeAssump' to the current context while executing a -- sub-computations withDataTypeAssump :: Term -> DataTypeAssump -> MRM a -> MRM a diff --git a/src/SAWScript/Prover/MRSolver/Solver.hs b/src/SAWScript/Prover/MRSolver/Solver.hs index 8f25dc5d72..6c18e9f253 100644 --- a/src/SAWScript/Prover/MRSolver/Solver.hs +++ b/src/SAWScript/Prover/MRSolver/Solver.hs @@ -117,7 +117,8 @@ module SAWScript.Prover.MRSolver.Solver where import Data.Either import Data.List (findIndices, intercalate) import Control.Monad.Except -import qualified Data.Map as Map + +import Prettyprinter import Verifier.SAW.Term.Functor import Verifier.SAW.SharedTerm @@ -345,17 +346,42 @@ handling the recursive ones -- * Handling Coinductive Hypotheses ---------------------------------------------------------------------- --- | Run a compuation under the additional co-inductive assumption that --- @forall x1, ..., xn. F y1 ... ym |= G z1 ... zl@, where @F@ and @G@ are --- the given 'FunName's, @y1, ..., ym@ and @z1, ..., zl@ are the given --- argument lists, and @x1, ..., xn@ is the current context of uvars. If --- while running the given computation a 'CoIndHypMismatchWidened' error is --- reached with the given names, the state is restored and the computation is --- re-run with the widened hypothesis. +-- | Prove the precondition of a coinductive hypothesis applied to the given +-- left- and right-hand arguments +proveCoIndHypPreCond :: CoIndHyp -> [Term] -> [Term] -> MRM () +proveCoIndHypPreCond hyp args1 args2 = + do pre1 <- liftSC2 scApplyAll (coIndHypPrecondLHS hyp) args1 + pre2 <- liftSC2 scApplyAll (coIndHypPrecondRHS hyp) args2 + -- FIXME: pre is just for printing / debugging purposes... + pre <- liftSC2 scAnd pre1 pre2 + success <- liftSC2 scAnd pre1 pre2 >>= mrProvable + if success then return () else + throwMRFailure $ + PrecondNotProvable (coIndHypLHSFun hyp) (coIndHypRHSFun hyp) pre + +-- | Run a compuation @m@ under the additional co-inductive assumption that +-- +-- > forall x1, ..., xn. preF y1 ... ym -> preG z1 ... zl -> +-- > F y1 ... ym |= G z1 ... zl@ +-- +-- where @F@ and @G@ are the given 'FunName's, @y1, ..., ym@ and @z1, ..., zl@ +-- are the given argument lists, @x1, ..., xn@ is the current context of uvars, +-- and @preF@ and @preG@ are the preconditions associated with @F@ and @G@, +-- respectively. Note that @m@ is run with /only/ these preconditions as +-- assumptions; all other assumptions are thrown away. If while running the +-- given computation a 'CoIndHypMismatchWidened' error is reached with the given +-- names, the state is restored and the computation is re-run with the widened +-- hypothesis. withCoIndHyp :: FunName -> [Term] -> FunName -> [Term] -> MRM a -> MRM a withCoIndHyp f1 args1 f2 args2 m = do ctx <- mrUVarCtx - withCoIndHyp' (CoIndHyp ctx f1 f2 args1 args2) m + pre1 <- mrGetPrecond f1 + pre2 <- mrGetPrecond f2 + pre <- liftSC2 scAnd pre1 pre2 + let hyp = CoIndHyp ctx f1 f2 args1 args2 pre1 pre2 + debugPretty 1 ("withCoIndHyp" <+> ppInEmptyCtx hyp) + proveCoIndHypPreCond hyp args1 args2 + withOnlyAssumption pre $ withCoIndHyp' hyp m -- | The main loop of 'withCoIndHyp' withCoIndHyp' :: CoIndHyp -> MRM a -> MRM a @@ -382,6 +408,8 @@ matchCoIndHyp hyp args1 args2 = if and (eqs1 ++ eqs2) then return () else throwError $ MRExnWiden (coIndHypLHSFun hyp) (coIndHypRHSFun hyp) (map Left (findIndices not eqs1) ++ map Right (findIndices not eqs2)) + proveCoIndHypPreCond hyp args1 args2 + -- | Generalize some of the arguments of a coinductive hypothesis generalizeCoIndHyp :: CoIndHyp -> [Either Int Int] -> MRM CoIndHyp @@ -412,7 +440,7 @@ generalizeCoIndHyp hyp all_specs@(arg_spec:arg_specs) = -- | Add a new variable of the given type to the context of a coinductive -- hypothesis and set the specified arguments to that new variable generalizeCoIndHypArgs :: CoIndHyp -> Term -> [Either Int Int] -> MRM CoIndHyp -generalizeCoIndHypArgs (CoIndHyp ctx f1 f2 args1 args2) tp specs = +generalizeCoIndHypArgs (CoIndHyp ctx f1 f2 args1 args2 pre1 pre2) tp specs = do let set_arg i args = take i args ++ (Unshared $ LocalVar 0) : drop (i+1) args let (specs1, specs2) = partitionEithers specs @@ -421,7 +449,7 @@ generalizeCoIndHypArgs (CoIndHyp ctx f1 f2 args1 args2) tp specs = args2' <- liftTermLike 0 1 args2 let args1'' = foldr set_arg args1' specs1 args2'' = foldr set_arg args2' specs2 - return $ CoIndHyp (ctx ++ [("z",tp)]) f1 f2 args1'' args2'' + return $ CoIndHyp (ctx ++ [("z",tp)]) f1 f2 args1'' args2'' pre1 pre2 ---------------------------------------------------------------------- @@ -726,16 +754,17 @@ mrRefinesFun _ _ = error "mrRefinesFun: unreachable!" askMRSolver :: SharedContext -> Int {- ^ The debug level -} -> + MREnv {- ^ The Mr Solver environment -} -> Maybe Integer {- ^ Timeout in milliseconds for each SMT call -} -> Term -> Term -> IO (Maybe MRFailure) -askMRSolver sc dlvl timeout t1 t2 = +askMRSolver sc dlvl env timeout t1 t2 = do tp1 <- scTypeOf sc t1 >>= scWhnf sc tp2 <- scTypeOf sc t2 >>= scWhnf sc case asPiList tp1 of (uvar_ctx, asCompM -> Just _) -> fmap (either Just (const Nothing)) $ - runMRM sc timeout dlvl Map.empty $ + runMRM sc timeout dlvl env $ withUVars uvar_ctx $ \vars -> do tps_are_eq <- mrConvertible tp1 tp2 if tps_are_eq then return () else diff --git a/src/SAWScript/Value.hs b/src/SAWScript/Value.hs index ca1eac5f59..8e0e40bb2b 100644 --- a/src/SAWScript/Value.hs +++ b/src/SAWScript/Value.hs @@ -76,6 +76,7 @@ import SAWScript.JavaPretty (prettyClass) import SAWScript.Options (Options(printOutFn),printOutLn,Verbosity) import SAWScript.Proof import SAWScript.Prover.SolverStats +import SAWScript.Prover.MRSolver.Monad as MRSolver import SAWScript.Crucible.LLVM.Skeleton import SAWScript.X86 (X86Unsupported(..), X86Error(..)) @@ -431,6 +432,7 @@ data TopLevelRW = , rwDocs :: Map SS.Name String , rwCryptol :: CEnv.CryptolEnv , rwMonadify :: Monadify.MonadifyEnv + , rwMRSolverEnv :: MRSolver.MREnv , rwProofs :: [Value] {- ^ Values, generated anywhere, that represent proofs. -} , rwPPOpts :: PPOpts -- , rwCrucibleLLVMCtx :: Crucible.LLVMContext From 5352afbd8ff728110a2e099c5f5a5670283a85bc Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Fri, 4 Mar 2022 18:11:08 -0800 Subject: [PATCH 070/105] changed how preconditions work so that they are given with a precondHint in the spec rather than with a separate mr_solver_set_precond command --- saw-core/prelude/Prelude.sawcore | 4 ++ src/SAWScript/Prover/MRSolver/Monad.hs | 65 +++++++++++++---- src/SAWScript/Prover/MRSolver/Solver.hs | 93 ++++++++++++++----------- 3 files changed, 106 insertions(+), 56 deletions(-) diff --git a/saw-core/prelude/Prelude.sawcore b/saw-core/prelude/Prelude.sawcore index 7b0676ff67..43cdafd843 100644 --- a/saw-core/prelude/Prelude.sawcore +++ b/saw-core/prelude/Prelude.sawcore @@ -2158,6 +2158,10 @@ orM a m1 m2 = existsM Bool a (\ (b:Bool) -> ite (CompM a) b m1 m2); -- those computations diverge from each other. primitive forallM : (a b:sort 0) -> (a -> CompM b) -> CompM b; +-- A hint to Mr Solver that a recursive function has the given precondition +precondHint : (a : sort 0) -> Bool -> a -> a; +precondHint _ _ a = a; + -- NOTE: for the simplicity and efficiency of MR solver, we define all -- fixed-point computations in CompM via a primitive multiFixM, defined below. -- Thus, even though fixM is really the primitive operation, we write this file diff --git a/src/SAWScript/Prover/MRSolver/Monad.hs b/src/SAWScript/Prover/MRSolver/Monad.hs index a379a3d0ef..af462235be 100644 --- a/src/SAWScript/Prover/MRSolver/Monad.hs +++ b/src/SAWScript/Prover/MRSolver/Monad.hs @@ -197,10 +197,10 @@ data CoIndHyp = CoIndHyp { coIndHypRHS :: [Term], -- | The precondition for the left-hand arguments, as a closed function from -- the left-hand arguments to @Bool@ - coIndHypPrecondLHS :: Term, + coIndHypPrecondLHS :: Maybe Term, -- | The precondition for the right-hand arguments, as a closed function from -- the left-hand arguments to @Bool@ - coIndHypPrecondRHS :: Term + coIndHypPrecondRHS :: Maybe Term } deriving Show -- | Extract the @i@th argument on either the left- or right-hand side of a @@ -217,8 +217,12 @@ instance PrettyInCtx CoIndHyp where prettyInCtx (CoIndHyp ctx f1 f2 args1 args2 pre1 pre2) = local (const $ map fst $ reverse ctx) $ prettyAppList [return (ppCtx ctx <> "."), - prettyTermApp pre1 args1, return "=>", - prettyTermApp pre2 args2, return "=>", + (case pre1 of + Just f -> prettyTermApp f args1 + Nothing -> return "True"), return "=>", + (case pre2 of + Just f -> prettyTermApp f args2 + Nothing -> return "True"), return "=>", prettyInCtx (FunBind f1 args1 CompFunReturn), return "|=", prettyInCtx (FunBind f2 args2 CompFunReturn)] @@ -267,6 +271,8 @@ asEither _ = Nothing -- | A map from 'Term's to 'DataTypeAssump's over that term type DataTypeAssumps = HashMap Term DataTypeAssump +-- FIXME HERE NOW: remove preconditions from MREnv + -- | A global MR Solver environment data MREnv = MREnv { -- | The set of function refinements to be assumed by to Mr. Solver (which @@ -826,8 +832,8 @@ mrGetCoIndHyp :: FunName -> FunName -> MRM (Maybe CoIndHyp) mrGetCoIndHyp nm1 nm2 = Map.lookup (nm1, nm2) <$> mrCoIndHyps -- | Run a compuation under an additional co-inductive assumption -withCoIndHypRaw :: CoIndHyp -> MRM a -> MRM a -withCoIndHypRaw hyp m = +withCoIndHyp :: CoIndHyp -> MRM a -> MRM a +withCoIndHyp hyp m = do debugPretty 2 ("withCoIndHypRaw" <+> ppInEmptyCtx hyp) hyps' <- Map.insert (coIndHypLHSFun hyp, coIndHypRHSFun hyp) hyp <$> mrCoIndHyps @@ -842,6 +848,25 @@ instantiateCoIndHyp (CoIndHyp {..}) = rhs <- substTermLike 0 evars coIndHypRHS return (lhs, rhs) +-- | Apply the preconditions of a 'CoIndHyp' to their respective arguments, +-- yielding @Bool@ conditions, using the constant @True@ value when a +-- precondition is absent +applyCoIndHypPreconds :: CoIndHyp -> MRM (Term, Term) +applyCoIndHypPreconds hyp = + let apply_precond :: Maybe Term -> [Term] -> MRM Term + apply_precond (Just (asLambdaList -> (vars, phi))) args + | length vars == length args + -- NOTE: applying to a list of arguments == substituting the reverse + -- of that list, because the first argument corresponds to the + -- greatest deBruijn index + = substTerm 0 (reverse args) phi + apply_precond (Just _) _ = + error "applyCoIndHypPreconds: wrong number of arguments for precondition!" + apply_precond Nothing _ = liftSC1 scBool True in + do pre1 <- apply_precond (coIndHypPrecondLHS hyp) (coIndHypLHS hyp) + pre2 <- apply_precond (coIndHypPrecondRHS hyp) (coIndHypRHS hyp) + return (pre1, pre2) + -- | Look up the 'FunAssump' for a 'FunName', if there is one mrGetFunAssump :: FunName -> MRM (Maybe FunAssump) mrGetFunAssump nm = Map.lookup nm <$> mrFunAssumps @@ -869,15 +894,27 @@ instantiateFunAssump fassump = rhs <- substTermLike 0 evars $ fassumpRHS fassump return (args, rhs) --- | Look up the precondition associated with a function name, returning the --- trivial @True@ one if there is none -mrGetPrecond :: FunName -> MRM Term +-- FIXME HERE NOW: delete this and remove the preconditions from the env +-- | Look up the precondition associated with a function name, if there is one +-- mrLookupPrecond :: FunName -> MRM (Maybe Term) +-- mrLookupPrecond nm = Map.lookup nm <$> mrePreconditions <$> mriEnv <$> ask + +-- | Get the precondition hint associated with a function name, by unfolding the +-- name and checking if its body has the form +-- +-- > \ x1 ... xn -> precondHint a phi m +-- +-- If so, return @\ x1 ... xn -> phi@ as a term with the @xi@ variables free. +-- Otherwise, return 'Nothing'. +mrGetPrecond :: FunName -> MRM (Maybe Term) mrGetPrecond nm = - (Map.lookup nm <$> mrePreconditions <$> mriEnv <$> ask) >>= \case - Just t -> return t - Nothing -> - do (nm_args, _) <- asPiList <$> funNameType nm - liftSC1 scBool True >>= liftSC2 scPiList nm_args + mrFunNameBody nm >>= \case + Just (asLambdaList -> + (args, + asApplyAll -> (isGlobalDef "Prelude.precondHint" -> Just (), + [_, phi, _]))) -> + Just <$> liftSC2 scLambdaList args phi + _ -> return Nothing -- | Add an assumption of type @Bool@ to the current path condition while -- executing a sub-computation diff --git a/src/SAWScript/Prover/MRSolver/Solver.hs b/src/SAWScript/Prover/MRSolver/Solver.hs index 6c18e9f253..df12b04b77 100644 --- a/src/SAWScript/Prover/MRSolver/Solver.hs +++ b/src/SAWScript/Prover/MRSolver/Solver.hs @@ -114,6 +114,7 @@ C |- F e1 ... en >>= k |= F' e1' ... em' >>= k': module SAWScript.Prover.MRSolver.Solver where +import Data.Maybe import Data.Either import Data.List (findIndices, intercalate) import Control.Monad.Except @@ -346,20 +347,17 @@ handling the recursive ones -- * Handling Coinductive Hypotheses ---------------------------------------------------------------------- --- | Prove the precondition of a coinductive hypothesis applied to the given --- left- and right-hand arguments -proveCoIndHypPreCond :: CoIndHyp -> [Term] -> [Term] -> MRM () -proveCoIndHypPreCond hyp args1 args2 = - do pre1 <- liftSC2 scApplyAll (coIndHypPrecondLHS hyp) args1 - pre2 <- liftSC2 scApplyAll (coIndHypPrecondRHS hyp) args2 - -- FIXME: pre is just for printing / debugging purposes... +-- | Prove the precondition of a coinductive hypothesis +proveCoIndHypPreCond :: CoIndHyp -> MRM () +proveCoIndHypPreCond hyp = + do (pre1, pre2) <- applyCoIndHypPreconds hyp pre <- liftSC2 scAnd pre1 pre2 - success <- liftSC2 scAnd pre1 pre2 >>= mrProvable + success <- mrProvable pre if success then return () else throwMRFailure $ PrecondNotProvable (coIndHypLHSFun hyp) (coIndHypRHSFun hyp) pre --- | Run a compuation @m@ under the additional co-inductive assumption that +-- | Co-inductively prove the refinement -- -- > forall x1, ..., xn. preF y1 ... ym -> preG z1 ... zl -> -- > F y1 ... ym |= G z1 ... zl@ @@ -367,35 +365,47 @@ proveCoIndHypPreCond hyp args1 args2 = -- where @F@ and @G@ are the given 'FunName's, @y1, ..., ym@ and @z1, ..., zl@ -- are the given argument lists, @x1, ..., xn@ is the current context of uvars, -- and @preF@ and @preG@ are the preconditions associated with @F@ and @G@, --- respectively. Note that @m@ is run with /only/ these preconditions as --- assumptions; all other assumptions are thrown away. If while running the --- given computation a 'CoIndHypMismatchWidened' error is reached with the given --- names, the state is restored and the computation is re-run with the widened --- hypothesis. -withCoIndHyp :: FunName -> [Term] -> FunName -> [Term] -> MRM a -> MRM a -withCoIndHyp f1 args1 f2 args2 m = +-- respectively. This proof is performed by coinductively assuming the +-- refinement holds and proving the refinement with the definitions of @F@ and +-- @G@ unfolded to their bodies. Note that this refinement is performed with +-- /only/ the preconditions @preF@ and @preG@ as assumptions; all other +-- assumptions are thrown away. If while running the refinement computation a +-- 'CoIndHypMismatchWidened' error is reached with the given names, the state is +-- restored and the computation is re-run with the widened hypothesis. +mrRefinesCoInd :: FunName -> [Term] -> FunName -> [Term] -> MRM () +mrRefinesCoInd f1 args1 f2 args2 = do ctx <- mrUVarCtx - pre1 <- mrGetPrecond f1 - pre2 <- mrGetPrecond f2 + preF1 <- mrGetPrecond f1 + preF2 <- mrGetPrecond f2 + let hyp = CoIndHyp ctx f1 f2 args1 args2 preF1 preF2 + proveCoIndHypPreCond hyp + proveCoIndHyp hyp + +-- | Prove the refinement represented by a 'CoIndHyp' coinductively. This is the +-- main loop implementing 'mrRefinesCoInd'. See that function for documentation. +proveCoIndHyp :: CoIndHyp -> MRM () +proveCoIndHyp hyp = + do let f1 = coIndHypLHSFun hyp + f2 = coIndHypRHSFun hyp + args1 = coIndHypLHS hyp + args2 = coIndHypRHS hyp + debugPretty 1 ("proveCoIndHyp" <+> ppInEmptyCtx hyp) + lhs <- fromMaybe (error "proveCoIndHyp") <$> mrFunBody f1 args1 + rhs <- fromMaybe (error "proveCoIndHyp") <$> mrFunBody f2 args2 + (pre1, pre2) <- applyCoIndHypPreconds hyp pre <- liftSC2 scAnd pre1 pre2 - let hyp = CoIndHyp ctx f1 f2 args1 args2 pre1 pre2 - debugPretty 1 ("withCoIndHyp" <+> ppInEmptyCtx hyp) - proveCoIndHypPreCond hyp args1 args2 - withOnlyAssumption pre $ withCoIndHyp' hyp m - --- | The main loop of 'withCoIndHyp' -withCoIndHyp' :: CoIndHyp -> MRM a -> MRM a -withCoIndHyp' hyp m = - withCoIndHypRaw hyp m `catchError` \case - MRExnWiden nm1' nm2' new_vars - | coIndHypLHSFun hyp == nm1' && coIndHypRHSFun hyp == nm2' -> - -- NOTE: the state automatically gets reset here because we defined MRM - -- with ExceptT at a lower level than StateT - do mrDebugPPPrefixSep 1 "Widening recursive assumption for" nm1' "|=" nm2' - debugPrint 2 $ "Widening indices: " ++ intercalate ", " (map show new_vars) - hyp' <- generalizeCoIndHyp hyp new_vars - withCoIndHyp' hyp' m - e -> throwError e + (withOnlyUVars (coIndHypCtx hyp) $ withOnlyAssumption pre $ + withCoIndHyp hyp $ mrRefines lhs rhs) `catchError` \case + MRExnWiden nm1' nm2' new_vars + | f1 == nm1' && f2 == nm2' -> + -- NOTE: the state automatically gets reset here because we defined + -- MRM with ExceptT at a lower level than StateT + do mrDebugPPPrefixSep 1 "Widening recursive assumption for" nm1' "|=" nm2' + debugPrint 2 ("Widening indices: " ++ + intercalate ", " (map show new_vars)) + hyp' <- generalizeCoIndHyp hyp new_vars + proveCoIndHyp hyp' + e -> throwError e -- | Test that a coinductive hypothesis for the given function names matches the @@ -408,7 +418,7 @@ matchCoIndHyp hyp args1 args2 = if and (eqs1 ++ eqs2) then return () else throwError $ MRExnWiden (coIndHypLHSFun hyp) (coIndHypRHSFun hyp) (map Left (findIndices not eqs1) ++ map Right (findIndices not eqs2)) - proveCoIndHypPreCond hyp args1 args2 + proveCoIndHypPreCond hyp -- | Generalize some of the arguments of a coinductive hypothesis @@ -608,7 +618,7 @@ mrRefines' m1@(FunBind f1 args1 k1) m2@(FunBind f2 args2 k2) = -- * If it is convertible to our goal, continue and prove that k1 |= k2 -- * If it can be widened with our goal, restart the current proof branch -- with the widened hypothesis (done by throwing a - -- 'CoIndHypMismatchWidened' error for 'withCoIndHyp' to catch) + -- 'CoIndHypMismatchWidened' error for 'proveCoIndHyp' to catch) -- * Otherwise, throw a 'CoIndHypMismatchFailure' error. (Just hyp, _) -> matchCoIndHyp hyp args1 args2 >> @@ -636,10 +646,9 @@ mrRefines' m1@(FunBind f1 args1 k1) m2@(FunBind f2 args2 k2) = -- that f1 args1 |= f2 args2 under the assumption that f1 args1 |= f2 args2, -- and then try to prove that k1 |= k2 _ | tps_eq - , Just (f1_body, _) <- maybe_f1_body - , Just (f2_body, _) <- maybe_f2_body -> - do withCoIndHyp f1 args1 f2 args2 $ mrRefines f1_body f2_body - mrRefinesFun k1 k2 + , Just _ <- maybe_f1_body + , Just _ <- maybe_f2_body -> + mrRefinesCoInd f1 args1 f2 args2 >> mrRefinesFun k1 k2 -- If we cannot line up f1 and f2, then making progress here would require us -- to somehow split either m1 or m2 into some bind m' >>= k' such that m' is From 670f641fc7a7936b4114e987e5b4492afcb3fa3e Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Mon, 7 Mar 2022 09:56:18 -0800 Subject: [PATCH 071/105] added logic to normalize precondHint terms --- src/SAWScript/Prover/MRSolver/Solver.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/SAWScript/Prover/MRSolver/Solver.hs b/src/SAWScript/Prover/MRSolver/Solver.hs index df12b04b77..793b02ffbc 100644 --- a/src/SAWScript/Prover/MRSolver/Solver.hs +++ b/src/SAWScript/Prover/MRSolver/Solver.hs @@ -228,6 +228,8 @@ normComp (CompTerm t) = return $ ExistsM (Type tp) (CompFunTerm body_tm) (isGlobalDef "Prelude.forallM" -> Just (), [tp, _, body_tm]) -> return $ ForallM (Type tp) (CompFunTerm body_tm) + (isGlobalDef "Prelude.precondHint" -> Just (), [_, _, body_tm]) -> + normCompTerm body_tm (isGlobalDef "Prelude.letRecM" -> Just (), [lrts, _, defs_f, body_f]) -> do -- Bind fresh function vars for the letrec-bound functions From 4fab1e8c597a2e46dffa7fbbaf743eafa2ed04c7 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Mon, 7 Mar 2022 13:53:20 -0800 Subject: [PATCH 072/105] fixed a bug in smallestBitSetElem --- saw-core/src/Verifier/SAW/Term/Functor.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/saw-core/src/Verifier/SAW/Term/Functor.hs b/saw-core/src/Verifier/SAW/Term/Functor.hs index fb7ae57fef..59c3e3276d 100644 --- a/saw-core/src/Verifier/SAW/Term/Functor.hs +++ b/saw-core/src/Verifier/SAW/Term/Functor.hs @@ -58,6 +58,7 @@ module Verifier.SAW.Term.Functor -- * Sets of free variables , BitSet, emptyBitSet, inBitSet, unionBitSets, intersectBitSets , decrBitSet, multiDecrBitSet, completeBitSet, singletonBitSet, bitSetElems + , smallestBitSetElem , looseVars, smallestFreeVar ) where @@ -485,7 +486,7 @@ bitSetElems = go 0 where go shft bs = case smallestBitSetElem bs of Nothing -> [] Just i -> - shft + i : go (shft + i + 1) (multiDecrBitSet (shft + i + 1) bs) + shft + i : go (shft + i + 1) (multiDecrBitSet (i + 1) bs) -- | Compute the free variables of a term given free variables for its immediate -- subterms From 4c8f7a1e14cf5f945a2ae37117f447e2a0c90206 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Mon, 7 Mar 2022 13:54:56 -0800 Subject: [PATCH 073/105] fixed a subtle free variable bug in mrTrySetAppliedEVar; also changed mrSetEVarClosed to have a more understandable error message --- src/SAWScript/Prover/MRSolver/Monad.hs | 26 +++++++++++++++++++------- 1 file changed, 19 insertions(+), 7 deletions(-) diff --git a/src/SAWScript/Prover/MRSolver/Monad.hs b/src/SAWScript/Prover/MRSolver/Monad.hs index af462235be..4036b9132f 100644 --- a/src/SAWScript/Prover/MRSolver/Monad.hs +++ b/src/SAWScript/Prover/MRSolver/Monad.hs @@ -744,7 +744,15 @@ mrSetEVarClosed var val = -- following subtyping check will succeed var_tp <- mrSubstEVars $ mrVarType var -- FIXME: catch subtyping errors and report them as being evar failures - liftSC3 scCheckSubtype Nothing (TypedTerm val val_tp) var_tp + eith_err <- + liftSC2 (runTCM $ checkSubtype (TypedTerm val val_tp) var_tp) Nothing [] + case eith_err of + Left _ -> + error ("mrSetEVarClosed: incorrect instantiation for evar " ++ + showMRVar var ++ + "\nexpected type:\n" ++ showTerm var_tp ++ + "\nactual type:\n" ++ showTerm val_tp) + Right _ -> return () modify $ \st -> st { mrsVars = Map.alter @@ -766,6 +774,8 @@ mrTrySetAppliedEVar evar args t = let (evar_vars, _) = asPiList (mrVarType evar) in -- Get all the free variables of t let free_vars = bitSetElems (looseVars t) in + -- Get the maximum deBruijn index of free_vars + let max_fv = maximum free_vars in -- For each free var of t, find an arg equal to it case mapM (\i -> findIndex (\case (asLocalVar -> Just j) -> i == j @@ -776,15 +786,17 @@ mrTrySetAppliedEVar evar args t = -- Build a list of the input vars x1 ... xn as terms, noting that the -- first variable is the least recently bound and so has the highest -- deBruijn index - let arg_ixs = [length args - 1, length args - 2 .. 0] + let arg_ixs = reverse [0 .. length args - 1] arg_vars <- mapM (liftSC1 scLocalVar) arg_ixs - -- For free variable of t, we substitute the corresponding variable - -- xi, substituting error terms for the variables that are not free - -- (since we have nothing else to substitute for them) + -- For each free variable of t, we substitute the corresponding + -- variable xi, substituting error terms for the variables that are + -- not free (since we have nothing else to substitute for them) let var_map = zip free_vars fv_arg_ixs - let subst = flip map [0 .. length args - 1] $ \i -> - maybe (error "mrTrySetAppliedEVar: unexpected free variable") + let subst = flip map [0 .. max_fv] $ \i -> + maybe (error + ("mrTrySetAppliedEVar: unexpected free variable " + ++ show i ++ " in term\n" ++ showTerm t)) (arg_vars !!) (lookup i var_map) body <- substTerm 0 subst t From fe62c84635b5dfead57b5008a9aed7a83b35e22a Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Mon, 7 Mar 2022 13:55:21 -0800 Subject: [PATCH 074/105] added some printing helper functions --- src/SAWScript/Prover/MRSolver/SMT.hs | 7 ++++++- src/SAWScript/Prover/MRSolver/Solver.hs | 1 - src/SAWScript/Prover/MRSolver/Term.hs | 7 +++++++ 3 files changed, 13 insertions(+), 2 deletions(-) diff --git a/src/SAWScript/Prover/MRSolver/SMT.hs b/src/SAWScript/Prover/MRSolver/SMT.hs index cb49875836..8cd193b8a6 100644 --- a/src/SAWScript/Prover/MRSolver/SMT.hs +++ b/src/SAWScript/Prover/MRSolver/SMT.hs @@ -274,7 +274,12 @@ mrProveEqSimple eqf t1 t2 = mrProveEq :: Term -> Term -> MRM Bool mrProveEq t1 t2 = do mrDebugPPPrefixSep 1 "mrProveEq" t1 "==" t2 - tp <- mrTypeOf t1 + tp <- mrTypeOf t1 >>= mrSubstEVars + tp2 <- mrTypeOf t2 >>= mrSubstEVars + tps_eq <- mrConvertible tp tp2 + if tps_eq then return () else + error ("mrProveEq: types not equal:\n" ++ + showTerm tp ++ "\n" ++ showTerm tp2) varmap <- mrVars cond_in_ctx <- mrProveEqH varmap tp t1 t2 res <- withTermInCtx cond_in_ctx mrProvable diff --git a/src/SAWScript/Prover/MRSolver/Solver.hs b/src/SAWScript/Prover/MRSolver/Solver.hs index 793b02ffbc..442f7d3946 100644 --- a/src/SAWScript/Prover/MRSolver/Solver.hs +++ b/src/SAWScript/Prover/MRSolver/Solver.hs @@ -439,7 +439,6 @@ generalizeCoIndHyp hyp all_specs@(arg_spec:arg_specs) = do let arg' = coIndHypArg hyp spec' tp' <- mrTypeOf arg' mrDebugPPPrefixSep 2 "generalizeCoIndHyp: the type of" arg' "is" tp' - debugPrint 2 ("arg' = " ++ show arg') tps_eq <- mrConvertible arg_tp tp' args_eq <- if tps_eq then mrProveEq arg arg' else return False return $ if args_eq then Left spec' else Right spec' diff --git a/src/SAWScript/Prover/MRSolver/Term.hs b/src/SAWScript/Prover/MRSolver/Term.hs index fcc88f4639..78feb8d8b7 100644 --- a/src/SAWScript/Prover/MRSolver/Term.hs +++ b/src/SAWScript/Prover/MRSolver/Term.hs @@ -56,6 +56,10 @@ newtype MRVar = MRVar { unMRVar :: ExtCns Term } deriving (Eq, Show, Ord) mrVarType :: MRVar -> Term mrVarType = ecType . unMRVar +-- | Print the string name of an 'MRVar' +showMRVar :: MRVar -> String +showMRVar = show . ppName . ecName . unMRVar + -- | A tuple or record projection of a 'Term' data TermProj = TermProjLeft | TermProjRight | TermProjRecord FieldName deriving (Eq, Ord, Show) @@ -324,6 +328,9 @@ instance PrettyInCtx Type where instance PrettyInCtx MRVar where prettyInCtx (MRVar ec) = return $ ppName $ ecName ec +instance PrettyInCtx [Term] where + prettyInCtx xs = list <$> mapM prettyInCtx xs + instance PrettyInCtx TermProj where prettyInCtx TermProjLeft = return (pretty '.' <> "1") prettyInCtx TermProjRight = return (pretty '.' <> "2") From 3962bdc0423fb8bc94b1fdf06242a5abd004aaf0 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Mon, 7 Mar 2022 14:26:21 -0800 Subject: [PATCH 075/105] removed the type equality check in mrProveEq --- src/SAWScript/Prover/MRSolver/SMT.hs | 5 ----- 1 file changed, 5 deletions(-) diff --git a/src/SAWScript/Prover/MRSolver/SMT.hs b/src/SAWScript/Prover/MRSolver/SMT.hs index 8cd193b8a6..04f85ece7f 100644 --- a/src/SAWScript/Prover/MRSolver/SMT.hs +++ b/src/SAWScript/Prover/MRSolver/SMT.hs @@ -275,11 +275,6 @@ mrProveEq :: Term -> Term -> MRM Bool mrProveEq t1 t2 = do mrDebugPPPrefixSep 1 "mrProveEq" t1 "==" t2 tp <- mrTypeOf t1 >>= mrSubstEVars - tp2 <- mrTypeOf t2 >>= mrSubstEVars - tps_eq <- mrConvertible tp tp2 - if tps_eq then return () else - error ("mrProveEq: types not equal:\n" ++ - showTerm tp ++ "\n" ++ showTerm tp2) varmap <- mrVars cond_in_ctx <- mrProveEqH varmap tp t1 t2 res <- withTermInCtx cond_in_ctx mrProvable From eccfdebce30c86798356ff720b7ea264e8d99f05 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Mon, 7 Mar 2022 15:14:01 -0800 Subject: [PATCH 076/105] added Mr Solver proof that contains0 |= noErrorsContains0 --- heapster-saw/examples/arrays.sawcore | 37 ++++++++++++++++++++++ heapster-saw/examples/arrays_mr_solver.saw | 6 +++- 2 files changed, 42 insertions(+), 1 deletion(-) diff --git a/heapster-saw/examples/arrays.sawcore b/heapster-saw/examples/arrays.sawcore index 7c20a89268..6b1f16867b 100644 --- a/heapster-saw/examples/arrays.sawcore +++ b/heapster-saw/examples/arrays.sawcore @@ -2,3 +2,40 @@ module arrays where import Prelude; + +-- The helper function for noErrorsContains0 +-- +-- noErrorsContains0H len i v = +-- orM (exists x. returnM x) (noErrorsContains0H len (i+1) v) +noErrorsContains0H : (len i:Vec 64 Bool) -> BVVec 64 len (Vec 64 Bool) -> + CompM (BVVec 64 len (Vec 64 Bool) * Vec 64 Bool); +noErrorsContains0H len_top i_top v_top = + letRecM + (LRT_Cons + (LRT_Fun (Vec 64 Bool) (\ (len:Vec 64 Bool) -> + LRT_Fun (Vec 64 Bool) (\ (_:Vec 64 Bool) -> + LRT_Fun (BVVec 64 len (Vec 64 Bool)) (\ (_:BVVec 64 len (Vec 64 Bool)) -> + LRT_Ret (BVVec 64 len (Vec 64 Bool) * Vec 64 Bool))))) + LRT_Nil) + (BVVec 64 len_top (Vec 64 Bool) * Vec 64 Bool) + (\ (f : (len i:Vec 64 Bool) -> BVVec 64 len (Vec 64 Bool) -> + CompM (BVVec 64 len (Vec 64 Bool) * Vec 64 Bool)) -> + ((\ (len:Vec 64 Bool) (i:Vec 64 Bool) (v:BVVec 64 len (Vec 64 Bool)) -> + precondHint + (CompM (BVVec 64 len (Vec 64 Bool) * Vec 64 Bool)) + (and (bvsle 64 0x0000000000000000 i) + (bvsle 64 i 0x0fffffffffffffff)) + (orM (BVVec 64 len (Vec 64 Bool) * Vec 64 Bool) + (existsM (BVVec 64 len (Vec 64 Bool) * Vec 64 Bool) + (BVVec 64 len (Vec 64 Bool) * Vec 64 Bool) + (returnM (BVVec 64 len (Vec 64 Bool) * Vec 64 Bool))) + (f len (bvAdd 64 i 0x0000000000000001) v))), ())) + (\ (f : (len i:Vec 64 Bool) -> BVVec 64 len (Vec 64 Bool) -> + CompM (BVVec 64 len (Vec 64 Bool) * Vec 64 Bool)) -> + f len_top i_top v_top); + +-- The specification that contains0 has no errors +noErrorsContains0 : (len:Vec 64 Bool) -> BVVec 64 len (Vec 64 Bool) -> + CompM (BVVec 64 len (Vec 64 Bool) * Vec 64 Bool); +noErrorsContains0 len v = + noErrorsContains0H len 0x0000000000000000 v; diff --git a/heapster-saw/examples/arrays_mr_solver.saw b/heapster-saw/examples/arrays_mr_solver.saw index 838e1d2874..eaa38a79f7 100644 --- a/heapster-saw/examples/arrays_mr_solver.saw +++ b/heapster-saw/examples/arrays_mr_solver.saw @@ -16,4 +16,8 @@ let run_test name test expected = // Test that contains0 |= contains0 contains0 <- parse_core_mod "arrays" "contains0"; -run_test "contains0 |= contains0" (mr_solver contains0 contains0) true; +// run_test "contains0 |= contains0" (mr_solver contains0 contains0) true; + +noErrorsContains0 <- parse_core_mod "arrays" "noErrorsContains0"; +run_test "contains0 |= noErrorsContains0" + (mr_solver_debug 0 contains0 noErrorsContains0) true; From 02aed402170b77b2c1052f5ce53fc9c6c71344d1 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Mon, 7 Mar 2022 15:43:04 -0800 Subject: [PATCH 077/105] removed mr_solver_set_precond; removed preconditions from MR Solver environments; changed mr_solver command to remember refinements that have been proved --- src/SAWScript/Builtins.hs | 25 +------------ src/SAWScript/Interpreter.hs | 5 --- src/SAWScript/Prover/MRSolver.hs | 2 +- src/SAWScript/Prover/MRSolver/Monad.hs | 45 ----------------------- src/SAWScript/Prover/MRSolver/Solver.hs | 17 +++++++-- src/SAWScript/Prover/MRSolver/Term.hs | 49 +++++++++++++++++++++++++ src/SAWScript/Value.hs | 2 +- 7 files changed, 66 insertions(+), 79 deletions(-) diff --git a/src/SAWScript/Builtins.hs b/src/SAWScript/Builtins.hs index a95569d946..1765ce785b 100644 --- a/src/SAWScript/Builtins.hs +++ b/src/SAWScript/Builtins.hs @@ -71,7 +71,6 @@ import Verifier.SAW.SATQuery import Verifier.SAW.SCTypeCheck hiding (TypedTerm) import qualified Verifier.SAW.SCTypeCheck as TC (TypedTerm(..)) import Verifier.SAW.SharedTerm -import Verifier.SAW.Recognizer import Verifier.SAW.TypedTerm import qualified Verifier.SAW.Simulator.Concrete as Concrete import Verifier.SAW.Prim (rethrowEvalError) @@ -1571,28 +1570,8 @@ mrSolver sc dlvl t1 t2 = let env = rwMRSolverEnv rw res <- liftIO $ Prover.askMRSolver sc dlvl env Nothing m1 m2 case res of - Just err -> io (putStrLn $ Prover.showMRFailure err) >> return False - Nothing -> return True - --- | Set the precondition for a named function, given as a SAW core term -mrSolverSetPrecond :: SharedContext -> TypedTerm -> TypedTerm -> TopLevel () -mrSolverSetPrecond sc f pre = - do rw <- get - f_mon <- ttTerm <$> ensureMonadicTerm sc f - gdef <- case Monadify.asTypedGlobalDef f_mon of - Just gdef -> return gdef - Nothing -> fail "mr_solver_set_precond: Not an identifier" - -- NOTE: do not monadify pre, as it is supposed to be pure - (asPiList -> (f_args, _)) <- io $ scTypeOf sc f_mon - pre_tp <- io (scTypeOf sc $ ttTerm pre) - pre_tp_req <- io (scBoolType sc >>= scPiList sc f_args) - correct_tp <- io (scConvertible sc True pre_tp pre_tp_req) - if correct_tp then return () else - fail ("mr_solver_set_precond: incorrect type for precondition\n" ++ - "Expected: " ++ showTerm pre_tp_req ++ "\n" ++ - "Actual: " ++ showTerm pre_tp) - let env = rwMRSolverEnv rw - put (rw { rwMRSolverEnv = Prover.mrEnvAddPrecond gdef (ttTerm pre) env }) + Left err -> io (putStrLn $ Prover.showMRFailure err) >> return False + Right env' -> put (rw { rwMRSolverEnv = env' }) >> return True setMonadification :: SharedContext -> String -> String -> TopLevel () setMonadification sc cry_str saw_str = diff --git a/src/SAWScript/Interpreter.hs b/src/SAWScript/Interpreter.hs index 114ea7f32d..4a4b2c8f10 100644 --- a/src/SAWScript/Interpreter.hs +++ b/src/SAWScript/Interpreter.hs @@ -3169,11 +3169,6 @@ primitives = Map.fromList Experimental [ "Call the monadic-recursive solver at the supplied debug level" ] - , prim "mr_solver_set_precond" "Term -> Term -> TopLevel ()" - (scVal mrSolverSetPrecond) - Experimental - [ "Set the precondition for use in Mr Solver of a function to a function" ] - , prim "monadify_term" "Term -> TopLevel Term" (scVal monadifyTypedTerm) Experimental diff --git a/src/SAWScript/Prover/MRSolver.hs b/src/SAWScript/Prover/MRSolver.hs index fb2589766d..759116dedf 100644 --- a/src/SAWScript/Prover/MRSolver.hs +++ b/src/SAWScript/Prover/MRSolver.hs @@ -10,7 +10,7 @@ Portability : non-portable (language extensions) module SAWScript.Prover.MRSolver (askMRSolver, MRFailure(..), showMRFailure, isCompFunType, - MREnv(..), emptyMREnv, mrEnvAddPrecond) where + MREnv(..), emptyMREnv) where import SAWScript.Prover.MRSolver.Term import SAWScript.Prover.MRSolver.Monad diff --git a/src/SAWScript/Prover/MRSolver/Monad.hs b/src/SAWScript/Prover/MRSolver/Monad.hs index 4036b9132f..38be1476dc 100644 --- a/src/SAWScript/Prover/MRSolver/Monad.hs +++ b/src/SAWScript/Prover/MRSolver/Monad.hs @@ -227,31 +227,6 @@ instance PrettyInCtx CoIndHyp where return "|=", prettyInCtx (FunBind f2 args2 CompFunReturn)] --- | An assumption that a named function refines some specificaiton. This has --- the form --- --- > forall x1, ..., xn. F e1 ... ek |= m --- --- for some universal context @x1:T1, .., xn:Tn@, some list of argument --- expressions @ei@ over the universal @xj@ variables, and some right-hand side --- computation expression @m@. -data FunAssump = FunAssump { - -- | The uvars that were in scope when this assmption was created, in order - -- from outermost to innermost; that is, the uvars as "seen from outside their - -- scope", which is the reverse of the order of 'mrUVars', below - fassumpCtx :: [(LocalName,Term)], - -- | The argument expressions @e1, ..., en@ over the 'fassumpCtx' uvars - fassumpArgs :: [Term], - -- | The right-hand side upper bound @m@ over the 'fassumpCtx' uvars - fassumpRHS :: NormComp -} - --- | A map from function names to function refinement assumptions over that --- name --- --- FIXME: this should probably be an 'IntMap' on the 'VarIndex' of globals -type FunAssumps = Map FunName FunAssump - -- | An assumption that something is equal to one of the constructors of a -- datatype, e.g. equal to @Left@ of some 'Term' or @Right@ of some 'Term' data DataTypeAssump = IsLeft Term | IsRight Term @@ -273,26 +248,6 @@ type DataTypeAssumps = HashMap Term DataTypeAssump -- FIXME HERE NOW: remove preconditions from MREnv --- | A global MR Solver environment -data MREnv = MREnv { - -- | The set of function refinements to be assumed by to Mr. Solver (which - -- have hopefully been proved previously...) - mreFunAssumps :: FunAssumps, - -- | The preconditions associated with functions by the user - mrePreconditions :: Map FunName Term - } - --- | The empty 'MREnv' -emptyMREnv :: MREnv -emptyMREnv = MREnv { mreFunAssumps = Map.empty, - mrePreconditions = Map.empty } - --- | Add a precondition to an 'MREnv' -mrEnvAddPrecond :: GlobalDef -> Term -> MREnv -> MREnv -mrEnvAddPrecond gdef pre env = - env { mrePreconditions = - Map.insert (GlobalName gdef []) pre (mrePreconditions env) } - -- | Parameters and locals for MR. Solver data MRInfo = MRInfo { -- | Global shared context for building terms, etc. diff --git a/src/SAWScript/Prover/MRSolver/Solver.hs b/src/SAWScript/Prover/MRSolver/Solver.hs index 442f7d3946..fbde43b184 100644 --- a/src/SAWScript/Prover/MRSolver/Solver.hs +++ b/src/SAWScript/Prover/MRSolver/Solver.hs @@ -760,20 +760,21 @@ mrRefinesFun _ _ = error "mrRefinesFun: unreachable!" -- * External Entrypoints ---------------------------------------------------------------------- --- | Test two monadic, recursive terms for equivalence +-- | Test two monadic, recursive terms for refinement. On success, if the +-- left-hand term is a named function, add the refinement to the 'MREnv' +-- environment. askMRSolver :: SharedContext -> Int {- ^ The debug level -} -> MREnv {- ^ The Mr Solver environment -} -> Maybe Integer {- ^ Timeout in milliseconds for each SMT call -} -> - Term -> Term -> IO (Maybe MRFailure) + Term -> Term -> IO (Either MRFailure MREnv) askMRSolver sc dlvl env timeout t1 t2 = do tp1 <- scTypeOf sc t1 >>= scWhnf sc tp2 <- scTypeOf sc t2 >>= scWhnf sc case asPiList tp1 of (uvar_ctx, asCompM -> Just _) -> - fmap (either Just (const Nothing)) $ runMRM sc timeout dlvl env $ withUVars uvar_ctx $ \vars -> do tps_are_eq <- mrConvertible tp1 tp2 @@ -783,4 +784,12 @@ askMRSolver sc dlvl env timeout t1 t2 = m1 <- mrApplyAll t1 vars >>= normCompTerm m2 <- mrApplyAll t2 vars >>= normCompTerm mrRefines m1 m2 - _ -> return $ Just $ NotCompFunType tp1 + -- If t1 is a named function, add forall xs. f1 xs |= m2 to the env + case asGlobalFunName t1 of + Just f1 -> + let fassump = FunAssump { fassumpCtx = uvar_ctx, + fassumpArgs = vars, + fassumpRHS = m2 } in + return $ mrEnvAddFunAssump f1 fassump env + Nothing -> return env + _ -> return $ Left $ NotCompFunType tp1 diff --git a/src/SAWScript/Prover/MRSolver/Term.hs b/src/SAWScript/Prover/MRSolver/Term.hs index 78feb8d8b7..cd7a10c86d 100644 --- a/src/SAWScript/Prover/MRSolver/Term.hs +++ b/src/SAWScript/Prover/MRSolver/Term.hs @@ -37,6 +37,9 @@ import GHC.Generics import Prettyprinter +import Data.Map (Map) +import qualified Data.Map as Map + import Verifier.SAW.Term.Functor import Verifier.SAW.Term.CtxTerm (MonadTerm(..)) import Verifier.SAW.Term.Pretty @@ -168,6 +171,52 @@ isCompFunType sc t = scWhnf sc t >>= \case _ -> return False +---------------------------------------------------------------------- +-- * Mr Solver Environments +---------------------------------------------------------------------- + +-- | An assumption that a named function refines some specification. This has +-- the form +-- +-- > forall x1, ..., xn. F e1 ... ek |= m +-- +-- for some universal context @x1:T1, .., xn:Tn@, some list of argument +-- expressions @ei@ over the universal @xj@ variables, and some right-hand side +-- computation expression @m@. +data FunAssump = FunAssump { + -- | The uvars that were in scope when this assmption was created, in order + -- from outermost to innermost; that is, the uvars as "seen from outside their + -- scope", which is the reverse of the order of 'mrUVars', below + fassumpCtx :: [(LocalName,Term)], + -- | The argument expressions @e1, ..., en@ over the 'fassumpCtx' uvars + fassumpArgs :: [Term], + -- | The right-hand side upper bound @m@ over the 'fassumpCtx' uvars + fassumpRHS :: NormComp +} + +-- | A map from function names to function refinement assumptions over that +-- name +-- +-- FIXME: this should probably be an 'IntMap' on the 'VarIndex' of globals +type FunAssumps = Map FunName FunAssump + +-- | A global MR Solver environment +data MREnv = MREnv { + -- | The set of function refinements to be assumed by to Mr. Solver (which + -- have hopefully been proved previously...) + mreFunAssumps :: FunAssumps + } + +-- | The empty 'MREnv' +emptyMREnv :: MREnv +emptyMREnv = MREnv { mreFunAssumps = Map.empty } + +-- | Add a 'FunAssump' to a Mr Solver environment +mrEnvAddFunAssump :: FunName -> FunAssump -> MREnv -> MREnv +mrEnvAddFunAssump f fassump env = + env { mreFunAssumps = Map.insert f fassump (mreFunAssumps env) } + + ---------------------------------------------------------------------- -- * Utility Functions for Transforming 'Term's ---------------------------------------------------------------------- diff --git a/src/SAWScript/Value.hs b/src/SAWScript/Value.hs index 8e0e40bb2b..9da3910473 100644 --- a/src/SAWScript/Value.hs +++ b/src/SAWScript/Value.hs @@ -76,7 +76,7 @@ import SAWScript.JavaPretty (prettyClass) import SAWScript.Options (Options(printOutFn),printOutLn,Verbosity) import SAWScript.Proof import SAWScript.Prover.SolverStats -import SAWScript.Prover.MRSolver.Monad as MRSolver +import SAWScript.Prover.MRSolver.Term as MRSolver import SAWScript.Crucible.LLVM.Skeleton import SAWScript.X86 (X86Unsupported(..), X86Error(..)) From 7ee43cfe5a90e484794b957db4eb231c2b6b40c3 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Mon, 7 Mar 2022 16:52:01 -0800 Subject: [PATCH 078/105] added initialization of rwMRSolverEnv field to saw-remote-api --- saw-remote-api/src/SAWServer.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/saw-remote-api/src/SAWServer.hs b/saw-remote-api/src/SAWServer.hs index 776abea42e..b6ac03c7f6 100644 --- a/saw-remote-api/src/SAWServer.hs +++ b/saw-remote-api/src/SAWServer.hs @@ -59,6 +59,7 @@ import qualified Verifier.SAW.Cryptol.Prelude as CryptolSAW import Verifier.SAW.CryptolEnv (initCryptolEnv, bindTypedTerm) import qualified Cryptol.Utils.Ident as Cryptol import Verifier.SAW.Cryptol.Monadify (defaultMonEnv) +import SAWScript.Prover.MRSolver (emptyMREnv) import qualified Argo --import qualified CryptolServer (validateServerState, ServerState(..)) @@ -219,6 +220,7 @@ initialState readFileFn = , rwDocs = mempty , rwCryptol = cenv , rwMonadify = defaultMonEnv + , rwMRSolverEnv = emptyMREnv , rwPPOpts = defaultPPOpts , rwJVMTrans = jvmTrans , rwPrimsAvail = mempty From ee4b67bd87c1a41e71c9675b62e79caccee1bd22 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Tue, 8 Mar 2022 07:05:46 -0800 Subject: [PATCH 079/105] whoops, need to avoid calling maximum on an empty list --- src/SAWScript/Prover/MRSolver/Monad.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/SAWScript/Prover/MRSolver/Monad.hs b/src/SAWScript/Prover/MRSolver/Monad.hs index 38be1476dc..15df3e0f0f 100644 --- a/src/SAWScript/Prover/MRSolver/Monad.hs +++ b/src/SAWScript/Prover/MRSolver/Monad.hs @@ -729,8 +729,6 @@ mrTrySetAppliedEVar evar args t = let (evar_vars, _) = asPiList (mrVarType evar) in -- Get all the free variables of t let free_vars = bitSetElems (looseVars t) in - -- Get the maximum deBruijn index of free_vars - let max_fv = maximum free_vars in -- For each free var of t, find an arg equal to it case mapM (\i -> findIndex (\case (asLocalVar -> Just j) -> i == j @@ -748,7 +746,9 @@ mrTrySetAppliedEVar evar args t = -- variable xi, substituting error terms for the variables that are -- not free (since we have nothing else to substitute for them) let var_map = zip free_vars fv_arg_ixs - let subst = flip map [0 .. max_fv] $ \i -> + let subst_vars = if free_vars == [] then [] else + [0 .. maximum free_vars] + let subst = flip map subst_vars $ \i -> maybe (error ("mrTrySetAppliedEVar: unexpected free variable " ++ show i ++ " in term\n" ++ showTerm t)) From a301dc659b52b60a0460ec96330d8daeede4c4e7 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Tue, 8 Mar 2022 07:19:50 -0800 Subject: [PATCH 080/105] updated efq1 to call Eq__rec instead of the Eq#rec recursor --- saw-core/prelude/Prelude.sawcore | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/saw-core/prelude/Prelude.sawcore b/saw-core/prelude/Prelude.sawcore index 43cdafd843..c8e065f121 100644 --- a/saw-core/prelude/Prelude.sawcore +++ b/saw-core/prelude/Prelude.sawcore @@ -1718,9 +1718,9 @@ efq a contra = -- Ex Falso Quodlibet at sort 1 efq1 : (a : sort 1) -> Eq Bool True False -> a; efq1 a contra = - Eq#rec Bit Bit1 - (\ (b:Bit) (_:Eq Bit Bit1 b) -> Bit#rec (\ (_:Bit) -> sort 1) #() a b) - () Bit0 (efq (Eq Bit Bit1 Bit0) contra); + Eq__rec Bit Bit1 + (\ (b:Bit) (_:Eq Bit Bit1 b) -> Bit#rec (\ (_:Bit) -> sort 1) #() a b) + () Bit0 (efq (Eq Bit Bit1 Bit0) contra); -- Generate an empty BVVec emptyBVVec : (n : Nat) -> (a : sort 0) -> BVVec n (bvNat n 0) a; From aa3deacd860712bb8ce78ce3fbeaaa423a031b6e Mon Sep 17 00:00:00 2001 From: weaversa Date: Tue, 8 Mar 2022 10:29:58 -0500 Subject: [PATCH 081/105] Update README.md (#1604) Updating LAC link. --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index 64192769b0..9aed46475a 100644 --- a/README.md +++ b/README.md @@ -148,7 +148,7 @@ unix-time Much of the work on SAW has been funded by, and lots of design input was provided by the team at the [NSA's Laboratory for Advanced Cybersecurity -Research](https://www.nsa.gov/what-we-do/research/cybersecurity-research/), +Research](https://www.nsa.gov/Research/NSA-Mission-Oriented-Research/LAC/), including Brad Martin, Frank Taylor, and Sean Weaver. Portions of SAW are also based upon work supported by the Office From 34518a69677c52b8825fc42c85fc026c669fc064 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Tue, 8 Mar 2022 10:52:47 -0800 Subject: [PATCH 082/105] changed multiFixM to be primitive, because the translator was not working correctly on some of its helper functions... --- .../CryptolPrimitivesForSAWCore.v | 80 ++++++++++++------- .../generated/CryptolToCoq/SAWCorePrelude.v | 53 +++++++++--- saw-core/prelude/Prelude.sawcore | 62 +++++++++----- 3 files changed, 138 insertions(+), 57 deletions(-) diff --git a/saw-core-coq/coq/generated/CryptolToCoq/CryptolPrimitivesForSAWCore.v b/saw-core-coq/coq/generated/CryptolToCoq/CryptolPrimitivesForSAWCore.v index a57aee7096..175ebcd520 100644 --- a/saw-core-coq/coq/generated/CryptolToCoq/CryptolPrimitivesForSAWCore.v +++ b/saw-core-coq/coq/generated/CryptolToCoq/CryptolPrimitivesForSAWCore.v @@ -131,6 +131,9 @@ Definition ecRatio : SAWCoreScaffolding.Integer -> SAWCoreScaffolding.Integer -> Definition eqRational : Rational -> Rational -> SAWCoreScaffolding.Bool := fun (x : unit : Type) (y : unit : Type) => SAWCoreScaffolding.error SAWCoreScaffolding.Bool "Unimplemented: (==) Rational"%string. +Definition leRational : Rational -> Rational -> SAWCoreScaffolding.Bool := + fun (x : unit : Type) (y : unit : Type) => SAWCoreScaffolding.error SAWCoreScaffolding.Bool "Unimplemented: (<=) Rational"%string. + Definition ltRational : Rational -> Rational -> SAWCoreScaffolding.Bool := fun (x : unit : Type) (y : unit : Type) => SAWCoreScaffolding.error SAWCoreScaffolding.Bool "Unimplemented: (<) Rational"%string. @@ -219,6 +222,9 @@ Definition errorBinary : forall (s : SAWCoreScaffolding.String), forall (a : Typ Definition boolCmp : SAWCoreScaffolding.Bool -> SAWCoreScaffolding.Bool -> SAWCoreScaffolding.Bool -> SAWCoreScaffolding.Bool := fun (x : SAWCoreScaffolding.Bool) (y : SAWCoreScaffolding.Bool) (k : SAWCoreScaffolding.Bool) => if x then SAWCoreScaffolding.and y k else SAWCoreScaffolding.or y k. +Definition boolLt : SAWCoreScaffolding.Bool -> SAWCoreScaffolding.Bool -> SAWCoreScaffolding.Bool := + fun (x : SAWCoreScaffolding.Bool) (y : SAWCoreScaffolding.Bool) => SAWCoreScaffolding.and (SAWCoreScaffolding.not x) y. + Definition integerCmp : SAWCoreScaffolding.Integer -> SAWCoreScaffolding.Integer -> SAWCoreScaffolding.Bool -> SAWCoreScaffolding.Bool := fun (x : SAWCoreScaffolding.Integer) (y : SAWCoreScaffolding.Integer) (k : SAWCoreScaffolding.Bool) => SAWCoreScaffolding.or (SAWCoreScaffolding.intLt x y) (SAWCoreScaffolding.and (SAWCoreScaffolding.intEq x y) k). @@ -235,12 +241,25 @@ Definition vecCmp : forall (n : SAWCoreScaffolding.Nat), forall (a : Type), fora fun (n : SAWCoreScaffolding.Nat) (a : Type) {Inh_a : SAWCoreScaffolding.Inhabited a} (f : a -> a -> SAWCoreScaffolding.Bool -> SAWCoreScaffolding.Bool) (xs : SAWCoreVectorsAsCoqVectors.Vec n a) (ys : SAWCoreVectorsAsCoqVectors.Vec n a) (k : SAWCoreScaffolding.Bool) => let var__0 := SAWCoreScaffolding.Bool -> SAWCoreScaffolding.Bool in SAWCoreVectorsAsCoqVectors.foldr var__0 SAWCoreScaffolding.Bool n (fun (f1 : var__0) => f1) k (SAWCorePrelude.zipWith a a var__0 f n xs ys). +Definition vecLt : forall (n : SAWCoreScaffolding.Nat), forall (a : Type), forall {Inh_a : SAWCoreScaffolding.Inhabited a}, (a -> a -> SAWCoreScaffolding.Bool -> SAWCoreScaffolding.Bool) -> (a -> a -> SAWCoreScaffolding.Bool) -> SAWCoreVectorsAsCoqVectors.Vec n a -> SAWCoreVectorsAsCoqVectors.Vec n a -> SAWCoreScaffolding.Bool := + fun (n : SAWCoreScaffolding.Nat) (a : Type) {Inh_a : SAWCoreScaffolding.Inhabited a} (f : a -> a -> SAWCoreScaffolding.Bool -> SAWCoreScaffolding.Bool) (g : a -> a -> SAWCoreScaffolding.Bool) (xs : SAWCoreVectorsAsCoqVectors.Vec n a) (ys : SAWCoreVectorsAsCoqVectors.Vec n a) => let var__0 := SAWCoreScaffolding.Bool -> SAWCoreScaffolding.Bool in + SAWCoreVectorsAsCoqVectors.foldr var__0 SAWCoreScaffolding.Bool n (fun (f1 : var__0) => f1) SAWCoreScaffolding.false (SAWCorePrelude.zipWith a a var__0 f n xs ys). + Definition unitCmp : (unit : Type) -> (unit : Type) -> SAWCoreScaffolding.Bool -> SAWCoreScaffolding.Bool := - fun (_1 : unit : Type) (_2 : unit : Type) (_3 : SAWCoreScaffolding.Bool) => SAWCoreScaffolding.false. + fun (_1 : unit : Type) (_2 : unit : Type) (k : SAWCoreScaffolding.Bool) => k. + +Definition unitLe : (unit : Type) -> (unit : Type) -> SAWCoreScaffolding.Bool := + fun (_1 : unit : Type) (_2 : unit : Type) => SAWCoreScaffolding.true. + +Definition unitLt : (unit : Type) -> (unit : Type) -> SAWCoreScaffolding.Bool := + fun (_1 : unit : Type) (_2 : unit : Type) => SAWCoreScaffolding.false. Definition pairCmp : forall (a : Type), forall (b : Type), (a -> a -> SAWCoreScaffolding.Bool -> SAWCoreScaffolding.Bool) -> (b -> b -> SAWCoreScaffolding.Bool -> SAWCoreScaffolding.Bool) -> prod a b -> prod a b -> SAWCoreScaffolding.Bool -> SAWCoreScaffolding.Bool := fun (a : Type) (b : Type) (f : a -> a -> SAWCoreScaffolding.Bool -> SAWCoreScaffolding.Bool) (g : b -> b -> SAWCoreScaffolding.Bool -> SAWCoreScaffolding.Bool) (x12 : prod a b) (y12 : prod a b) (k : SAWCoreScaffolding.Bool) => f (fst x12) (fst y12) (g (snd x12) (snd y12) k). +Definition pairLt : forall (a : Type), forall (b : Type), (a -> a -> SAWCoreScaffolding.Bool -> SAWCoreScaffolding.Bool) -> (b -> b -> SAWCoreScaffolding.Bool) -> prod a b -> prod a b -> SAWCoreScaffolding.Bool := + fun (a : Type) (b : Type) (f : a -> a -> SAWCoreScaffolding.Bool -> SAWCoreScaffolding.Bool) (g : b -> b -> SAWCoreScaffolding.Bool) (x : prod a b) (y : prod a b) => f (fst x) (fst y) (g (snd x) (snd y)). + Definition PEq : Type -> Type := fun (a : Type) => RecordTypeCons "eq" (a -> a -> SAWCoreScaffolding.Bool) RecordTypeNil. @@ -278,55 +297,61 @@ Definition PEqPair : forall (a : Type), forall (b : Type), PEq a -> PEq b -> PEq fun (a : Type) (b : Type) (pa : RecordTypeCons "eq" (a -> a -> SAWCoreScaffolding.Bool) RecordTypeNil) (pb : RecordTypeCons "eq" (b -> b -> SAWCoreScaffolding.Bool) RecordTypeNil) => RecordCons "eq" (SAWCorePrelude.pairEq a b (RecordProj pa "eq") (RecordProj pb "eq")) RecordNil. Definition PCmp : Type -> Type := - fun (a : Type) => RecordTypeCons "cmp" (a -> a -> SAWCoreScaffolding.Bool -> SAWCoreScaffolding.Bool) (RecordTypeCons "cmpEq" (PEq a) RecordTypeNil). + fun (a : Type) => let var__0 := a -> a -> SAWCoreScaffolding.Bool in + RecordTypeCons "cmp" (a -> a -> SAWCoreScaffolding.Bool -> SAWCoreScaffolding.Bool) (RecordTypeCons "cmpEq" (PEq a) (RecordTypeCons "le" var__0 (RecordTypeCons "lt" var__0 RecordTypeNil))). Definition PCmpBit : PCmp SAWCoreScaffolding.Bool := - RecordCons "cmp" boolCmp (RecordCons "cmpEq" PEqBit RecordNil). + RecordCons "cmp" boolCmp (RecordCons "cmpEq" PEqBit (RecordCons "le" implies (RecordCons "lt" boolLt RecordNil))). Definition PCmpInteger : PCmp SAWCoreScaffolding.Integer := - RecordCons "cmp" integerCmp (RecordCons "cmpEq" PEqInteger RecordNil). + RecordCons "cmp" integerCmp (RecordCons "cmpEq" PEqInteger (RecordCons "le" SAWCoreScaffolding.intLe (RecordCons "lt" SAWCoreScaffolding.intLt RecordNil))). Definition PCmpRational : PCmp Rational := - RecordCons "cmp" rationalCmp (RecordCons "cmpEq" PEqRational RecordNil). + RecordCons "cmp" rationalCmp (RecordCons "cmpEq" PEqRational (RecordCons "le" leRational (RecordCons "lt" ltRational RecordNil))). Definition PCmpVec : forall (n : SAWCoreScaffolding.Nat), forall (a : Type), forall {Inh_a : SAWCoreScaffolding.Inhabited a}, PCmp a -> PCmp (SAWCoreVectorsAsCoqVectors.Vec n a) := - fun (n : SAWCoreScaffolding.Nat) (a : Type) {Inh_a : SAWCoreScaffolding.Inhabited a} (pa : RecordTypeCons "cmp" (a -> a -> SAWCoreScaffolding.Bool -> SAWCoreScaffolding.Bool) (RecordTypeCons "cmpEq" (RecordTypeCons "eq" (a -> a -> SAWCoreScaffolding.Bool) RecordTypeNil) RecordTypeNil)) => RecordCons "cmp" (vecCmp n a (RecordProj pa "cmp")) (RecordCons "cmpEq" (PEqVec n a (RecordProj pa "cmpEq")) RecordNil). + fun (n : SAWCoreScaffolding.Nat) (a : Type) {Inh_a : SAWCoreScaffolding.Inhabited a} (pa : RecordTypeCons "cmp" (a -> a -> SAWCoreScaffolding.Bool -> SAWCoreScaffolding.Bool) (RecordTypeCons "cmpEq" (RecordTypeCons "eq" (a -> a -> SAWCoreScaffolding.Bool) RecordTypeNil) (RecordTypeCons "le" (a -> a -> SAWCoreScaffolding.Bool) (RecordTypeCons "lt" (a -> a -> SAWCoreScaffolding.Bool) RecordTypeNil)))) => let var__0 := SAWCoreVectorsAsCoqVectors.Vec n a in + RecordCons "cmp" (vecCmp n a (RecordProj pa "cmp")) (RecordCons "cmpEq" (PEqVec n a (RecordProj pa "cmpEq")) (RecordCons "le" (fun (x : var__0) (y : SAWCoreVectorsAsCoqVectors.Vec n a) => vecCmp n a (RecordProj pa "cmp") x y SAWCoreScaffolding.true) (RecordCons "lt" (fun (x : var__0) (y : SAWCoreVectorsAsCoqVectors.Vec n a) => vecCmp n a (RecordProj pa "cmp") x y SAWCoreScaffolding.false) RecordNil))). Definition PCmpSeq : forall (n : Num), forall (a : Type), forall {Inh_a : SAWCoreScaffolding.Inhabited a}, PCmp a -> PCmp (seq n a) := - fun (n : Num) => CryptolPrimitivesForSAWCore.Num_rect (fun (n1 : Num) => forall (a : Type), forall {Inh_a : SAWCoreScaffolding.Inhabited a}, PCmp a -> PCmp (seq n1 a)) (fun (n1 : SAWCoreScaffolding.Nat) => PCmpVec n1) (fun (a : Type) {Inh_a : SAWCoreScaffolding.Inhabited a} (pa : RecordTypeCons "cmp" (a -> a -> SAWCoreScaffolding.Bool -> SAWCoreScaffolding.Bool) (RecordTypeCons "cmpEq" (RecordTypeCons "eq" (a -> a -> SAWCoreScaffolding.Bool) RecordTypeNil) RecordTypeNil)) => SAWCoreScaffolding.error (PCmp (SAWCorePrelude.Stream a)) "invalid Cmp instance"%string) n. + fun (n : Num) => CryptolPrimitivesForSAWCore.Num_rect (fun (n1 : Num) => forall (a : Type), forall {Inh_a : SAWCoreScaffolding.Inhabited a}, PCmp a -> PCmp (seq n1 a)) (fun (n1 : SAWCoreScaffolding.Nat) => PCmpVec n1) (fun (a : Type) {Inh_a : SAWCoreScaffolding.Inhabited a} (pa : RecordTypeCons "cmp" (a -> a -> SAWCoreScaffolding.Bool -> SAWCoreScaffolding.Bool) (RecordTypeCons "cmpEq" (RecordTypeCons "eq" (a -> a -> SAWCoreScaffolding.Bool) RecordTypeNil) (RecordTypeCons "le" (a -> a -> SAWCoreScaffolding.Bool) (RecordTypeCons "lt" (a -> a -> SAWCoreScaffolding.Bool) RecordTypeNil)))) => SAWCoreScaffolding.error (PCmp (SAWCorePrelude.Stream a)) "invalid Cmp instance"%string) n. Definition PCmpWord : forall (n : SAWCoreScaffolding.Nat), PCmp (SAWCoreVectorsAsCoqVectors.Vec n SAWCoreScaffolding.Bool) := - fun (n : SAWCoreScaffolding.Nat) => RecordCons "cmp" (bvCmp n) (RecordCons "cmpEq" (PEqWord n) RecordNil). + fun (n : SAWCoreScaffolding.Nat) => RecordCons "cmp" (bvCmp n) (RecordCons "cmpEq" (PEqWord n) (RecordCons "le" (SAWCoreVectorsAsCoqVectors.bvule n) (RecordCons "lt" (SAWCoreVectorsAsCoqVectors.bvult n) RecordNil))). Definition PCmpSeqBool : forall (n : Num), PCmp (seq n SAWCoreScaffolding.Bool) := fun (n : Num) => CryptolPrimitivesForSAWCore.Num_rect (fun (n1 : Num) => PCmp (seq n1 SAWCoreScaffolding.Bool)) (fun (n1 : SAWCoreScaffolding.Nat) => PCmpWord n1) (SAWCoreScaffolding.error (PCmp (SAWCorePrelude.Stream SAWCoreScaffolding.Bool)) "invalid Cmp instance"%string) n. Definition PCmpUnit : PCmp (unit : Type) := - RecordCons "cmp" unitCmp (RecordCons "cmpEq" PEqUnit RecordNil). + RecordCons "cmp" unitCmp (RecordCons "cmpEq" PEqUnit (RecordCons "le" unitLe (RecordCons "lt" unitLt RecordNil))). Definition PCmpPair : forall (a : Type), forall (b : Type), PCmp a -> PCmp b -> PCmp (prod a b) := - fun (a : Type) (b : Type) (pa : RecordTypeCons "cmp" (a -> a -> SAWCoreScaffolding.Bool -> SAWCoreScaffolding.Bool) (RecordTypeCons "cmpEq" (RecordTypeCons "eq" (a -> a -> SAWCoreScaffolding.Bool) RecordTypeNil) RecordTypeNil)) (pb : RecordTypeCons "cmp" (b -> b -> SAWCoreScaffolding.Bool -> SAWCoreScaffolding.Bool) (RecordTypeCons "cmpEq" (RecordTypeCons "eq" (b -> b -> SAWCoreScaffolding.Bool) RecordTypeNil) RecordTypeNil)) => RecordCons "cmp" (pairCmp a b (RecordProj pa "cmp") (RecordProj pb "cmp")) (RecordCons "cmpEq" (PEqPair a b (RecordProj pa "cmpEq") (RecordProj pb "cmpEq")) RecordNil). + fun (a : Type) (b : Type) (pa : RecordTypeCons "cmp" (a -> a -> SAWCoreScaffolding.Bool -> SAWCoreScaffolding.Bool) (RecordTypeCons "cmpEq" (RecordTypeCons "eq" (a -> a -> SAWCoreScaffolding.Bool) RecordTypeNil) (RecordTypeCons "le" (a -> a -> SAWCoreScaffolding.Bool) (RecordTypeCons "lt" (a -> a -> SAWCoreScaffolding.Bool) RecordTypeNil)))) (pb : RecordTypeCons "cmp" (b -> b -> SAWCoreScaffolding.Bool -> SAWCoreScaffolding.Bool) (RecordTypeCons "cmpEq" (RecordTypeCons "eq" (b -> b -> SAWCoreScaffolding.Bool) RecordTypeNil) (RecordTypeCons "le" (b -> b -> SAWCoreScaffolding.Bool) (RecordTypeCons "lt" (b -> b -> SAWCoreScaffolding.Bool) RecordTypeNil)))) => let var__0 := RecordProj pa "cmp" in + RecordCons "cmp" (pairCmp a b var__0 (RecordProj pb "cmp")) (RecordCons "cmpEq" (PEqPair a b (RecordProj pa "cmpEq") (RecordProj pb "cmpEq")) (RecordCons "le" (pairLt a b var__0 (RecordProj pb "le")) (RecordCons "lt" (pairLt a b var__0 (RecordProj pb "lt")) RecordNil))). Definition PSignedCmp : Type -> Type := - fun (a : Type) => RecordTypeCons "scmp" (a -> a -> SAWCoreScaffolding.Bool -> SAWCoreScaffolding.Bool) (RecordTypeCons "signedCmpEq" (PEq a) RecordTypeNil). + fun (a : Type) => let var__0 := a -> a -> SAWCoreScaffolding.Bool in + RecordTypeCons "scmp" (a -> a -> SAWCoreScaffolding.Bool -> SAWCoreScaffolding.Bool) (RecordTypeCons "signedCmpEq" (PEq a) (RecordTypeCons "sle" var__0 (RecordTypeCons "slt" var__0 RecordTypeNil))). Definition PSignedCmpVec : forall (n : SAWCoreScaffolding.Nat), forall (a : Type), forall {Inh_a : SAWCoreScaffolding.Inhabited a}, PSignedCmp a -> PSignedCmp (SAWCoreVectorsAsCoqVectors.Vec n a) := - fun (n : SAWCoreScaffolding.Nat) (a : Type) {Inh_a : SAWCoreScaffolding.Inhabited a} (pa : RecordTypeCons "scmp" (a -> a -> SAWCoreScaffolding.Bool -> SAWCoreScaffolding.Bool) (RecordTypeCons "signedCmpEq" (RecordTypeCons "eq" (a -> a -> SAWCoreScaffolding.Bool) RecordTypeNil) RecordTypeNil)) => RecordCons "scmp" (vecCmp n a (RecordProj pa "scmp")) (RecordCons "signedCmpEq" (PEqVec n a (RecordProj pa "signedCmpEq")) RecordNil). + fun (n : SAWCoreScaffolding.Nat) (a : Type) {Inh_a : SAWCoreScaffolding.Inhabited a} (pa : RecordTypeCons "scmp" (a -> a -> SAWCoreScaffolding.Bool -> SAWCoreScaffolding.Bool) (RecordTypeCons "signedCmpEq" (RecordTypeCons "eq" (a -> a -> SAWCoreScaffolding.Bool) RecordTypeNil) (RecordTypeCons "sle" (a -> a -> SAWCoreScaffolding.Bool) (RecordTypeCons "slt" (a -> a -> SAWCoreScaffolding.Bool) RecordTypeNil)))) => let var__0 := SAWCoreVectorsAsCoqVectors.Vec n a in + RecordCons "scmp" (vecCmp n a (RecordProj pa "scmp")) (RecordCons "signedCmpEq" (PEqVec n a (RecordProj pa "signedCmpEq")) (RecordCons "sle" (fun (x : var__0) (y : SAWCoreVectorsAsCoqVectors.Vec n a) => vecCmp n a (RecordProj pa "scmp") x y SAWCoreScaffolding.true) (RecordCons "slt" (fun (x : var__0) (y : SAWCoreVectorsAsCoqVectors.Vec n a) => vecCmp n a (RecordProj pa "scmp") x y SAWCoreScaffolding.false) RecordNil))). Definition PSignedCmpSeq : forall (n : Num), forall (a : Type), forall {Inh_a : SAWCoreScaffolding.Inhabited a}, PSignedCmp a -> PSignedCmp (seq n a) := - fun (n : Num) => CryptolPrimitivesForSAWCore.Num_rect (fun (n1 : Num) => forall (a : Type), forall {Inh_a : SAWCoreScaffolding.Inhabited a}, PSignedCmp a -> PSignedCmp (seq n1 a)) (fun (n1 : SAWCoreScaffolding.Nat) => PSignedCmpVec n1) (fun (a : Type) {Inh_a : SAWCoreScaffolding.Inhabited a} (pa : RecordTypeCons "scmp" (a -> a -> SAWCoreScaffolding.Bool -> SAWCoreScaffolding.Bool) (RecordTypeCons "signedCmpEq" (RecordTypeCons "eq" (a -> a -> SAWCoreScaffolding.Bool) RecordTypeNil) RecordTypeNil)) => SAWCoreScaffolding.error (PSignedCmp (SAWCorePrelude.Stream a)) "invalid SignedCmp instance"%string) n. + fun (n : Num) => CryptolPrimitivesForSAWCore.Num_rect (fun (n1 : Num) => forall (a : Type), forall {Inh_a : SAWCoreScaffolding.Inhabited a}, PSignedCmp a -> PSignedCmp (seq n1 a)) (fun (n1 : SAWCoreScaffolding.Nat) => PSignedCmpVec n1) (fun (a : Type) {Inh_a : SAWCoreScaffolding.Inhabited a} (pa : RecordTypeCons "scmp" (a -> a -> SAWCoreScaffolding.Bool -> SAWCoreScaffolding.Bool) (RecordTypeCons "signedCmpEq" (RecordTypeCons "eq" (a -> a -> SAWCoreScaffolding.Bool) RecordTypeNil) (RecordTypeCons "sle" (a -> a -> SAWCoreScaffolding.Bool) (RecordTypeCons "slt" (a -> a -> SAWCoreScaffolding.Bool) RecordTypeNil)))) => SAWCoreScaffolding.error (PSignedCmp (SAWCorePrelude.Stream a)) "invalid SignedCmp instance"%string) n. Definition PSignedCmpWord : forall (n : SAWCoreScaffolding.Nat), PSignedCmp (SAWCoreVectorsAsCoqVectors.Vec n SAWCoreScaffolding.Bool) := - fun (n : SAWCoreScaffolding.Nat) => RecordCons "scmp" (bvSCmp n) (RecordCons "signedCmpEq" (PEqWord n) RecordNil). + fun (n : SAWCoreScaffolding.Nat) => RecordCons "scmp" (bvSCmp n) (RecordCons "signedCmpEq" (PEqWord n) (RecordCons "sle" (SAWCoreVectorsAsCoqVectors.bvsle n) (RecordCons "slt" (SAWCoreVectorsAsCoqVectors.bvslt n) RecordNil))). Definition PSignedCmpSeqBool : forall (n : Num), PSignedCmp (seq n SAWCoreScaffolding.Bool) := fun (n : Num) => CryptolPrimitivesForSAWCore.Num_rect (fun (n1 : Num) => PSignedCmp (seq n1 SAWCoreScaffolding.Bool)) (fun (n1 : SAWCoreScaffolding.Nat) => PSignedCmpWord n1) (SAWCoreScaffolding.error (PSignedCmp (SAWCorePrelude.Stream SAWCoreScaffolding.Bool)) "invalid SignedCmp instance"%string) n. Definition PSignedCmpUnit : PSignedCmp (unit : Type) := - RecordCons "scmp" unitCmp (RecordCons "signedCmpEq" PEqUnit RecordNil). + RecordCons "scmp" unitCmp (RecordCons "signedCmpEq" PEqUnit (RecordCons "sle" unitLe (RecordCons "slt" unitLt RecordNil))). Definition PSignedCmpPair : forall (a : Type), forall (b : Type), PSignedCmp a -> PSignedCmp b -> PSignedCmp (prod a b) := - fun (a : Type) (b : Type) (pa : RecordTypeCons "scmp" (a -> a -> SAWCoreScaffolding.Bool -> SAWCoreScaffolding.Bool) (RecordTypeCons "signedCmpEq" (RecordTypeCons "eq" (a -> a -> SAWCoreScaffolding.Bool) RecordTypeNil) RecordTypeNil)) (pb : RecordTypeCons "scmp" (b -> b -> SAWCoreScaffolding.Bool -> SAWCoreScaffolding.Bool) (RecordTypeCons "signedCmpEq" (RecordTypeCons "eq" (b -> b -> SAWCoreScaffolding.Bool) RecordTypeNil) RecordTypeNil)) => RecordCons "scmp" (pairCmp a b (RecordProj pa "scmp") (RecordProj pb "scmp")) (RecordCons "signedCmpEq" (PEqPair a b (RecordProj pa "signedCmpEq") (RecordProj pb "signedCmpEq")) RecordNil). + fun (a : Type) (b : Type) (pa : RecordTypeCons "scmp" (a -> a -> SAWCoreScaffolding.Bool -> SAWCoreScaffolding.Bool) (RecordTypeCons "signedCmpEq" (RecordTypeCons "eq" (a -> a -> SAWCoreScaffolding.Bool) RecordTypeNil) (RecordTypeCons "sle" (a -> a -> SAWCoreScaffolding.Bool) (RecordTypeCons "slt" (a -> a -> SAWCoreScaffolding.Bool) RecordTypeNil)))) (pb : RecordTypeCons "scmp" (b -> b -> SAWCoreScaffolding.Bool -> SAWCoreScaffolding.Bool) (RecordTypeCons "signedCmpEq" (RecordTypeCons "eq" (b -> b -> SAWCoreScaffolding.Bool) RecordTypeNil) (RecordTypeCons "sle" (b -> b -> SAWCoreScaffolding.Bool) (RecordTypeCons "slt" (b -> b -> SAWCoreScaffolding.Bool) RecordTypeNil)))) => let var__0 := RecordProj pa "scmp" in + RecordCons "scmp" (pairCmp a b var__0 (RecordProj pb "scmp")) (RecordCons "signedCmpEq" (PEqPair a b (RecordProj pa "signedCmpEq") (RecordProj pb "signedCmpEq")) (RecordCons "sle" (pairLt a b var__0 (RecordProj pb "sle")) (RecordCons "slt" (pairLt a b var__0 (RecordProj pb "slt")) RecordNil))). Definition PZero : Type -> Type := fun (a : Type) => a. @@ -523,19 +548,19 @@ Definition ecFieldDiv : forall (a : Type), PField a -> a -> a -> a := fun (a : Type) (pf : RecordTypeCons "fieldDiv" (a -> a -> a) (RecordTypeCons "fieldRing" (RecordTypeCons "add" (a -> a -> a) (RecordTypeCons "int" (SAWCoreScaffolding.Integer -> a) (RecordTypeCons "mul" (a -> a -> a) (RecordTypeCons "neg" (a -> a) (RecordTypeCons "ringZero" a (RecordTypeCons "sub" (a -> a -> a) RecordTypeNil)))))) (RecordTypeCons "recip" (a -> a) RecordTypeNil))) => RecordProj pf "fieldDiv". Definition ecCeiling : forall (a : Type), PRound a -> a -> SAWCoreScaffolding.Integer := - fun (a : Type) (pr : RecordTypeCons "ceiling" (a -> SAWCoreScaffolding.Integer) (RecordTypeCons "floor" (a -> SAWCoreScaffolding.Integer) (RecordTypeCons "roundAway" (a -> SAWCoreScaffolding.Integer) (RecordTypeCons "roundCmp" (RecordTypeCons "cmp" (a -> a -> SAWCoreScaffolding.Bool -> SAWCoreScaffolding.Bool) (RecordTypeCons "cmpEq" (RecordTypeCons "eq" (a -> a -> SAWCoreScaffolding.Bool) RecordTypeNil) RecordTypeNil)) (RecordTypeCons "roundField" (RecordTypeCons "fieldDiv" (a -> a -> a) (RecordTypeCons "fieldRing" (RecordTypeCons "add" (a -> a -> a) (RecordTypeCons "int" (SAWCoreScaffolding.Integer -> a) (RecordTypeCons "mul" (a -> a -> a) (RecordTypeCons "neg" (a -> a) (RecordTypeCons "ringZero" a (RecordTypeCons "sub" (a -> a -> a) RecordTypeNil)))))) (RecordTypeCons "recip" (a -> a) RecordTypeNil))) (RecordTypeCons "roundToEven" (a -> SAWCoreScaffolding.Integer) (RecordTypeCons "trunc" (a -> SAWCoreScaffolding.Integer) RecordTypeNil))))))) => RecordProj pr "ceiling". + fun (a : Type) (pr : RecordTypeCons "ceiling" (a -> SAWCoreScaffolding.Integer) (RecordTypeCons "floor" (a -> SAWCoreScaffolding.Integer) (RecordTypeCons "roundAway" (a -> SAWCoreScaffolding.Integer) (RecordTypeCons "roundCmp" (RecordTypeCons "cmp" (a -> a -> SAWCoreScaffolding.Bool -> SAWCoreScaffolding.Bool) (RecordTypeCons "cmpEq" (RecordTypeCons "eq" (a -> a -> SAWCoreScaffolding.Bool) RecordTypeNil) (RecordTypeCons "le" (a -> a -> SAWCoreScaffolding.Bool) (RecordTypeCons "lt" (a -> a -> SAWCoreScaffolding.Bool) RecordTypeNil)))) (RecordTypeCons "roundField" (RecordTypeCons "fieldDiv" (a -> a -> a) (RecordTypeCons "fieldRing" (RecordTypeCons "add" (a -> a -> a) (RecordTypeCons "int" (SAWCoreScaffolding.Integer -> a) (RecordTypeCons "mul" (a -> a -> a) (RecordTypeCons "neg" (a -> a) (RecordTypeCons "ringZero" a (RecordTypeCons "sub" (a -> a -> a) RecordTypeNil)))))) (RecordTypeCons "recip" (a -> a) RecordTypeNil))) (RecordTypeCons "roundToEven" (a -> SAWCoreScaffolding.Integer) (RecordTypeCons "trunc" (a -> SAWCoreScaffolding.Integer) RecordTypeNil))))))) => RecordProj pr "ceiling". Definition ecFloor : forall (a : Type), PRound a -> a -> SAWCoreScaffolding.Integer := - fun (a : Type) (pr : RecordTypeCons "ceiling" (a -> SAWCoreScaffolding.Integer) (RecordTypeCons "floor" (a -> SAWCoreScaffolding.Integer) (RecordTypeCons "roundAway" (a -> SAWCoreScaffolding.Integer) (RecordTypeCons "roundCmp" (RecordTypeCons "cmp" (a -> a -> SAWCoreScaffolding.Bool -> SAWCoreScaffolding.Bool) (RecordTypeCons "cmpEq" (RecordTypeCons "eq" (a -> a -> SAWCoreScaffolding.Bool) RecordTypeNil) RecordTypeNil)) (RecordTypeCons "roundField" (RecordTypeCons "fieldDiv" (a -> a -> a) (RecordTypeCons "fieldRing" (RecordTypeCons "add" (a -> a -> a) (RecordTypeCons "int" (SAWCoreScaffolding.Integer -> a) (RecordTypeCons "mul" (a -> a -> a) (RecordTypeCons "neg" (a -> a) (RecordTypeCons "ringZero" a (RecordTypeCons "sub" (a -> a -> a) RecordTypeNil)))))) (RecordTypeCons "recip" (a -> a) RecordTypeNil))) (RecordTypeCons "roundToEven" (a -> SAWCoreScaffolding.Integer) (RecordTypeCons "trunc" (a -> SAWCoreScaffolding.Integer) RecordTypeNil))))))) => RecordProj pr "floor". + fun (a : Type) (pr : RecordTypeCons "ceiling" (a -> SAWCoreScaffolding.Integer) (RecordTypeCons "floor" (a -> SAWCoreScaffolding.Integer) (RecordTypeCons "roundAway" (a -> SAWCoreScaffolding.Integer) (RecordTypeCons "roundCmp" (RecordTypeCons "cmp" (a -> a -> SAWCoreScaffolding.Bool -> SAWCoreScaffolding.Bool) (RecordTypeCons "cmpEq" (RecordTypeCons "eq" (a -> a -> SAWCoreScaffolding.Bool) RecordTypeNil) (RecordTypeCons "le" (a -> a -> SAWCoreScaffolding.Bool) (RecordTypeCons "lt" (a -> a -> SAWCoreScaffolding.Bool) RecordTypeNil)))) (RecordTypeCons "roundField" (RecordTypeCons "fieldDiv" (a -> a -> a) (RecordTypeCons "fieldRing" (RecordTypeCons "add" (a -> a -> a) (RecordTypeCons "int" (SAWCoreScaffolding.Integer -> a) (RecordTypeCons "mul" (a -> a -> a) (RecordTypeCons "neg" (a -> a) (RecordTypeCons "ringZero" a (RecordTypeCons "sub" (a -> a -> a) RecordTypeNil)))))) (RecordTypeCons "recip" (a -> a) RecordTypeNil))) (RecordTypeCons "roundToEven" (a -> SAWCoreScaffolding.Integer) (RecordTypeCons "trunc" (a -> SAWCoreScaffolding.Integer) RecordTypeNil))))))) => RecordProj pr "floor". Definition ecTruncate : forall (a : Type), PRound a -> a -> SAWCoreScaffolding.Integer := - fun (a : Type) (pr : RecordTypeCons "ceiling" (a -> SAWCoreScaffolding.Integer) (RecordTypeCons "floor" (a -> SAWCoreScaffolding.Integer) (RecordTypeCons "roundAway" (a -> SAWCoreScaffolding.Integer) (RecordTypeCons "roundCmp" (RecordTypeCons "cmp" (a -> a -> SAWCoreScaffolding.Bool -> SAWCoreScaffolding.Bool) (RecordTypeCons "cmpEq" (RecordTypeCons "eq" (a -> a -> SAWCoreScaffolding.Bool) RecordTypeNil) RecordTypeNil)) (RecordTypeCons "roundField" (RecordTypeCons "fieldDiv" (a -> a -> a) (RecordTypeCons "fieldRing" (RecordTypeCons "add" (a -> a -> a) (RecordTypeCons "int" (SAWCoreScaffolding.Integer -> a) (RecordTypeCons "mul" (a -> a -> a) (RecordTypeCons "neg" (a -> a) (RecordTypeCons "ringZero" a (RecordTypeCons "sub" (a -> a -> a) RecordTypeNil)))))) (RecordTypeCons "recip" (a -> a) RecordTypeNil))) (RecordTypeCons "roundToEven" (a -> SAWCoreScaffolding.Integer) (RecordTypeCons "trunc" (a -> SAWCoreScaffolding.Integer) RecordTypeNil))))))) => RecordProj pr "trunc". + fun (a : Type) (pr : RecordTypeCons "ceiling" (a -> SAWCoreScaffolding.Integer) (RecordTypeCons "floor" (a -> SAWCoreScaffolding.Integer) (RecordTypeCons "roundAway" (a -> SAWCoreScaffolding.Integer) (RecordTypeCons "roundCmp" (RecordTypeCons "cmp" (a -> a -> SAWCoreScaffolding.Bool -> SAWCoreScaffolding.Bool) (RecordTypeCons "cmpEq" (RecordTypeCons "eq" (a -> a -> SAWCoreScaffolding.Bool) RecordTypeNil) (RecordTypeCons "le" (a -> a -> SAWCoreScaffolding.Bool) (RecordTypeCons "lt" (a -> a -> SAWCoreScaffolding.Bool) RecordTypeNil)))) (RecordTypeCons "roundField" (RecordTypeCons "fieldDiv" (a -> a -> a) (RecordTypeCons "fieldRing" (RecordTypeCons "add" (a -> a -> a) (RecordTypeCons "int" (SAWCoreScaffolding.Integer -> a) (RecordTypeCons "mul" (a -> a -> a) (RecordTypeCons "neg" (a -> a) (RecordTypeCons "ringZero" a (RecordTypeCons "sub" (a -> a -> a) RecordTypeNil)))))) (RecordTypeCons "recip" (a -> a) RecordTypeNil))) (RecordTypeCons "roundToEven" (a -> SAWCoreScaffolding.Integer) (RecordTypeCons "trunc" (a -> SAWCoreScaffolding.Integer) RecordTypeNil))))))) => RecordProj pr "trunc". Definition ecRoundAway : forall (a : Type), PRound a -> a -> SAWCoreScaffolding.Integer := - fun (a : Type) (pr : RecordTypeCons "ceiling" (a -> SAWCoreScaffolding.Integer) (RecordTypeCons "floor" (a -> SAWCoreScaffolding.Integer) (RecordTypeCons "roundAway" (a -> SAWCoreScaffolding.Integer) (RecordTypeCons "roundCmp" (RecordTypeCons "cmp" (a -> a -> SAWCoreScaffolding.Bool -> SAWCoreScaffolding.Bool) (RecordTypeCons "cmpEq" (RecordTypeCons "eq" (a -> a -> SAWCoreScaffolding.Bool) RecordTypeNil) RecordTypeNil)) (RecordTypeCons "roundField" (RecordTypeCons "fieldDiv" (a -> a -> a) (RecordTypeCons "fieldRing" (RecordTypeCons "add" (a -> a -> a) (RecordTypeCons "int" (SAWCoreScaffolding.Integer -> a) (RecordTypeCons "mul" (a -> a -> a) (RecordTypeCons "neg" (a -> a) (RecordTypeCons "ringZero" a (RecordTypeCons "sub" (a -> a -> a) RecordTypeNil)))))) (RecordTypeCons "recip" (a -> a) RecordTypeNil))) (RecordTypeCons "roundToEven" (a -> SAWCoreScaffolding.Integer) (RecordTypeCons "trunc" (a -> SAWCoreScaffolding.Integer) RecordTypeNil))))))) => RecordProj pr "roundAway". + fun (a : Type) (pr : RecordTypeCons "ceiling" (a -> SAWCoreScaffolding.Integer) (RecordTypeCons "floor" (a -> SAWCoreScaffolding.Integer) (RecordTypeCons "roundAway" (a -> SAWCoreScaffolding.Integer) (RecordTypeCons "roundCmp" (RecordTypeCons "cmp" (a -> a -> SAWCoreScaffolding.Bool -> SAWCoreScaffolding.Bool) (RecordTypeCons "cmpEq" (RecordTypeCons "eq" (a -> a -> SAWCoreScaffolding.Bool) RecordTypeNil) (RecordTypeCons "le" (a -> a -> SAWCoreScaffolding.Bool) (RecordTypeCons "lt" (a -> a -> SAWCoreScaffolding.Bool) RecordTypeNil)))) (RecordTypeCons "roundField" (RecordTypeCons "fieldDiv" (a -> a -> a) (RecordTypeCons "fieldRing" (RecordTypeCons "add" (a -> a -> a) (RecordTypeCons "int" (SAWCoreScaffolding.Integer -> a) (RecordTypeCons "mul" (a -> a -> a) (RecordTypeCons "neg" (a -> a) (RecordTypeCons "ringZero" a (RecordTypeCons "sub" (a -> a -> a) RecordTypeNil)))))) (RecordTypeCons "recip" (a -> a) RecordTypeNil))) (RecordTypeCons "roundToEven" (a -> SAWCoreScaffolding.Integer) (RecordTypeCons "trunc" (a -> SAWCoreScaffolding.Integer) RecordTypeNil))))))) => RecordProj pr "roundAway". Definition ecRoundToEven : forall (a : Type), PRound a -> a -> SAWCoreScaffolding.Integer := - fun (a : Type) (pr : RecordTypeCons "ceiling" (a -> SAWCoreScaffolding.Integer) (RecordTypeCons "floor" (a -> SAWCoreScaffolding.Integer) (RecordTypeCons "roundAway" (a -> SAWCoreScaffolding.Integer) (RecordTypeCons "roundCmp" (RecordTypeCons "cmp" (a -> a -> SAWCoreScaffolding.Bool -> SAWCoreScaffolding.Bool) (RecordTypeCons "cmpEq" (RecordTypeCons "eq" (a -> a -> SAWCoreScaffolding.Bool) RecordTypeNil) RecordTypeNil)) (RecordTypeCons "roundField" (RecordTypeCons "fieldDiv" (a -> a -> a) (RecordTypeCons "fieldRing" (RecordTypeCons "add" (a -> a -> a) (RecordTypeCons "int" (SAWCoreScaffolding.Integer -> a) (RecordTypeCons "mul" (a -> a -> a) (RecordTypeCons "neg" (a -> a) (RecordTypeCons "ringZero" a (RecordTypeCons "sub" (a -> a -> a) RecordTypeNil)))))) (RecordTypeCons "recip" (a -> a) RecordTypeNil))) (RecordTypeCons "roundToEven" (a -> SAWCoreScaffolding.Integer) (RecordTypeCons "trunc" (a -> SAWCoreScaffolding.Integer) RecordTypeNil))))))) => RecordProj pr "roundToEven". + fun (a : Type) (pr : RecordTypeCons "ceiling" (a -> SAWCoreScaffolding.Integer) (RecordTypeCons "floor" (a -> SAWCoreScaffolding.Integer) (RecordTypeCons "roundAway" (a -> SAWCoreScaffolding.Integer) (RecordTypeCons "roundCmp" (RecordTypeCons "cmp" (a -> a -> SAWCoreScaffolding.Bool -> SAWCoreScaffolding.Bool) (RecordTypeCons "cmpEq" (RecordTypeCons "eq" (a -> a -> SAWCoreScaffolding.Bool) RecordTypeNil) (RecordTypeCons "le" (a -> a -> SAWCoreScaffolding.Bool) (RecordTypeCons "lt" (a -> a -> SAWCoreScaffolding.Bool) RecordTypeNil)))) (RecordTypeCons "roundField" (RecordTypeCons "fieldDiv" (a -> a -> a) (RecordTypeCons "fieldRing" (RecordTypeCons "add" (a -> a -> a) (RecordTypeCons "int" (SAWCoreScaffolding.Integer -> a) (RecordTypeCons "mul" (a -> a -> a) (RecordTypeCons "neg" (a -> a) (RecordTypeCons "ringZero" a (RecordTypeCons "sub" (a -> a -> a) RecordTypeNil)))))) (RecordTypeCons "recip" (a -> a) RecordTypeNil))) (RecordTypeCons "roundToEven" (a -> SAWCoreScaffolding.Integer) (RecordTypeCons "trunc" (a -> SAWCoreScaffolding.Integer) RecordTypeNil))))))) => RecordProj pr "roundToEven". Definition ecLg2 : forall (n : Num), seq n SAWCoreScaffolding.Bool -> seq n SAWCoreScaffolding.Bool := fun (n : Num) => CryptolPrimitivesForSAWCore.Num_rect (fun (n1 : Num) => seq n1 SAWCoreScaffolding.Bool -> seq n1 SAWCoreScaffolding.Bool) SAWCoreVectorsAsCoqVectors.bvLg2 (SAWCoreScaffolding.error (SAWCorePrelude.Stream SAWCoreScaffolding.Bool -> SAWCorePrelude.Stream SAWCoreScaffolding.Bool) "ecLg2: expected finite word"%string) n. @@ -556,19 +581,19 @@ Definition ecNotEq : forall (a : Type), PEq a -> a -> a -> SAWCoreScaffolding.Bo fun (a : Type) (pa : RecordTypeCons "eq" (a -> a -> SAWCoreScaffolding.Bool) RecordTypeNil) (x : a) (y : a) => SAWCoreScaffolding.not (ecEq a pa x y). Definition ecLt : forall (a : Type), PCmp a -> a -> a -> SAWCoreScaffolding.Bool := - fun (a : Type) (pa : RecordTypeCons "cmp" (a -> a -> SAWCoreScaffolding.Bool -> SAWCoreScaffolding.Bool) (RecordTypeCons "cmpEq" (RecordTypeCons "eq" (a -> a -> SAWCoreScaffolding.Bool) RecordTypeNil) RecordTypeNil)) (x : a) (y : a) => RecordProj pa "cmp" x y SAWCoreScaffolding.false. + fun (a : Type) (pa : RecordTypeCons "cmp" (a -> a -> SAWCoreScaffolding.Bool -> SAWCoreScaffolding.Bool) (RecordTypeCons "cmpEq" (RecordTypeCons "eq" (a -> a -> SAWCoreScaffolding.Bool) RecordTypeNil) (RecordTypeCons "le" (a -> a -> SAWCoreScaffolding.Bool) (RecordTypeCons "lt" (a -> a -> SAWCoreScaffolding.Bool) RecordTypeNil)))) => RecordProj pa "lt". Definition ecGt : forall (a : Type), PCmp a -> a -> a -> SAWCoreScaffolding.Bool := - fun (a : Type) (pa : RecordTypeCons "cmp" (a -> a -> SAWCoreScaffolding.Bool -> SAWCoreScaffolding.Bool) (RecordTypeCons "cmpEq" (RecordTypeCons "eq" (a -> a -> SAWCoreScaffolding.Bool) RecordTypeNil) RecordTypeNil)) (x : a) (y : a) => ecLt a pa y x. + fun (a : Type) (pa : RecordTypeCons "cmp" (a -> a -> SAWCoreScaffolding.Bool -> SAWCoreScaffolding.Bool) (RecordTypeCons "cmpEq" (RecordTypeCons "eq" (a -> a -> SAWCoreScaffolding.Bool) RecordTypeNil) (RecordTypeCons "le" (a -> a -> SAWCoreScaffolding.Bool) (RecordTypeCons "lt" (a -> a -> SAWCoreScaffolding.Bool) RecordTypeNil)))) (x : a) (y : a) => ecLt a pa y x. Definition ecLtEq : forall (a : Type), PCmp a -> a -> a -> SAWCoreScaffolding.Bool := - fun (a : Type) (pa : RecordTypeCons "cmp" (a -> a -> SAWCoreScaffolding.Bool -> SAWCoreScaffolding.Bool) (RecordTypeCons "cmpEq" (RecordTypeCons "eq" (a -> a -> SAWCoreScaffolding.Bool) RecordTypeNil) RecordTypeNil)) (x : a) (y : a) => SAWCoreScaffolding.not (ecLt a pa y x). + fun (a : Type) (pa : RecordTypeCons "cmp" (a -> a -> SAWCoreScaffolding.Bool -> SAWCoreScaffolding.Bool) (RecordTypeCons "cmpEq" (RecordTypeCons "eq" (a -> a -> SAWCoreScaffolding.Bool) RecordTypeNil) (RecordTypeCons "le" (a -> a -> SAWCoreScaffolding.Bool) (RecordTypeCons "lt" (a -> a -> SAWCoreScaffolding.Bool) RecordTypeNil)))) => RecordProj pa "le". Definition ecGtEq : forall (a : Type), PCmp a -> a -> a -> SAWCoreScaffolding.Bool := - fun (a : Type) (pa : RecordTypeCons "cmp" (a -> a -> SAWCoreScaffolding.Bool -> SAWCoreScaffolding.Bool) (RecordTypeCons "cmpEq" (RecordTypeCons "eq" (a -> a -> SAWCoreScaffolding.Bool) RecordTypeNil) RecordTypeNil)) (x : a) (y : a) => SAWCoreScaffolding.not (ecLt a pa x y). + fun (a : Type) (pa : RecordTypeCons "cmp" (a -> a -> SAWCoreScaffolding.Bool -> SAWCoreScaffolding.Bool) (RecordTypeCons "cmpEq" (RecordTypeCons "eq" (a -> a -> SAWCoreScaffolding.Bool) RecordTypeNil) (RecordTypeCons "le" (a -> a -> SAWCoreScaffolding.Bool) (RecordTypeCons "lt" (a -> a -> SAWCoreScaffolding.Bool) RecordTypeNil)))) (x : a) (y : a) => ecLtEq a pa y x. Definition ecSLt : forall (a : Type), PSignedCmp a -> a -> a -> SAWCoreScaffolding.Bool := - fun (a : Type) (pa : RecordTypeCons "scmp" (a -> a -> SAWCoreScaffolding.Bool -> SAWCoreScaffolding.Bool) (RecordTypeCons "signedCmpEq" (RecordTypeCons "eq" (a -> a -> SAWCoreScaffolding.Bool) RecordTypeNil) RecordTypeNil)) (x : a) (y : a) => RecordProj pa "scmp" x y SAWCoreScaffolding.false. + fun (a : Type) (pa : RecordTypeCons "scmp" (a -> a -> SAWCoreScaffolding.Bool -> SAWCoreScaffolding.Bool) (RecordTypeCons "signedCmpEq" (RecordTypeCons "eq" (a -> a -> SAWCoreScaffolding.Bool) RecordTypeNil) (RecordTypeCons "sle" (a -> a -> SAWCoreScaffolding.Bool) (RecordTypeCons "slt" (a -> a -> SAWCoreScaffolding.Bool) RecordTypeNil)))) => RecordProj pa "slt". Definition ecAnd : forall (a : Type), PLogic a -> a -> a -> a := fun (a : Type) (pa : RecordTypeCons "and" (a -> a -> a) (RecordTypeCons "logicZero" a (RecordTypeCons "not" (a -> a) (RecordTypeCons "or" (a -> a -> a) (RecordTypeCons "xor" (a -> a -> a) RecordTypeNil))))) => RecordProj pa "and". @@ -694,7 +719,8 @@ Definition PEqFloat : forall (e : Num), forall (p : Num), PEq (TCFloat e p) := fun (e : Num) (p : Num) => RecordCons "eq" (fun (x : unit : Type) (y : unit : Type) => SAWCoreScaffolding.error SAWCoreScaffolding.Bool "Unimplemented: (==) Float"%string) RecordNil. Definition PCmpFloat : forall (e : Num), forall (p : Num), PCmp (TCFloat e p) := - fun (e : Num) (p : Num) => RecordCons "cmp" (fun (x : unit : Type) (y : unit : Type) (k : SAWCoreScaffolding.Bool) => SAWCoreScaffolding.error SAWCoreScaffolding.Bool "Unimplemented: Cmp Float"%string) (RecordCons "cmpEq" (PEqFloat e p) RecordNil). + fun (e : Num) (p : Num) => let var__0 := fun (x : unit : Type) (y : unit : Type) => SAWCoreScaffolding.error SAWCoreScaffolding.Bool "Unimplemented: Cmp Float"%string in + RecordCons "cmp" (fun (x : unit : Type) (y : unit : Type) (k : SAWCoreScaffolding.Bool) => SAWCoreScaffolding.error SAWCoreScaffolding.Bool "Unimplemented: Cmp Float"%string) (RecordCons "cmpEq" (PEqFloat e p) (RecordCons "le" var__0 (RecordCons "lt" var__0 RecordNil))). Definition PZeroFloat : forall (e : Num), forall (p : Num), PZero (TCFloat e p) := fun (e : Num) (p : Num) => SAWCoreScaffolding.error (TCFloat e p) "Unimplemented: Zero Float"%string. diff --git a/saw-core-coq/coq/generated/CryptolToCoq/SAWCorePrelude.v b/saw-core-coq/coq/generated/CryptolToCoq/SAWCorePrelude.v index 792b54e6e9..78855c23b9 100644 --- a/saw-core-coq/coq/generated/CryptolToCoq/SAWCorePrelude.v +++ b/saw-core-coq/coq/generated/CryptolToCoq/SAWCorePrelude.v @@ -377,12 +377,12 @@ Definition and_triv2 : forall (x : SAWCoreScaffolding.Bool), SAWCoreScaffolding. fun (x : SAWCoreScaffolding.Bool) => let var__0 := SAWCoreScaffolding.not SAWCoreScaffolding.true in SAWCoreScaffolding.iteDep (fun (b : SAWCoreScaffolding.Bool) => SAWCoreScaffolding.Eq SAWCoreScaffolding.Bool (SAWCoreScaffolding.and (SAWCoreScaffolding.not b) b) SAWCoreScaffolding.false) x (trans SAWCoreScaffolding.Bool (SAWCoreScaffolding.and var__0 SAWCoreScaffolding.true) var__0 SAWCoreScaffolding.false (and_True2 var__0) not_True) (and_False2 (SAWCoreScaffolding.not SAWCoreScaffolding.false)). -Definition FalseProp : Prop := - SAWCoreScaffolding.Eq SAWCoreScaffolding.Bool SAWCoreScaffolding.true SAWCoreScaffolding.false. - Definition EqTrue : SAWCoreScaffolding.Bool -> Prop := fun (x : SAWCoreScaffolding.Bool) => SAWCoreScaffolding.Eq SAWCoreScaffolding.Bool x SAWCoreScaffolding.true. +Definition TrueProp : Prop := + EqTrue SAWCoreScaffolding.true. + Definition TrueI : EqTrue SAWCoreScaffolding.true := SAWCoreScaffolding.Refl SAWCoreScaffolding.Bool SAWCoreScaffolding.true. @@ -534,6 +534,9 @@ Axiom head : forall (n : SAWCoreScaffolding.Nat), forall (a : Type), SAWCoreVect Axiom tail : forall (n : SAWCoreScaffolding.Nat), forall (a : Type), SAWCoreVectorsAsCoqVectors.Vec (SAWCoreScaffolding.Succ n) a -> SAWCoreVectorsAsCoqVectors.Vec n a . +Definition atWithDefault' : forall (n : SAWCoreScaffolding.Nat), forall (a : Type), a -> SAWCoreVectorsAsCoqVectors.Vec n a -> SAWCoreScaffolding.Nat -> a := + fun (n_top : SAWCoreScaffolding.Nat) (a : Type) (d : a) => Nat__rec (fun (n : SAWCoreScaffolding.Nat) => SAWCoreVectorsAsCoqVectors.Vec n a -> SAWCoreScaffolding.Nat -> a) (fun (_1 : SAWCoreVectorsAsCoqVectors.Vec 0 a) (_2 : SAWCoreScaffolding.Nat) => d) (fun (n : SAWCoreScaffolding.Nat) (rec_f : SAWCoreVectorsAsCoqVectors.Vec n a -> SAWCoreScaffolding.Nat -> a) (v : SAWCoreVectorsAsCoqVectors.Vec (SAWCoreScaffolding.Succ n) a) (i : SAWCoreScaffolding.Nat) => Nat_cases a (head n a v) (fun (i_prev : SAWCoreScaffolding.Nat) (_1 : a) => rec_f (tail n a v) i_prev) i) n_top. + (* Prelude.atWithDefault was skipped *) Definition sawAt : forall (n : SAWCoreScaffolding.Nat), forall (a : Type), forall {Inh_a : SAWCoreScaffolding.Inhabited a}, SAWCoreVectorsAsCoqVectors.Vec n a -> SAWCoreScaffolding.Nat -> a := @@ -1009,10 +1012,16 @@ Definition genBVVec : forall (n : SAWCoreScaffolding.Nat), forall (len : SAWCore Definition genBVVecFromVec : forall (m : SAWCoreScaffolding.Nat), forall (a : Type), SAWCoreVectorsAsCoqVectors.Vec m a -> a -> forall (n : SAWCoreScaffolding.Nat), forall (len : SAWCoreVectorsAsCoqVectors.Vec n SAWCoreScaffolding.Bool), BVVec n len a := fun (m : SAWCoreScaffolding.Nat) (a : Type) (v : SAWCoreVectorsAsCoqVectors.Vec m a) (def : a) (n : SAWCoreScaffolding.Nat) (len : SAWCoreVectorsAsCoqVectors.Vec n SAWCoreScaffolding.Bool) => genBVVec n len a (fun (i : SAWCoreVectorsAsCoqVectors.Vec n SAWCoreScaffolding.Bool) (_1 : SAWCoreScaffolding.Eq SAWCoreScaffolding.Bool (SAWCoreVectorsAsCoqVectors.bvult n i len) SAWCoreScaffolding.true) => SAWCoreVectorsAsCoqVectors.atWithDefault m a def v (SAWCoreVectorsAsCoqVectors.bvToNat n i)). -Definition efq : forall (a : Type), SAWCoreScaffolding.Eq SAWCoreScaffolding.Bool SAWCoreScaffolding.true SAWCoreScaffolding.false -> a := +Definition FalseProp : Prop := + SAWCoreScaffolding.Eq SAWCoreScaffolding.Bool SAWCoreScaffolding.true SAWCoreScaffolding.false. + +Definition efq : forall (a : Type), FalseProp -> a := fun (a : Type) (contra : SAWCoreScaffolding.Eq SAWCoreScaffolding.Bool SAWCoreScaffolding.true SAWCoreScaffolding.false) => let var__0 := if SAWCoreScaffolding.true then unit : Type else a in SAWCoreScaffolding.coerce (unit : Type) a (trans Type (unit : Type) var__0 a (sym Type var__0 (unit : Type) (ite_true Type (unit : Type) a)) (trans Type var__0 (if SAWCoreScaffolding.false then unit : Type else a) a (eq_cong SAWCoreScaffolding.Bool SAWCoreScaffolding.true SAWCoreScaffolding.false contra Type (fun (b : SAWCoreScaffolding.Bool) => if b then unit : Type else a)) (ite_false Type (unit : Type) a))) tt. +Definition efq1 : forall (a : Type), SAWCoreScaffolding.Eq SAWCoreScaffolding.Bool SAWCoreScaffolding.true SAWCoreScaffolding.false -> a := + fun (a : Type) (contra : SAWCoreScaffolding.Eq SAWCoreScaffolding.Bool SAWCoreScaffolding.true SAWCoreScaffolding.false) => SAWCoreScaffolding.Eq__rec Bit Bit1 (fun (b : Bit) (_1 : SAWCoreScaffolding.Eq Bit Bit1 b) => SAWCorePrelude.Bit_rect (fun (_2 : Bit) => Type) (unit : Type) a b) tt Bit0 (efq (SAWCoreScaffolding.Eq Bit Bit1 Bit0) contra). + Definition emptyBVVec : forall (n : SAWCoreScaffolding.Nat), forall (a : Type), BVVec n (SAWCoreVectorsAsCoqVectors.bvNat n 0) a := fun (n : SAWCoreScaffolding.Nat) (a : Type) => genBVVec n (SAWCoreVectorsAsCoqVectors.bvNat n 0) a (fun (i : SAWCoreVectorsAsCoqVectors.Vec n SAWCoreScaffolding.Bool) (pf : SAWCoreScaffolding.Eq SAWCoreScaffolding.Bool (SAWCoreVectorsAsCoqVectors.bvult n i (SAWCoreVectorsAsCoqVectors.bvNat n 0)) SAWCoreScaffolding.true) => let var__0 := SAWCoreVectorsAsCoqVectors.bvult n i (SAWCoreVectorsAsCoqVectors.bvNat n 0) in efq a (trans SAWCoreScaffolding.Bool SAWCoreScaffolding.true var__0 SAWCoreScaffolding.false (sym SAWCoreScaffolding.Bool var__0 SAWCoreScaffolding.true pf) (not_bvult_zero n i))). @@ -1130,8 +1139,6 @@ Definition foldIRT : forall (As : ListSort), forall (Ds : IRTSubsts As), forall (* Prelude.bindM was skipped *) -(* Prelude.existsM was skipped *) - (* Prelude.errorM was skipped *) Definition fmapM : forall (a : Type), forall (b : Type), (a -> b) -> CompM a -> CompM b := @@ -1147,6 +1154,21 @@ Definition fmapM2 : forall (a : Type), forall (b : Type), forall (c : Type), (a Definition fmapM3 : forall (a : Type), forall (b : Type), forall (c : Type), forall (d : Type), (a -> b -> c -> d) -> CompM a -> CompM b -> CompM c -> CompM d := fun (a : Type) (b : Type) (c : Type) (d : Type) (f : a -> b -> c -> d) (m1 : CompM a) (m2 : CompM b) (m3 : CompM c) => applyM c d (fmapM2 a b (c -> d) f m1 m2) m3. +Definition bindM2 : forall (a : Type), forall (b : Type), forall (c : Type), CompM a -> CompM b -> (a -> b -> CompM c) -> CompM c := + fun (a : Type) (b : Type) (c : Type) (m1 : CompM a) (m2 : CompM b) (f : a -> b -> CompM c) => @bindM CompM _ a c m1 (fun (x : a) => @bindM CompM _ b c m2 (f x)). + +Definition bindM3 : forall (a : Type), forall (b : Type), forall (c : Type), forall (d : Type), CompM a -> CompM b -> CompM c -> (a -> b -> c -> CompM d) -> CompM d := + fun (a : Type) (b : Type) (c : Type) (d : Type) (m1 : CompM a) (m2 : CompM b) (m3 : CompM c) (f : a -> b -> c -> CompM d) => @bindM CompM _ a d m1 (fun (x : a) => bindM2 b c d m2 m3 (f x)). + +Definition bindApplyM : forall (a : Type), forall (b : Type), (a -> CompM b) -> CompM a -> CompM b := + fun (a : Type) (b : Type) (f : a -> CompM b) (m : CompM a) => @bindM CompM _ a b m f. + +Definition bindApplyM2 : forall (a : Type), forall (b : Type), forall (c : Type), (a -> b -> CompM c) -> CompM a -> CompM b -> CompM c := + fun (a : Type) (b : Type) (c : Type) (f : a -> b -> CompM c) (m1 : CompM a) (m2 : CompM b) => @bindM CompM _ a c m1 (fun (x : a) => @bindM CompM _ b c m2 (f x)). + +Definition bindApplyM3 : forall (a : Type), forall (b : Type), forall (c : Type), forall (d : Type), (a -> b -> c -> CompM d) -> CompM a -> CompM b -> CompM c -> CompM d := + fun (a : Type) (b : Type) (c : Type) (d : Type) (f : a -> b -> c -> CompM d) (m1 : CompM a) (m2 : CompM b) (m3 : CompM c) => bindM3 a b c d m1 m2 m3 f. + Definition composeM : forall (a : Type), forall (b : Type), forall (c : Type), (a -> CompM b) -> (b -> CompM c) -> a -> CompM c := fun (a : Type) (b : Type) (c : Type) (f : a -> CompM b) (g : b -> CompM c) (x : a) => @bindM CompM _ b c (f x) g. @@ -1171,7 +1193,15 @@ Definition appendCastBVVecM : forall (n : SAWCoreScaffolding.Nat), forall (len1 let var__5 := BVVec n len3 a in @returnM CompM _ var__5 (SAWCoreScaffolding.coerce (BVVec n var__4 a) var__5 (eq_cong var__3 var__4 len3 pf Type (fun (l : var__3) => BVVec n l a)) (appendBVVec n len1 len2 a v1 v2))) (bvEqWithProof n var__0 len3). -(* Prelude.fixM was skipped *) +(* Prelude.existsM was skipped *) + +Definition orM : forall (a : Type), CompM a -> CompM a -> CompM a := + fun (a : Type) (m1 : CompM a) (m2 : CompM a) => @CompM.existsM SAWCoreScaffolding.Bool a (fun (b : SAWCoreScaffolding.Bool) => if b then m1 else m2). + +(* Prelude.forallM was skipped *) + +Definition precondHint : forall (a : Type), SAWCoreScaffolding.Bool -> a -> a := + fun (_1 : Type) (_2 : SAWCoreScaffolding.Bool) (a : _1) => a. (* Prelude.LetRecType was skipped *) @@ -1183,14 +1213,19 @@ Definition appendCastBVVecM : forall (n : SAWCoreScaffolding.Nat), forall (len1 (* Prelude.lrtTupleType was skipped *) -(* Prelude.multiFixM was skipped *) - (* Prelude.letRecM was skipped *) Definition letRecM1 : forall (a : Type), forall (b : Type), forall (c : Type), ((a -> CompM b) -> a -> CompM b) -> ((a -> CompM b) -> CompM c) -> CompM c := fun (a : Type) (b : Type) (c : Type) (fn : (a -> CompM b) -> a -> CompM b) (body : (a -> CompM b) -> CompM c) => let var__0 := a -> CompM b in @CompM.letRecM (CompM.LRT_Cons (CompM.LRT_Fun a (fun (_1 : a) => CompM.LRT_Ret b)) CompM.LRT_Nil) c (fun (f : var__0) => pair (fn f) tt) (fun (f : var__0) => body f). +(* Prelude.fixM was skipped *) + +(* Prelude.multiFixM was skipped *) + +Definition multiArgFixM : forall (lrt : CompM.LetRecType), (CompM.lrtToType lrt -> CompM.lrtToType lrt) -> CompM.lrtToType lrt := + fun (lrt : CompM.LetRecType) (F : CompM.LetRecType_rect (fun (lrt1 : CompM.LetRecType) => Type) (fun (b : Type) => CompM b) (fun (a : Type) (_1 : a -> CompM.LetRecType) (b : a -> Type) => forall (x : a), b x) lrt -> CompM.LetRecType_rect (fun (lrt1 : CompM.LetRecType) => Type) (fun (b : Type) => CompM b) (fun (a : Type) (_2 : a -> CompM.LetRecType) (b : a -> Type) => forall (x : a), b x) lrt) => SAWCoreScaffolding.fst (@CompM.multiFixM (CompM.LRT_Cons lrt CompM.LRT_Nil) (fun (f : CompM.LetRecType_rect (fun (lrt1 : CompM.LetRecType) => Type) (fun (b : Type) => CompM b) (fun (a : Type) (_1 : a -> CompM.LetRecType) (b : a -> Type) => forall (x : a), b x) lrt) => pair (F f) tt)). + (* Prelude.test_fun0 was skipped *) (* Prelude.test_fun1 was skipped *) diff --git a/saw-core/prelude/Prelude.sawcore b/saw-core/prelude/Prelude.sawcore index c8e065f121..8eeaaf033b 100644 --- a/saw-core/prelude/Prelude.sawcore +++ b/saw-core/prelude/Prelude.sawcore @@ -2266,27 +2266,6 @@ lrtPi lrts b = (\ (lrt:LetRecType) (_:LetRecTypes) (rest:sort 0) -> lrtToType lrt -> rest) lrts; --- Apply a function the the body of a multi-arity lrtPi function -lrtPiMap : (a b : sort 0) -> (f : a -> b) -> (lrts : LetRecTypes) -> - lrtPi lrts a -> lrtPi lrts b; -lrtPiMap a b f lrts_top = - LetRecTypes#rec - (\ (lrts:LetRecTypes) -> lrtPi lrts a -> lrtPi lrts b) - (\ (x:a) -> f x) - (\ (lrt:LetRecType) (lrts:LetRecTypes) (rec:lrtPi lrts a -> lrtPi lrts b) - (f:lrtToType lrt -> lrtPi lrts a) (g:lrtToType lrt) -> - rec (f g)) - lrts_top; - --- Convert a multi-arity lrtPi that returns a pair to a pair of lrtPi functions --- that return the individual arguments -lrtPiPair : (a b:sort 0) -> (lrts : LetRecTypes) -> lrtPi lrts #(a,b) -> - #(lrtPi lrts a, lrtPi lrts b); -lrtPiPair a b lrts f = - (lrtPiMap #(a,b) a (\ (tup:#(a,b)) -> tup.(1)) lrts f, - lrtPiMap #(a,b) b (\ (tup:#(a,b)) -> tup.(2)) lrts f); - - -- Build the product type (lrtToType lrt1, ..., lrtToType lrtn) from the -- LetRecTypes list [lrt1, ..., lrtn] lrtTupleType : LetRecTypes -> sort 0; @@ -2391,6 +2370,32 @@ fixM a b f x = (\ (g: (y:a) -> CompM (b y)) -> (f g, ())) (\ (g: (y:a) -> CompM (b y)) -> g x); + +-- The following commented block allows multiFixM to be defined in terms of and +-- to reduce to letRecM, which is useful if we want to define all our automated +-- reasoning in terms of letRecM instead of multiFixM + +-- Apply a function the the body of a multi-arity lrtPi function +{- +lrtPiMap : (a b : sort 0) -> (f : a -> b) -> (lrts : LetRecTypes) -> + lrtPi lrts a -> lrtPi lrts b; +lrtPiMap a b f lrts_top = + LetRecTypes#rec + (\ (lrts:LetRecTypes) -> lrtPi lrts a -> lrtPi lrts b) + (\ (x:a) -> f x) + (\ (lrt:LetRecType) (lrts:LetRecTypes) (rec:lrtPi lrts a -> lrtPi lrts b) + (f:lrtToType lrt -> lrtPi lrts a) (g:lrtToType lrt) -> + rec (f g)) + lrts_top; + +-- Convert a multi-arity lrtPi that returns a pair to a pair of lrtPi functions +-- that return the individual arguments +lrtPiPair : (a b:sort 0) -> (lrts : LetRecTypes) -> lrtPi lrts #(a,b) -> + #(lrtPi lrts a, lrtPi lrts b); +lrtPiPair a b lrts f = + (lrtPiMap #(a,b) a (\ (tup:#(a,b)) -> tup.(1)) lrts f, + lrtPiMap #(a,b) b (\ (tup:#(a,b)) -> tup.(2)) lrts f); + -- Build a monadic function that takes in its arguments and then calls letRecM. -- That is, build a function -- @@ -2443,6 +2448,21 @@ multiFixM lrts_top F_top = rec (lrtPiPair (lrtToType lrt) (lrtTupleType lrts) lrts_top F).(2))) lrts_top F_top; +-} + +-- Construct a fixed-point for a tuple of mutually-recursive functions +-- +-- NOTE: Currently, Mr Solver actually works better with a primitive multiFixM, +-- so that's what we are going to do for now... +primitive +multiFixM : (lrts:LetRecTypes) -> lrtPi lrts (lrtTupleType lrts) -> + lrtTupleType lrts; + +-- Build a multi-argument fixed-point of type A1 -> ... -> An -> CompM B +multiArgFixM : (lrt:LetRecType) -> (lrtToType lrt -> lrtToType lrt) -> + lrtToType lrt; +multiArgFixM lrt F = + (multiFixM (LRT_Cons lrt LRT_Nil) (\ (f:lrtToType lrt) -> (F f, ()))).(1); -- Test computations From 3929005a66da17baad9ab33d3e5b77ab0aaf1781 Mon Sep 17 00:00:00 2001 From: Matthew Yacavone Date: Tue, 8 Mar 2022 13:13:36 -0800 Subject: [PATCH 083/105] remove old comments --- src/SAWScript/Prover/MRSolver/Monad.hs | 9 +-------- 1 file changed, 1 insertion(+), 8 deletions(-) diff --git a/src/SAWScript/Prover/MRSolver/Monad.hs b/src/SAWScript/Prover/MRSolver/Monad.hs index 15df3e0f0f..433a4a382f 100644 --- a/src/SAWScript/Prover/MRSolver/Monad.hs +++ b/src/SAWScript/Prover/MRSolver/Monad.hs @@ -246,8 +246,6 @@ asEither _ = Nothing -- | A map from 'Term's to 'DataTypeAssump's over that term type DataTypeAssumps = HashMap Term DataTypeAssump --- FIXME HERE NOW: remove preconditions from MREnv - -- | Parameters and locals for MR. Solver data MRInfo = MRInfo { -- | Global shared context for building terms, etc. @@ -801,7 +799,7 @@ mrGetCoIndHyp nm1 nm2 = Map.lookup (nm1, nm2) <$> mrCoIndHyps -- | Run a compuation under an additional co-inductive assumption withCoIndHyp :: CoIndHyp -> MRM a -> MRM a withCoIndHyp hyp m = - do debugPretty 2 ("withCoIndHypRaw" <+> ppInEmptyCtx hyp) + do debugPretty 2 ("withCoIndHyp" <+> ppInEmptyCtx hyp) hyps' <- Map.insert (coIndHypLHSFun hyp, coIndHypRHSFun hyp) hyp <$> mrCoIndHyps local (\info -> info { mriCoIndHyps = hyps' }) m @@ -861,11 +859,6 @@ instantiateFunAssump fassump = rhs <- substTermLike 0 evars $ fassumpRHS fassump return (args, rhs) --- FIXME HERE NOW: delete this and remove the preconditions from the env --- | Look up the precondition associated with a function name, if there is one --- mrLookupPrecond :: FunName -> MRM (Maybe Term) --- mrLookupPrecond nm = Map.lookup nm <$> mrePreconditions <$> mriEnv <$> ask - -- | Get the precondition hint associated with a function name, by unfolding the -- name and checking if its body has the form -- From f1827565fa44eb2d98eea37dd249d29ada9af3c6 Mon Sep 17 00:00:00 2001 From: Matthew Yacavone Date: Tue, 8 Mar 2022 13:17:52 -0800 Subject: [PATCH 084/105] add `orM` and add more `mapsToExpl`s to SpecialTreatment.hs --- saw-core-coq/coq/generated/CryptolToCoq/SAWCorePrelude.v | 3 +-- .../src/Verifier/SAW/Translation/Coq/SpecialTreatment.hs | 6 +++--- 2 files changed, 4 insertions(+), 5 deletions(-) diff --git a/saw-core-coq/coq/generated/CryptolToCoq/SAWCorePrelude.v b/saw-core-coq/coq/generated/CryptolToCoq/SAWCorePrelude.v index 78855c23b9..8ea02a2411 100644 --- a/saw-core-coq/coq/generated/CryptolToCoq/SAWCorePrelude.v +++ b/saw-core-coq/coq/generated/CryptolToCoq/SAWCorePrelude.v @@ -1195,8 +1195,7 @@ Definition appendCastBVVecM : forall (n : SAWCoreScaffolding.Nat), forall (len1 (* Prelude.existsM was skipped *) -Definition orM : forall (a : Type), CompM a -> CompM a -> CompM a := - fun (a : Type) (m1 : CompM a) (m2 : CompM a) => @CompM.existsM SAWCoreScaffolding.Bool a (fun (b : SAWCoreScaffolding.Bool) => if b then m1 else m2). +(* Prelude.orM was skipped *) (* Prelude.forallM was skipped *) diff --git a/saw-core-coq/src/Verifier/SAW/Translation/Coq/SpecialTreatment.hs b/saw-core-coq/src/Verifier/SAW/Translation/Coq/SpecialTreatment.hs index c772b7d01d..d8e61537de 100644 --- a/saw-core-coq/src/Verifier/SAW/Translation/Coq/SpecialTreatment.hs +++ b/saw-core-coq/src/Verifier/SAW/Translation/Coq/SpecialTreatment.hs @@ -451,11 +451,11 @@ sawCorePreludeSpecialTreatmentMap configuration = , ("errorM", replace (Coq.App (Coq.ExplVar "errorM") [Coq.Var "CompM", Coq.Var "_"])) , ("catchM", skip) - , ("existsM", mapsTo compMModule "existsM") - , ("forallM", mapsTo compMModule "forallM") + , ("existsM", mapsToExpl compMModule "existsM") + , ("forallM", mapsToExpl compMModule "forallM") + , ("orM", mapsToExpl compMModule "orM") , ("fixM", replace (Coq.App (Coq.ExplVar "fixM") [Coq.Var "CompM", Coq.Var "_"])) - , ("existsM", mapsToExpl compMModule "existsM") , ("LetRecType", mapsTo compMModule "LetRecType") , ("LRT_Ret", mapsTo compMModule "LRT_Ret") , ("LRT_Fun", mapsTo compMModule "LRT_Fun") From 63bc072e91cdd7207c808681039743e7cac2276b Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Wed, 9 Mar 2022 15:51:52 -0800 Subject: [PATCH 085/105] added the cryptol_add_prim_type SAW command to set the translation of Cryptol abstract types --- cryptol-saw-core/src/Verifier/SAW/Cryptol.hs | 10 ++++++++-- cryptol-saw-core/src/Verifier/SAW/CryptolEnv.hs | 3 +++ src/SAWScript/Builtins.hs | 13 ++++++++++++- src/SAWScript/Interpreter.hs | 7 +++++++ 4 files changed, 30 insertions(+), 3 deletions(-) diff --git a/cryptol-saw-core/src/Verifier/SAW/Cryptol.hs b/cryptol-saw-core/src/Verifier/SAW/Cryptol.hs index acf988b2c5..e678bf34e4 100644 --- a/cryptol-saw-core/src/Verifier/SAW/Cryptol.hs +++ b/cryptol-saw-core/src/Verifier/SAW/Cryptol.hs @@ -82,10 +82,11 @@ data Env = Env , envC :: Map C.Name C.Schema -- ^ Cryptol type environment , envS :: [Term] -- ^ SAW-Core bound variable environment (for type checking) , envRefPrims :: Map C.PrimIdent C.Expr + , envPrimTypes :: Map C.PrimIdent Term -- ^ Translations for primitive types } emptyEnv :: Env -emptyEnv = Env Map.empty Map.empty Map.empty Map.empty [] Map.empty +emptyEnv = Env Map.empty Map.empty Map.empty Map.empty [] Map.empty Map.empty liftTerm :: (Term, Int) -> (Term, Int) liftTerm (t, j) = (t, j + 1) @@ -102,6 +103,7 @@ liftEnv env = , envC = envC env , envS = envS env , envRefPrims = envRefPrims env + , envPrimTypes = envPrimTypes env } bindTParam :: SharedContext -> C.TParam -> Env -> IO Env @@ -262,7 +264,11 @@ importType sc env ty = b <- go (tyargs !! 1) scFun sc a b C.TCTuple _n -> scTupleType sc =<< traverse go tyargs - C.TCAbstract{} -> panic "importType TODO: abstract type" [] + C.TCAbstract (C.UserTC n _) + | Just prim <- C.asPrim n + , Just t <- Map.lookup prim (envPrimTypes env) -> + return t + | True -> panic ("importType: unknown primitive type: " ++ show n) [] C.PC pc -> case pc of C.PLiteral -> -- we omit first argument to class Literal diff --git a/cryptol-saw-core/src/Verifier/SAW/CryptolEnv.hs b/cryptol-saw-core/src/Verifier/SAW/CryptolEnv.hs index 1e9a9fc9ad..70ebb0c2d3 100644 --- a/cryptol-saw-core/src/Verifier/SAW/CryptolEnv.hs +++ b/cryptol-saw-core/src/Verifier/SAW/CryptolEnv.hs @@ -126,6 +126,7 @@ data CryptolEnv = CryptolEnv , eExtraTypes :: Map T.Name T.Schema -- ^ Cryptol types for extra names in scope , eExtraTSyns :: Map T.Name T.TySyn -- ^ Extra Cryptol type synonyms in scope , eTermEnv :: Map T.Name Term -- ^ SAWCore terms for *all* names in scope + , ePrimTypes :: Map C.PrimIdent Term -- ^ SAWCore terms for primitive type names } @@ -217,6 +218,7 @@ initCryptolEnv sc = do , eExtraTypes = Map.empty , eExtraTSyns = Map.empty , eTermEnv = termEnv + , ePrimTypes = Map.empty } -- Parse ----------------------------------------------------------------------- @@ -297,6 +299,7 @@ mkCryEnv env = let cryEnv = C.emptyEnv { C.envE = fmap (\t -> (t, 0)) terms , C.envC = types' + , C.envPrimTypes = ePrimTypes env } return cryEnv diff --git a/src/SAWScript/Builtins.hs b/src/SAWScript/Builtins.hs index 1765ce785b..bf5b995de9 100644 --- a/src/SAWScript/Builtins.hs +++ b/src/SAWScript/Builtins.hs @@ -106,7 +106,8 @@ import qualified Cryptol.Backend.Monad as C (runEval) import qualified Cryptol.Eval.Type as C (evalType) import qualified Cryptol.Eval.Value as C (fromVBit, fromVWord) import qualified Cryptol.Eval.Concrete as C (Concrete(..), bvVal) -import qualified Cryptol.Utils.Ident as C (mkIdent, packModName) +import qualified Cryptol.Utils.Ident as C (mkIdent, packModName, + textToModName, PrimIdent(..)) import qualified Cryptol.Utils.RecordMap as C (recordFromFields) import qualified SAWScript.SBVParser as SBV @@ -1526,6 +1527,16 @@ cryptol_add_path path = let rw' = rw { rwCryptol = ce' } putTopLevelRW rw' +cryptol_add_prim_type :: String -> String -> TypedTerm -> TopLevel () +cryptol_add_prim_type mnm nm tp = + do rw <- getTopLevelRW + let env = rwCryptol rw + let prim_name = + C.PrimIdent (C.textToModName $ Text.pack mnm) (Text.pack nm) + let env' = env { CEnv.ePrimTypes = + Map.insert prim_name (ttTerm tp) (CEnv.ePrimTypes env) } + putTopLevelRW (rw { rwCryptol = env' }) + -- | Call 'Cryptol.importSchema' using a 'CEnv.CryptolEnv' importSchemaCEnv :: SharedContext -> CEnv.CryptolEnv -> Cryptol.Schema -> IO Term diff --git a/src/SAWScript/Interpreter.hs b/src/SAWScript/Interpreter.hs index 4a4b2c8f10..6e5a890a12 100644 --- a/src/SAWScript/Interpreter.hs +++ b/src/SAWScript/Interpreter.hs @@ -1878,6 +1878,13 @@ primitives = Map.fromList , "Cryptol source files." ] + , prim "cryptol_add_prim_type" "String -> String -> Term -> TopLevel ()" + (pureVal cryptol_add_prim_type) + Current + [ "cryptol_add_prim_type mod nm tp sets the translation of Cryptol" + , "primitive type nm in module mod to tp" + ] + -- Java stuff , prim "java_bool" "JavaType" From c0b9ed38b6f2d45cfa02e403dac419dfba7579a7 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Wed, 9 Mar 2022 15:58:27 -0800 Subject: [PATCH 086/105] whoops, marked cryptol_add_prim_type as experimental --- src/SAWScript/Interpreter.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/SAWScript/Interpreter.hs b/src/SAWScript/Interpreter.hs index 6e5a890a12..2e746e155f 100644 --- a/src/SAWScript/Interpreter.hs +++ b/src/SAWScript/Interpreter.hs @@ -1880,7 +1880,7 @@ primitives = Map.fromList , prim "cryptol_add_prim_type" "String -> String -> Term -> TopLevel ()" (pureVal cryptol_add_prim_type) - Current + Experimental [ "cryptol_add_prim_type mod nm tp sets the translation of Cryptol" , "primitive type nm in module mod to tp" ] From 7952a1d0751c313e1038fad536362b410cae783d Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Wed, 9 Mar 2022 17:10:42 -0800 Subject: [PATCH 087/105] added cryptol_add_prim; also fixed a bug in translating abstract types, where the translation of the types were not getting applied --- cryptol-saw-core/src/Verifier/SAW/Cryptol.hs | 10 ++++++++-- cryptol-saw-core/src/Verifier/SAW/CryptolEnv.hs | 5 ++++- saw-core/src/Verifier/SAW/SharedTerm.hs | 13 +++++++++++++ src/SAWScript/Builtins.hs | 11 +++++++++++ src/SAWScript/Interpreter.hs | 7 +++++++ 5 files changed, 43 insertions(+), 3 deletions(-) diff --git a/cryptol-saw-core/src/Verifier/SAW/Cryptol.hs b/cryptol-saw-core/src/Verifier/SAW/Cryptol.hs index e678bf34e4..e61eaff02e 100644 --- a/cryptol-saw-core/src/Verifier/SAW/Cryptol.hs +++ b/cryptol-saw-core/src/Verifier/SAW/Cryptol.hs @@ -82,11 +82,13 @@ data Env = Env , envC :: Map C.Name C.Schema -- ^ Cryptol type environment , envS :: [Term] -- ^ SAW-Core bound variable environment (for type checking) , envRefPrims :: Map C.PrimIdent C.Expr + , envPrims :: Map C.PrimIdent Term -- ^ Translations for other primitives , envPrimTypes :: Map C.PrimIdent Term -- ^ Translations for primitive types } emptyEnv :: Env -emptyEnv = Env Map.empty Map.empty Map.empty Map.empty [] Map.empty Map.empty +emptyEnv = + Env Map.empty Map.empty Map.empty Map.empty [] Map.empty Map.empty Map.empty liftTerm :: (Term, Int) -> (Term, Int) liftTerm (t, j) = (t, j + 1) @@ -103,6 +105,7 @@ liftEnv env = , envC = envC env , envS = envS env , envRefPrims = envRefPrims env + , envPrims = envPrims env , envPrimTypes = envPrimTypes env } @@ -267,7 +270,7 @@ importType sc env ty = C.TCAbstract (C.UserTC n _) | Just prim <- C.asPrim n , Just t <- Map.lookup prim (envPrimTypes env) -> - return t + scApplyAllBeta sc t =<< traverse go tyargs | True -> panic ("importType: unknown primitive type: " ++ show n) [] C.PC pc -> case pc of @@ -674,6 +677,9 @@ importPrimitive sc primOpts env n sch nmi <- importName n scConstant' sc nmi e t + -- lookup primitive in the extra primitive lookup table + | Just nm <- C.asPrim n, Just t <- Map.lookup nm (envPrims env) = return t + -- Optionally, create an opaque constant representing the primitive -- if it doesn't match one of the ones we know about. | Just _ <- C.asPrim n, allowUnknownPrimitives primOpts = diff --git a/cryptol-saw-core/src/Verifier/SAW/CryptolEnv.hs b/cryptol-saw-core/src/Verifier/SAW/CryptolEnv.hs index 70ebb0c2d3..13e6689366 100644 --- a/cryptol-saw-core/src/Verifier/SAW/CryptolEnv.hs +++ b/cryptol-saw-core/src/Verifier/SAW/CryptolEnv.hs @@ -126,6 +126,7 @@ data CryptolEnv = CryptolEnv , eExtraTypes :: Map T.Name T.Schema -- ^ Cryptol types for extra names in scope , eExtraTSyns :: Map T.Name T.TySyn -- ^ Extra Cryptol type synonyms in scope , eTermEnv :: Map T.Name Term -- ^ SAWCore terms for *all* names in scope + , ePrims :: Map C.PrimIdent Term -- ^ SAWCore terms for primitives , ePrimTypes :: Map C.PrimIdent Term -- ^ SAWCore terms for primitive type names } @@ -218,7 +219,8 @@ initCryptolEnv sc = do , eExtraTypes = Map.empty , eExtraTSyns = Map.empty , eTermEnv = termEnv - , ePrimTypes = Map.empty + , ePrims = Map.empty + , ePrimTypes = Map.empty } -- Parse ----------------------------------------------------------------------- @@ -299,6 +301,7 @@ mkCryEnv env = let cryEnv = C.emptyEnv { C.envE = fmap (\t -> (t, 0)) terms , C.envC = types' + , C.envPrims = ePrims env , C.envPrimTypes = ePrimTypes env } return cryEnv diff --git a/saw-core/src/Verifier/SAW/SharedTerm.hs b/saw-core/src/Verifier/SAW/SharedTerm.hs index ef6b1146c8..4a8cde027a 100644 --- a/saw-core/src/Verifier/SAW/SharedTerm.hs +++ b/saw-core/src/Verifier/SAW/SharedTerm.hs @@ -108,6 +108,8 @@ module Verifier.SAW.SharedTerm -- *** Functions and function application , scApply , scApplyAll + , scApplyBeta + , scApplyAllBeta , scGlobalApply , scFun , scFunAll @@ -1283,6 +1285,17 @@ betaNormalize sc t0 = scApplyAll :: SharedContext -> Term -> [Term] -> IO Term scApplyAll sc = foldlM (scApply sc) +-- | Apply a function to an argument, beta-reducing if the function is a lambda +scApplyBeta :: SharedContext -> Term -> Term -> IO Term +scApplyBeta sc (asLambda -> Just (_, _, body)) arg = + instantiateVar sc 0 arg body +scApplyBeta sc f arg = scApply sc f arg + +-- | Apply a function 'Term' to zero or more arguments, beta reducing any time +-- the function is a lambda +scApplyAllBeta :: SharedContext -> Term -> [Term] -> IO Term +scApplyAllBeta sc = foldlM (scApplyBeta sc) + -- | Returns the defined constant with the given 'Ident'. Fails if no -- such constant exists in the module. scLookupDef :: SharedContext -> Ident -> IO Term diff --git a/src/SAWScript/Builtins.hs b/src/SAWScript/Builtins.hs index bf5b995de9..4edc37ef2d 100644 --- a/src/SAWScript/Builtins.hs +++ b/src/SAWScript/Builtins.hs @@ -1527,6 +1527,17 @@ cryptol_add_path path = let rw' = rw { rwCryptol = ce' } putTopLevelRW rw' +cryptol_add_prim :: String -> String -> TypedTerm -> TopLevel () +cryptol_add_prim mnm nm trm = + do rw <- getTopLevelRW + let env = rwCryptol rw + let prim_name = + C.PrimIdent (C.textToModName $ Text.pack mnm) (Text.pack nm) + let env' = + env { CEnv.ePrims = + Map.insert prim_name (ttTerm trm) (CEnv.ePrims env) } + putTopLevelRW (rw { rwCryptol = env' }) + cryptol_add_prim_type :: String -> String -> TypedTerm -> TopLevel () cryptol_add_prim_type mnm nm tp = do rw <- getTopLevelRW diff --git a/src/SAWScript/Interpreter.hs b/src/SAWScript/Interpreter.hs index 2e746e155f..2b11857fb3 100644 --- a/src/SAWScript/Interpreter.hs +++ b/src/SAWScript/Interpreter.hs @@ -1878,6 +1878,13 @@ primitives = Map.fromList , "Cryptol source files." ] + , prim "cryptol_add_prim" "String -> String -> Term -> TopLevel ()" + (pureVal cryptol_add_prim) + Experimental + [ "cryptol_add_prim mod nm trm sets the translation of Cryptol primitive" + , "nm in module mod to trm" + ] + , prim "cryptol_add_prim_type" "String -> String -> Term -> TopLevel ()" (pureVal cryptol_add_prim_type) Experimental From eb4ed6a694415b9c5c5d8d6eff0202af6ff61fa4 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Thu, 10 Mar 2022 06:41:52 -0800 Subject: [PATCH 088/105] added a macro for monadifying the either eliminator --- .../src/Verifier/SAW/Cryptol/Monadify.hs | 20 +++++++++++++++++++ 1 file changed, 20 insertions(+) diff --git a/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs b/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs index 526990782e..ea79ee1b21 100644 --- a/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs +++ b/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs @@ -959,6 +959,25 @@ iteMacro = MonMacro 4 $ \_ args -> [toCompType mtp, toArgTerm atrm_cond, toCompTerm mtrm1, toCompTerm mtrm2] +-- | The macro for the either elimination function, which converts the +-- application @either a b c@ to @either a b (CompM c)@ +eitherMacro :: MonMacro +eitherMacro = MonMacro 3 $ \_ args -> + do let (tp_a, tp_b, tp_c) = + case args of + [t1, t2, t3] -> (t1, t2, t3) + _ -> error "eitherMacro: wrong number of arguments!" + mtp_a <- monadifyTypeM tp_a + mtp_b <- monadifyTypeM tp_b + mtp_c <- monadifyTypeM tp_c + let eith_app = applyGlobalOpenTerm "Prelude.either" [toArgType mtp_a, + toArgType mtp_b, + toCompType mtp_c] + let tp_eith = dataTypeOpenTerm "Prelude.Either" [toArgType mtp_a, + toArgType mtp_b] + return $ fromCompTerm (MTyArrow (MTyArrow mtp_a mtp_c) + (MTyArrow (MTyArrow mtp_b mtp_c) + (MTyArrow (mkMonType0 tp_eith) mtp_c))) eith_app -- | Make a 'MonMacro' that maps a named global whose first argument is @n:Num@ -- to a global of semi-pure type that takes an additional argument of type @@ -1048,6 +1067,7 @@ defaultMonEnv = mmCustom "Prelude.unsafeAssert" unsafeAssertMacro , mmCustom "Prelude.ite" iteMacro , mmCustom "Prelude.fix" fixMacro + , mmCustom "Prelude.either" eitherMacro -- Top-level sequence functions , mmArg "Cryptol.seqMap" "CryptolM.seqMapM" From 747d31f288555c2fa48e52480513d9dbf5818034 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Thu, 10 Mar 2022 07:23:01 -0800 Subject: [PATCH 089/105] changed cryptol monadification to translate any global of semi-pure type to itself --- .../src/Verifier/SAW/Cryptol/Monadify.hs | 40 ++++++++++++++++++- 1 file changed, 38 insertions(+), 2 deletions(-) diff --git a/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs b/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs index ea79ee1b21..b296dabb4d 100644 --- a/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs +++ b/cryptol-saw-core/src/Verifier/SAW/Cryptol/Monadify.hs @@ -398,6 +398,7 @@ monadifyType ctx tp@(asPi -> Just (_, _, tp_out)) monadifyType ctx tp@(asPi -> Just (x, tp_in, tp_out)) = MTyArrow (monadifyType ctx tp_in) (monadifyType ((x,tp,Nothing):ctx) tp_out) +monadifyType _ (asTupleType -> Just []) = mkMonType0 unitTypeOpenTerm monadifyType ctx (asPairType -> Just (tp1, tp2)) = MTyPair (monadifyType ctx tp1) (monadifyType ctx tp2) monadifyType ctx (asRecordType -> Just tps) = @@ -529,6 +530,36 @@ fromCompTerm :: MonType -> OpenTerm -> MonTerm fromCompTerm mtp t | isBaseType mtp = CompMonTerm mtp t fromCompTerm mtp t = ArgMonTerm $ fromArgTerm mtp t +-- | Test if a monadification type @tp@ is pure, meaning @MT(tp)=tp@ +monTypeIsPure :: MonType -> Bool +monTypeIsPure (MTyForall _ _ _) = False -- NOTE: this could potentially be true +monTypeIsPure (MTyArrow _ _) = False +monTypeIsPure (MTySeq _ _) = False +monTypeIsPure (MTyPair mtp1 mtp2) = monTypeIsPure mtp1 && monTypeIsPure mtp2 +monTypeIsPure (MTyRecord fld_mtps) = all (monTypeIsPure . snd) fld_mtps +monTypeIsPure (MTyBase _ _) = True +monTypeIsPure (MTyNum _) = True + +-- | Test if a monadification type @tp@ is semi-pure, meaning @SemiP(tp) = tp@, +-- where @SemiP@ is defined in the documentation for 'fromSemiPureTermFun' below +monTypeIsSemiPure :: MonType -> Bool +monTypeIsSemiPure (MTyForall _ k tp_f) = + monTypeIsSemiPure $ tp_f $ MTyBase k $ + -- This dummy OpenTerm should never be inspected by the recursive call + error "monTypeIsSemiPure" +monTypeIsSemiPure (MTyArrow tp_in tp_out) = + monTypeIsPure tp_in && monTypeIsSemiPure tp_out +monTypeIsSemiPure (MTySeq _ _) = False +monTypeIsSemiPure (MTyPair mtp1 mtp2) = + -- NOTE: functions in pairs are not semi-pure; only pure types in pairs are + -- semi-pure + monTypeIsPure mtp1 && monTypeIsPure mtp2 +monTypeIsSemiPure (MTyRecord fld_mtps) = + -- Same as pairs, record types are only semi-pure if they are pure + all (monTypeIsPure . snd) fld_mtps +monTypeIsSemiPure (MTyBase _ _) = True +monTypeIsSemiPure (MTyNum _) = True + -- | Build a monadification term from a function on terms which, when viewed as -- a lambda, is a "semi-pure" function of the given monadification type, meaning -- it maps terms of argument type @MT(tp)@ to an output value of argument type; @@ -857,8 +888,13 @@ monadifyTerm' _ (asApplyAll -> (asTypedGlobalDef -> Just glob, args)) = do let (macro_args, reg_args) = splitAt (macroNumArgs macro) args mtrm_f <- macroApply macro glob macro_args monadifyApply mtrm_f reg_args - Nothing -> error ("Monadification failed: unhandled constant: " - ++ globalDefString glob) + Nothing -> + monadifyTypeM (globalDefType glob) >>= \glob_mtp -> + if monTypeIsSemiPure glob_mtp then + monadifyApply (ArgMonTerm $ fromSemiPureTerm glob_mtp $ + globalDefOpenTerm glob) args + else error ("Monadification failed: unhandled constant: " + ++ globalDefString glob) monadifyTerm' _ (asApp -> Just (f, arg)) = do mtrm_f <- monadifyTerm Nothing f monadifyApply mtrm_f [arg] From fa1110a94372a311a1d3498ffa9053ea3565edf7 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Thu, 10 Mar 2022 07:29:45 -0800 Subject: [PATCH 090/105] added a case to computation normalization in Mr Solver to handle beta redexes --- src/SAWScript/Prover/MRSolver/Solver.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/SAWScript/Prover/MRSolver/Solver.hs b/src/SAWScript/Prover/MRSolver/Solver.hs index fbde43b184..8d7fb09157 100644 --- a/src/SAWScript/Prover/MRSolver/Solver.hs +++ b/src/SAWScript/Prover/MRSolver/Solver.hs @@ -209,6 +209,8 @@ normComp (CompBind m f) = normComp (CompTerm t) = withFailureCtx (FailCtxMNF t) $ case asApplyAll t of + (f@(asLambda -> Just _), args) -> + mrApplyAll f args >>= normCompTerm (isGlobalDef "Prelude.returnM" -> Just (), [_, x]) -> return $ ReturnM x (isGlobalDef "Prelude.bindM" -> Just (), [_, _, m, f]) -> From a25cefcfd4da60cea21d5068377c8fc904916d84 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Thu, 10 Mar 2022 11:10:01 -0800 Subject: [PATCH 091/105] changed mrApplyAll to use the new scApplyAllBeta combinator rather than beta normalizing the entire output term --- src/SAWScript/Prover/MRSolver/Monad.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/SAWScript/Prover/MRSolver/Monad.hs b/src/SAWScript/Prover/MRSolver/Monad.hs index 433a4a382f..48ed75dc43 100644 --- a/src/SAWScript/Prover/MRSolver/Monad.hs +++ b/src/SAWScript/Prover/MRSolver/Monad.hs @@ -448,7 +448,7 @@ funNameType (GlobalName gd projs) = -- | Apply a 'Term' to a list of arguments and beta-reduce in Mr. Monad mrApplyAll :: Term -> [Term] -> MRM Term -mrApplyAll f args = liftSC2 scApplyAll f args >>= liftSC1 betaNormalize +mrApplyAll f args = liftSC2 scApplyAllBeta f args -- | Get the current context of uvars as a list of variable names and their -- types as SAW core 'Term's, with the least recently bound uvar first, i.e., in From 235dcf4b1399f8a53aee66bb7f68ab12ddf6b98f Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Thu, 10 Mar 2022 11:11:47 -0800 Subject: [PATCH 092/105] trying to prove is_elem refines a cryptol spec for its behavior --- heapster-saw/examples/Either.cry | 10 ++++++++++ heapster-saw/examples/either.saw | 15 +++++++++++++++ heapster-saw/examples/linked_list.cry | 14 ++++++++++++++ 3 files changed, 39 insertions(+) create mode 100644 heapster-saw/examples/Either.cry create mode 100644 heapster-saw/examples/either.saw create mode 100644 heapster-saw/examples/linked_list.cry diff --git a/heapster-saw/examples/Either.cry b/heapster-saw/examples/Either.cry new file mode 100644 index 0000000000..6adf0f39e0 --- /dev/null +++ b/heapster-saw/examples/Either.cry @@ -0,0 +1,10 @@ + +/* The definition of the Either type as an abstract type in Cryptol */ + +module Either where + +primitive type Either : * -> * -> * + +primitive Left : {a, b} a -> Either a b +primitive Right : {a, b} b -> Either a b +primitive either : {a, b, c} (a -> c) -> (b -> c) -> Either a b -> c diff --git a/heapster-saw/examples/either.saw b/heapster-saw/examples/either.saw new file mode 100644 index 0000000000..b711c9a8fb --- /dev/null +++ b/heapster-saw/examples/either.saw @@ -0,0 +1,15 @@ +/* Helper SAW script for defining the Either type in Cryptol */ + +eith_tp <- parse_core "\\ (a b:sort 0) -> Either a b"; +cryptol_add_prim_type "Either" "Either" eith_tp; + +left_fun <- parse_core "\\ (a b:sort 0) (x:a) -> Left a b x"; +cryptol_add_prim "Either" "Left" left_fun; + +right_fun <- parse_core "\\ (a b:sort 0) (x:b) -> Right a b x"; +cryptol_add_prim "Either" "Right" right_fun; + +either_fun <- parse_core "either"; +cryptol_add_prim "Either" "either" either_fun; + +import "Either.cry"; diff --git a/heapster-saw/examples/linked_list.cry b/heapster-saw/examples/linked_list.cry new file mode 100644 index 0000000000..85e63ec8c4 --- /dev/null +++ b/heapster-saw/examples/linked_list.cry @@ -0,0 +1,14 @@ + +module LinkedList where + +import Either + +primitive type List : * -> * + +primitive foldList : {a} Either () (a, List a) -> List a +primitive unfoldList : {a} List a -> Either () (a, List a) + +is_elem_spec : [64] -> List [64] -> [64] +is_elem_spec x l = + either (\ _ -> 0) (\ (y,l') -> if x == y then 1 else is_elem_spec x l') + (unfoldList l) From 8ec0be1bc643df324b481ef25eaad8e3ea625582 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Thu, 10 Mar 2022 12:32:49 -0800 Subject: [PATCH 093/105] reimplemented assertFiniteM to use the maybe eliminator --- cryptol-saw-core/saw/CryptolM.sawcore | 16 ++++++++++++---- 1 file changed, 12 insertions(+), 4 deletions(-) diff --git a/cryptol-saw-core/saw/CryptolM.sawcore b/cryptol-saw-core/saw/CryptolM.sawcore index 452fb45cbc..61df5156f2 100644 --- a/cryptol-saw-core/saw/CryptolM.sawcore +++ b/cryptol-saw-core/saw/CryptolM.sawcore @@ -24,12 +24,20 @@ numAssertEqM n m = isFinite : Num -> Prop; isFinite = Num_rec (\ (_:Num) -> Prop) (\ (_:Nat) -> TrueProp) FalseProp; +-- Check whether a Num is finite +checkFinite : (n:Num) -> Maybe (isFinite n); +checkFinite = + Num_rec (\ (n:Num) -> Maybe (isFinite n)) + (\ (n:Nat) -> Just (isFinite (TCNum n)) (Refl Bool True)) + (Nothing (isFinite TCInf)); + -- Assert that a Num is finite, or fail assertFiniteM : (n:Num) -> CompM (isFinite n); -assertFiniteM = - Num_rec (\ (n:Num) -> CompM (isFinite n)) - (\ (_:Nat) -> returnM TrueProp TrueI) - (errorM FalseProp "assertFiniteM: Num not finite"); +assertFiniteM n = + maybe (isFinite n) (CompM (isFinite n)) + (errorM (isFinite n) "assertFiniteM: Num not finite") + (returnM (isFinite n)) + (checkFinite n); -- Recurse over a Num known to be finite Num_rec_fin : (p: Num -> sort 1) -> ((n:Nat) -> p (TCNum n)) -> From 09681ad2348c36367af691848eab3d514ddc8d56 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Thu, 10 Mar 2022 13:53:36 -0800 Subject: [PATCH 094/105] added support to Mr Solver for maybe eliminators over isFinite proofs --- src/SAWScript/Prover/MRSolver/Monad.hs | 28 +++++++++++++-- src/SAWScript/Prover/MRSolver/Solver.hs | 46 ++++++++++++++++++++++--- 2 files changed, 67 insertions(+), 7 deletions(-) diff --git a/src/SAWScript/Prover/MRSolver/Monad.hs b/src/SAWScript/Prover/MRSolver/Monad.hs index 48ed75dc43..9e8acd6c60 100644 --- a/src/SAWScript/Prover/MRSolver/Monad.hs +++ b/src/SAWScript/Prover/MRSolver/Monad.hs @@ -229,12 +229,15 @@ instance PrettyInCtx CoIndHyp where -- | An assumption that something is equal to one of the constructors of a -- datatype, e.g. equal to @Left@ of some 'Term' or @Right@ of some 'Term' -data DataTypeAssump = IsLeft Term | IsRight Term - deriving (Generic, Show, TermLike) +data DataTypeAssump + = IsLeft Term | IsRight Term | IsNum Term | IsInf + deriving (Generic, Show, TermLike) instance PrettyInCtx DataTypeAssump where prettyInCtx (IsLeft x) = prettyInCtx x >>= ppWithPrefix "Left _ _" prettyInCtx (IsRight x) = prettyInCtx x >>= ppWithPrefix "Right _ _" + prettyInCtx (IsNum x) = prettyInCtx x >>= ppWithPrefix "TCNum" + prettyInCtx (IsRight x) = prettyInCtx x >>= ppWithPrefix "TCInf" -- | Recognize a term as a @Left@ or @Right@ asEither :: Recognizer Term (Either Term Term) @@ -243,6 +246,20 @@ asEither (asCtor -> Just (c, [_, _, x])) | primName c == "Prelude.Right" = return $ Right x asEither _ = Nothing +-- | Recognize a term as a @TCNum n@ or @TCInf@ +asNum :: Recognizer Term (Either Term ()) +asNum (asCtor -> Just (c, [n])) + | primName c == "Cryptol.TCNum" = return $ Left n +asNum (asCtor -> Just (c, [])) + | primName c == "Cryptol.TCInf" = return $ Right () +asNum _ = Nothing + +-- | Recognize a term as being of the form @isFinite n@ +asIsFinite :: Recognizer Term Term +asIsFinite (asApp -> Just (isGlobalDef "CryptolM.isFinite" -> Just (), n)) = + Just n +asIsFinite _ = Nothing + -- | A map from 'Term's to 'DataTypeAssump's over that term type DataTypeAssumps = HashMap Term DataTypeAssump @@ -590,6 +607,13 @@ mrVarTerm (MRVar ec) = vars <- getAllUVarTerms liftSC2 scApplyAll var_tm vars +-- | Create a dummy proof term of the specified type, which can be open but +-- should be of @Prop@ sort, by creating an 'ExtCns' axiom. This is sound as +-- long as we only use the resulting term in computation branches where we know +-- the proposition holds. +mrDummyProof :: Term -> MRM Term +mrDummyProof tp = piUVarsM tp >>= mrFreshVar "pf" >>= mrVarTerm + -- | Get the 'VarInfo' associated with a 'MRVar' mrVarInfo :: MRVar -> MRM (Maybe MRVarInfo) mrVarInfo var = Map.lookup var <$> mrVars diff --git a/src/SAWScript/Prover/MRSolver/Solver.hs b/src/SAWScript/Prover/MRSolver/Solver.hs index 8d7fb09157..758d2acdd9 100644 --- a/src/SAWScript/Prover/MRSolver/Solver.hs +++ b/src/SAWScript/Prover/MRSolver/Solver.hs @@ -497,28 +497,64 @@ mrRefines' (ErrorM _) (ErrorM _) = return () mrRefines' (ReturnM e) (ErrorM _) = throwMRFailure (ReturnNotError e) mrRefines' (ErrorM _) (ReturnM e) = throwMRFailure (ReturnNotError e) --- FIXME: Add support for arbitrary maybe asusmptions, like the either case +-- A maybe eliminator on an equality type on the left mrRefines' (MaybeElim (Type (asEq -> Just (tp,e1,e2))) m1 f1 _) m2 = do cond <- mrEq' tp e1 e2 not_cond <- liftSC1 scNot cond - cond_pf <- - liftSC1 scEqTrue cond >>= piUVarsM >>= mrFreshVar "pf" >>= mrVarTerm + cond_pf <- liftSC1 scEqTrue cond >>= mrDummyProof m1' <- applyNormCompFun f1 cond_pf cond_holds <- mrProvable cond if cond_holds then mrRefines m1' m2 else withAssumption cond (mrRefines m1' m2) >> withAssumption not_cond (mrRefines m1 m2) + +-- A maybe eliminator on an equality type on the right mrRefines' m1 (MaybeElim (Type (asEq -> Just (tp,e1,e2))) m2 f2 _) = do cond <- mrEq' tp e1 e2 not_cond <- liftSC1 scNot cond - cond_pf <- - liftSC1 scEqTrue cond >>= piUVarsM >>= mrFreshVar "pf" >>= mrVarTerm + cond_pf <- liftSC1 scEqTrue cond >>= mrDummyProof m2' <- applyNormCompFun f2 cond_pf cond_holds <- mrProvable cond if cond_holds then mrRefines m1 m2' else withAssumption cond (mrRefines m1 m2') >> withAssumption not_cond (mrRefines m1 m2) +-- A maybe eliminator on an isFinite type on the left +mrRefines' (MaybeElim (Type (asIsFinite -> Just n1)) m1 f1 _) m2 = + do n1_norm <- liftSC1 scWhnf n1 + maybe_assump <- mrGetDataTypeAssump n1_norm + fin_pf <- + liftSC2 scGlobalApply "CryptolM.isFinite" [n1_norm] >>= mrDummyProof + case (maybe_assump, asNum n1_norm) of + (_, Just (Left _)) -> applyNormCompFun f1 fin_pf >>= flip mrRefines m2 + (_, Just (Right _)) -> mrRefines m1 m2 + (Just (IsNum _), _) -> applyNormCompFun f1 fin_pf >>= flip mrRefines m2 + (Just IsInf, _) -> mrRefines m1 m2 + _ -> + withDataTypeAssump n1_norm IsInf (mrRefines m1 m2) >> + liftSC0 scNatType >>= \nat_tp -> + (withUVarLift "n" (Type nat_tp) (n1_norm, f1, m2) $ \ n (n1', f1', m2') -> + withDataTypeAssump n1' (IsNum n) + (applyNormCompFun f1' n >>= flip mrRefines m2')) + +-- A maybe eliminator on an isFinite type on the right +mrRefines' m1 (MaybeElim (Type (asIsFinite -> Just n2)) m2 f2 _) = + do n2_norm <- liftSC1 scWhnf n2 + maybe_assump <- mrGetDataTypeAssump n2_norm + fin_pf <- + liftSC2 scGlobalApply "CryptolM.isFinite" [n2_norm] >>= mrDummyProof + case (maybe_assump, asNum n2_norm) of + (_, Just (Left _)) -> applyNormCompFun f2 fin_pf >>= mrRefines m1 + (_, Just (Right _)) -> mrRefines m1 m2 + (Just (IsNum _), _) -> applyNormCompFun f2 fin_pf >>= mrRefines m1 + (Just IsInf, _) -> mrRefines m1 m2 + _ -> + withDataTypeAssump n2_norm IsInf (mrRefines m1 m2) >> + liftSC0 scNatType >>= \nat_tp -> + (withUVarLift "n" (Type nat_tp) (n2_norm, f2, m1) $ \ n (n2', f2', m1') -> + withDataTypeAssump n2' (IsNum n) + (applyNormCompFun f2' n >>= mrRefines m1')) + mrRefines' (Ite cond1 m1 m1') m2 = liftSC1 scNot cond1 >>= \not_cond1 -> mrProvable cond1 >>= \cond1_true_pv-> From 6cacfc5974123a5f63d64065d069802ad364961c Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Thu, 10 Mar 2022 15:15:17 -0800 Subject: [PATCH 095/105] added support for CompM types during normalization with normSMTProp --- src/SAWScript/Prover/MRSolver/SMT.hs | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/src/SAWScript/Prover/MRSolver/SMT.hs b/src/SAWScript/Prover/MRSolver/SMT.hs index 04f85ece7f..6a63e8e5a3 100644 --- a/src/SAWScript/Prover/MRSolver/SMT.hs +++ b/src/SAWScript/Prover/MRSolver/SMT.hs @@ -1,6 +1,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ImplicitParams #-} {- | Module : SAWScript.Prover.MRSolver.SMT @@ -136,7 +137,16 @@ smtNormPrims sc = Map.fromList PrimFun $ \_n -> PrimFun $ \_len -> tvalFun $ \a -> primGenBVVec sc $ \f -> primBVTermFun sc $ \ix -> PrimFun $ \_pf -> Prim (VExtra <$> VExtraTerm a <$> scApply sc f ix) - ) + ), + ("Prelude.CompM", + PrimFilterFun "CompM" (\case + TValue tv -> return tv + _ -> mzero) $ \tv -> + Prim (do let ?recordEC = \_ec -> return () + let cfg = error "FIXME: smtNormPrims: need the simulator config" + tv_trm <- readBackTValue sc cfg tv + TValue <$> VTyTerm (mkSort 0) <$> + scGlobalApply sc "Prelude.CompM" [tv_trm])) ] -- | Normalize a 'Term' before building an SMT query for it From 5daa95aee27a8cd76fc884aaec8df040289eb7ff Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Thu, 10 Mar 2022 15:15:58 -0800 Subject: [PATCH 096/105] changed the handling for normalizing multiFixM so that the function being called is not unfolded during normalization; also added a special case for normalizing multiArgFixM --- src/SAWScript/Prover/MRSolver/Solver.hs | 24 +++++++++++++----------- 1 file changed, 13 insertions(+), 11 deletions(-) diff --git a/src/SAWScript/Prover/MRSolver/Solver.hs b/src/SAWScript/Prover/MRSolver/Solver.hs index 758d2acdd9..5dd5129902 100644 --- a/src/SAWScript/Prover/MRSolver/Solver.hs +++ b/src/SAWScript/Prover/MRSolver/Solver.hs @@ -251,21 +251,23 @@ normComp (CompTerm t) = mrApplyAll body args >>= normCompTerm -} + -- Recognize and unfold a multiArgFixM + (f@(isGlobalDef "Prelude.multiArgFixM" -> Just ()), args) + | Just (_, Just body) <- asConstant f -> + mrApplyAll body args >>= normCompTerm + -- Recognize (multiFixM lrts (\ f1 ... fn -> (body1, ..., bodyn))).i args (asTupleSelector -> Just (asApplyAll -> (isGlobalDef "Prelude.multiFixM" -> Just (), [lrts, defs_f]), - i), args) - -- Extract out the function \f1 ... fn -> bodyi - | Just (vars, body_i) <- synProjFunBody i defs_f -> - do - -- Bind fresh function variables for the functions f1 ... fn - fun_tms <- mrFreshLetRecVars lrts defs_f - -- Re-abstract the body - body_f <- liftSC2 scLambdaList vars body_i - -- Apply body_f to f1 ... fn and the top-level arguments - body_tm <- mrApplyAll body_f (fun_tms ++ args) - normComp (CompTerm body_tm) + i), args) -> + do + -- Bind fresh function variables for the functions f1 ... fn + fun_tms <- mrFreshLetRecVars lrts defs_f + -- Apply fi to the top-level arguments, keeping in mind that tuple + -- selectors are one-based, not zero-based, so we subtract 1 from i + body_tm <- mrApplyAll (fun_tms !! (i-1)) args + normComp (CompTerm body_tm) -- For an ExtCns, we have to check what sort of variable it is From 54be292c3b20945087b19eaf9a56c70c2a5a6378 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Thu, 10 Mar 2022 15:54:49 -0800 Subject: [PATCH 097/105] renamed normSMTProp to mrNormTerm, and added a mrNormOpenTerm function that can normalize open terms --- src/SAWScript/Prover/MRSolver/SMT.hs | 24 +++++++++++++++++++----- src/SAWScript/Prover/MRSolver/Solver.hs | 25 ++++++++----------------- 2 files changed, 27 insertions(+), 22 deletions(-) diff --git a/src/SAWScript/Prover/MRSolver/SMT.hs b/src/SAWScript/Prover/MRSolver/SMT.hs index 6a63e8e5a3..efb196f0bc 100644 --- a/src/SAWScript/Prover/MRSolver/SMT.hs +++ b/src/SAWScript/Prover/MRSolver/SMT.hs @@ -124,7 +124,7 @@ primBVTermFun sc = scVectorReduced sc tp tms v -> lift (putStrLn ("primBVTermFun: unhandled value: " ++ show v)) >> mzero --- | Implementations of primitives for normalizing SMT terms +-- | Implementations of primitives for normalizing Mr Solver terms smtNormPrims :: SharedContext -> Map Ident TmPrim smtNormPrims sc = Map.fromList [ @@ -149,15 +149,29 @@ smtNormPrims sc = Map.fromList scGlobalApply sc "Prelude.CompM" [tv_trm])) ] --- | Normalize a 'Term' before building an SMT query for it -normSMTProp :: Term -> MRM Term -normSMTProp t = +-- | Normalize a 'Term' using some Mr Solver specific primitives +mrNormTerm :: Term -> MRM Term +mrNormTerm t = debugPrint 2 "Normalizing term:" >> debugPrettyInCtx 2 t >> liftSC0 return >>= \sc -> liftSC0 scGetModuleMap >>= \modmap -> liftSC5 normalizeSharedTerm modmap (smtNormPrims sc) Map.empty Set.empty t +-- | Normalize an open term by wrapping it in lambdas, normalizing, and then +-- removing those lambdas +mrNormOpenTerm :: Term -> MRM Term +mrNormOpenTerm body = + do ctx <- mrUVarCtx + fun_term <- liftSC2 scLambdaList ctx body + normed_fun <- mrNormTerm fun_term + return (peel_lambdas (length ctx) normed_fun) + where + peel_lambdas :: Int -> Term -> Term + peel_lambdas 0 t = t + peel_lambdas i (asLambda -> Just (_, _, t)) = peel_lambdas (i-1) t + peel_lambdas _ _ = error "mrNormOpenTerm: unexpected non-lambda term!" + ---------------------------------------------------------------------- -- * Checking Provability with SMT @@ -192,7 +206,7 @@ mrProvable bool_tm = do assumps <- mrAssumptions prop <- liftSC2 scImplies assumps bool_tm >>= liftSC1 scEqTrue prop_inst <- instantiateUVarsM instUVar prop - normSMTProp prop_inst >>= mrProvableRaw + mrNormTerm prop_inst >>= mrProvableRaw where -- | Given a UVar name and type, generate a 'Term' to be passed to -- SMT, with special cases for BVVec and pair types instUVar :: LocalName -> Term -> MRM Term diff --git a/src/SAWScript/Prover/MRSolver/Solver.hs b/src/SAWScript/Prover/MRSolver/Solver.hs index 5dd5129902..f6b711a1e7 100644 --- a/src/SAWScript/Prover/MRSolver/Solver.hs +++ b/src/SAWScript/Prover/MRSolver/Solver.hs @@ -152,18 +152,6 @@ asNestedPairs (asPairValue -> Just (x, asNestedPairs -> Just xs)) = Just (x:xs) asNestedPairs (asFTermF -> Just UnitValue) = Just [] asNestedPairs _ = Nothing --- | Syntactically project then @i@th element of the body of a lambda. That is, --- assuming the input 'Term' has the form --- --- > \ (x1:T1) ... (xn:Tn) -> (e1, (e2, ... (en, ()))) --- --- return the bindings @x1:T1,...,xn:Tn@ and @ei@ -synProjFunBody :: Int -> Term -> Maybe ([(LocalName, Term)], Term) -synProjFunBody i (asLambdaList -> (vars, asTupleValue -> Just es)) = - -- NOTE: we are doing 1-based indexing instead of 0-based, thus the -1 - Just $ (vars, es !! (i-1)) -synProjFunBody _ _ = Nothing - -- | Bind fresh function variables for a @letRecM@ or @multiFixM@ with the given -- @LetRecTypes@ and definitions for the function bodies as a lambda mrFreshLetRecVars :: Term -> Term -> MRM [Term] @@ -266,7 +254,10 @@ normComp (CompTerm t) = fun_tms <- mrFreshLetRecVars lrts defs_f -- Apply fi to the top-level arguments, keeping in mind that tuple -- selectors are one-based, not zero-based, so we subtract 1 from i - body_tm <- mrApplyAll (fun_tms !! (i-1)) args + body_tm <- + if i > 0 && i <= length fun_tms then + mrApplyAll (fun_tms !! (i-1)) args + else throwMRFailure (MalformedComp t) normComp (CompTerm body_tm) @@ -523,7 +514,7 @@ mrRefines' m1 (MaybeElim (Type (asEq -> Just (tp,e1,e2))) m2 f2 _) = -- A maybe eliminator on an isFinite type on the left mrRefines' (MaybeElim (Type (asIsFinite -> Just n1)) m1 f1 _) m2 = - do n1_norm <- liftSC1 scWhnf n1 + do n1_norm <- mrNormOpenTerm n1 maybe_assump <- mrGetDataTypeAssump n1_norm fin_pf <- liftSC2 scGlobalApply "CryptolM.isFinite" [n1_norm] >>= mrDummyProof @@ -541,7 +532,7 @@ mrRefines' (MaybeElim (Type (asIsFinite -> Just n1)) m1 f1 _) m2 = -- A maybe eliminator on an isFinite type on the right mrRefines' m1 (MaybeElim (Type (asIsFinite -> Just n2)) m2 f2 _) = - do n2_norm <- liftSC1 scWhnf n2 + do n2_norm <- mrNormOpenTerm n2 maybe_assump <- mrGetDataTypeAssump n2_norm fin_pf <- liftSC2 scGlobalApply "CryptolM.isFinite" [n2_norm] >>= mrDummyProof @@ -577,7 +568,7 @@ mrRefines' m1 (Ite cond2 m2 m2') = withAssumption not_cond2 (mrRefines m1 m2') mrRefines' (Either ltp1 rtp1 f1 g1 t1) m2 = - liftSC1 scWhnf t1 >>= \t1' -> + mrNormOpenTerm t1 >>= \t1' -> mrGetDataTypeAssump t1' >>= \mb_assump -> case (mb_assump, asEither t1') of (_, Just (Left x)) -> applyNormCompFun f1 x >>= flip mrRefines m2 @@ -593,7 +584,7 @@ mrRefines' (Either ltp1 rtp1 f1 g1 t1) m2 = applyNormCompFun g1' x >>= withDataTypeAssump t1'' (IsRight x) . flip mrRefines m2') mrRefines' m1 (Either ltp2 rtp2 f2 g2 t2) = - liftSC1 scWhnf t2 >>= \t2' -> + mrNormOpenTerm t2 >>= \t2' -> mrGetDataTypeAssump t2' >>= \mb_assump -> case (mb_assump, asEither t2') of (_, Just (Left x)) -> applyNormCompFun f2 x >>= mrRefines m1 From 648c5ba31776bb534b8cafdfd55f397003b3bf4a Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Thu, 10 Mar 2022 15:57:06 -0800 Subject: [PATCH 098/105] updated the linked_list_mr_solver.saw test case to prove that is_elem refines a cryptol version of its specification --- .../examples/linked_list_mr_solver.saw | 31 ++++++++++++++++++- 1 file changed, 30 insertions(+), 1 deletion(-) diff --git a/heapster-saw/examples/linked_list_mr_solver.saw b/heapster-saw/examples/linked_list_mr_solver.saw index 931e102351..c741d7e890 100644 --- a/heapster-saw/examples/linked_list_mr_solver.saw +++ b/heapster-saw/examples/linked_list_mr_solver.saw @@ -1,5 +1,9 @@ include "linked_list.saw"; +/*** + *** Testing infrastructure + ***/ + let eq_bool b1 b2 = if b1 then if b2 then true else false @@ -15,12 +19,37 @@ let run_test name test expected = do { print "Test failed\n"; exit 1; }; }; +/*** + *** Setup Cryptol environment + ***/ + +include "either.saw"; + +list_tp <- parse_core "\\ (a:sort 0) -> List a"; +cryptol_add_prim_type "LinkedList" "List" list_tp; + +fold_fun <- parse_core "foldList"; +cryptol_add_prim "LinkedList" "foldList" fold_fun; + +unfold_fun <- parse_core "unfoldList"; +cryptol_add_prim "LinkedList" "unfoldList" unfold_fun; + +import "linked_list.cry"; + + +/*** + *** The actual tests + ***/ + heapster_typecheck_fun env "is_head" "(). arg0:int64<>, arg1:List,always,R> -o \ \ arg0:true, arg1:true, ret:int64<>"; +/* is_head <- parse_core_mod "linked_list" "is_head"; run_test "is_head |= is_head" (mr_solver is_head is_head) true; +*/ is_elem <- parse_core_mod "linked_list" "is_elem"; -run_test "is_elem |= is_elem" (mr_solver is_elem is_elem) true; +run_test "is_elem |= is_elem_spec" (mr_solver_debug 2 is_elem {{ is_elem_spec }}) true; +//run_test "is_elem |= is_elem" (mr_solver_debug 1 is_elem is_elem) true; From 3007ec9a850c3c3eb8e8ac0d4664c595af4b703c Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Fri, 11 Mar 2022 06:24:38 -0800 Subject: [PATCH 099/105] whoops, fixed some typos --- src/SAWScript/Prover/MRSolver/Monad.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/SAWScript/Prover/MRSolver/Monad.hs b/src/SAWScript/Prover/MRSolver/Monad.hs index 9e8acd6c60..71e79735ba 100644 --- a/src/SAWScript/Prover/MRSolver/Monad.hs +++ b/src/SAWScript/Prover/MRSolver/Monad.hs @@ -237,7 +237,7 @@ instance PrettyInCtx DataTypeAssump where prettyInCtx (IsLeft x) = prettyInCtx x >>= ppWithPrefix "Left _ _" prettyInCtx (IsRight x) = prettyInCtx x >>= ppWithPrefix "Right _ _" prettyInCtx (IsNum x) = prettyInCtx x >>= ppWithPrefix "TCNum" - prettyInCtx (IsRight x) = prettyInCtx x >>= ppWithPrefix "TCInf" + prettyInCtx IsInf = return "TCInf" -- | Recognize a term as a @Left@ or @Right@ asEither :: Recognizer Term (Either Term Term) From 0c1db335bfb0e4c0240f50febc2ff6666b5e80f2 Mon Sep 17 00:00:00 2001 From: Andrei Stefanescu Date: Wed, 17 Nov 2021 01:43:31 +0000 Subject: [PATCH 100/105] Add llvm_verify_fixpoint_x86. --- deps/crucible | 2 +- src/SAWScript/Crucible/LLVM/X86.hs | 96 +++++++++++++++++++++++++++++- src/SAWScript/Interpreter.hs | 6 ++ 3 files changed, 100 insertions(+), 4 deletions(-) diff --git a/deps/crucible b/deps/crucible index e1308319ee..e370a721dc 160000 --- a/deps/crucible +++ b/deps/crucible @@ -1 +1 @@ -Subproject commit e1308319eef8e0fcb55ed04df7eb2e9d5e87aac5 +Subproject commit e370a721dc273270df0cbac5f0893d1d749d4ba8 diff --git a/src/SAWScript/Crucible/LLVM/X86.hs b/src/SAWScript/Crucible/LLVM/X86.hs index 24770eda78..fc8f76b14a 100644 --- a/src/SAWScript/Crucible/LLVM/X86.hs +++ b/src/SAWScript/Crucible/LLVM/X86.hs @@ -22,9 +22,11 @@ Stability : provisional {-# Language ConstraintKinds #-} {-# Language GeneralizedNewtypeDeriving #-} {-# Language TemplateHaskell #-} +{-# Language ViewPatterns #-} module SAWScript.Crucible.LLVM.X86 ( llvm_verify_x86 + , llvm_verify_fixpoint_x86 , defaultStackBaseAlign ) where @@ -46,6 +48,7 @@ import qualified Data.Set as Set import Data.Text (Text) import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Data.Time.Clock (getCurrentTime, diffUTCTime) +import qualified Data.List as List import qualified Data.Map as Map import Data.Map (Map) import Data.Maybe @@ -53,12 +56,15 @@ import Data.Maybe import qualified Text.LLVM.AST as LLVM import Data.Parameterized.Some +import qualified Data.Parameterized.Map as MapF import Data.Parameterized.NatRepr -import Data.Parameterized.Context hiding (view) +import Data.Parameterized.Context hiding (view, zipWithM) import Verifier.SAW.CryptolEnv import Verifier.SAW.FiniteValue import Verifier.SAW.Name (toShortName) +import Verifier.SAW.Prelude +import Verifier.SAW.Recognizer import Verifier.SAW.SharedTerm import Verifier.SAW.TypedTerm @@ -113,6 +119,7 @@ import qualified Lang.Crucible.LLVM.Extension as C.LLVM import qualified Lang.Crucible.LLVM.Intrinsics as C.LLVM import qualified Lang.Crucible.LLVM.MemModel as C.LLVM import qualified Lang.Crucible.LLVM.MemType as C.LLVM +import qualified Lang.Crucible.LLVM.SimpleLoopFixpoint as Crucible.LLVM.Fixpoint import qualified Lang.Crucible.LLVM.Translation as C.LLVM import qualified Lang.Crucible.LLVM.TypeContext as C.LLVM @@ -297,7 +304,36 @@ llvm_verify_x86 :: LLVMCrucibleSetupM () {- ^ Specification to verify against -} -> ProofScript () {- ^ Tactic used to use when discharging goals -} -> TopLevel (SomeLLVM MS.ProvedSpec) -llvm_verify_x86 (Some (llvmModule :: LLVMModule x)) path nm globsyms checkSat setup tactic +llvm_verify_x86 llvmModule path nm globsyms checkSat = + llvm_verify_x86_common llvmModule path nm globsyms checkSat Nothing + +-- | Verify that an x86_64 function (following the System V AMD64 ABI) conforms +-- to an LLVM specification. This allows for compositional verification of LLVM +-- functions that call x86_64 functions (but not the other way around). +llvm_verify_fixpoint_x86 :: + Some LLVMModule {- ^ Module to associate with method spec -} -> + FilePath {- ^ Path to ELF file -} -> + String {- ^ Function's symbol in ELF file -} -> + [(String, Integer)] {- ^ Global variable symbol names and sizes (in bytes) -} -> + Bool {- ^ Whether to enable path satisfiability checking -} -> + TypedTerm {- ^ Function specifying the loop -} -> + LLVMCrucibleSetupM () {- ^ Specification to verify against -} -> + ProofScript () {- ^ Tactic used to use when discharging goals -} -> + TopLevel (SomeLLVM MS.ProvedSpec) +llvm_verify_fixpoint_x86 llvmModule path nm globsyms checkSat f = + llvm_verify_x86_common llvmModule path nm globsyms checkSat (Just f) + +llvm_verify_x86_common :: + Some LLVMModule {- ^ Module to associate with method spec -} -> + FilePath {- ^ Path to ELF file -} -> + String {- ^ Function's symbol in ELF file -} -> + [(String, Integer)] {- ^ Global variable symbol names and sizes (in bytes) -} -> + Bool {- ^ Whether to enable path satisfiability checking -} -> + Maybe TypedTerm -> + LLVMCrucibleSetupM () {- ^ Specification to verify against -} -> + ProofScript () {- ^ Tactic used to use when discharging goals -} -> + TopLevel (SomeLLVM MS.ProvedSpec) +llvm_verify_x86_common (Some (llvmModule :: LLVMModule x)) path nm globsyms checkSat maybeFixpointFunc setup tactic | Just Refl <- testEquality (C.LLVM.X86Repr $ knownNat @64) . C.LLVM.llvmArch $ modTrans llvmModule ^. C.LLVM.transContext = do start <- io getCurrentTime @@ -460,7 +496,61 @@ llvm_verify_x86 (Some (llvmModule :: LLVMModule x)) path nm globsyms checkSat se else pure [] - let execFeatures = psatf + simpleLoopFixpointFeature <- maybeToList <$> mapM + (\func -> liftIO $ Crucible.LLVM.Fixpoint.simpleLoopFixpoint sym cfg mvar $ \fixpoint_substitution condition -> + do let fixpoint_substitution_as_list = reverse $ MapF.toList fixpoint_substitution + let body_exprs = map (mapSome $ Crucible.LLVM.Fixpoint.bodyValue) (MapF.elems fixpoint_substitution) + let uninterpreted_constants = foldMap + (viewSome $ Set.map (mapSome $ W4.varExpr sym) . W4.exprUninterpConstants sym) + (Some condition : body_exprs) + let filtered_uninterpreted_constants = Set.toList $ Set.filter + (\(Some variable) -> + not (List.isPrefixOf "creg_join_var" $ show $ W4.printSymExpr variable) + && not (List.isPrefixOf "cmem_join_var" $ show $ W4.printSymExpr variable) + && not (List.isPrefixOf "cundefined" $ show $ W4.printSymExpr variable) + && not (List.isPrefixOf "calign_amount" $ show $ W4.printSymExpr variable)) + uninterpreted_constants + body_tms <- mapM (viewSome $ toSC sym sawst) filtered_uninterpreted_constants + implicit_parameters <- mapM (scExtCns sc) $ Set.toList $ foldMap getAllExtSet body_tms + + arguments <- forM fixpoint_substitution_as_list $ \(MapF.Pair _ fixpoint_entry) -> + toSC sym sawst $ Crucible.LLVM.Fixpoint.headerValue fixpoint_entry + applied_func <- scApplyAll sc (ttTerm func) $ implicit_parameters ++ arguments + applied_func_selectors <- forM [1 .. (length fixpoint_substitution_as_list)] $ \i -> + scTupleSelector sc applied_func i (length fixpoint_substitution_as_list) + result_substitution <- MapF.fromList <$> zipWithM + (\(MapF.Pair variable _) applied_func_selector -> + MapF.Pair variable <$> bindSAWTerm sym sawst (W4.exprType variable) applied_func_selector) + fixpoint_substitution_as_list + applied_func_selectors + + explicit_parameters <- forM fixpoint_substitution_as_list $ \(MapF.Pair variable _) -> + toSC sym sawst variable + inner_func <- case asConstant (ttTerm func) of + Just (_, Just (asApplyAll -> (isGlobalDef "Prelude.fix" -> Just (), [_, inner_func]))) -> + return inner_func + _ -> fail $ "not Prelude.fix: " ++ showTerm (ttTerm func) + func_body <- betaNormalize sc + =<< scApplyAll sc inner_func ((ttTerm func) : (implicit_parameters ++ explicit_parameters)) + + step_arguments <- forM fixpoint_substitution_as_list $ \(MapF.Pair _ fixpoint_entry) -> + toSC sym sawst $ Crucible.LLVM.Fixpoint.bodyValue fixpoint_entry + tail_applied_func <- scApplyAll sc (ttTerm func) $ implicit_parameters ++ step_arguments + explicit_parameters_tuple <- scTuple sc explicit_parameters + let lhs = Prelude.last step_arguments + w <- scNat sc 64 + rhs <- scBvMul sc w (head implicit_parameters) =<< scBvNat sc w =<< scNat sc 128 + loop_condition <- scBvULt sc w lhs rhs + output_tuple_type <- scTupleType sc =<< mapM (scTypeOf sc) explicit_parameters + loop_body <- scIte sc output_tuple_type loop_condition tail_applied_func explicit_parameters_tuple + + induction_step_condition <- scEq sc loop_body func_body + result_condition <- bindSAWTerm sym sawst W4.BaseBoolRepr induction_step_condition + + return (result_substitution, result_condition)) + maybeFixpointFunc + + let execFeatures = simpleLoopFixpointFeature ++ psatf liftIO $ C.executeCrucible execFeatures initial >>= \case C.FinishedResult{} -> pure () diff --git a/src/SAWScript/Interpreter.hs b/src/SAWScript/Interpreter.hs index 2b11857fb3..1e549eb0e6 100644 --- a/src/SAWScript/Interpreter.hs +++ b/src/SAWScript/Interpreter.hs @@ -2728,6 +2728,12 @@ primitives = Map.fromList Experimental [ "Legacy alternative name for `llvm_verify_x86`." ] + , prim "llvm_verify_fixpoint_x86" + "LLVMModule -> String -> String -> [(String, Int)] -> Bool -> Term -> LLVMSetup () -> ProofScript () -> TopLevel LLVMSpec" + (pureVal llvm_verify_fixpoint_x86) + Experimental + [] + , prim "enable_x86_what4_hash_consing" "TopLevel ()" (pureVal enable_x86_what4_hash_consing) Experimental From ba9638916517b3b33546cffc1a948b354aea6f3d Mon Sep 17 00:00:00 2001 From: Andrei Stefanescu Date: Sat, 8 Jan 2022 02:40:35 +0000 Subject: [PATCH 101/105] Update ci. --- s2nTests/docker/awslc.dockerfile | 2 +- s2nTests/scripts/awslc-entrypoint.sh | 1 + 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/s2nTests/docker/awslc.dockerfile b/s2nTests/docker/awslc.dockerfile index 7f5267fb45..d05b6f99ed 100644 --- a/s2nTests/docker/awslc.dockerfile +++ b/s2nTests/docker/awslc.dockerfile @@ -7,7 +7,7 @@ WORKDIR /saw-script RUN mkdir -p /saw-script && \ git clone https://github.com/GaloisInc/aws-lc-verification.git && \ cd aws-lc-verification && \ - git checkout 7acbcfadd2e040b63cc33e8143e3f8e972408288 && \ + git checkout 1dcf4258305ce17592fb5b90a1c7b638e6bdff9e && \ git config --file=.gitmodules submodule.src.url https://github.com/awslabs/aws-lc && \ git submodule sync && \ git submodule update --init diff --git a/s2nTests/scripts/awslc-entrypoint.sh b/s2nTests/scripts/awslc-entrypoint.sh index 62ca1eb26f..afe2953913 100755 --- a/s2nTests/scripts/awslc-entrypoint.sh +++ b/s2nTests/scripts/awslc-entrypoint.sh @@ -3,6 +3,7 @@ set -xe cd /saw-script/aws-lc-verification/SAW ./scripts/install.sh +rm bin/saw cp /saw-bin/saw bin/saw cp /saw-bin/abc bin/abc From a77b6a29017b4e0de8901860cf0e85281957fb23 Mon Sep 17 00:00:00 2001 From: Rob Dockins Date: Fri, 4 Mar 2022 09:34:37 -0800 Subject: [PATCH 102/105] bump crucible submodule --- deps/crucible | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/deps/crucible b/deps/crucible index e370a721dc..d18505d1ad 160000 --- a/deps/crucible +++ b/deps/crucible @@ -1 +1 @@ -Subproject commit e370a721dc273270df0cbac5f0893d1d749d4ba8 +Subproject commit d18505d1ad1fe03e142371359852b5f52ea0b1f0 From 0a3bd6e55309ce7c454556d0ea8d8c16d64b64e7 Mon Sep 17 00:00:00 2001 From: Rob Dockins Date: Fri, 4 Mar 2022 13:02:42 -0800 Subject: [PATCH 103/105] Reorganize slightly the new simple loop fixpoint feature, and add some documentation text. --- src/SAWScript/Crucible/LLVM/X86.hs | 132 +++++++++++++++++------------ src/SAWScript/Interpreter.hs | 5 +- 2 files changed, 83 insertions(+), 54 deletions(-) diff --git a/src/SAWScript/Crucible/LLVM/X86.hs b/src/SAWScript/Crucible/LLVM/X86.hs index fc8f76b14a..e95786b426 100644 --- a/src/SAWScript/Crucible/LLVM/X86.hs +++ b/src/SAWScript/Crucible/LLVM/X86.hs @@ -496,59 +496,12 @@ llvm_verify_x86_common (Some (llvmModule :: LLVMModule x)) path nm globsyms chec else pure [] - simpleLoopFixpointFeature <- maybeToList <$> mapM - (\func -> liftIO $ Crucible.LLVM.Fixpoint.simpleLoopFixpoint sym cfg mvar $ \fixpoint_substitution condition -> - do let fixpoint_substitution_as_list = reverse $ MapF.toList fixpoint_substitution - let body_exprs = map (mapSome $ Crucible.LLVM.Fixpoint.bodyValue) (MapF.elems fixpoint_substitution) - let uninterpreted_constants = foldMap - (viewSome $ Set.map (mapSome $ W4.varExpr sym) . W4.exprUninterpConstants sym) - (Some condition : body_exprs) - let filtered_uninterpreted_constants = Set.toList $ Set.filter - (\(Some variable) -> - not (List.isPrefixOf "creg_join_var" $ show $ W4.printSymExpr variable) - && not (List.isPrefixOf "cmem_join_var" $ show $ W4.printSymExpr variable) - && not (List.isPrefixOf "cundefined" $ show $ W4.printSymExpr variable) - && not (List.isPrefixOf "calign_amount" $ show $ W4.printSymExpr variable)) - uninterpreted_constants - body_tms <- mapM (viewSome $ toSC sym sawst) filtered_uninterpreted_constants - implicit_parameters <- mapM (scExtCns sc) $ Set.toList $ foldMap getAllExtSet body_tms - - arguments <- forM fixpoint_substitution_as_list $ \(MapF.Pair _ fixpoint_entry) -> - toSC sym sawst $ Crucible.LLVM.Fixpoint.headerValue fixpoint_entry - applied_func <- scApplyAll sc (ttTerm func) $ implicit_parameters ++ arguments - applied_func_selectors <- forM [1 .. (length fixpoint_substitution_as_list)] $ \i -> - scTupleSelector sc applied_func i (length fixpoint_substitution_as_list) - result_substitution <- MapF.fromList <$> zipWithM - (\(MapF.Pair variable _) applied_func_selector -> - MapF.Pair variable <$> bindSAWTerm sym sawst (W4.exprType variable) applied_func_selector) - fixpoint_substitution_as_list - applied_func_selectors - - explicit_parameters <- forM fixpoint_substitution_as_list $ \(MapF.Pair variable _) -> - toSC sym sawst variable - inner_func <- case asConstant (ttTerm func) of - Just (_, Just (asApplyAll -> (isGlobalDef "Prelude.fix" -> Just (), [_, inner_func]))) -> - return inner_func - _ -> fail $ "not Prelude.fix: " ++ showTerm (ttTerm func) - func_body <- betaNormalize sc - =<< scApplyAll sc inner_func ((ttTerm func) : (implicit_parameters ++ explicit_parameters)) - - step_arguments <- forM fixpoint_substitution_as_list $ \(MapF.Pair _ fixpoint_entry) -> - toSC sym sawst $ Crucible.LLVM.Fixpoint.bodyValue fixpoint_entry - tail_applied_func <- scApplyAll sc (ttTerm func) $ implicit_parameters ++ step_arguments - explicit_parameters_tuple <- scTuple sc explicit_parameters - let lhs = Prelude.last step_arguments - w <- scNat sc 64 - rhs <- scBvMul sc w (head implicit_parameters) =<< scBvNat sc w =<< scNat sc 128 - loop_condition <- scBvULt sc w lhs rhs - output_tuple_type <- scTupleType sc =<< mapM (scTypeOf sc) explicit_parameters - loop_body <- scIte sc output_tuple_type loop_condition tail_applied_func explicit_parameters_tuple - - induction_step_condition <- scEq sc loop_body func_body - result_condition <- bindSAWTerm sym sawst W4.BaseBoolRepr induction_step_condition - - return (result_substitution, result_condition)) - maybeFixpointFunc + simpleLoopFixpointFeature <- + case maybeFixpointFunc of + Nothing -> return [] + Just func -> + do f <- liftIO (setupSimpleLoopFixpointFeature sym sc sawst cfg mvar func) + return [f] let execFeatures = simpleLoopFixpointFeature ++ psatf @@ -574,6 +527,79 @@ llvm_verify_x86_common (Some (llvmModule :: LLVMModule x)) path nm globsyms chec | otherwise = fail "LLVM module must be 64-bit" + + +setupSimpleLoopFixpointFeature :: + ( sym ~ W4.B.ExprBuilder n st fs + , C.IsSymInterface sym + , ?memOpts::C.LLVM.MemOptions + , C.LLVM.HasLLVMAnn sym + ) => + sym -> + SharedContext -> + SAWCoreState n -> + C.CFG ext blocks init ret -> + C.GlobalVar C.LLVM.Mem -> + TypedTerm -> + IO (C.ExecutionFeature p sym ext rtp) + +setupSimpleLoopFixpointFeature sym sc sawst cfg mvar func = + Crucible.LLVM.Fixpoint.simpleLoopFixpoint sym cfg mvar fixpoint_func + + where + fixpoint_func fixpoint_substitution condition = + do let fixpoint_substitution_as_list = reverse $ MapF.toList fixpoint_substitution + let body_exprs = map (mapSome $ Crucible.LLVM.Fixpoint.bodyValue) (MapF.elems fixpoint_substitution) + let uninterpreted_constants = foldMap + (viewSome $ Set.map (mapSome $ W4.varExpr sym) . W4.exprUninterpConstants sym) + (Some condition : body_exprs) + let filtered_uninterpreted_constants = Set.toList $ Set.filter + (\(Some variable) -> + not (List.isPrefixOf "creg_join_var" $ show $ W4.printSymExpr variable) + && not (List.isPrefixOf "cmem_join_var" $ show $ W4.printSymExpr variable) + && not (List.isPrefixOf "cundefined" $ show $ W4.printSymExpr variable) + && not (List.isPrefixOf "calign_amount" $ show $ W4.printSymExpr variable)) + uninterpreted_constants + body_tms <- mapM (viewSome $ toSC sym sawst) filtered_uninterpreted_constants + implicit_parameters <- mapM (scExtCns sc) $ Set.toList $ foldMap getAllExtSet body_tms + + arguments <- forM fixpoint_substitution_as_list $ \(MapF.Pair _ fixpoint_entry) -> + toSC sym sawst $ Crucible.LLVM.Fixpoint.headerValue fixpoint_entry + applied_func <- scApplyAll sc (ttTerm func) $ implicit_parameters ++ arguments + applied_func_selectors <- forM [1 .. (length fixpoint_substitution_as_list)] $ \i -> + scTupleSelector sc applied_func i (length fixpoint_substitution_as_list) + result_substitution <- MapF.fromList <$> zipWithM + (\(MapF.Pair variable _) applied_func_selector -> + MapF.Pair variable <$> bindSAWTerm sym sawst (W4.exprType variable) applied_func_selector) + fixpoint_substitution_as_list + applied_func_selectors + + explicit_parameters <- forM fixpoint_substitution_as_list $ \(MapF.Pair variable _) -> + toSC sym sawst variable + inner_func <- case asConstant (ttTerm func) of + Just (_, Just (asApplyAll -> (isGlobalDef "Prelude.fix" -> Just (), [_, inner_func]))) -> + return inner_func + _ -> fail $ "not Prelude.fix: " ++ showTerm (ttTerm func) + func_body <- betaNormalize sc + =<< scApplyAll sc inner_func ((ttTerm func) : (implicit_parameters ++ explicit_parameters)) + + step_arguments <- forM fixpoint_substitution_as_list $ \(MapF.Pair _ fixpoint_entry) -> + toSC sym sawst $ Crucible.LLVM.Fixpoint.bodyValue fixpoint_entry + tail_applied_func <- scApplyAll sc (ttTerm func) $ implicit_parameters ++ step_arguments + explicit_parameters_tuple <- scTuple sc explicit_parameters + let lhs = Prelude.last step_arguments + w <- scNat sc 64 + rhs <- scBvMul sc w (head implicit_parameters) =<< scBvNat sc w =<< scNat sc 128 + loop_condition <- scBvULt sc w lhs rhs + output_tuple_type <- scTupleType sc =<< mapM (scTypeOf sc) explicit_parameters + loop_body <- scIte sc output_tuple_type loop_condition tail_applied_func explicit_parameters_tuple + + induction_step_condition <- scEq sc loop_body func_body + result_condition <- bindSAWTerm sym sawst W4.BaseBoolRepr induction_step_condition + + return (result_substitution, result_condition) + + -------------------------------------------------------------------------------- -- ** Computing the CFG diff --git a/src/SAWScript/Interpreter.hs b/src/SAWScript/Interpreter.hs index 1e549eb0e6..93dc3e3118 100644 --- a/src/SAWScript/Interpreter.hs +++ b/src/SAWScript/Interpreter.hs @@ -2732,7 +2732,10 @@ primitives = Map.fromList "LLVMModule -> String -> String -> [(String, Int)] -> Bool -> Term -> LLVMSetup () -> ProofScript () -> TopLevel LLVMSpec" (pureVal llvm_verify_fixpoint_x86) Experimental - [] + [ "An experimental variant of 'llvm_verify_x86'. This variant can prove some properties" + , "involving simple loops with the help of a user-provided term that describes how" + , "the live variables in the loop evolve as the loop computes." + ] , prim "enable_x86_what4_hash_consing" "TopLevel ()" (pureVal enable_x86_what4_hash_consing) From 321e1ede87a5fe89599a7cf794666f0ba5f95141 Mon Sep 17 00:00:00 2001 From: Rob Dockins Date: Fri, 4 Mar 2022 13:07:33 -0800 Subject: [PATCH 104/105] update changelog --- CHANGES.md | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/CHANGES.md b/CHANGES.md index fdc01b341a..3fe9085243 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -40,6 +40,13 @@ as with `llvm_field`, debug symbols are required for `llvm_union` to work correctly. +* A new highly experimental `llvm_verify_fixpoint_x86` function that + allows partial correctness verification of loops using loop + invariants instead of full symbolic unrolling. Only certain very simple + styles of loops can currently be accommodated, and the user is + required to provide a term that describes how the live variables in + the loop evolve over an iteration. + # Version 0.9 ## New Features From 22474c3f3daad70334ea6d19c3cb7ad60a774410 Mon Sep 17 00:00:00 2001 From: Brian Huffman Date: Mon, 14 Mar 2022 13:52:32 -0700 Subject: [PATCH 105/105] Update submodule versions. --- deps/argo | 2 +- deps/cryptol | 2 +- deps/llvm-pretty | 2 +- deps/llvm-pretty-bc-parser | 2 +- deps/macaw | 2 +- deps/parameterized-utils | 2 +- deps/what4 | 2 +- 7 files changed, 7 insertions(+), 7 deletions(-) diff --git a/deps/argo b/deps/argo index afee6bb49c..904fb34872 160000 --- a/deps/argo +++ b/deps/argo @@ -1 +1 @@ -Subproject commit afee6bb49c7831a38316221e7b9721fbc65e88d7 +Subproject commit 904fb34872fcef462030fe38978842aa5a9db903 diff --git a/deps/cryptol b/deps/cryptol index 7748a619e9..fe0bd96ca7 160000 --- a/deps/cryptol +++ b/deps/cryptol @@ -1 +1 @@ -Subproject commit 7748a619e9e2167097ef680a20578c17803ccc0a +Subproject commit fe0bd96ca72c493608ffed5bf7547f2ab2aad2bc diff --git a/deps/llvm-pretty b/deps/llvm-pretty index ca81abf2ec..34c95e77fb 160000 --- a/deps/llvm-pretty +++ b/deps/llvm-pretty @@ -1 +1 @@ -Subproject commit ca81abf2ecab957aff9e068777203a3af2a19088 +Subproject commit 34c95e77fb9fdc584c23208f81f6072cb0e05c3f diff --git a/deps/llvm-pretty-bc-parser b/deps/llvm-pretty-bc-parser index af0c6951b3..1bad3e43c7 160000 --- a/deps/llvm-pretty-bc-parser +++ b/deps/llvm-pretty-bc-parser @@ -1 +1 @@ -Subproject commit af0c6951b3eebffa3404ff116685a92ad8b0697e +Subproject commit 1bad3e43c7444e363ef4c3d9f954bc04b01b1795 diff --git a/deps/macaw b/deps/macaw index a43151963d..45f8af1e5a 160000 --- a/deps/macaw +++ b/deps/macaw @@ -1 +1 @@ -Subproject commit a43151963da70e4d4c3d69f9605e82e44ff30731 +Subproject commit 45f8af1e5a0023f00c8c1985834bdf3b1e8bcfbc diff --git a/deps/parameterized-utils b/deps/parameterized-utils index 8bb69110b5..fea8c1ab6c 160000 --- a/deps/parameterized-utils +++ b/deps/parameterized-utils @@ -1 +1 @@ -Subproject commit 8bb69110b5c9658c94ef8dcf9f3028d6e7ad32e6 +Subproject commit fea8c1ab6c354485d065eb4764714b06b015ce93 diff --git a/deps/what4 b/deps/what4 index ac64bcd580..ea717ac94a 160000 --- a/deps/what4 +++ b/deps/what4 @@ -1 +1 @@ -Subproject commit ac64bcd580f552bd22ec5a135fdbcc3d523723a1 +Subproject commit ea717ac94a186b5ee18f138b71d8b4b4b2f00955