From 3ef878d0347bd442370da21cd14325a4ed26f153 Mon Sep 17 00:00:00 2001 From: Rob Dockins Date: Thu, 9 Jun 2022 12:05:42 -0700 Subject: [PATCH 01/35] Add helpers for computing multiple `and` or `or` applications. --- saw-core/src/Verifier/SAW/SharedTerm.hs | 21 +++++++++++++++++++++ 1 file changed, 21 insertions(+) diff --git a/saw-core/src/Verifier/SAW/SharedTerm.hs b/saw-core/src/Verifier/SAW/SharedTerm.hs index da056dc77c..d20754f7aa 100644 --- a/saw-core/src/Verifier/SAW/SharedTerm.hs +++ b/saw-core/src/Verifier/SAW/SharedTerm.hs @@ -168,6 +168,8 @@ module Verifier.SAW.SharedTerm , scXor , scBoolEq , scIte + , scAndList + , scOrList -- *** Natural numbers , scNat , scNatType @@ -1702,6 +1704,25 @@ scIte :: SharedContext -> Term -> Term -> Term -> Term -> IO Term scIte sc t b x y = scGlobalApply sc "Prelude.ite" [t, b, x, y] +-- | Build a conjunction from a list of boolean terms. +scAndList :: SharedContext -> [Term] -> IO Term +scAndList sc = conj . filter nontrivial + where + nontrivial x = asBool x /= Just True + conj [] = scBool sc True + conj [x] = return x + conj (x : xs) = foldM (scAnd sc) x xs + +-- | Build a conjunction from a list of boolean terms. +scOrList :: SharedContext -> [Term] -> IO Term +scOrList sc = disj . filter nontrivial + where + nontrivial x = asBool x /= Just False + disj [] = scBool sc False + disj [x] = return x + disj (x : xs) = foldM (scOr sc) x xs + + -- | Create a term applying @Prelude.append@ to two vectors. -- -- > append : (m n : Nat) -> (e : sort 0) -> Vec m e -> Vec n e -> Vec (addNat m n) e; From 7e774ca7b13a605a3b92290ad724dc5bce235d55 Mon Sep 17 00:00:00 2001 From: Rob Dockins Date: Tue, 7 Jun 2022 13:31:42 -0700 Subject: [PATCH 02/35] First steps toward refactoring the proof tactic system to use sequents. --- src/SAWScript/Builtins.hs | 85 ++--- src/SAWScript/Crucible/JVM/Builtins.hs | 2 +- src/SAWScript/Crucible/LLVM/Builtins.hs | 4 +- src/SAWScript/Crucible/LLVM/X86.hs | 2 +- src/SAWScript/Interpreter.hs | 3 + src/SAWScript/Proof.hs | 400 ++++++++++++++++-------- src/SAWScript/Prover/ABC.hs | 11 +- 7 files changed, 325 insertions(+), 182 deletions(-) diff --git a/src/SAWScript/Builtins.hs b/src/SAWScript/Builtins.hs index cf9e669870..8e4274f52e 100644 --- a/src/SAWScript/Builtins.hs +++ b/src/SAWScript/Builtins.hs @@ -365,13 +365,13 @@ quickcheckGoal sc n = do execTactic $ tacticSolve $ \goal -> io $ do printOutLn opts Warn $ "WARNING: using quickcheck to prove goal..." hFlush stdout - satq <- propToSATQuery sc mempty (goalProp goal) + satq <- sequentToSATQuery sc mempty (goalSequent goal) testGen <- prepareSATQuery sc satq - let stats = solverStats "quickcheck" (propSize (goalProp goal)) + let stats = solverStats "quickcheck" (sequentSize (goalSequent goal)) runManyTests testGen n >>= \case Nothing -> do printOutLn opts Info $ "checked " ++ show n ++ " cases." - return (stats, SolveSuccess (QuickcheckEvidence n (goalProp goal))) + return (stats, SolveSuccess (QuickcheckEvidence n (goalSequent goal))) Just cex -> return (stats, SolveCounterexample cex) assumeValid :: ProofScript () @@ -380,8 +380,8 @@ assumeValid = do printOutLnTop Warn $ "WARNING: assuming goal " ++ goalName goal ++ " is valid" pos <- SV.getPosition let admitMsg = "assumeValid: " <> Text.pack (goalName goal) - let stats = solverStats "ADMITTED" (propSize (goalProp goal)) - return (stats, SolveSuccess (Admitted admitMsg pos (goalProp goal))) + let stats = solverStats "ADMITTED" (sequentSize (goalSequent goal)) + return (stats, SolveSuccess (Admitted admitMsg pos (goalSequent goal))) assumeUnsat :: ProofScript () assumeUnsat = @@ -389,16 +389,16 @@ assumeUnsat = do printOutLnTop Warn $ "WARNING: assuming goal " ++ goalName goal ++ " is unsat" pos <- SV.getPosition let admitMsg = "assumeUnsat: " <> Text.pack (goalName goal) - let stats = solverStats "ADMITTED" (propSize (goalProp goal)) - return (stats, SolveSuccess (Admitted admitMsg pos (goalProp goal))) + let stats = solverStats "ADMITTED" (sequentSize (goalSequent goal)) + return (stats, SolveSuccess (Admitted admitMsg pos (goalSequent goal))) admitProof :: Text -> ProofScript () admitProof msg = execTactic $ tacticSolve $ \goal -> do printOutLnTop Warn $ "WARNING: admitting goal " ++ goalName goal pos <- SV.getPosition - let stats = solverStats "ADMITTED" (propSize (goalProp goal)) - return (stats, SolveSuccess (Admitted msg pos (goalProp goal))) + let stats = solverStats "ADMITTED" (sequentSize (goalSequent goal)) + return (stats, SolveSuccess (Admitted msg pos (goalSequent goal))) trivial :: ProofScript () trivial = @@ -449,7 +449,8 @@ write_goal fp = do opts <- getTopLevelPPOpts sc <- getSharedContext liftIO $ do - output <- liftIO (scShowTerm sc opts =<< propToTerm sc (goalProp goal)) + -- TODO, something better here + output <- liftIO (scShowTerm sc opts =<< propToTerm sc =<< sequentToProp sc (goalSequent goal)) writeFile fp (unlines [goalSummary goal, output]) print_goal :: ProofScript () @@ -457,7 +458,8 @@ print_goal = execTactic $ tacticId $ \goal -> do opts <- getTopLevelPPOpts sc <- getSharedContext - output <- liftIO (scShowTerm sc opts =<< propToTerm sc (goalProp goal)) + -- TODO, something better here + output <- liftIO (scShowTerm sc opts =<< propToTerm sc =<< sequentToProp sc (goalSequent goal)) printOutLnTop Info (goalSummary goal) printOutLnTop Info output @@ -477,7 +479,8 @@ print_goal_depth n = do opts <- getTopLevelPPOpts sc <- getSharedContext let opts' = opts { ppMaxDepth = Just n } - output <- liftIO (scShowTerm sc opts' =<< propToTerm sc (goalProp goal)) + -- TODO, something better here + output <- liftIO (scShowTerm sc opts' =<< propToTerm sc =<< sequentToProp sc (goalSequent goal)) printOutLnTop Info ("Goal " ++ goalName goal ++ ":") printOutLnTop Info output @@ -485,7 +488,7 @@ printGoalConsts :: ProofScript () printGoalConsts = execTactic $ tacticId $ \goal -> do sc <- getSharedContext - tm <- io (propToTerm sc (goalProp goal)) + tm <- io (propToTerm sc =<< sequentToProp sc (goalSequent goal)) mapM_ (printOutLnTop Info) $ [ show nm | (_,(nm,_,_)) <- Map.toList (getConstantSet tm) @@ -495,7 +498,7 @@ printGoalSize :: ProofScript () printGoalSize = execTactic $ tacticId $ \goal -> do sc <- getSharedContext - t <- io (propToTerm sc (goalProp goal)) + t <- io (propToTerm sc =<< sequentToProp sc (goalSequent goal)) printOutLnTop Info $ "Goal shared size: " ++ show (scSharedSize t) printOutLnTop Info $ "Goal unshared size: " ++ show (scTreeSize t) @@ -551,22 +554,22 @@ unfoldGoal unints = execTactic $ tacticChange $ \goal -> do sc <- getSharedContext unints' <- resolveNames unints - prop' <- io (unfoldProp sc unints' (goalProp goal)) - return (prop', UnfoldEvidence unints') + sqt' <- traverseSequent (io . unfoldProp sc unints') (goalSequent goal) + return (sqt', UnfoldEvidence unints') simplifyGoal :: SV.SAWSimpset -> ProofScript () simplifyGoal ss = execTactic $ tacticChange $ \goal -> do sc <- getSharedContext - (_,prop') <- io (simplifyProp sc ss (goalProp goal)) - return (prop', RewriteEvidence ss) + sqt' <- traverseSequent (\p -> snd <$> io (simplifyProp sc ss p)) (goalSequent goal) + return (sqt', RewriteEvidence ss) hoistIfsInGoalPrim :: ProofScript () hoistIfsInGoalPrim = execTactic $ tacticChange $ \goal -> do sc <- getSharedContext - p <- io $ hoistIfsInGoal sc (goalProp goal) - return (p, HoistIfsEvidence) + sqt' <- traverseSequent (io . hoistIfsInGoal sc) (goalSequent goal) + return (sqt', HoistIfsEvidence) term_type :: TypedTerm -> TopLevel C.Schema term_type tt = @@ -582,8 +585,8 @@ goal_eval unints = execTactic $ tacticChange $ \goal -> do sc <- getSharedContext unintSet <- resolveNames unints - prop' <- io (evalProp sc unintSet (goalProp goal)) - return (prop', EvalEvidence unintSet) + sqt' <- traverseSequent (io . evalProp sc unintSet) (goalSequent goal) + return (sqt', EvalEvidence unintSet) extract_uninterp :: [String] {- ^ uninterpred identifiers -} -> @@ -711,8 +714,8 @@ beta_reduce_goal :: ProofScript () beta_reduce_goal = execTactic $ tacticChange $ \goal -> do sc <- getSharedContext - prop' <- io (betaReduceProp sc (goalProp goal)) - return (prop', id) + sqt' <- traverseSequent (io . betaReduceProp sc) (goalSequent goal) + return (sqt', id) goal_apply :: Theorem -> ProofScript () goal_apply thm = @@ -724,21 +727,25 @@ goal_exact tm = do sc <- SV.scriptTopLevel getSharedContext execTactic (tacticExact sc (ttTerm tm)) +{- goal_assume :: ProofScript Theorem goal_assume = do sc <- SV.scriptTopLevel getSharedContext pos <- SV.scriptTopLevel SV.getPosition execTactic (tacticAssume sc pos) +-} goal_intro :: Text -> ProofScript TypedTerm goal_intro s = do sc <- SV.scriptTopLevel getSharedContext execTactic (tacticIntro sc s) +{- goal_insert :: Theorem -> ProofScript () goal_insert thm = do sc <- SV.scriptTopLevel getSharedContext execTactic (tacticCut sc thm) +-} goal_num_when :: Int -> ProofScript () -> ProofScript () goal_num_when n script = @@ -788,7 +795,7 @@ satExternal doCNF execName args = sc <- SV.getSharedContext (mb, stats) <- Prover.abcSatExternal proxy sc doCNF execName args g case mb of - Nothing -> return (stats, SolveSuccess (SolverEvidence stats (goalProp g))) + Nothing -> return (stats, SolveSuccess (SolverEvidence stats (goalSequent g))) Just a -> return (stats, SolveCounterexample a) writeAIGPrim :: FilePath -> Term -> TopLevel () @@ -830,9 +837,10 @@ applyProverToGoal :: (Prop -> TopLevel (Maybe CEX, SolverStats)) -> ProofGoal -> TopLevel (SolverStats, SolveResult) applyProverToGoal f g = do - (mb, stats) <- f (goalProp g) + sc <- getSharedContext + (mb, stats) <- f =<< io (sequentToProp sc (goalSequent g)) case mb of - Nothing -> return (stats, SolveSuccess (SolverEvidence stats (goalProp g))) + Nothing -> return (stats, SolveSuccess (SolverEvidence stats (goalSequent g))) Just a -> return (stats, SolveCounterexample a) wrapProver :: @@ -952,8 +960,9 @@ proveWithSATExporter :: proveWithSATExporter exporter unintSet path sep ext = execTactic $ tacticSolve $ \g -> do let file = path ++ sep ++ goalType g ++ show (goalNum g) ++ ext - stats <- Prover.proveWithSATExporter exporter unintSet file (goalProp g) - return (stats, SolveSuccess (SolverEvidence stats (goalProp g))) + sc <- getSharedContext + stats <- Prover.proveWithSATExporter exporter unintSet file =<< io (sequentToProp sc (goalSequent g)) + return (stats, SolveSuccess (SolverEvidence stats (goalSequent g))) proveWithPropExporter :: (FilePath -> Prop -> TopLevel a) -> @@ -964,8 +973,9 @@ proveWithPropExporter :: proveWithPropExporter exporter path sep ext = execTactic $ tacticSolve $ \g -> do let file = path ++ sep ++ goalType g ++ show (goalNum g) ++ ext - stats <- Prover.proveWithPropExporter exporter file (goalProp g) - return (stats, SolveSuccess (SolverEvidence stats (goalProp g))) + sc <- getSharedContext + stats <- Prover.proveWithPropExporter exporter file =<< io (sequentToProp sc (goalSequent g)) + return (stats, SolveSuccess (SolverEvidence stats (goalSequent g))) offline_aig :: FilePath -> ProofScript () offline_aig path = @@ -1030,7 +1040,7 @@ provePrim script t = do , goalName = "prove_prim" , goalLoc = show pos , goalDesc = "" - , goalProp = prop + , goalSequent = propToSequent prop , goalTags = mempty } res <- SV.runProofScript script goal Nothing "prove_prim" @@ -1056,7 +1066,7 @@ proveHelper nm script t f = do , goalName = nm , goalLoc = show pos , goalDesc = "" - , goalProp = prop + , goalSequent = propToSequent prop , goalTags = mempty } opts <- rwPPOpts <$> getTopLevelRW @@ -1102,7 +1112,7 @@ satPrim script t = , goalName = "sat" , goalLoc = show pos , goalDesc = "" - , goalProp = prop + , goalSequent = propToSequent prop , goalTags = mempty } res <- SV.runProofScript script goal Nothing "sat" @@ -1235,9 +1245,8 @@ check_goal = g : _ -> SV.scriptTopLevel $ do sc <- getSharedContext - tm <- io (propToTerm sc (goalProp g)) - check_term tm - return () + opts <- getTopLevelPPOpts + io $ checkSequent sc opts (goalSequent g) fixPos :: Pos fixPos = PosInternal "FIXME" @@ -1627,7 +1636,7 @@ prove_core script input = , goalName = "prove_core" , goalLoc = show pos , goalDesc = "" - , goalProp = p + , goalSequent = propToSequent p , goalTags = mempty } res <- SV.runProofScript script goal Nothing "prove_core" diff --git a/src/SAWScript/Crucible/JVM/Builtins.hs b/src/SAWScript/Crucible/JVM/Builtins.hs index e799b403bf..63103fcdb1 100644 --- a/src/SAWScript/Crucible/JVM/Builtins.hs +++ b/src/SAWScript/Crucible/JVM/Builtins.hs @@ -314,7 +314,7 @@ verifyObligations cc mspec tactic assumes asserts = , goalName = nm , goalLoc = gloc , goalDesc = msg - , goalProp = goal' + , goalSequent = propToSequent goal' , goalTags = MS.conditionTags md } res <- runProofScript tactic proofgoal (Just ploc) $ Text.unwords diff --git a/src/SAWScript/Crucible/LLVM/Builtins.hs b/src/SAWScript/Crucible/LLVM/Builtins.hs index 0b883eaa8f..8869fa7b9a 100644 --- a/src/SAWScript/Crucible/LLVM/Builtins.hs +++ b/src/SAWScript/Crucible/LLVM/Builtins.hs @@ -799,7 +799,7 @@ verifyObligations cc mspec tactic assumes asserts = , goalName = nm , goalLoc = gloc , goalDesc = msg - , goalProp = goal' + , goalSequent = propToSequent goal' , goalTags = MS.conditionTags md } res <- runProofScript tactic proofgoal (Just ploc) $ Text.unwords @@ -982,7 +982,7 @@ assumptionsContainContradiction cc methodSpec tactic assumptions = , goalName = show (methodSpec^.MS.csMethod) , goalLoc = show (W4.plSourceLoc ploc) ++ " in " ++ show (W4.plFunction ploc) , goalDesc = "vacuousness check" - , goalProp = goal' + , goalSequent = propToSequent goal' , goalTags = mempty } res <- runProofScript tactic pgl Nothing "vacuousness check" diff --git a/src/SAWScript/Crucible/LLVM/X86.hs b/src/SAWScript/Crucible/LLVM/X86.hs index 81518c9dde..e715833395 100644 --- a/src/SAWScript/Crucible/LLVM/X86.hs +++ b/src/SAWScript/Crucible/LLVM/X86.hs @@ -1196,7 +1196,7 @@ checkGoals bak opts nm sc tactic mdMap = do , goalName = nm , goalLoc = gloc , goalDesc = show $ gMessage g - , goalProp = term + , goalSequent = propToSequent term , goalTags = MS.conditionTags md } res <- runProofScript tactic proofgoal (Just (gLoc g)) $ Text.unwords diff --git a/src/SAWScript/Interpreter.hs b/src/SAWScript/Interpreter.hs index d10529e645..6cfe27613d 100644 --- a/src/SAWScript/Interpreter.hs +++ b/src/SAWScript/Interpreter.hs @@ -1600,6 +1600,7 @@ primitives = Map.fromList , "This will succeed if the type of the given term matches the current goal." ] +{- , prim "goal_assume" "ProofScript Theorem" (pureVal goal_assume) Experimental @@ -1611,6 +1612,8 @@ primitives = Map.fromList Experimental [ "Insert a Theorem as a new hypothesis in the current proof goal." ] +-} + , prim "goal_intro" "String -> ProofScript Term" (pureVal goal_intro) Experimental diff --git a/src/SAWScript/Proof.hs b/src/SAWScript/Proof.hs index 823352d3d6..97059198f9 100644 --- a/src/SAWScript/Proof.hs +++ b/src/SAWScript/Proof.hs @@ -30,6 +30,18 @@ module SAWScript.Proof , prettyProp , ppProp , propToSATQuery + , checkProp + + , Sequent + , SequentState(..) + , sequentToProp + , sequentToSATQuery + , sequentSize + , prettySequent + , ppSequent + , propToSequent + , traverseSequent + , checkSequent , TheoremDB , newTheoremDB @@ -62,8 +74,8 @@ module SAWScript.Proof , Tactic , withFirstGoal , tacticIntro - , tacticCut - , tacticAssume +-- , tacticCut +-- , tacticAssume , tacticApply , tacticSplit , tacticTrivial @@ -204,6 +216,12 @@ splitProp sc (Prop p) = t2 <- scPiList sc vars =<< scEqTrue sc p2 return (Just (Prop t1,Prop t2)) +splitSequent :: SharedContext -> Sequent -> IO (Maybe (Sequent, Sequent)) +splitSequent sc (Sequent_ p) = + splitProp sc p >>= \case + Nothing -> return Nothing + Just (x, y) -> return (Just (Sequent_ x, Sequent_ y)) + -- | Unfold all the constants appearing in the proposition -- whose VarIndex is found in the given set. unfoldProp :: SharedContext -> Set VarIndex -> Prop -> IO Prop @@ -217,6 +235,12 @@ simplifyProp sc ss (Prop tm) = do (a, tm') <- rewriteSharedTerm sc ss tm return (a, Prop tm') +-- | Rewrite in the sequent using the provided Simpset +simplifySequent :: Ord a => SharedContext -> Simpset a -> Sequent -> IO (Set a, Sequent) +simplifySequent sc ss (Sequent_ p) = + do (a, p') <- simplifyProp sc ss p + return (a, Sequent_ p') + hoistIfsInGoal :: SharedContext -> Prop -> IO Prop hoistIfsInGoal sc (Prop p) = do let (args, body) = asPiList p @@ -296,6 +320,53 @@ prettyProp opts (Prop tm) = scPrettyTerm opts tm ppProp :: PPOpts -> Prop -> SawDoc ppProp opts (Prop tm) = ppTerm opts tm + + +-- Dummy definition for now +data Sequent = Sequent_ Prop + +data SequentState + = Unfocused + | GoalFocus Prop (Prop -> Sequent) + | HypFocus Prop (Prop -> Sequent) + +propToSequent :: Prop -> Sequent +propToSequent p = Sequent_ p + +sequentToProp :: SharedContext -> Sequent -> IO Prop +sequentToProp _sc (Sequent_ p) = return p + +sequentToSATQuery :: SharedContext -> Set VarIndex -> Sequent -> IO SATQuery +sequentToSATQuery sc unintSet sqt = + sequentToProp sc sqt >>= propToSATQuery sc unintSet + +-- | Pretty print the given proposition as a string. +prettySequent :: PPOpts -> Sequent -> String +prettySequent opts (Sequent_ p) = prettyProp opts p + +-- | Pretty print the given proposition as a @SawDoc@. +ppSequent :: PPOpts -> Sequent -> SawDoc +ppSequent opts (Sequent_ p) = ppProp opts p + +sequentState :: Sequent -> SequentState +sequentState (Sequent_ p) = GoalFocus p Sequent_ + +sequentSize :: Sequent -> Integer +sequentSize (Sequent_ p) = propSize p + +traverseSequent :: Applicative m => (Prop -> m Prop) -> Sequent -> m Sequent +traverseSequent f (Sequent_ p) = Sequent_ <$> f p + +checkSequent :: SharedContext -> PPOpts -> Sequent -> IO () +checkSequent sc ppOpts (Sequent_ p) = checkProp sc ppOpts p + +checkProp :: SharedContext -> PPOpts -> Prop -> IO () +checkProp sc ppOpts (Prop t) = + do ty <- TC.scTypeCheckError sc t + case asSort ty of + Just s | s == propSort -> return () + _ -> fail $ unlines ["Term is not a prop!", scPrettyTerm ppOpts t, scPrettyTerm ppOpts ty] + type TheoremNonce = Nonce GlobalNonceGenerator Theorem -- | A theorem is a proposition which has been wrapped in a @@ -408,18 +479,18 @@ data Evidence -- has been dispatched to a solver which has indicated that it -- was able to prove the proposition. The included @SolverStats@ -- give some details about the solver run. - | SolverEvidence SolverStats Prop + | SolverEvidence SolverStats Sequent -- | This type of evidence is produced when the given proposition -- has been randomly tested against input vectors in the style -- of quickcheck. The included number is the number of successfully -- passed test vectors. - | QuickcheckEvidence Integer Prop + | QuickcheckEvidence Integer Sequent -- | This type of evidence is produced when the given proposition -- has been explicitly assumed without other evidence at the -- user's direction. - | Admitted Text Pos Prop + | Admitted Text Pos Sequent -- | This type of evidence is produced when a proposition can be deconstructed -- along a conjunction into two subgoals, each of which is supported by @@ -438,14 +509,14 @@ data Evidence -- proposition must match the hypothesis of the goal, and the included -- evidence must match the conclusion of the goal. The proposition is -- allowed to appear inside the evidence as a local assumption. - | AssumeEvidence TheoremNonce Prop Evidence +-- | AssumeEvidence TheoremNonce Prop Evidence -- | This type of evidence is used to prove a universally-quantified statement. - | ForallEvidence (ExtCns Term) Evidence + | IntroEvidence (ExtCns Term) Evidence -- | This type of evidence is used to weaken a goal by adding a hypothesis, -- where the hypothesis is proved by the given theorem. - | CutEvidence Theorem Evidence + -- | CutEvidence Theorem Evidence -- | This type of evidence is used to modify a goal to prove via rewriting. -- The goal to prove is rewritten by the given simpset; then the provided @@ -523,17 +594,21 @@ splitEvidence :: [Evidence] -> IO Evidence splitEvidence [e1,e2] = pure (SplitEvidence e1 e2) splitEvidence _ = fail "splitEvidence: expected two evidence values" +{- assumeEvidence :: TheoremNonce -> Prop -> [Evidence] -> IO Evidence assumeEvidence n p [e] = pure (AssumeEvidence n p e) assumeEvidence _ _ _ = fail "assumeEvidence: expected one evidence value" +-} -forallEvidence :: ExtCns Term -> [Evidence] -> IO Evidence -forallEvidence x [e] = pure (ForallEvidence x e) -forallEvidence _ _ = fail "forallEvidence: expected one evidence value" +introEvidence :: ExtCns Term -> [Evidence] -> IO Evidence +introEvidence x [e] = pure (IntroEvidence x e) +introEvidence _ _ = fail "introEvidence: expected one evidence value" +{- cutEvidence :: Theorem -> [Evidence] -> IO Evidence cutEvidence thm [e] = pure (CutEvidence thm e) cutEvidence _ _ = fail "cutEvidence: expected one evidence value" +-} -- | Construct a theorem directly via a proof term. proofByTerm :: SharedContext -> TheoremDB -> Term -> Pos -> Text -> IO Theorem @@ -625,7 +700,7 @@ admitTheorem db msg p loc rsn = Theorem { _thmProp = p , _thmStats = solverStats "ADMITTED" (propSize p) - , _thmEvidence = Admitted msg loc p + , _thmEvidence = Admitted msg loc (propToSequent p) , _thmLocation = loc , _thmProgramLoc = Nothing , _thmReason = rsn @@ -650,7 +725,7 @@ solverTheorem db p stats loc rsn elapsed = Theorem { _thmProp = p , _thmStats = stats - , _thmEvidence = SolverEvidence stats p + , _thmEvidence = SolverEvidence stats (propToSequent p) , _thmLocation = loc , _thmReason = rsn , _thmProgramLoc = Nothing @@ -669,8 +744,8 @@ data ProofGoal = , goalName :: String , goalLoc :: String , goalDesc :: String - , goalProp :: Prop , goalTags :: Set String + , goalSequent :: Sequent } @@ -711,7 +786,7 @@ predicateToProp sc quant = loop [] data ProofState = ProofState { _psGoals :: [ProofGoal] - , _psConcl :: (Prop,Pos,Maybe ProgramLoc,Text) + , _psConcl :: (Sequent,Pos,Maybe ProgramLoc,Text) , _psStats :: SolverStats , _psTimeout :: Maybe Integer , _psEvidence :: [Evidence] -> IO Evidence @@ -727,24 +802,32 @@ psGoals = _psGoals psStats :: ProofState -> SolverStats psStats = _psStats +-- | Test if the first given sequent subsumes the +-- second given sequent. This is a shallow syntactic +-- check that is sufficent to show that a proof +-- of the first sequent is sufficent to prove the second +sequentSubsumes :: SharedContext -> Sequent -> Sequent -> IO Bool +sequentSubsumes sc (Sequent_ p1) (Sequent_ p2) = + scConvertible sc False (unProp p1) (unProp p2) + -- | Verify that the given evidence in fact supports the given proposition. -- 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 + check hyps e (propToSequent p) where - checkApply _hyps (Prop p) [] = return (mempty, mempty, p) + checkApply _hyps _mkSqt (Prop p) [] = return (mempty, mempty, p) -- 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) + checkApply hyps mkSqt (Prop p) (Right e:es) | Just (_lnm, tp, body) <- asPi p , looseVars body == emptyBitSet - = do (d1,sy1) <- check hyps e =<< termToProp sc tp - (d2,sy2,p') <- checkApply hyps (Prop body) es + = do (d1,sy1) <- check hyps e . mkSqt =<< termToProp sc tp + (d2,sy2,p') <- checkApply hyps mkSqt (Prop body) es return (Set.union d1 d2, sy1 <> sy2, p') | otherwise = fail $ unlines [ "Apply evidence mismatch: non-function or dependent function" @@ -753,7 +836,7 @@ checkEvidence sc db = \e p -> do hyps <- Map.keysSet <$> readIORef (theoremMap d -- Check a theorem applied to a term. This explicity instantiates -- a Pi binder with the given term. - checkApply hyps (Prop p) (Left tm:es) = + checkApply hyps mkSqt (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' @@ -761,7 +844,7 @@ checkEvidence sc db = \e p -> do hyps <- Map.keysSet <$> readIORef (theoremMap d res <- TC.runTCM m sc Nothing [] case res of Left msg -> fail (unlines (TC.prettyTCError msg)) - Right p' -> checkApply hyps (Prop p') es + Right p' -> checkApply hyps mkSqt (Prop p') es checkTheorem :: Set TheoremNonce -> Theorem -> IO () checkTheorem hyps (LocalAssumption p loc n) = @@ -775,18 +858,22 @@ checkEvidence sc db = \e p -> do hyps <- Map.keysSet <$> readIORef (theoremMap d check :: Set TheoremNonce -> Evidence -> - Prop -> + Sequent -> IO (Set TheoremNonce, TheoremSummary) - check hyps e p@(Prop ptm) = case e of + check hyps e sqt = case e of ProofTerm 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" - , showTerm ptm - , showTerm tm - ] - return (mempty, ProvedTheorem mempty) + case sequentState sqt of + GoalFocus (Prop ptm) _ -> + do ty <- TC.scTypeCheckError sc tm + ok <- scConvertible sc True ptm ty + unless ok $ fail $ unlines + [ "Proof term does not prove the required proposition" + , showTerm ptm + , showTerm tm + ] + return (mempty, ProvedTheorem mempty) + _ -> fail "Sequent must be goal-focused for proof term evidence" + LocalAssumptionEvidence (Prop l) n -> do unless (Set.member n hyps) $ fail $ unlines @@ -795,83 +882,92 @@ checkEvidence sc db = \e p -> do hyps <- Map.keysSet <$> readIORef (theoremMap d ] return (Set.singleton n, ProvedTheorem mempty) - SolverEvidence stats (Prop p') -> - do ok <- scConvertible sc False ptm p' + SolverEvidence stats sqt' -> + do ok <- sequentSubsumes sc sqt' sqt unless ok $ fail $ unlines - [ "Solver proof does not prove the required proposition" - , showTerm ptm - , showTerm p' + [ "Solver proof does not prove the required sequent" + , prettySequent defaultPPOpts sqt + , prettySequent defaultPPOpts sqt' ] return (mempty, ProvedTheorem stats) - Admitted msg pos (Prop p') -> - do ok <- scConvertible sc False ptm p' + Admitted msg pos sqt' -> + do ok <- sequentSubsumes sc sqt' sqt unless ok $ fail $ unlines - [ "Admitted proof does not match the required proposition " ++ show pos + [ "Admitted proof does not match the required sequent " ++ show pos , Text.unpack msg - , showTerm ptm - , showTerm p' + , prettySequent defaultPPOpts sqt + , prettySequent defaultPPOpts sqt' ] return (mempty, AdmittedTheorem msg) - QuickcheckEvidence n (Prop p') -> - do ok <- scConvertible sc False ptm p' + QuickcheckEvidence n sqt' -> + do ok <- sequentSubsumes sc sqt' sqt unless ok $ fail $ unlines - [ "Quickcheck evidence does not match the required proposition" - , showTerm ptm - , showTerm p' + [ "Quickcheck evidence does not match the required sequent" + , prettySequent defaultPPOpts sqt + , prettySequent defaultPPOpts sqt' ] return (mempty, TestedTheorem n) SplitEvidence e1 e2 -> - splitProp sc p >>= \case + splitSequent sc sqt >>= \case Nothing -> fail $ unlines - [ "Split evidence does not apply to non-conjunction prop" - , showTerm ptm + [ "Split evidence does not apply" + , prettySequent defaultPPOpts sqt ] - Just (p1,p2) -> - do d1 <- check hyps e1 p1 - d2 <- check hyps e2 p2 + Just (sqt1,sqt2) -> + do d1 <- check hyps e1 sqt1 + d2 <- check hyps e2 sqt2 return (d1 <> d2) ApplyEvidence thm es -> - do checkTheorem hyps thm - (d,sy,p') <- checkApply hyps (thmProp thm) es - ok <- scConvertible sc False ptm p' - unless ok $ fail $ unlines - [ "Apply evidence does not match the required proposition" - , showTerm ptm - , showTerm p' - ] - return (Set.insert (thmNonce thm) d, sy) + case sequentState sqt of + GoalFocus p mkSqt -> + do checkTheorem hyps thm + (d,sy,p') <- checkApply hyps mkSqt (thmProp thm) es + ok <- scConvertible sc False (unProp p) p' + unless ok $ fail $ unlines + [ "Apply evidence does not match the required proposition" + , showTerm (unProp p) + , showTerm p' + ] + return (Set.insert (thmNonce thm) d, sy) + _ -> fail $ unlines $ + [ "Apply evidence requires a goal-focused sequent" + , prettySequent defaultPPOpts sqt + ] +{- CutEvidence thm e' -> do checkTheorem hyps thm p' <- scFun sc (unProp (thmProp thm)) ptm (d,sy) <- check hyps e' (Prop p') return (Set.insert (thmNonce thm) d, sy) +-} UnfoldEvidence vars e' -> - do p' <- unfoldProp sc vars p - check hyps e' p' + do sqt' <- traverseSequent (unfoldProp sc vars) sqt + check hyps e' sqt' RewriteEvidence ss e' -> - do (d1,p') <- simplifyProp sc ss p + do (d1,sqt') <- simplifySequent sc ss sqt unless (Set.isSubsetOf d1 hyps) $ fail $ unlines [ "Rewrite step used theorem not in hypothesis database" , show (Set.difference d1 hyps) ] - (d2,sy) <- check hyps e' p' + (d2,sy) <- check hyps e' sqt' return (Set.union d1 d2, sy) HoistIfsEvidence e' -> - do p' <- hoistIfsInGoal sc p - check hyps e' p' + do sqt' <- traverseSequent (hoistIfsInGoal sc) sqt + check hyps e' sqt' EvalEvidence vars e' -> - do p' <- evalProp sc vars p - check hyps e' p' + do sqt' <- traverseSequent (evalProp sc vars) sqt + check hyps e' sqt' +{- AssumeEvidence n (Prop p') e' -> case asPi ptm of Nothing -> fail $ unlines ["Assume evidence expected function prop", showTerm ptm] @@ -888,21 +984,27 @@ checkEvidence sc db = \e p -> do hyps <- Map.keysSet <$> readIORef (theoremMap d ] (d,sy) <- check (Set.insert n hyps) e' (Prop body) return (Set.delete n d, sy) +-} - ForallEvidence x e' -> - case asPi ptm of - Nothing -> fail $ unlines ["Assume evidence expected function prop", showTerm ptm] - Just (_lnm, ty, body) -> - do let ty' = ecType x - ok <- scConvertible sc False ty ty' - unless ok $ fail $ unlines - ["Forall evidence types do not match" - , showTerm ty' - , showTerm ty - ] - x' <- scExtCns sc x - body' <- instantiateVar sc 0 x' body - check hyps e' (Prop body') + IntroEvidence x e' -> + -- TODO! Check that the given ExtCns is fresh for the sequent + case sequentState sqt of + Unfocused -> fail "Intro evidence requires a focused sequent" + HypFocus _ _ -> fail "Intro evidence apply in hypothesis: TODO: apply to existentials" + GoalFocus (Prop ptm) mkSqt -> + case asPi ptm of + Nothing -> fail $ unlines ["Assume evidence expected function prop", showTerm ptm] + Just (_lnm, ty, body) -> + do let ty' = ecType x + ok <- scConvertible sc False ty ty' + unless ok $ fail $ unlines + ["Forall evidence types do not match" + , showTerm ty' + , showTerm ty + ] + x' <- scExtCns sc x + body' <- instantiateVar sc 0 x' body + check hyps e' (mkSqt (Prop body')) passthroughEvidence :: [Evidence] -> IO Evidence passthroughEvidence [e] = pure e @@ -923,7 +1025,7 @@ setProofTimeout to ps = ps { _psTimeout = Just to } startProof :: ProofGoal -> Pos -> Maybe ProgramLoc -> Text -> IO ProofState startProof g pos ploc rsn = do start <- getCurrentTime - pure (ProofState [g] (goalProp g,pos,ploc,rsn) mempty Nothing passthroughEvidence start) + pure (ProofState [g] (goalSequent g,pos,ploc,rsn) mempty Nothing passthroughEvidence start) -- | Attempt to complete a proof by checking that all subgoals have been discharged, -- and validate the computed evidence to ensure that it supports the original @@ -934,12 +1036,13 @@ finishProof sc db ps@(ProofState gs (concl,loc,ploc,rsn) stats _ checkEv start) case gs of [] -> do e <- checkEv [] - (deps,sy) <- checkEvidence sc db e concl + conclProp <- sequentToProp sc concl + (deps,sy) <- checkEvidence sc db e conclProp n <- freshNonce globalNonceGenerator end <- getCurrentTime thm <- recordTheorem db Theorem - { _thmProp = concl + { _thmProp = conclProp , _thmStats = stats , _thmEvidence = e , _thmLocation = loc @@ -1097,13 +1200,13 @@ propToSATQuery sc unintSet prop = -- | 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 [Either Term Prop]) +goalApply :: SharedContext -> Prop -> Prop -> IO (Maybe [Either Term Prop]) goalApply sc rule goal = applyFirst (asPiLists (unProp rule)) where applyFirst [] = pure Nothing applyFirst ((ruleArgs, ruleConcl) : rest) = - do result <- scMatch sc ruleConcl (unProp (goalProp goal)) + do result <- scMatch sc ruleConcl (unProp goal) case result of Nothing -> applyFirst rest Just inst -> @@ -1141,18 +1244,24 @@ tacticIntro :: (F.MonadFail m, MonadIO m) => Text {- ^ Name to give to the variable. If empty, will be chosen automatically from the goal. -} -> Tactic m TypedTerm tacticIntro sc usernm = Tactic \goal -> - case asPi (unProp (goalProp goal)) of - Just (nm, tp, body) -> - do let name = if Text.null usernm then nm else usernm - xv <- liftIO $ scFreshEC sc name tp - x <- liftIO $ scExtCns sc xv - tt <- liftIO $ mkTypedTerm sc x - body' <- liftIO $ instantiateVar sc 0 x body - let goal' = goal { goalProp = Prop body' } - return (tt, mempty, [goal'], forallEvidence xv) + case sequentState (goalSequent goal) of + GoalFocus p mkSqt -> + case asPi (unProp p) of + Just (nm, tp, body) -> + do let name = if Text.null usernm then nm else usernm + xv <- liftIO $ scFreshEC sc name tp + x <- liftIO $ scExtCns sc xv + tt <- liftIO $ mkTypedTerm sc x + body' <- liftIO $ instantiateVar sc 0 x body + let goal' = goal { goalSequent = mkSqt (Prop body') } + return (tt, mempty, [goal'], introEvidence xv) + + _ -> fail "intro tactic failed: not a function" - _ -> fail "intro tactic failed: not a function" + HypFocus _ _ -> fail "TODO: implement intro on hyps" + Unfocused -> fail "intro tactic: focus required" +{- -- | Attempt to prove an implication goal by introducing a local assumption for -- hypothesis. Return a @Theorem@ representing this local assumption. -- This hypothesis should only be used for proving subgoals arising @@ -1177,20 +1286,25 @@ tacticCut sc thm = Tactic \goal -> do body' <- liftIO (scFun sc (unProp (thmProp thm)) (unProp (goalProp goal))) let goal' = goal{ goalProp = Prop body' } return ((), mempty, [goal'], cutEvidence thm) +-} -- | Attempt to prove a goal by applying the given theorem. Any hypotheses of -- the theorem will generate additional subgoals. tacticApply :: (F.MonadFail m, MonadIO m) => SharedContext -> Theorem -> Tactic m () tacticApply sc thm = Tactic \goal -> - liftIO (goalApply sc (thmProp thm) goal) >>= \case - Nothing -> fail "apply tactic failed: no match" - 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) + case sequentState (goalSequent goal) of + Unfocused -> fail "apply tactic: focus required" + HypFocus _ _ -> fail "apply tactic: cannot apply in a hypothesis" + GoalFocus gl mkSqt -> + liftIO (goalApply sc (thmProp thm) gl) >>= \case + Nothing -> fail "apply tactic failed: no match" + Just newterms -> + let newgoals = + [ goal{ goalSequent = mkSqt 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] @@ -1203,39 +1317,51 @@ tacticApply sc thm = Tactic \goal -> -- two subgoals will be produced, representing the two conjuncts to be proved. tacticSplit :: (F.MonadFail m, MonadIO m) => SharedContext -> Tactic m () tacticSplit sc = Tactic \gl -> - liftIO (splitProp sc (goalProp gl)) >>= \case - Nothing -> fail "split tactic failed: goal not a conjunction" - Just (p1,p2) -> - do let g1 = gl{ goalType = goalType gl ++ ".left", goalProp = p1 } - let g2 = gl{ goalType = goalType gl ++ ".right", goalProp = p2 } - return ((), mempty, [g1,g2], splitEvidence) + case sequentState (goalSequent gl) of + Unfocused -> fail "split tactic: focus required" + HypFocus _ _ -> fail "split tactic: TODO implement splitting in hyps" + GoalFocus g mkSqt -> + liftIO (splitProp sc g) >>= \case + Nothing -> fail "split tactic failed: goal not a conjunction" + Just (p1,p2) -> + do let g1 = gl{ goalType = goalType gl ++ ".left", goalSequent = mkSqt p1 } + let g2 = gl{ goalType = goalType gl ++ ".right", goalSequent = mkSqt p2 } + return ((), mempty, [g1,g2], splitEvidence) -- | Attempt to solve a goal by recognizing it as a trivially true proposition. tacticTrivial :: (F.MonadFail m, MonadIO m) => SharedContext -> Tactic m () tacticTrivial sc = Tactic \goal -> - liftIO (trivialProofTerm sc (goalProp goal)) >>= \case - Left err -> fail err - Right pf -> - do let gp = unProp (goalProp goal) - ty <- liftIO $ TC.scTypeCheckError sc pf - ok <- liftIO $ scConvertible sc True gp ty - unless ok $ fail $ unlines - [ "The trivial tactic cannot prove this equality" - , showTerm gp - ] - return ((), mempty, [], leafEvidence (ProofTerm pf)) + case sequentState (goalSequent goal) of + Unfocused -> fail "trivial tactic: focus required" + HypFocus _ _ -> fail "trivial tactic: cannot apply trivial in a hypothesis" + GoalFocus g _ -> + liftIO (trivialProofTerm sc g) >>= \case + Left err -> fail err + Right pf -> + do let gp = unProp g + ty <- liftIO $ TC.scTypeCheckError sc pf + ok <- liftIO $ scConvertible sc True gp ty + unless ok $ fail $ unlines + [ "The trivial tactic cannot prove this equality" + , showTerm gp + ] + return ((), mempty, [], leafEvidence (ProofTerm pf)) tacticExact :: (F.MonadFail m, MonadIO m) => SharedContext -> Term -> Tactic m () tacticExact sc tm = Tactic \goal -> - do let gp = unProp (goalProp goal) - 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" - , showTerm gp - , showTerm tm - ] - return ((), mempty, [], leafEvidence (ProofTerm tm)) + case sequentState (goalSequent goal) of + Unfocused -> fail "tactic exact: focus required" + HypFocus _ _ -> fail "tactic exact: cannot apply exact in a hypothesis" + GoalFocus g _ -> + do let gp = unProp g + 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" + , showTerm gp + , showTerm tm + ] + return ((), mempty, [], leafEvidence (ProofTerm tm)) -- | Examine the given proof goal and potentially do some work with it, @@ -1266,7 +1392,7 @@ tacticSolve f = Tactic \gl -> -- The tactic should return a new proposition to prove and a method for -- transferring evidence for the modified proposition into a evidence for -- the original goal. -tacticChange :: Monad m => (ProofGoal -> m (Prop, Evidence -> Evidence)) -> Tactic m () +tacticChange :: Monad m => (ProofGoal -> m (Sequent, Evidence -> Evidence)) -> Tactic m () tacticChange f = Tactic \gl -> - do (p, ef) <- lift (f gl) - return ((), mempty, [ gl{ goalProp = p } ], updateEvidence ef) + do (sqt, ef) <- lift (f gl) + return ((), mempty, [ gl{ goalSequent = sqt } ], updateEvidence ef) diff --git a/src/SAWScript/Prover/ABC.hs b/src/SAWScript/Prover/ABC.hs index 77e9ef3c3e..2346928d31 100644 --- a/src/SAWScript/Prover/ABC.hs +++ b/src/SAWScript/Prover/ABC.hs @@ -29,7 +29,11 @@ import Verifier.SAW.SATQuery import Verifier.SAW.SharedTerm import qualified Verifier.SAW.Simulator.BitBlast as BBSim -import SAWScript.Proof(Prop, propToSATQuery, propSize, goalProp, ProofGoal, goalType, goalNum, CEX) +import SAWScript.Proof + ( Prop, propToSATQuery, sequentToSATQuery, propSize + , goalSequent, ProofGoal, goalType, goalNum, CEX + , sequentToProp + ) import SAWScript.Prover.SolverStats (SolverStats, solverStats) import qualified SAWScript.Prover.Exporter as Exporter import SAWScript.Prover.Util (liftCexBB, liftLECexBB) @@ -166,7 +170,7 @@ abcSatExternal :: MonadIO m => ProofGoal -> m (Maybe CEX, SolverStats) abcSatExternal proxy sc doCNF execName args g = liftIO $ - do satq <- propToSATQuery sc mempty (goalProp g) + do satq <- sequentToSATQuery sc mempty (goalSequent g) let cnfName = goalType g ++ show (goalNum g) ++ ".cnf" (path, fh) <- openTempFile "." cnfName hClose fh -- Yuck. TODO: allow writeCNF et al. to work on handles. @@ -184,7 +188,8 @@ abcSatExternal proxy sc doCNF execName args g = liftIO $ let ls = lines out sls = filter ("s " `isPrefixOf`) ls vls = filter ("v " `isPrefixOf`) ls - let stats = solverStats ("external SAT:" ++ execName) (propSize (goalProp g)) + gp <- sequentToProp sc (goalSequent g) + let stats = solverStats ("external SAT:" ++ execName) (propSize gp) case (sls, vls) of (["s SATISFIABLE"], _) -> do let bs = parseDimacsSolution variables vls From 7dcc91dad57cc056fba35ada70148586263356e3 Mon Sep 17 00:00:00 2001 From: Rob Dockins Date: Tue, 7 Jun 2022 18:03:55 -0700 Subject: [PATCH 03/35] Next steps toward sequent refactorings --- src/SAWScript/Builtins.hs | 28 ++- src/SAWScript/Proof.hs | 291 ++++++++++++++++++++++++--- src/SAWScript/Prover/ABC.hs | 25 ++- src/SAWScript/Prover/Exporter.hs | 9 +- src/SAWScript/Prover/MRSolver/SMT.hs | 4 +- src/SAWScript/Prover/RME.hs | 8 +- src/SAWScript/Prover/SBV.hs | 12 +- src/SAWScript/Prover/What4.hs | 24 +-- 8 files changed, 315 insertions(+), 86 deletions(-) diff --git a/src/SAWScript/Builtins.hs b/src/SAWScript/Builtins.hs index 8e4274f52e..ec5cbca581 100644 --- a/src/SAWScript/Builtins.hs +++ b/src/SAWScript/Builtins.hs @@ -487,12 +487,9 @@ print_goal_depth n = printGoalConsts :: ProofScript () printGoalConsts = execTactic $ tacticId $ \goal -> - do sc <- getSharedContext - tm <- io (propToTerm sc =<< sequentToProp sc (goalSequent goal)) + do let cs = sequentConstantSet (goalSequent goal) mapM_ (printOutLnTop Info) $ - [ show nm - | (_,(nm,_,_)) <- Map.toList (getConstantSet tm) - ] + [ show nm | (_,(nm,_,_)) <- Map.toList cs ] printGoalSize :: ProofScript () printGoalSize = @@ -715,7 +712,7 @@ beta_reduce_goal = execTactic $ tacticChange $ \goal -> do sc <- getSharedContext sqt' <- traverseSequent (io . betaReduceProp sc) (goalSequent goal) - return (sqt', id) + return (sqt', ConversionEvidence sqt') goal_apply :: Theorem -> ProofScript () goal_apply thm = @@ -833,24 +830,23 @@ proveUnintSBV conf unints = unintSet <- SV.scriptTopLevel (resolveNames unints) wrapProver (Prover.proveUnintSBV conf unintSet timeout) -applyProverToGoal :: (Prop -> TopLevel (Maybe CEX, SolverStats)) +applyProverToGoal :: (Sequent -> TopLevel (Maybe CEX, SolverStats)) -> ProofGoal -> TopLevel (SolverStats, SolveResult) applyProverToGoal f g = do - sc <- getSharedContext - (mb, stats) <- f =<< io (sequentToProp sc (goalSequent g)) + (mb, stats) <- f (goalSequent g) case mb of Nothing -> return (stats, SolveSuccess (SolverEvidence stats (goalSequent g))) Just a -> return (stats, SolveCounterexample a) wrapProver :: - (Prop -> TopLevel (Maybe CEX, SolverStats)) -> + (Sequent -> TopLevel (Maybe CEX, SolverStats)) -> ProofScript () wrapProver f = execTactic $ tacticSolve $ applyProverToGoal f wrapW4Prover :: ( Set VarIndex -> Bool -> - Prop -> TopLevel (Maybe CEX, SolverStats)) -> + Sequent -> TopLevel (Maybe CEX, SolverStats)) -> [String] -> ProofScript () wrapW4Prover f unints = do @@ -860,7 +856,7 @@ wrapW4Prover f unints = do wrapW4ProveExporter :: ( Set VarIndex -> Bool -> FilePath -> - Prop -> TopLevel (Maybe CEX, SolverStats)) -> + Sequent -> TopLevel (Maybe CEX, SolverStats)) -> [String] -> String -> String -> @@ -960,8 +956,7 @@ proveWithSATExporter :: proveWithSATExporter exporter unintSet path sep ext = execTactic $ tacticSolve $ \g -> do let file = path ++ sep ++ goalType g ++ show (goalNum g) ++ ext - sc <- getSharedContext - stats <- Prover.proveWithSATExporter exporter unintSet file =<< io (sequentToProp sc (goalSequent g)) + stats <- Prover.proveWithSATExporter exporter unintSet file (goalSequent g) return (stats, SolveSuccess (SolverEvidence stats (goalSequent g))) proveWithPropExporter :: @@ -974,7 +969,8 @@ proveWithPropExporter exporter path sep ext = execTactic $ tacticSolve $ \g -> do let file = path ++ sep ++ goalType g ++ show (goalNum g) ++ ext sc <- getSharedContext - stats <- Prover.proveWithPropExporter exporter file =<< io (sequentToProp sc (goalSequent g)) + p <- io $ sequentToProp sc (goalSequent g) + stats <- Prover.proveWithPropExporter exporter file p return (stats, SolveSuccess (SolverEvidence stats (goalSequent g))) offline_aig :: FilePath -> ProofScript () @@ -1471,7 +1467,7 @@ term_theories unints t = do unintSet <- resolveNames unints hashConsing <- gets SV.rwWhat4HashConsing prop <- io (predicateToProp sc Universal (ttTerm t)) - Prover.what4Theories unintSet hashConsing prop + Prover.what4Theories unintSet hashConsing (propToSequent prop) default_typed_term :: TypedTerm -> TopLevel TypedTerm default_typed_term tt = do diff --git a/src/SAWScript/Proof.hs b/src/SAWScript/Proof.hs index 97059198f9..cbab22cea3 100644 --- a/src/SAWScript/Proof.hs +++ b/src/SAWScript/Proof.hs @@ -15,7 +15,8 @@ Stability : provisional module SAWScript.Proof ( Prop - , splitProp + , splitConj + , splitDisj , unfoldProp , simplifyProp , hoistIfsInGoal @@ -42,6 +43,7 @@ module SAWScript.Proof , propToSequent , traverseSequent , checkSequent + , sequentConstantSet , TheoremDB , newTheoremDB @@ -203,11 +205,9 @@ propToRewriteRule _sc (Prop tm) ann = Nothing -> pure Nothing Just r -> pure (Just r) --- | Attempt to split a conjunctive proposition into two propositions, --- such that a proof of both return propositions is equivalent to --- a proof of the original. -splitProp :: SharedContext -> Prop -> IO (Maybe (Prop, Prop)) -splitProp sc (Prop p) = +-- | Attempt to split a conjunctive proposition into two propositions. +splitConj :: SharedContext -> Prop -> IO (Maybe (Prop, Prop)) +splitConj sc (Prop p) = do let (vars, body) = asPiList p case (isGlobalDef "Prelude.and" <@> return <@> return) =<< asEqTrue body of Nothing -> pure Nothing @@ -216,11 +216,30 @@ splitProp sc (Prop p) = t2 <- scPiList sc vars =<< scEqTrue sc p2 return (Just (Prop t1,Prop t2)) +-- | Attempt to split a disjunctive proposition into two propositions. +splitDisj :: SharedContext -> Prop -> IO (Maybe (Prop, Prop)) +splitDisj sc (Prop p) = + do let (vars, body) = asPiList p + case (isGlobalDef "Prelude.or" <@> return <@> return) =<< asEqTrue body of + Nothing -> pure Nothing + Just (_ :*: p1 :*: p2) -> + do t1 <- scPiList sc vars =<< scEqTrue sc p1 + t2 <- scPiList sc vars =<< scEqTrue sc p2 + return (Just (Prop t1,Prop t2)) + + splitSequent :: SharedContext -> Sequent -> IO (Maybe (Sequent, Sequent)) -splitSequent sc (Sequent_ p) = - splitProp sc p >>= \case - Nothing -> return Nothing - Just (x, y) -> return (Just (Sequent_ x, Sequent_ y)) +splitSequent sc sqt = + case sequentState sqt of + GoalFocus g mkSqt -> + splitConj sc g >>= \case + Nothing -> return Nothing + Just (x, y) -> return (Just (mkSqt x, mkSqt y)) + HypFocus h mkSqt -> + splitDisj sc h >>= \case + Nothing -> return Nothing + Just (x, y) -> return (Just (mkSqt x, mkSqt y)) + Unfocused -> fail "split tactic: focus required" -- | Unfold all the constants appearing in the proposition -- whose VarIndex is found in the given set. @@ -235,11 +254,27 @@ simplifyProp sc ss (Prop tm) = do (a, tm') <- rewriteSharedTerm sc ss tm return (a, Prop tm') +-- | Rewrite the propositions using the provided Simpset +simplifyProps :: Ord a => SharedContext -> Simpset a -> [Prop] -> IO (Set a, [Prop]) +simplifyProps _sc _ss [] = return (mempty, []) +simplifyProps sc ss (p:ps) = + do (a, p') <- simplifyProp sc ss p + (b, ps') <- simplifyProps sc ss ps + return (Set.union a b, p' : ps') + -- | Rewrite in the sequent using the provided Simpset simplifySequent :: Ord a => SharedContext -> Simpset a -> Sequent -> IO (Set a, Sequent) -simplifySequent sc ss (Sequent_ p) = - do (a, p') <- simplifyProp sc ss p - return (a, Sequent_ p') +simplifySequent sc ss (UnfocusedSequent hs gs) = + do (a, hs') <- simplifyProps sc ss hs + (b, gs') <- simplifyProps sc ss gs + return (Set.union a b, UnfocusedSequent hs' gs') +simplifySequent sc ss (GoalFocusedSequent hs (gs1,g,gs2)) = + do (a, g') <- simplifyProp sc ss g + return (a, GoalFocusedSequent hs (gs1, g', gs2)) +simplifySequent sc ss (HypFocusedSequent (hs1, h, hs2) gs) = + do (a, h') <- simplifyProp sc ss h + return (a, HypFocusedSequent (hs1, h', hs2) gs) + hoistIfsInGoal :: SharedContext -> Prop -> IO Prop hoistIfsInGoal sc (Prop p) = do @@ -320,10 +355,117 @@ prettyProp opts (Prop tm) = scPrettyTerm opts tm ppProp :: PPOpts -> Prop -> SawDoc ppProp opts (Prop tm) = ppTerm opts tm +-- TODO, I'd like to add metadata here +type SequentBranch = Prop + +data Sequent + = UnfocusedSequent [SequentBranch] [SequentBranch] + | GoalFocusedSequent [SequentBranch] ([SequentBranch], SequentBranch, [SequentBranch]) + | HypFocusedSequent ([SequentBranch], SequentBranch, [SequentBranch]) [SequentBranch] + +sequentToRawSequent :: Sequent -> RawSequent +sequentToRawSequent sqt = + case sqt of + UnfocusedSequent hs gs -> f hs gs + GoalFocusedSequent hs (gs1, g, gs2) -> f hs (gs1 ++ g : gs2) + HypFocusedSequent (hs1, h, hs2) gs -> f (hs1 ++ h : hs2) gs + + where + f hs gs = RawSequent (map toRaw hs) (map toRaw gs) + toRaw (Prop p) = + case asEqTrue p of + Just p' -> p' + Nothing -> p + +sequentConstantSet :: Sequent -> Map VarIndex (NameInfo, Term, Maybe Term) +sequentConstantSet sqt = foldr (\t m -> Map.union (getConstantSet t) m) mempty (hs++gs) + where + RawSequent hs gs = sequentToRawSequent sqt + +data RawSequent = RawSequent [Term] [Term] +data NormalizedSequent = NormSeq (Set Term) (Set Term) + +normalizedSequentSubsumes :: NormalizedSequent -> NormalizedSequent -> Bool +normalizedSequentSubsumes (NormSeq h1 g1) (NormSeq h2 g2) = + (h1 `Set.isSubsetOf` h2) && (g1 `Set.isSubsetOf` g2) + +normalizedSequentIsAxiom :: SharedContext -> NormalizedSequent -> IO Bool +normalizedSequentIsAxiom sc (NormSeq hset gset) = + loop [ (h,g) | h <- Set.toList hset, g <- Set.toList gset ] + where + loop [] = return False + loop ((h,g):xs) = + do ok <- scConvertible sc False h g + if ok then return True else loop xs + +convertibleTerms :: SharedContext -> [Term] -> [Term] -> IO Bool +convertibleTerms _sc [] [] = return True +convertibleTerms sc (p1:ps1) (p2:ps2) = + do ok1 <- scConvertible sc False p1 p2 + ok2 <- convertibleTerms sc ps1 ps2 + return (ok1 && ok2) +convertibleTerms _sc _ _ = return False + +convertibleSequents :: SharedContext -> Sequent -> Sequent -> IO Bool +convertibleSequents sc sqt1 sqt2 = + do ok1 <- convertibleTerms sc hs1 hs2 + ok2 <- convertibleTerms sc gs1 gs2 + return (ok1 && ok2) + where + RawSequent hs1 gs1 = sequentToRawSequent sqt1 + RawSequent hs2 gs2 = sequentToRawSequent sqt2 + + +normalizeSequent :: SharedContext -> RawSequent -> IO NormalizedSequent +normalizeSequent sc = loop (NormSeq mempty mempty) + where + loop (NormSeq hset gset) (RawSequent (h:hs) gs) = + do body <- scWhnf sc h + case () of + _ | Just (_ :*: p1) <- (isGlobalDef "Prelude.not" <@> return) body + -> loop (NormSeq hset gset) (RawSequent hs (p1 : gs)) + + | Just (_ :*: p1 :*: p2) <- (isGlobalDef "Prelude.and" <@> return <@> return) body + -> loop (NormSeq hset gset) (RawSequent (p1 : p2 : hs) gs) + + | Just (_ :*: p1 :*: p2) <- (isGlobalDef "Prelude.xor" <@> return <@> return) body + -> do g1 <- scBoolEq sc p1 p2 + loop (NormSeq hset gset) (RawSequent hs (g1:gs)) + + | Just _ <- (isGlobalDef "Prelude.True") body + -> loop (NormSeq hset gset) (RawSequent hs gs) + + | Just _ <- (isGlobalDef "Prelude.False") body + -> return (NormSeq (Set.singleton body) (Set.singleton body)) + + | otherwise -> + loop (NormSeq (Set.insert h hset) gset) (RawSequent hs gs) + + loop (NormSeq hset gset) (RawSequent [] (g:gs)) = + do body <- scWhnf sc g + case () of + _ | Just (_ :*: p1) <- (isGlobalDef "Prelude.not" <@> return) body + -> loop (NormSeq hset gset) (RawSequent [p1] gs) + + | Just (_ :*: p1 :*: p2) <- (isGlobalDef "Prelude.or" <@> return <@> return) body + -> loop (NormSeq hset gset) (RawSequent [] (p1 : p2 : gs)) + + | Just (_ :*: p1 :*: p2) <- (isGlobalDef "Prelude.xor" <@> return <@> return) body + -> do h1 <- scBoolEq sc p1 p2 + loop (NormSeq hset gset) (RawSequent [h1] gs) + + | Just _ <- (isGlobalDef "Prelude.False") body + -> loop (NormSeq hset gset) (RawSequent [] gs) + + | Just _ <- (isGlobalDef "Prelude.True") body + -> return (NormSeq (Set.singleton body) (Set.singleton body)) + + | otherwise -> + loop (NormSeq hset (Set.insert g gset)) (RawSequent [] gs) + + loop (NormSeq hset gset) (RawSequent [] []) = return (NormSeq hset gset) --- Dummy definition for now -data Sequent = Sequent_ Prop data SequentState = Unfocused @@ -331,10 +473,21 @@ data SequentState | HypFocus Prop (Prop -> Sequent) propToSequent :: Prop -> Sequent -propToSequent p = Sequent_ p +propToSequent p = GoalFocusedSequent [] ([], p, []) sequentToProp :: SharedContext -> Sequent -> IO Prop -sequentToProp _sc (Sequent_ p) = return p +sequentToProp sc sqt = + case sqt of + UnfocusedSequent hs [g] -> loop hs g + GoalFocusedSequent hs ([],g,[]) -> loop hs g + HypFocusedSequent (hs1,h,hs2) [g] -> loop (hs1++h:hs2) g + _ -> fail "sequentToProp cannot currently handle multi-conclusion sequents FIXME" + + where + loop [] g = return g + loop (h:hs) g = + do g' <- loop hs g + Prop <$> scFun sc (unProp h) (unProp g') sequentToSATQuery :: SharedContext -> Set VarIndex -> Sequent -> IO SATQuery sequentToSATQuery sc unintSet sqt = @@ -342,23 +495,50 @@ sequentToSATQuery sc unintSet sqt = -- | Pretty print the given proposition as a string. prettySequent :: PPOpts -> Sequent -> String -prettySequent opts (Sequent_ p) = prettyProp opts p +prettySequent opts sqt = show (ppSequent opts sqt) -- | Pretty print the given proposition as a @SawDoc@. ppSequent :: PPOpts -> Sequent -> SawDoc -ppSequent opts (Sequent_ p) = ppProp opts p +ppSequent opts sqt = + case sqt of + GoalFocusedSequent [] ([],g,[]) -> ppProp opts g + _ -> error "FIXME! implement printing for sequents" sequentState :: Sequent -> SequentState -sequentState (Sequent_ p) = GoalFocus p Sequent_ +sequentState (UnfocusedSequent _ _) = Unfocused +sequentState (GoalFocusedSequent hs (gs1,g,gs2)) = + GoalFocus g (\g' -> GoalFocusedSequent hs (gs1,g',gs2)) +sequentState (HypFocusedSequent (hs1,h,hs2) gs) = + HypFocus h (\h' -> HypFocusedSequent (hs1,h',hs2) gs) sequentSize :: Sequent -> Integer -sequentSize (Sequent_ p) = propSize p +sequentSize sqt = + case sqt of + GoalFocusedSequent [] ([],g,[]) -> propSize g + _ -> error "FIXME! implement size counding for sequents" traverseSequent :: Applicative m => (Prop -> m Prop) -> Sequent -> m Sequent -traverseSequent f (Sequent_ p) = Sequent_ <$> f p +traverseSequent f (UnfocusedSequent hs gs) = + UnfocusedSequent <$> traverse f hs <*> traverse f gs +traverseSequent f (GoalFocusedSequent hs (gs1, g, gs2)) = + (\g' -> GoalFocusedSequent hs (gs1, g', gs2)) <$> f g +traverseSequent f (HypFocusedSequent (hs1, h, hs2) gs) = + (\h' -> HypFocusedSequent (hs1, h', hs2) gs) <$> f h checkSequent :: SharedContext -> PPOpts -> Sequent -> IO () -checkSequent sc ppOpts (Sequent_ p) = checkProp sc ppOpts p +checkSequent sc ppOpts (UnfocusedSequent hs gs) = + do forM_ hs (checkProp sc ppOpts) + forM_ gs (checkProp sc ppOpts) +checkSequent sc ppOpts (GoalFocusedSequent hs (gs1,g,gs2)) = + do forM_ hs (checkProp sc ppOpts) + forM_ gs1 (checkProp sc ppOpts) + checkProp sc ppOpts g + forM_ gs2 (checkProp sc ppOpts) +checkSequent sc ppOpts (HypFocusedSequent (hs1,h,hs2) gs) = + do forM_ hs1 (checkProp sc ppOpts) + checkProp sc ppOpts h + forM_ hs2 (checkProp sc ppOpts) + forM_ gs (checkProp sc ppOpts) checkProp :: SharedContext -> PPOpts -> Prop -> IO () checkProp sc ppOpts (Prop t) = @@ -536,10 +716,24 @@ data Evidence -- evidence is use to check the modified goal. | EvalEvidence (Set VarIndex) Evidence + -- | This type of evidence is used to modify a focused part of the goal. + -- The modified goal should be equivalent up to conversion. + | ConversionEvidence Sequent Evidence + -- | This type of evidence is used to modify a goal to prove by applying -- 'hoistIfsInGoal'. | HoistIfsEvidence Evidence + -- | Change the state of the sequence in some "structural" way. This + -- can involve changing focus, or applying reversable sequent calculus + -- rules. + | StructuralEvidence Sequent Evidence + + -- | This type of evidence is used when the current sequent, after + -- applying structural rules, is an instance of the basic + -- sequent calculus axiom, which connects a hypothesis to a goal. + | AxiomEvidence + -- | The the proposition proved by a given theorem. thmProp :: Theorem -> Prop thmProp (LocalAssumption p _loc _n) = p @@ -807,8 +1001,15 @@ psStats = _psStats -- check that is sufficent to show that a proof -- of the first sequent is sufficent to prove the second sequentSubsumes :: SharedContext -> Sequent -> Sequent -> IO Bool -sequentSubsumes sc (Sequent_ p1) (Sequent_ p2) = - scConvertible sc False (unProp p1) (unProp p2) +sequentSubsumes sc sqt1 sqt2 = + do sqt1' <- normalizeSequent sc (sequentToRawSequent sqt1) + sqt2' <- normalizeSequent sc (sequentToRawSequent sqt2) + return (normalizedSequentSubsumes sqt1' sqt2') + +sequentIsAxiom :: SharedContext -> Sequent -> IO Bool +sequentIsAxiom sc sqt = + do sqt' <- normalizeSequent sc (sequentToRawSequent sqt) + normalizedSequentIsAxiom sc sqt' -- | Verify that the given evidence in fact supports the given proposition. -- Returns the identifers of all the theorems depended on while checking evidence. @@ -967,6 +1168,24 @@ checkEvidence sc db = \e p -> do hyps <- Map.keysSet <$> readIORef (theoremMap d do sqt' <- traverseSequent (evalProp sc vars) sqt check hyps e' sqt' + ConversionEvidence sqt' e' -> + do ok <- convertibleSequents sc sqt sqt' + unless ok $ fail $ unlines + [ "Converted sequent does not match goal" + , prettySequent defaultPPOpts sqt + , prettySequent defaultPPOpts sqt' + ] + check hyps e' sqt' + + StructuralEvidence sqt' e' -> + do ok <- sequentSubsumes sc sqt' sqt + unless ok $ fail $ unlines + [ "Restated sequents does not subsume goal" + , prettySequent defaultPPOpts sqt + , prettySequent defaultPPOpts sqt' + ] + check hyps e' sqt' + {- AssumeEvidence n (Prop p') e' -> case asPi ptm of @@ -986,6 +1205,14 @@ checkEvidence sc db = \e p -> do hyps <- Map.keysSet <$> readIORef (theoremMap d return (Set.delete n d, sy) -} + AxiomEvidence -> + do ok <- sequentIsAxiom sc sqt + unless ok $ fail $ unlines + [ "Sequent is not an instance of the sequent calculus axiom" + , prettySequent defaultPPOpts sqt + ] + return (mempty, ProvedTheorem mempty) + IntroEvidence x e' -> -- TODO! Check that the given ExtCns is fresh for the sequent case sequentState sqt of @@ -993,12 +1220,12 @@ checkEvidence sc db = \e p -> do hyps <- Map.keysSet <$> readIORef (theoremMap d HypFocus _ _ -> fail "Intro evidence apply in hypothesis: TODO: apply to existentials" GoalFocus (Prop ptm) mkSqt -> case asPi ptm of - Nothing -> fail $ unlines ["Assume evidence expected function prop", showTerm ptm] + Nothing -> fail $ unlines ["Intro evidence expected function prop", showTerm ptm] Just (_lnm, ty, body) -> do let ty' = ecType x ok <- scConvertible sc False ty ty' unless ok $ fail $ unlines - ["Forall evidence types do not match" + ["Intro evidence types do not match" , showTerm ty' , showTerm ty ] @@ -1319,9 +1546,15 @@ tacticSplit :: (F.MonadFail m, MonadIO m) => SharedContext -> Tactic m () tacticSplit sc = Tactic \gl -> case sequentState (goalSequent gl) of Unfocused -> fail "split tactic: focus required" - HypFocus _ _ -> fail "split tactic: TODO implement splitting in hyps" + HypFocus h mkSqt -> + liftIO (splitDisj sc h) >>= \case + Nothing -> fail "split tactic failed: hypothesis not a disjunction" + Just (p1,p2) -> + do let g1 = gl{ goalType = goalType gl ++ ".left", goalSequent = mkSqt p1 } + let g2 = gl{ goalType = goalType gl ++ ".right", goalSequent = mkSqt p2 } + return ((), mempty, [g1,g2], splitEvidence) GoalFocus g mkSqt -> - liftIO (splitProp sc g) >>= \case + liftIO (splitConj sc g) >>= \case Nothing -> fail "split tactic failed: goal not a conjunction" Just (p1,p2) -> do let g1 = gl{ goalType = goalType gl ++ ".left", goalSequent = mkSqt p1 } diff --git a/src/SAWScript/Prover/ABC.hs b/src/SAWScript/Prover/ABC.hs index 2346928d31..35be0ef0aa 100644 --- a/src/SAWScript/Prover/ABC.hs +++ b/src/SAWScript/Prover/ABC.hs @@ -30,9 +30,9 @@ import Verifier.SAW.SharedTerm import qualified Verifier.SAW.Simulator.BitBlast as BBSim import SAWScript.Proof - ( Prop, propToSATQuery, sequentToSATQuery, propSize - , goalSequent, ProofGoal, goalType, goalNum, CEX - , sequentToProp + ( sequentToSATQuery, goalSequent, ProofGoal + , goalType, goalNum, CEX + , Sequent, sequentSize ) import SAWScript.Prover.SolverStats (SolverStats, solverStats) import qualified SAWScript.Prover.Exporter as Exporter @@ -48,14 +48,14 @@ import Lang.JVM.ProcessUtils (readProcessExitIfFailure) proveABC :: (AIG.IsAIG l g) => AIG.Proxy l g -> - Prop -> + Sequent -> TopLevel (Maybe CEX, SolverStats) proveABC proxy goal = getSharedContext >>= \sc -> liftIO $ - do satq <- propToSATQuery sc mempty goal + do satq <- sequentToSATQuery sc mempty goal BBSim.withBitBlastedSATQuery proxy sc mempty satq $ \be lit shapes -> do let (ecs,fts) = unzip shapes res <- getModel ecs fts =<< AIG.checkSat be lit - let stats = solverStats "ABC" (propSize goal) + let stats = solverStats "ABC" (sequentSize goal) return (res, stats) @@ -87,7 +87,7 @@ getModel argNames shapes satRes = w4AbcVerilog :: Set VarIndex -> Bool -> - Prop -> + Sequent -> TopLevel (Maybe CEX, SolverStats) w4AbcVerilog = w4AbcExternal Exporter.writeVerilogSAT cmd where cmd tmp tmpCex = "%read " ++ tmp ++ @@ -97,7 +97,7 @@ w4AbcVerilog = w4AbcExternal Exporter.writeVerilogSAT cmd w4AbcAIGER :: Set VarIndex -> Bool -> - Prop -> + Sequent -> TopLevel (Maybe CEX, SolverStats) w4AbcAIGER = do w4AbcExternal Exporter.writeAIG_SAT cmd @@ -108,7 +108,7 @@ w4AbcExternal :: (String -> String -> String) -> Set VarIndex -> Bool -> - Prop -> + Sequent -> TopLevel (Maybe CEX, SolverStats) w4AbcExternal exporter argFn unints _hashcons goal = -- Create temporary files @@ -118,7 +118,7 @@ w4AbcExternal exporter argFn unints _hashcons goal = tmp <- liftIO $ emptySystemTempFile tpl tmpCex <- liftIO $ emptySystemTempFile tplCex - satq <- liftIO $ propToSATQuery sc unints goal + satq <- liftIO $ sequentToSATQuery sc unints goal (argNames, argTys) <- unzip <$> exporter tmp satq -- Run ABC and remove temporaries @@ -130,7 +130,7 @@ w4AbcExternal exporter argFn unints _hashcons goal = liftIO $ removeFile tmpCex -- Parse and report results - let stats = solverStats "abc_verilog" (propSize goal) + let stats = solverStats "abc_verilog" (sequentSize goal) res <- if all isSpace cexText then return Nothing else do cex <- liftIO $ parseAigerCex cexText argTys @@ -188,8 +188,7 @@ abcSatExternal proxy sc doCNF execName args g = liftIO $ let ls = lines out sls = filter ("s " `isPrefixOf`) ls vls = filter ("v " `isPrefixOf`) ls - gp <- sequentToProp sc (goalSequent g) - let stats = solverStats ("external SAT:" ++ execName) (propSize gp) + let stats = solverStats ("external SAT:" ++ execName) (sequentSize (goalSequent g)) case (sls, vls) of (["s SATISFIABLE"], _) -> do let bs = parseDimacsSolution variables vls diff --git a/src/SAWScript/Prover/Exporter.hs b/src/SAWScript/Prover/Exporter.hs index ee4cecd7ea..c255de5981 100644 --- a/src/SAWScript/Prover/Exporter.hs +++ b/src/SAWScript/Prover/Exporter.hs @@ -89,7 +89,8 @@ import qualified Verifier.SAW.UntypedAST as Un import SAWScript.Crucible.Common import SAWScript.Crucible.Common.MethodSpec (ppTypedTermType) -import SAWScript.Proof (Prop, propSize, propToTerm, predicateToSATQuery, propToSATQuery) +import SAWScript.Proof + (Prop, Sequent, propSize, sequentSize, propToTerm, predicateToSATQuery, sequentToSATQuery) import SAWScript.Prover.SolverStats import SAWScript.Prover.Util import SAWScript.Prover.What4 @@ -108,13 +109,13 @@ proveWithSATExporter :: (FilePath -> SATQuery -> TopLevel a) -> Set VarIndex -> String -> - Prop -> + Sequent -> TopLevel SolverStats proveWithSATExporter exporter unintSet path goal = do sc <- getSharedContext - satq <- io $ propToSATQuery sc unintSet goal + satq <- io $ sequentToSATQuery sc unintSet goal _ <- exporter path satq - let stats = solverStats ("offline: "++ path) (propSize goal) + let stats = solverStats ("offline: "++ path) (sequentSize goal) return stats diff --git a/src/SAWScript/Prover/MRSolver/SMT.hs b/src/SAWScript/Prover/MRSolver/SMT.hs index 29142dc90c..e5eef3d8d6 100644 --- a/src/SAWScript/Prover/MRSolver/SMT.hs +++ b/src/SAWScript/Prover/MRSolver/SMT.hs @@ -38,7 +38,7 @@ import Verifier.SAW.Simulator.Value import Verifier.SAW.Simulator.TermModel import Verifier.SAW.Simulator.Prims -import SAWScript.Proof (termToProp, propToTerm, prettyProp) +import SAWScript.Proof (termToProp, propToTerm, prettyProp, propToSequent) import What4.Solver import SAWScript.Prover.What4 @@ -292,7 +292,7 @@ mrProvableRaw prop_term = -- Haskell error - in this case we want to just return False, not stop -- execution smt_res <- liftIO $ - (Right <$> proveWhat4_solver z3Adapter sym unints sc prop (return ())) + (Right <$> proveWhat4_solver z3Adapter sym unints sc (propToSequent prop) (return ())) `X.catch` \case UserError msg -> return $ Left msg e -> X.throw e diff --git a/src/SAWScript/Prover/RME.hs b/src/SAWScript/Prover/RME.hs index d0824e81f3..58b5a61425 100644 --- a/src/SAWScript/Prover/RME.hs +++ b/src/SAWScript/Prover/RME.hs @@ -9,19 +9,19 @@ import Verifier.SAW.FiniteValue import qualified Verifier.SAW.Simulator.RME as RME -import SAWScript.Proof(Prop, propToSATQuery, propSize, CEX) +import SAWScript.Proof(Sequent, sequentToSATQuery, sequentSize, CEX) import SAWScript.Prover.SolverStats import SAWScript.Prover.Util import SAWScript.Value -- | Bit-blast a proposition and check its validity using RME. proveRME :: - Prop {- ^ A proposition to be proved -} -> + Sequent {- ^ A proposition to be proved -} -> TopLevel (Maybe CEX, SolverStats) proveRME goal = getSharedContext >>= \sc -> liftIO $ - do satq <- propToSATQuery sc mempty goal + do satq <- sequentToSATQuery sc mempty goal RME.withBitBlastedSATQuery sc Map.empty satq $ \lit shapes -> - let stats = solverStats "RME" (propSize goal) + let stats = solverStats "RME" (sequentSize goal) in case RME.sat lit of Nothing -> return (Nothing, stats) Just cex -> do diff --git a/src/SAWScript/Prover/SBV.hs b/src/SAWScript/Prover/SBV.hs index fa008f5cff..f1212e0464 100644 --- a/src/SAWScript/Prover/SBV.hs +++ b/src/SAWScript/Prover/SBV.hs @@ -19,7 +19,7 @@ import qualified Verifier.SAW.Simulator.SBV as SBVSim import Verifier.SAW.SharedTerm -import SAWScript.Proof(Prop, propSize, propToSATQuery, CEX) +import SAWScript.Proof(Sequent, sequentSize, sequentToSATQuery, CEX) import SAWScript.Prover.SolverStats import SAWScript.Value @@ -30,7 +30,7 @@ proveUnintSBV :: SBV.SMTConfig {- ^ SBV configuration -} -> Set VarIndex {- ^ Uninterpreted functions -} -> Maybe Integer {- ^ Timeout in milliseconds -} -> - Prop {- ^ A proposition to be proved -} -> + Sequent {- ^ A proposition to be proved -} -> TopLevel (Maybe CEX, SolverStats) -- ^ (example/counter-example, solver statistics) proveUnintSBV conf unintSet timeout goal = @@ -42,7 +42,7 @@ proveUnintSBVIO :: SBV.SMTConfig {- ^ SBV configuration -} -> Set VarIndex {- ^ Uninterpreted functions -} -> Maybe Integer {- ^ Timeout in milliseconds -} -> - Prop {- ^ A proposition to be proved -} -> + Sequent {- ^ A proposition to be proved -} -> IO (Maybe CEX, SolverStats) -- ^ (example/counter-example, solver statistics) proveUnintSBVIO sc conf unintSet timeout goal = @@ -61,7 +61,7 @@ proveUnintSBVIO sc conf unintSet timeout goal = SBV.SatResult r <- SBV.satWith conf script let stats = solverStats ("SBV->" ++ show (SBV.name (SBV.solver conf))) - (propSize goal) + (sequentSize goal) case r of SBV.Unsatisfiable {} -> return (Nothing, stats) @@ -87,8 +87,8 @@ proveUnintSBVIO sc conf unintSet timeout goal = prepNegatedSBV :: SharedContext -> Set VarIndex {- ^ Uninterpreted function names -} -> - Prop {- ^ Proposition to prove -} -> + Sequent {- ^ Proposition to prove -} -> IO ([SBVSim.Labeler], [ExtCns Term], SBV.Symbolic SBV.SVal) prepNegatedSBV sc unintSet goal = - do satq <- propToSATQuery sc unintSet goal + do satq <- sequentToSATQuery sc unintSet goal SBVSim.sbvSATQuery sc mempty satq diff --git a/src/SAWScript/Prover/What4.hs b/src/SAWScript/Prover/What4.hs index 36088ddfae..c47d2d8224 100644 --- a/src/SAWScript/Prover/What4.hs +++ b/src/SAWScript/Prover/What4.hs @@ -17,7 +17,7 @@ import Verifier.SAW.SharedTerm import Verifier.SAW.FiniteValue import Verifier.SAW.SATQuery (SATQuery(..)) -import SAWScript.Proof(Prop, propToSATQuery, propSize, CEX) +import SAWScript.Proof(Sequent, sequentToSATQuery, sequentSize, CEX) import SAWScript.Prover.SolverStats import SAWScript.Value (TopLevel, io, getSharedContext) @@ -54,12 +54,12 @@ setupWhat4_sym hashConsing = what4Theories :: Set VarIndex -> Bool -> - Prop -> + Sequent -> TopLevel [String] what4Theories unintSet hashConsing goal = getSharedContext >>= \sc -> io $ do sym <- setupWhat4_sym hashConsing - satq <- propToSATQuery sc unintSet goal + satq <- sequentToSATQuery sc unintSet goal (_varMap, lit) <- W.w4Solve sym sc satq let pf = (predicateVarInfo lit)^.problemFeatures return (evalTheories pf) @@ -84,7 +84,7 @@ proveWhat4_sym :: SolverAdapter St -> Set VarIndex -> Bool -> - Prop -> + Sequent -> TopLevel (Maybe CEX, SolverStats) proveWhat4_sym solver un hashConsing t = getSharedContext >>= \sc -> io $ @@ -96,7 +96,7 @@ proveExportWhat4_sym :: Set VarIndex -> Bool -> FilePath -> - Prop -> + Sequent-> TopLevel (Maybe CEX, SolverStats) proveExportWhat4_sym solver un hashConsing outFilePath t = getSharedContext >>= \sc -> io $ @@ -115,7 +115,7 @@ proveWhat4_z3, proveWhat4_boolector, proveWhat4_cvc4, proveWhat4_abc :: Set VarIndex {- ^ Uninterpreted functions -} -> Bool {- ^ Hash-consing of What4 terms -}-> - Prop {- ^ A proposition to be proved -} -> + Sequent {- ^ A proposition to be proved -} -> TopLevel (Maybe CEX, SolverStats) proveWhat4_z3 = proveWhat4_sym z3Adapter @@ -130,7 +130,7 @@ proveWhat4_z3_using :: String {- ^ Solver tactic -} -> Set VarIndex {- ^ Uninterpreted functions -} -> Bool {- ^ Hash-consing of What4 terms -}-> - Prop {- ^ A proposition to be proved -} -> + Sequent {- ^ A proposition to be proved -} -> TopLevel (Maybe CEX, SolverStats) proveWhat4_z3_using tactic un hashConsing t = getSharedContext >>= \sc -> io $ @@ -145,7 +145,7 @@ proveExportWhat4_z3, proveExportWhat4_boolector, proveExportWhat4_cvc4, Set VarIndex {- ^ Uninterpreted functions -} -> Bool {- ^ Hash-consing of ExportWhat4 terms -}-> FilePath {- ^ Path of file to write SMT to -}-> - Prop {- ^ A proposition to be proved -} -> + Sequent {- ^ A proposition to be proved -} -> TopLevel (Maybe CEX, SolverStats) proveExportWhat4_z3 = proveExportWhat4_sym z3Adapter @@ -161,7 +161,7 @@ setupWhat4_solver :: forall st t ff. B.ExprBuilder t st ff {- ^ The glorious sym -} -> Set VarIndex {- ^ Uninterpreted functions -} -> SharedContext {- ^ Context for working with terms -} -> - Prop {- ^ A proposition to be proved/checked. -} -> + Sequent {- ^ A proposition to be proved/checked. -} -> IO ( [ExtCns Term] , [W.Labeler (B.ExprBuilder t st ff)] , Pred (B.ExprBuilder t st ff) @@ -169,7 +169,7 @@ setupWhat4_solver :: forall st t ff. setupWhat4_solver solver sym unintSet sc goal = do -- symbolically evaluate - satq <- propToSATQuery sc unintSet goal + satq <- sequentToSATQuery sc unintSet goal let varList = Map.toList (satVariables satq) let argNames = map fst varList (varMap, lit) <- W.w4Solve sym sc satq @@ -179,7 +179,7 @@ setupWhat4_solver solver sym unintSet sc goal = (getConfiguration sym) let stats = solverStats ("W4 ->" ++ solver_adapter_name solver) - (propSize goal) + (sequentSize goal) return (argNames, bvs, lit, stats) @@ -190,7 +190,7 @@ proveWhat4_solver :: forall st t ff. B.ExprBuilder t st ff {- ^ The glorious sym -} -> Set VarIndex {- ^ Uninterpreted functions -} -> SharedContext {- ^ Context for working with terms -} -> - Prop {- ^ A proposition to be proved/checked. -} -> + Sequent {- ^ A proposition to be proved/checked. -} -> IO () {- ^ Extra setup actions -} -> IO (Maybe CEX, SolverStats) -- ^ (example/counter-example, solver statistics) From c9e75ce8f5a20ab602e0ff02f852493db6b12570 Mon Sep 17 00:00:00 2001 From: Rob Dockins Date: Wed, 8 Jun 2022 09:31:46 -0700 Subject: [PATCH 04/35] Expose more primitives for term size counting, so we can get a joint count of the size of terms appearing in sequents. --- saw-core/src/Verifier/SAW/SharedTerm.hs | 21 ++++++++++++++++++--- src/SAWScript/Builtins.hs | 14 ++++++-------- src/SAWScript/Proof.hs | 17 +++++++++++------ src/SAWScript/Prover/ABC.hs | 8 ++++---- src/SAWScript/Prover/Exporter.hs | 4 ++-- src/SAWScript/Prover/RME.hs | 4 ++-- src/SAWScript/Prover/SBV.hs | 4 ++-- src/SAWScript/Prover/What4.hs | 4 ++-- 8 files changed, 47 insertions(+), 29 deletions(-) diff --git a/saw-core/src/Verifier/SAW/SharedTerm.hs b/saw-core/src/Verifier/SAW/SharedTerm.hs index d20754f7aa..6d586c8f50 100644 --- a/saw-core/src/Verifier/SAW/SharedTerm.hs +++ b/saw-core/src/Verifier/SAW/SharedTerm.hs @@ -267,7 +267,11 @@ module Verifier.SAW.SharedTerm , scUnfoldConstantSet , scUnfoldConstantSet' , scSharedSize + , scSharedSizeAux + , scSharedSizeMany , scTreeSize + , scTreeSizeAux + , scTreeSizeMany ) where import Control.Applicative @@ -2625,7 +2629,13 @@ scUnfoldConstantSet' sc b names t0 = do -- | Return the number of DAG nodes used by the given @Term@. scSharedSize :: Term -> Integer -scSharedSize = fst . go (0, Set.empty) +scSharedSize = fst . scSharedSizeAux (0, Set.empty) + +scSharedSizeMany :: [Term] -> Integer +scSharedSizeMany = fst . foldl scSharedSizeAux (0, Set.empty) + +scSharedSizeAux :: (Integer, Set TermIndex) -> Term -> (Integer, Set TermIndex) +scSharedSizeAux = go where go (sz, seen) (Unshared tf) = foldl' go (strictPair (sz + 1) seen) tf go (sz, seen) (STApp{ stAppIndex = idx, stAppTermF = tf }) @@ -2638,7 +2648,13 @@ strictPair x y = x `seq` y `seq` (x, y) -- | Return the number of nodes that would be used by the given -- @Term@ if it were represented as a tree instead of a DAG. scTreeSize :: Term -> Integer -scTreeSize = fst . go (0, Map.empty) +scTreeSize = fst . scTreeSizeAux (0, Map.empty) + +scTreeSizeMany :: [Term] -> Integer +scTreeSizeMany = fst . foldl scTreeSizeAux (0, Map.empty) + +scTreeSizeAux :: (Integer, Map TermIndex Integer) -> Term -> (Integer, Map TermIndex Integer) +scTreeSizeAux = go where go (sz, seen) (Unshared tf) = foldl' go (sz + 1, seen) tf go (sz, seen) (STApp{ stAppIndex = idx, stAppTermF = tf }) = @@ -2647,7 +2663,6 @@ scTreeSize = fst . go (0, Map.empty) Nothing -> (sz + sz', Map.insert idx sz' seen') where (sz', seen') = foldl' go (1, seen) tf - -- | `openTerm sc nm ty i body` replaces the loose deBruijn variable `i` -- with a fresh external constant (with name `nm`, and type `ty`) in `body`. scOpenTerm :: SharedContext diff --git a/src/SAWScript/Builtins.hs b/src/SAWScript/Builtins.hs index ec5cbca581..4707a076f8 100644 --- a/src/SAWScript/Builtins.hs +++ b/src/SAWScript/Builtins.hs @@ -367,7 +367,7 @@ quickcheckGoal sc n = do hFlush stdout satq <- sequentToSATQuery sc mempty (goalSequent goal) testGen <- prepareSATQuery sc satq - let stats = solverStats "quickcheck" (sequentSize (goalSequent goal)) + let stats = solverStats "quickcheck" (sequentSharedSize (goalSequent goal)) runManyTests testGen n >>= \case Nothing -> do printOutLn opts Info $ "checked " ++ show n ++ " cases." @@ -380,7 +380,7 @@ assumeValid = do printOutLnTop Warn $ "WARNING: assuming goal " ++ goalName goal ++ " is valid" pos <- SV.getPosition let admitMsg = "assumeValid: " <> Text.pack (goalName goal) - let stats = solverStats "ADMITTED" (sequentSize (goalSequent goal)) + let stats = solverStats "ADMITTED" (sequentSharedSize (goalSequent goal)) return (stats, SolveSuccess (Admitted admitMsg pos (goalSequent goal))) assumeUnsat :: ProofScript () @@ -389,7 +389,7 @@ assumeUnsat = do printOutLnTop Warn $ "WARNING: assuming goal " ++ goalName goal ++ " is unsat" pos <- SV.getPosition let admitMsg = "assumeUnsat: " <> Text.pack (goalName goal) - let stats = solverStats "ADMITTED" (sequentSize (goalSequent goal)) + let stats = solverStats "ADMITTED" (sequentSharedSize (goalSequent goal)) return (stats, SolveSuccess (Admitted admitMsg pos (goalSequent goal))) admitProof :: Text -> ProofScript () @@ -397,7 +397,7 @@ admitProof msg = execTactic $ tacticSolve $ \goal -> do printOutLnTop Warn $ "WARNING: admitting goal " ++ goalName goal pos <- SV.getPosition - let stats = solverStats "ADMITTED" (sequentSize (goalSequent goal)) + let stats = solverStats "ADMITTED" (sequentSharedSize (goalSequent goal)) return (stats, SolveSuccess (Admitted msg pos (goalSequent goal))) trivial :: ProofScript () @@ -494,10 +494,8 @@ printGoalConsts = printGoalSize :: ProofScript () printGoalSize = execTactic $ tacticId $ \goal -> - do sc <- getSharedContext - t <- io (propToTerm sc =<< sequentToProp sc (goalSequent goal)) - printOutLnTop Info $ "Goal shared size: " ++ show (scSharedSize t) - printOutLnTop Info $ "Goal unshared size: " ++ show (scTreeSize t) + do printOutLnTop Info $ "Goal shared size: " ++ show (sequentSharedSize (goalSequent goal)) + printOutLnTop Info $ "Goal unshared size: " ++ show (sequentTreeSize (goalSequent goal)) resolveNames :: [String] -> TopLevel (Set VarIndex) resolveNames nms = diff --git a/src/SAWScript/Proof.hs b/src/SAWScript/Proof.hs index cbab22cea3..a47f96ef4b 100644 --- a/src/SAWScript/Proof.hs +++ b/src/SAWScript/Proof.hs @@ -37,7 +37,8 @@ module SAWScript.Proof , SequentState(..) , sequentToProp , sequentToSATQuery - , sequentSize + , sequentSharedSize + , sequentTreeSize , prettySequent , ppSequent , propToSequent @@ -511,11 +512,15 @@ sequentState (GoalFocusedSequent hs (gs1,g,gs2)) = sequentState (HypFocusedSequent (hs1,h,hs2) gs) = HypFocus h (\h' -> HypFocusedSequent (hs1,h',hs2) gs) -sequentSize :: Sequent -> Integer -sequentSize sqt = - case sqt of - GoalFocusedSequent [] ([],g,[]) -> propSize g - _ -> error "FIXME! implement size counding for sequents" +sequentSharedSize :: Sequent -> Integer +sequentSharedSize sqt = scSharedSizeMany (hs ++ gs) + where + RawSequent hs gs = sequentToRawSequent sqt + +sequentTreeSize :: Sequent -> Integer +sequentTreeSize sqt = scTreeSizeMany (hs ++ gs) + where + RawSequent hs gs = sequentToRawSequent sqt traverseSequent :: Applicative m => (Prop -> m Prop) -> Sequent -> m Sequent traverseSequent f (UnfocusedSequent hs gs) = diff --git a/src/SAWScript/Prover/ABC.hs b/src/SAWScript/Prover/ABC.hs index 35be0ef0aa..d1e4c79814 100644 --- a/src/SAWScript/Prover/ABC.hs +++ b/src/SAWScript/Prover/ABC.hs @@ -32,7 +32,7 @@ import qualified Verifier.SAW.Simulator.BitBlast as BBSim import SAWScript.Proof ( sequentToSATQuery, goalSequent, ProofGoal , goalType, goalNum, CEX - , Sequent, sequentSize + , Sequent, sequentSharedSize ) import SAWScript.Prover.SolverStats (SolverStats, solverStats) import qualified SAWScript.Prover.Exporter as Exporter @@ -55,7 +55,7 @@ proveABC proxy goal = getSharedContext >>= \sc -> liftIO $ BBSim.withBitBlastedSATQuery proxy sc mempty satq $ \be lit shapes -> do let (ecs,fts) = unzip shapes res <- getModel ecs fts =<< AIG.checkSat be lit - let stats = solverStats "ABC" (sequentSize goal) + let stats = solverStats "ABC" (sequentSharedSize goal) return (res, stats) @@ -130,7 +130,7 @@ w4AbcExternal exporter argFn unints _hashcons goal = liftIO $ removeFile tmpCex -- Parse and report results - let stats = solverStats "abc_verilog" (sequentSize goal) + let stats = solverStats "abc_verilog" (sequentSharedSize goal) res <- if all isSpace cexText then return Nothing else do cex <- liftIO $ parseAigerCex cexText argTys @@ -188,7 +188,7 @@ abcSatExternal proxy sc doCNF execName args g = liftIO $ let ls = lines out sls = filter ("s " `isPrefixOf`) ls vls = filter ("v " `isPrefixOf`) ls - let stats = solverStats ("external SAT:" ++ execName) (sequentSize (goalSequent g)) + let stats = solverStats ("external SAT:" ++ execName) (sequentSharedSize (goalSequent g)) case (sls, vls) of (["s SATISFIABLE"], _) -> do let bs = parseDimacsSolution variables vls diff --git a/src/SAWScript/Prover/Exporter.hs b/src/SAWScript/Prover/Exporter.hs index c255de5981..d42b5514d0 100644 --- a/src/SAWScript/Prover/Exporter.hs +++ b/src/SAWScript/Prover/Exporter.hs @@ -90,7 +90,7 @@ import qualified Verifier.SAW.UntypedAST as Un import SAWScript.Crucible.Common import SAWScript.Crucible.Common.MethodSpec (ppTypedTermType) import SAWScript.Proof - (Prop, Sequent, propSize, sequentSize, propToTerm, predicateToSATQuery, sequentToSATQuery) + (Prop, Sequent, propSize, sequentSharedSize, propToTerm, predicateToSATQuery, sequentToSATQuery) import SAWScript.Prover.SolverStats import SAWScript.Prover.Util import SAWScript.Prover.What4 @@ -115,7 +115,7 @@ proveWithSATExporter exporter unintSet path goal = do sc <- getSharedContext satq <- io $ sequentToSATQuery sc unintSet goal _ <- exporter path satq - let stats = solverStats ("offline: "++ path) (sequentSize goal) + let stats = solverStats ("offline: "++ path) (sequentSharedSize goal) return stats diff --git a/src/SAWScript/Prover/RME.hs b/src/SAWScript/Prover/RME.hs index 58b5a61425..3f4c9b7fd4 100644 --- a/src/SAWScript/Prover/RME.hs +++ b/src/SAWScript/Prover/RME.hs @@ -9,7 +9,7 @@ import Verifier.SAW.FiniteValue import qualified Verifier.SAW.Simulator.RME as RME -import SAWScript.Proof(Sequent, sequentToSATQuery, sequentSize, CEX) +import SAWScript.Proof(Sequent, sequentToSATQuery, sequentSharedSize, CEX) import SAWScript.Prover.SolverStats import SAWScript.Prover.Util import SAWScript.Value @@ -21,7 +21,7 @@ proveRME :: proveRME goal = getSharedContext >>= \sc -> liftIO $ do satq <- sequentToSATQuery sc mempty goal RME.withBitBlastedSATQuery sc Map.empty satq $ \lit shapes -> - let stats = solverStats "RME" (sequentSize goal) + let stats = solverStats "RME" (sequentSharedSize goal) in case RME.sat lit of Nothing -> return (Nothing, stats) Just cex -> do diff --git a/src/SAWScript/Prover/SBV.hs b/src/SAWScript/Prover/SBV.hs index f1212e0464..c401330348 100644 --- a/src/SAWScript/Prover/SBV.hs +++ b/src/SAWScript/Prover/SBV.hs @@ -19,7 +19,7 @@ import qualified Verifier.SAW.Simulator.SBV as SBVSim import Verifier.SAW.SharedTerm -import SAWScript.Proof(Sequent, sequentSize, sequentToSATQuery, CEX) +import SAWScript.Proof(Sequent, sequentSharedSize, sequentToSATQuery, CEX) import SAWScript.Prover.SolverStats import SAWScript.Value @@ -61,7 +61,7 @@ proveUnintSBVIO sc conf unintSet timeout goal = SBV.SatResult r <- SBV.satWith conf script let stats = solverStats ("SBV->" ++ show (SBV.name (SBV.solver conf))) - (sequentSize goal) + (sequentSharedSize goal) case r of SBV.Unsatisfiable {} -> return (Nothing, stats) diff --git a/src/SAWScript/Prover/What4.hs b/src/SAWScript/Prover/What4.hs index c47d2d8224..0ee9e6d1e0 100644 --- a/src/SAWScript/Prover/What4.hs +++ b/src/SAWScript/Prover/What4.hs @@ -17,7 +17,7 @@ import Verifier.SAW.SharedTerm import Verifier.SAW.FiniteValue import Verifier.SAW.SATQuery (SATQuery(..)) -import SAWScript.Proof(Sequent, sequentToSATQuery, sequentSize, CEX) +import SAWScript.Proof(Sequent, sequentToSATQuery, sequentSharedSize, CEX) import SAWScript.Prover.SolverStats import SAWScript.Value (TopLevel, io, getSharedContext) @@ -179,7 +179,7 @@ setupWhat4_solver solver sym unintSet sc goal = (getConfiguration sym) let stats = solverStats ("W4 ->" ++ solver_adapter_name solver) - (sequentSize goal) + (sequentSharedSize goal) return (argNames, bvs, lit, stats) From d71064b63ef8038ef24ba62eaf22a42009d344e9 Mon Sep 17 00:00:00 2001 From: Rob Dockins Date: Wed, 8 Jun 2022 11:07:34 -0700 Subject: [PATCH 05/35] Pipe naming environments into more places, and begin the task of proper pretty-printing support for sequents. --- saw-core/src/Verifier/SAW/SharedTerm.hs | 5 ++ saw-core/src/Verifier/SAW/Term/Pretty.hs | 99 ++++++++++++++------- src/SAWScript/Builtins.hs | 30 ++++--- src/SAWScript/Crucible/JVM/Builtins.hs | 9 -- src/SAWScript/Crucible/LLVM/Builtins.hs | 9 -- src/SAWScript/Interpreter.hs | 9 +- src/SAWScript/Proof.hs | 106 +++++++++++++---------- src/SAWScript/Prover/MRSolver/SMT.hs | 3 +- src/SAWScript/Value.hs | 23 +++-- src/SAWScript/VerificationSummary.hs | 7 +- 10 files changed, 173 insertions(+), 127 deletions(-) diff --git a/saw-core/src/Verifier/SAW/SharedTerm.hs b/saw-core/src/Verifier/SAW/SharedTerm.hs index 6d586c8f50..5094aa7a87 100644 --- a/saw-core/src/Verifier/SAW/SharedTerm.hs +++ b/saw-core/src/Verifier/SAW/SharedTerm.hs @@ -62,6 +62,7 @@ module Verifier.SAW.SharedTerm , SharedContextCheckpoint , checkpointSharedContext , restoreSharedContext + , scGetNamingEnv -- ** Low-level generic term constructors , scTermF , scFlatTermF @@ -532,6 +533,10 @@ scCtorApp sc c_id args = let (params,args') = splitAt (ctorNumParams ctor) args scCtorAppParams sc (ctorPrimName ctor) params args' +-- | Get the current naming environment +scGetNamingEnv :: SharedContext -> IO SAWNamingEnv +scGetNamingEnv sc = readIORef (scNamingEnv sc) + -- | Get the current 'ModuleMap' scGetModuleMap :: SharedContext -> IO ModuleMap scGetModuleMap sc = readIORef (scModuleMap sc) diff --git a/saw-core/src/Verifier/SAW/Term/Pretty.hs b/saw-core/src/Verifier/SAW/Term/Pretty.hs index 1ba288aa00..f574da49b3 100644 --- a/saw-core/src/Verifier/SAW/Term/Pretty.hs +++ b/saw-core/src/Verifier/SAW/Term/Pretty.hs @@ -36,9 +36,12 @@ module Verifier.SAW.Term.Pretty , PPModule(..), PPDecl(..) , ppPPModule , scTermCount + , scTermCountAux + , scTermCountMany , OccurrenceMap , shouldMemoizeTerm , ppName + , ppTermContainerWithNames ) where import Data.Char (intToDigit, isDigit) @@ -558,7 +561,17 @@ type OccurrenceMap = IntMap (Term, Int) -- side of an application are excluded. (FIXME: why?) The boolean flag indicates -- whether to descend under lambdas and other binders. scTermCount :: Bool -> Term -> OccurrenceMap -scTermCount doBinders t0 = execState (go [t0]) IntMap.empty +scTermCount doBinders t = execState (scTermCountAux doBinders [t]) IntMap.empty + +-- | Returns map that associates each term index appearing in the list of terms to the +-- number of occurrences in the shared term. Subterms that are on the left-hand +-- side of an application are excluded. (FIXME: why?) The boolean flag indicates +-- whether to descend under lambdas and other binders. +scTermCountMany :: Bool -> [Term] -> OccurrenceMap +scTermCountMany doBinders ts = execState (scTermCountAux doBinders ts) IntMap.empty + +scTermCountAux :: Bool -> [Term] -> State OccurrenceMap () +scTermCountAux doBinders = go where go :: [Term] -> State OccurrenceMap () go [] = return () go (t:r) = @@ -575,6 +588,7 @@ scTermCount doBinders t0 = execState (go [t0]) IntMap.empty recurse where recurse = go (r ++ argsAndSubterms t) + argsAndSubterms (unwrapTermF -> App f arg) = arg : argsAndSubterms f argsAndSubterms h = case unwrapTermF h of @@ -590,6 +604,7 @@ scTermCount doBinders t0 = execState (go [t0]) IntMap.empty map fst (Map.elems (recursorElims crec)) tf -> Fold.toList tf + -- | Return true if the printing of the given term should be memoized; we do not -- want to memoize the printing of terms that are "too small" shouldMemoizeTerm :: Term -> Bool @@ -615,38 +630,42 @@ shouldMemoizeTerm t = ppTermWithMemoTable :: Prec -> Bool -> Term -> PPM SawDoc ppTermWithMemoTable prec global_p trm = do min_occs <- ppMinSharing <$> ppOpts <$> ask - ppLets (occ_map_elems min_occs) [] where - - -- Generate an occurrence map for trm, filtering out terms that only occur - -- once, that are "too small" to memoize, and, for the global table, terms - -- that are not closed - occ_map_elems min_occs = - IntMap.assocs $ + let occPairs = IntMap.assocs $ filterOccurenceMap min_occs global_p $ scTermCount global_p trm + ppLets global_p occPairs [] (ppTerm' prec trm) + +-- Filter an occurrence map, filtering out terms that only occur +-- once, that are "too small" to memoize, and, for the global table, terms +-- that are not closed +filterOccurenceMap :: Int -> Bool -> OccurrenceMap -> OccurrenceMap +filterOccurenceMap min_occs global_p = IntMap.filter - (\(t,cnt) -> - cnt >= min_occs && shouldMemoizeTerm t && - (if global_p then looseVars t == emptyBitSet else True)) $ - scTermCount global_p trm - - -- For each (TermIndex, Term) pair in the occurrence map, pretty-print the - -- Term and then add it to the memoization table of subsequent printing. The - -- pretty-printing of these terms is reverse-accumulated in the second - -- list. Finally, print trm with a let-binding for the bound terms. - ppLets :: [(TermIndex, (Term, Int))] -> [(MemoVar, SawDoc)] -> PPM SawDoc - - -- Special case: don't print let-binding if there are no bound vars - ppLets [] [] = ppTerm' prec trm - -- When we have run out of (idx,term) pairs, pretty-print a let binding for - -- all the accumulated bindings around the term - ppLets [] bindings = ppLetBlock (reverse bindings) <$> ppTerm' prec trm - -- To add an (idx,term) pair, first check if idx is already bound, and, if - -- not, add a new MemoVar bind it to idx - ppLets ((idx, (t_rhs,_)):idxs) bindings = - do isBound <- isJust <$> memoLookupM idx - if isBound then ppLets idxs bindings else - do doc_rhs <- ppTerm' prec t_rhs - withMemoVar global_p idx $ \memo_var -> - ppLets idxs ((memo_var, doc_rhs):bindings) + (\(t,cnt) -> + cnt >= min_occs && shouldMemoizeTerm t && + (if global_p then looseVars t == emptyBitSet else True)) + + +-- For each (TermIndex, Term) pair in the occurrence map, pretty-print the +-- Term and then add it to the memoization table of subsequent printing. The +-- pretty-printing of these terms is reverse-accumulated in the second +-- list. Finally, print the given base document in the context of let-bindings +-- for the bound terms. +ppLets :: Bool -> [(TermIndex, (Term, Int))] -> [(MemoVar, SawDoc)] -> PPM SawDoc -> PPM SawDoc + +-- Special case: don't print let-binding if there are no bound vars +ppLets _ [] [] baseDoc = baseDoc + +-- When we have run out of (idx,term) pairs, pretty-print a let binding for +-- all the accumulated bindings around the term +ppLets _ [] bindings baseDoc = ppLetBlock (reverse bindings) <$> baseDoc + +-- To add an (idx,term) pair, first check if idx is already bound, and, if +-- not, add a new MemoVar bind it to idx +ppLets global_p ((idx, (t_rhs,_)):idxs) bindings baseDoc = + do isBound <- isJust <$> memoLookupM idx + if isBound then ppLets global_p idxs bindings baseDoc else + do doc_rhs <- ppTerm' PrecTerm t_rhs + withMemoVar global_p idx $ \memo_var -> + ppLets global_p idxs ((memo_var, doc_rhs):bindings) baseDoc -- | Pretty-print a term inside a binder for a variable of the given name, @@ -733,6 +752,22 @@ showTermWithNames :: PPOpts -> SAWNamingEnv -> Term -> String showTermWithNames opts ne trm = renderSawDoc opts $ ppTermWithNames opts ne trm + +ppTermContainerWithNames :: + (Traversable m) => + (m SawDoc -> SawDoc) -> + PPOpts -> SAWNamingEnv -> m Term -> SawDoc +ppTermContainerWithNames ppContainer opts ne trms = + let min_occs = ppMinSharing opts + global_p = True + occPairs = IntMap.assocs $ + filterOccurenceMap min_occs global_p $ + flip execState mempty $ + traverse (\t -> scTermCountAux global_p [t]) $ + trms + in runPPM opts ne $ ppLets global_p occPairs [] + (ppContainer <$> traverse (ppTerm' PrecTerm) trms) + -------------------------------------------------------------------------------- -- * Pretty-printers for Modules and Top-level Constructs -------------------------------------------------------------------------------- diff --git a/src/SAWScript/Builtins.hs b/src/SAWScript/Builtins.hs index 4707a076f8..b86abd66ef 100644 --- a/src/SAWScript/Builtins.hs +++ b/src/SAWScript/Builtins.hs @@ -140,7 +140,8 @@ import SAWScript.VerificationSummary showPrim :: SV.Value -> TopLevel String showPrim v = do opts <- fmap rwPPOpts getTopLevelRW - return (SV.showsPrecValue opts 0 v "") + nenv <- io . scGetNamingEnv =<< getSharedContext + return (SV.showsPrecValue opts nenv 0 v "") definePrim :: Text -> TypedTerm -> TopLevel TypedTerm definePrim name (TypedTerm (TypedTermSchema schema) rhs) = @@ -449,8 +450,8 @@ write_goal fp = do opts <- getTopLevelPPOpts sc <- getSharedContext liftIO $ do - -- TODO, something better here - output <- liftIO (scShowTerm sc opts =<< propToTerm sc =<< sequentToProp sc (goalSequent goal)) + nenv <- scGetNamingEnv sc + let output = prettySequent opts nenv (goalSequent goal) writeFile fp (unlines [goalSummary goal, output]) print_goal :: ProofScript () @@ -458,10 +459,9 @@ print_goal = execTactic $ tacticId $ \goal -> do opts <- getTopLevelPPOpts sc <- getSharedContext - -- TODO, something better here - output <- liftIO (scShowTerm sc opts =<< propToTerm sc =<< sequentToProp sc (goalSequent goal)) - printOutLnTop Info (goalSummary goal) - printOutLnTop Info output + nenv <- io (scGetNamingEnv sc) + let output = prettySequent opts nenv (goalSequent goal) + printOutLnTop Info (unlines [goalSummary goal, output]) print_goal_summary :: ProofScript () print_goal_summary = @@ -479,10 +479,9 @@ print_goal_depth n = do opts <- getTopLevelPPOpts sc <- getSharedContext let opts' = opts { ppMaxDepth = Just n } - -- TODO, something better here - output <- liftIO (scShowTerm sc opts' =<< propToTerm sc =<< sequentToProp sc (goalSequent goal)) - printOutLnTop Info ("Goal " ++ goalName goal ++ ":") - printOutLnTop Info output + nenv <- io (scGetNamingEnv sc) + let output = prettySequent opts' nenv (goalSequent goal) + printOutLnTop Info (unlines [goalSummary goal, output]) printGoalConsts :: ProofScript () printGoalConsts = @@ -2001,7 +2000,9 @@ summarize_verification = thms = [ t | SV.VTheorem t <- values ] db <- SV.getTheoremDB summary <- io (computeVerificationSummary db jspecs lspecs thms) - io $ putStrLn $ prettyVerificationSummary summary + opts <- fmap (SV.sawPPOpts . rwPPOpts) getTopLevelRW + nenv <- io . scGetNamingEnv =<< getSharedContext + io $ putStrLn $ prettyVerificationSummary opts nenv summary summarize_verification_json :: String -> TopLevel () summarize_verification_json fpath = @@ -2024,11 +2025,14 @@ writeVerificationSummary = do summary <- io (computeVerificationSummary db jspecs lspecs thms) opts <- roOptions <$> getTopLevelRO dir <- roInitWorkDir <$> getTopLevelRO + nenv <- io . scGetNamingEnv =<< getSharedContext + ppOpts <- fmap (SV.sawPPOpts . rwPPOpts) getTopLevelRW + case summaryFile opts of Nothing -> return () Just f -> let f' = if hasDrive f then f else dir f formatSummary = case summaryFormat opts of JSON -> jsonVerificationSummary - Pretty -> prettyVerificationSummary + Pretty -> prettyVerificationSummary ppOpts nenv in io $ writeFile f' $ formatSummary summary diff --git a/src/SAWScript/Crucible/JVM/Builtins.hs b/src/SAWScript/Crucible/JVM/Builtins.hs index 63103fcdb1..218c27e438 100644 --- a/src/SAWScript/Crucible/JVM/Builtins.hs +++ b/src/SAWScript/Crucible/JVM/Builtins.hs @@ -105,7 +105,6 @@ import qualified Data.Parameterized.Context as Ctx import Verifier.SAW.FiniteValue (ppFirstOrderValue) import Verifier.SAW.Name (toShortName) import Verifier.SAW.SharedTerm -import Verifier.SAW.Recognizer import Verifier.SAW.TypedTerm import Verifier.SAW.Simulator.What4.ReturnTrip @@ -722,14 +721,6 @@ verifySimulate opts cc pfs mspec args assumes top_loc lemmas globals _checkSat m return (Crucible.RegEntry tr v)) ctx --- | Build a conjunction from a list of boolean terms. -scAndList :: SharedContext -> [Term] -> IO Term -scAndList sc = conj . filter nontrivial - where - nontrivial x = asBool x /= Just True - conj [] = scBool sc True - conj (x : xs) = foldM (scAnd sc) x xs - -------------------------------------------------------------------------------- verifyPoststate :: diff --git a/src/SAWScript/Crucible/LLVM/Builtins.hs b/src/SAWScript/Crucible/LLVM/Builtins.hs index 8869fa7b9a..21f9b76de1 100644 --- a/src/SAWScript/Crucible/LLVM/Builtins.hs +++ b/src/SAWScript/Crucible/LLVM/Builtins.hs @@ -1594,15 +1594,6 @@ prepareArgs sym ctx x = return (Crucible.RegEntry tr v)) ctx - --- | Build a conjunction from a list of boolean terms. -scAndList :: SharedContext -> [Term] -> IO Term -scAndList sc = conj . filter nontrivial - where - nontrivial x = asBool x /= Just True - conj [] = scBool sc True - conj (x : xs) = foldM (scAnd sc) x xs - -------------------------------------------------------------------------------- verifyPoststate :: diff --git a/src/SAWScript/Interpreter.hs b/src/SAWScript/Interpreter.hs index 6cfe27613d..37dbaaf94f 100644 --- a/src/SAWScript/Interpreter.hs +++ b/src/SAWScript/Interpreter.hs @@ -304,10 +304,13 @@ processStmtBind printBinds pat _mc expr = do -- mx mt --io $ putStrLn $ "Top-level bind: " ++ show mx --showCryptolEnv + -- Print non-unit result if it was not bound to a variable case pat of SS.PWild _ | printBinds && not (isVUnit result) -> - liftTopLevel $ printOutLnTop Info (showsPrecValue opts 0 result "") + liftTopLevel $ + do nenv <- io . scGetNamingEnv =<< getSharedContext + printOutLnTop Info (showsPrecValue opts nenv 0 result "") _ -> return () -- Print function type if result was a function @@ -386,6 +389,7 @@ interpretStmt printBinds stmt = do rw <- getTopLevelRW putTopLevelRW $ addTypedef (getVal name) ty rw + interpretFile :: FilePath -> Bool {- ^ run main? -} -> TopLevel () interpretFile file runMain = do opts <- getOptions @@ -747,7 +751,8 @@ print_value (VTerm t) = do print_value v = do opts <- fmap rwPPOpts getTopLevelRW - printOutLnTop Info (showsPrecValue opts 0 v "") + nenv <- io . scGetNamingEnv =<< getSharedContext + printOutLnTop Info (showsPrecValue opts nenv 0 v "") readSchema :: String -> SS.Schema readSchema str = diff --git a/src/SAWScript/Proof.hs b/src/SAWScript/Proof.hs index a47f96ef4b..1ab1f7c7f7 100644 --- a/src/SAWScript/Proof.hs +++ b/src/SAWScript/Proof.hs @@ -110,6 +110,7 @@ module SAWScript.Proof import qualified Control.Monad.Fail as F import Control.Monad.Except import Data.IORef +import qualified Data.Foldable as Fold import Data.Maybe (fromMaybe) import Data.Map (Map) import qualified Data.Map as Map @@ -125,11 +126,12 @@ import Verifier.SAW.Prelude (scApplyPrelude_False) import Verifier.SAW.Recognizer import Verifier.SAW.Rewriter import Verifier.SAW.SATQuery +import Verifier.SAW.Name (SAWNamingEnv) import Verifier.SAW.SharedTerm import Verifier.SAW.TypedAST import Verifier.SAW.TypedTerm import Verifier.SAW.FiniteValue (FirstOrderValue) -import Verifier.SAW.Term.Pretty (SawDoc) +import Verifier.SAW.Term.Pretty (SawDoc, renderSawDoc, ppTermWithNames, ppTermContainerWithNames) import qualified Verifier.SAW.SCTypeCheck as TC import Verifier.SAW.Simulator.Concrete (evalSharedTerm) @@ -349,12 +351,12 @@ trivialProofTerm sc (Prop p) = runExceptT (loop =<< lift (scWhnf sc p)) ] -- | Pretty print the given proposition as a string. -prettyProp :: PPOpts -> Prop -> String -prettyProp opts (Prop tm) = scPrettyTerm opts tm +prettyProp :: PPOpts -> SAWNamingEnv -> Prop -> String +prettyProp opts nenv p = renderSawDoc opts (ppProp opts nenv p) -- | Pretty print the given proposition as a @SawDoc@. -ppProp :: PPOpts -> Prop -> SawDoc -ppProp opts (Prop tm) = ppTerm opts tm +ppProp :: PPOpts -> SAWNamingEnv -> Prop -> SawDoc +ppProp opts nenv (Prop tm) = ppTermWithNames opts nenv tm -- TODO, I'd like to add metadata here type SequentBranch = Prop @@ -364,7 +366,7 @@ data Sequent | GoalFocusedSequent [SequentBranch] ([SequentBranch], SequentBranch, [SequentBranch]) | HypFocusedSequent ([SequentBranch], SequentBranch, [SequentBranch]) [SequentBranch] -sequentToRawSequent :: Sequent -> RawSequent +sequentToRawSequent :: Sequent -> RawSequent Term sequentToRawSequent sqt = case sqt of UnfocusedSequent hs gs -> f hs gs @@ -383,7 +385,15 @@ sequentConstantSet sqt = foldr (\t m -> Map.union (getConstantSet t) m) mempty ( where RawSequent hs gs = sequentToRawSequent sqt -data RawSequent = RawSequent [Term] [Term] +data RawSequent a = RawSequent [a] [a] + +instance Functor RawSequent where + fmap f (RawSequent hs gs) = RawSequent (fmap f hs) (fmap f gs) +instance Foldable RawSequent where + foldMap f (RawSequent hs gs) = Fold.foldMap f (hs ++ gs) +instance Traversable RawSequent where + traverse f (RawSequent hs gs) = RawSequent <$> traverse f hs <*> traverse f gs + data NormalizedSequent = NormSeq (Set Term) (Set Term) normalizedSequentSubsumes :: NormalizedSequent -> NormalizedSequent -> Bool @@ -417,7 +427,7 @@ convertibleSequents sc sqt1 sqt2 = RawSequent hs2 gs2 = sequentToRawSequent sqt2 -normalizeSequent :: SharedContext -> RawSequent -> IO NormalizedSequent +normalizeSequent :: SharedContext -> RawSequent Term -> IO NormalizedSequent normalizeSequent sc = loop (NormSeq mempty mempty) where loop (NormSeq hset gset) (RawSequent (h:hs) gs) = @@ -495,15 +505,17 @@ sequentToSATQuery sc unintSet sqt = sequentToProp sc sqt >>= propToSATQuery sc unintSet -- | Pretty print the given proposition as a string. -prettySequent :: PPOpts -> Sequent -> String -prettySequent opts sqt = show (ppSequent opts sqt) +prettySequent :: PPOpts -> SAWNamingEnv -> Sequent -> String +prettySequent opts nenv sqt = renderSawDoc opts (ppSequent opts nenv sqt) -- | Pretty print the given proposition as a @SawDoc@. -ppSequent :: PPOpts -> Sequent -> SawDoc -ppSequent opts sqt = - case sqt of - GoalFocusedSequent [] ([],g,[]) -> ppProp opts g - _ -> error "FIXME! implement printing for sequents" +ppSequent :: PPOpts -> SAWNamingEnv -> Sequent -> SawDoc +ppSequent opts nenv sqt = + ppTermContainerWithNames ppRawSequent opts nenv (sequentToRawSequent sqt) + +ppRawSequent :: RawSequent SawDoc -> SawDoc +ppRawSequent (RawSequent [] [g]) = g +ppRawSequent (RawSequent hs gs) = error "ppRawSequent! implement nontrivial cases!" sequentState :: Sequent -> SequentState sequentState (UnfocusedSequent _ _) = Unfocused @@ -1020,20 +1032,21 @@ sequentIsAxiom sc sqt = -- 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 (propToSequent p) + nenv <- scGetNamingEnv sc + check nenv hyps e (propToSequent p) where - checkApply _hyps _mkSqt (Prop p) [] = return (mempty, mempty, p) + checkApply _nenv _hyps _mkSqt (Prop p) [] = return (mempty, mempty, p) -- 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 mkSqt (Prop p) (Right e:es) + checkApply nenv hyps mkSqt (Prop p) (Right e:es) | Just (_lnm, tp, body) <- asPi p , looseVars body == emptyBitSet - = do (d1,sy1) <- check hyps e . mkSqt =<< termToProp sc tp - (d2,sy2,p') <- checkApply hyps mkSqt (Prop body) es + = do (d1,sy1) <- check nenv hyps e . mkSqt =<< termToProp sc tp + (d2,sy2,p') <- checkApply nenv hyps mkSqt (Prop body) es return (Set.union d1 d2, sy1 <> sy2, p') | otherwise = fail $ unlines [ "Apply evidence mismatch: non-function or dependent function" @@ -1042,7 +1055,7 @@ checkEvidence sc db = \e p -> do hyps <- Map.keysSet <$> readIORef (theoremMap d -- Check a theorem applied to a term. This explicity instantiates -- a Pi binder with the given term. - checkApply hyps mkSqt (Prop p) (Left tm:es) = + checkApply nenv hyps mkSqt (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' @@ -1050,7 +1063,7 @@ checkEvidence sc db = \e p -> do hyps <- Map.keysSet <$> readIORef (theoremMap d res <- TC.runTCM m sc Nothing [] case res of Left msg -> fail (unlines (TC.prettyTCError msg)) - Right p' -> checkApply hyps mkSqt (Prop p') es + Right p' -> checkApply nenv hyps mkSqt (Prop p') es checkTheorem :: Set TheoremNonce -> Theorem -> IO () checkTheorem hyps (LocalAssumption p loc n) = @@ -1062,11 +1075,12 @@ checkEvidence sc db = \e p -> do hyps <- Map.keysSet <$> readIORef (theoremMap d checkTheorem _hyps Theorem{} = return () check :: + SAWNamingEnv -> Set TheoremNonce -> Evidence -> Sequent -> IO (Set TheoremNonce, TheoremSummary) - check hyps e sqt = case e of + check nenv hyps e sqt = case e of ProofTerm tm -> case sequentState sqt of GoalFocus (Prop ptm) _ -> @@ -1092,8 +1106,8 @@ checkEvidence sc db = \e p -> do hyps <- Map.keysSet <$> readIORef (theoremMap d do ok <- sequentSubsumes sc sqt' sqt unless ok $ fail $ unlines [ "Solver proof does not prove the required sequent" - , prettySequent defaultPPOpts sqt - , prettySequent defaultPPOpts sqt' + , prettySequent defaultPPOpts nenv sqt + , prettySequent defaultPPOpts nenv sqt' ] return (mempty, ProvedTheorem stats) @@ -1102,8 +1116,8 @@ checkEvidence sc db = \e p -> do hyps <- Map.keysSet <$> readIORef (theoremMap d unless ok $ fail $ unlines [ "Admitted proof does not match the required sequent " ++ show pos , Text.unpack msg - , prettySequent defaultPPOpts sqt - , prettySequent defaultPPOpts sqt' + , prettySequent defaultPPOpts nenv sqt + , prettySequent defaultPPOpts nenv sqt' ] return (mempty, AdmittedTheorem msg) @@ -1111,8 +1125,8 @@ checkEvidence sc db = \e p -> do hyps <- Map.keysSet <$> readIORef (theoremMap d do ok <- sequentSubsumes sc sqt' sqt unless ok $ fail $ unlines [ "Quickcheck evidence does not match the required sequent" - , prettySequent defaultPPOpts sqt - , prettySequent defaultPPOpts sqt' + , prettySequent defaultPPOpts nenv sqt + , prettySequent defaultPPOpts nenv sqt' ] return (mempty, TestedTheorem n) @@ -1120,18 +1134,18 @@ checkEvidence sc db = \e p -> do hyps <- Map.keysSet <$> readIORef (theoremMap d splitSequent sc sqt >>= \case Nothing -> fail $ unlines [ "Split evidence does not apply" - , prettySequent defaultPPOpts sqt + , prettySequent defaultPPOpts nenv sqt ] Just (sqt1,sqt2) -> - do d1 <- check hyps e1 sqt1 - d2 <- check hyps e2 sqt2 + do d1 <- check nenv hyps e1 sqt1 + d2 <- check nenv hyps e2 sqt2 return (d1 <> d2) ApplyEvidence thm es -> case sequentState sqt of GoalFocus p mkSqt -> do checkTheorem hyps thm - (d,sy,p') <- checkApply hyps mkSqt (thmProp thm) es + (d,sy,p') <- checkApply nenv hyps mkSqt (thmProp thm) es ok <- scConvertible sc False (unProp p) p' unless ok $ fail $ unlines [ "Apply evidence does not match the required proposition" @@ -1141,7 +1155,7 @@ checkEvidence sc db = \e p -> do hyps <- Map.keysSet <$> readIORef (theoremMap d return (Set.insert (thmNonce thm) d, sy) _ -> fail $ unlines $ [ "Apply evidence requires a goal-focused sequent" - , prettySequent defaultPPOpts sqt + , prettySequent defaultPPOpts nenv sqt ] {- @@ -1154,7 +1168,7 @@ checkEvidence sc db = \e p -> do hyps <- Map.keysSet <$> readIORef (theoremMap d UnfoldEvidence vars e' -> do sqt' <- traverseSequent (unfoldProp sc vars) sqt - check hyps e' sqt' + check nenv hyps e' sqt' RewriteEvidence ss e' -> do (d1,sqt') <- simplifySequent sc ss sqt @@ -1162,34 +1176,34 @@ checkEvidence sc db = \e p -> do hyps <- Map.keysSet <$> readIORef (theoremMap d [ "Rewrite step used theorem not in hypothesis database" , show (Set.difference d1 hyps) ] - (d2,sy) <- check hyps e' sqt' + (d2,sy) <- check nenv hyps e' sqt' return (Set.union d1 d2, sy) HoistIfsEvidence e' -> do sqt' <- traverseSequent (hoistIfsInGoal sc) sqt - check hyps e' sqt' + check nenv hyps e' sqt' EvalEvidence vars e' -> do sqt' <- traverseSequent (evalProp sc vars) sqt - check hyps e' sqt' + check nenv hyps e' sqt' ConversionEvidence sqt' e' -> do ok <- convertibleSequents sc sqt sqt' unless ok $ fail $ unlines [ "Converted sequent does not match goal" - , prettySequent defaultPPOpts sqt - , prettySequent defaultPPOpts sqt' + , prettySequent defaultPPOpts nenv sqt + , prettySequent defaultPPOpts nenv sqt' ] - check hyps e' sqt' + check nenv hyps e' sqt' StructuralEvidence sqt' e' -> do ok <- sequentSubsumes sc sqt' sqt unless ok $ fail $ unlines [ "Restated sequents does not subsume goal" - , prettySequent defaultPPOpts sqt - , prettySequent defaultPPOpts sqt' + , prettySequent defaultPPOpts nenv sqt + , prettySequent defaultPPOpts nenv sqt' ] - check hyps e' sqt' + check nenv hyps e' sqt' {- AssumeEvidence n (Prop p') e' -> @@ -1214,7 +1228,7 @@ checkEvidence sc db = \e p -> do hyps <- Map.keysSet <$> readIORef (theoremMap d do ok <- sequentIsAxiom sc sqt unless ok $ fail $ unlines [ "Sequent is not an instance of the sequent calculus axiom" - , prettySequent defaultPPOpts sqt + , prettySequent defaultPPOpts nenv sqt ] return (mempty, ProvedTheorem mempty) @@ -1236,7 +1250,7 @@ checkEvidence sc db = \e p -> do hyps <- Map.keysSet <$> readIORef (theoremMap d ] x' <- scExtCns sc x body' <- instantiateVar sc 0 x' body - check hyps e' (mkSqt (Prop body')) + check nenv hyps e' (mkSqt (Prop body')) passthroughEvidence :: [Evidence] -> IO Evidence passthroughEvidence [e] = pure e diff --git a/src/SAWScript/Prover/MRSolver/SMT.hs b/src/SAWScript/Prover/MRSolver/SMT.hs index e5eef3d8d6..8113158bb2 100644 --- a/src/SAWScript/Prover/MRSolver/SMT.hs +++ b/src/SAWScript/Prover/MRSolver/SMT.hs @@ -33,6 +33,7 @@ import Verifier.SAW.Recognizer import Verifier.SAW.OpenTerm import Verifier.SAW.Prim (EvalError(..)) +import Verifier.SAW.Name (emptySAWNamingEnv) import qualified Verifier.SAW.Prim as Prim import Verifier.SAW.Simulator.Value import Verifier.SAW.Simulator.TermModel @@ -286,7 +287,7 @@ mrProvableRaw prop_term = prop <- liftSC1 termToProp prop_term unints <- Set.map ecVarIndex <$> getAllExtSet <$> liftSC1 propToTerm prop debugPrint 2 ("Calling SMT solver with proposition: " ++ - prettyProp defaultPPOpts prop) + prettyProp defaultPPOpts emptySAWNamingEnv prop) sym <- liftIO $ setupWhat4_sym True -- If there are any saw-core `error`s in the term, this will throw a -- Haskell error - in this case we want to just return False, not stop diff --git a/src/SAWScript/Value.hs b/src/SAWScript/Value.hs index 3ea01878f6..1e281761d9 100644 --- a/src/SAWScript/Value.hs +++ b/src/SAWScript/Value.hs @@ -81,15 +81,14 @@ import SAWScript.Prover.MRSolver.Term as MRSolver import SAWScript.Crucible.LLVM.Skeleton import SAWScript.X86 (X86Unsupported(..), X86Error(..)) -import Verifier.SAW.Name (toShortName) +import Verifier.SAW.Name (toShortName, SAWNamingEnv, emptySAWNamingEnv) import Verifier.SAW.CryptolEnv as CEnv import Verifier.SAW.Cryptol.Monadify as Monadify import Verifier.SAW.FiniteValue (FirstOrderValue, ppFirstOrderValue) import Verifier.SAW.Rewriter (Simpset, lhsRewriteRule, rhsRewriteRule, listRules) import Verifier.SAW.SharedTerm hiding (PPOpts(..), defaultPPOpts, ppTerm, scPrettyTerm) -import qualified Verifier.SAW.SharedTerm as SAWCorePP (PPOpts(..), defaultPPOpts, - ppTerm, scPrettyTerm) +import qualified Verifier.SAW.Term.Pretty as SAWCorePP import Verifier.SAW.TypedTerm import Verifier.SAW.Term.Functor (ModuleName) @@ -292,24 +291,24 @@ showSimpset opts ss = ppTerm t = SAWCorePP.ppTerm opts' t opts' = sawPPOpts opts -showsPrecValue :: PPOpts -> Int -> Value -> ShowS -showsPrecValue opts p v = +showsPrecValue :: PPOpts -> SAWNamingEnv -> Int -> Value -> ShowS +showsPrecValue opts nenv p v = case v of VBool True -> showString "true" VBool False -> showString "false" VString s -> shows s VInteger n -> shows n - VArray vs -> showBrackets $ commaSep $ map (showsPrecValue opts 0) vs - VTuple vs -> showParen True $ commaSep $ map (showsPrecValue opts 0) vs - VMaybe (Just v') -> showString "(Just " . showsPrecValue opts 0 v' . showString ")" + VArray vs -> showBrackets $ commaSep $ map (showsPrecValue opts nenv 0) vs + VTuple vs -> showParen True $ commaSep $ map (showsPrecValue opts nenv 0) vs + VMaybe (Just v') -> showString "(Just " . showsPrecValue opts nenv 0 v' . showString ")" VMaybe Nothing -> showString "Nothing" VRecord m -> showBraces $ commaSep $ map showFld (M.toList m) where showFld (n, fv) = - showString n . showString "=" . showsPrecValue opts 0 fv + showString n . showString "=" . showsPrecValue opts nenv 0 fv VLambda {} -> showString "<>" - VTerm t -> showString (SAWCorePP.scPrettyTerm opts' (ttTerm t)) + VTerm t -> showString (SAWCorePP.showTermWithNames opts' nenv (ttTerm t)) VType sig -> showString (pretty sig) VReturn {} -> showString "<>" VBind {} -> showString "<>" @@ -318,7 +317,7 @@ showsPrecValue opts p v = VProofScript {} -> showString "<>" VTheorem thm -> showString "Theorem " . - showParen True (showString (prettyProp opts' (thmProp thm))) + showParen True (showString (prettyProp opts' nenv (thmProp thm))) VLLVMCrucibleSetup{} -> showString "<>" VLLVMCrucibleSetupValue{} -> showString "<>" VLLVMCrucibleMethodSpec{} -> showString "<>" @@ -347,7 +346,7 @@ showsPrecValue opts p v = opts' = sawPPOpts opts instance Show Value where - showsPrec p v = showsPrecValue defaultPPOpts p v + showsPrec p v = showsPrecValue defaultPPOpts emptySAWNamingEnv p v indexValue :: Value -> Value -> Value indexValue (VArray vs) (VInteger x) diff --git a/src/SAWScript/VerificationSummary.hs b/src/SAWScript/VerificationSummary.hs index 35e8d10613..b7e8744400 100644 --- a/src/SAWScript/VerificationSummary.hs +++ b/src/SAWScript/VerificationSummary.hs @@ -32,6 +32,7 @@ import qualified SAWScript.Crucible.JVM.MethodSpecIR as CMSJVM import SAWScript.Proof import SAWScript.Prover.SolverStats import qualified Verifier.SAW.Term.Pretty as PP +import Verifier.SAW.Name (SAWNamingEnv) import What4.ProgramLoc (ProgramLoc(..)) import What4.FunctionName @@ -129,8 +130,8 @@ jsonVerificationSummary (VerificationSummary jspecs lspecs thms) = lvals = (\(CMSLLVM.SomeLLVM ls) -> msToJSON ls) <$> lspecs -- TODO: why is the type annotation required here? thmvals = thmToJSON <$> thms -prettyVerificationSummary :: VerificationSummary -> String -prettyVerificationSummary vs@(VerificationSummary jspecs lspecs thms) = +prettyVerificationSummary :: PP.PPOpts -> SAWNamingEnv -> VerificationSummary -> String +prettyVerificationSummary ppOpts nenv vs@(VerificationSummary jspecs lspecs thms) = show $ vsep [ prettyJVMSpecs jspecs , prettyLLVMSpecs lspecs @@ -176,7 +177,7 @@ prettyVerificationSummary vs@(VerificationSummary jspecs lspecs thms) = ProvedTheorem{} -> "Theorem:" TestedTheorem n -> "Theorem (randomly tested on" <+> viaShow n <+> "samples):" AdmittedTheorem{} -> "Axiom:" - , code (indent 2 (ppProp PP.defaultPPOpts (thmProp t))) + , code (indent 2 (ppProp ppOpts nenv (thmProp t))) , "" ] prettySolvers ss = From 7af16c3352e87d97f056bfd4f869f255b688ae36 Mon Sep 17 00:00:00 2001 From: Rob Dockins Date: Thu, 9 Jun 2022 12:08:00 -0700 Subject: [PATCH 06/35] Further work on goal sequents --- src/SAWScript/Builtins.hs | 103 ++++- src/SAWScript/Crucible/JVM/Builtins.hs | 2 +- src/SAWScript/Crucible/LLVM/Builtins.hs | 25 +- src/SAWScript/Crucible/LLVM/X86.hs | 2 +- src/SAWScript/Interpreter.hs | 86 +++- src/SAWScript/Proof.hs | 536 +++++++++++++++++------- src/SAWScript/Value.hs | 7 +- 7 files changed, 579 insertions(+), 182 deletions(-) diff --git a/src/SAWScript/Builtins.hs b/src/SAWScript/Builtins.hs index b86abd66ef..e170f7dc44 100644 --- a/src/SAWScript/Builtins.hs +++ b/src/SAWScript/Builtins.hs @@ -543,26 +543,107 @@ normalize_term_opaque opaque tt = tm' <- io (TM.normalizeSharedTerm sc modmap mempty mempty opaqueSet (ttTerm tt)) pure tt{ ttTerm = tm' } +goal_normalize :: [String] -> ProofScript () +goal_normalize opaque = + execTactic $ tacticChange $ \goal -> + do sc <- getSharedContext + idxs <- mconcat <$> mapM (resolveName sc) opaque + modmap <- io (scGetModuleMap sc) + let opaqueSet = Set.fromList idxs + sqt' <- io $ traverseSequentWithFocus (normalizeProp sc modmap opaqueSet) (goalSequent goal) + return (sqt', NormalizePropEvidence opaqueSet) + +unfocus :: ProofScript () +unfocus = + execTactic $ tacticChange $ \goal -> + do let sqt' = unfocusSequent (goalSequent goal) + return (sqt', structuralEvidence sqt') + +focus_concl :: Integer -> ProofScript () +focus_concl i = + execTactic $ tacticChange $ \goal -> + case focusOnGoal i (goalSequent goal) of + Nothing -> fail "focus_concl : not enough conclusions" + Just sqt' -> return (sqt', structuralEvidence sqt') + +focus_hyp :: Integer -> ProofScript () +focus_hyp i = + execTactic $ tacticChange $ \goal -> + case focusOnGoal i (goalSequent goal) of + Nothing -> fail "focus_hyp : not enough hypotheses" + Just sqt' -> return (sqt', structuralEvidence sqt') + +delete_hyps :: [Integer] -> ProofScript () +delete_hyps hs = + execTactic $ tacticChange $ \goal -> + let sqt' = filterHyps (BlackList (Set.fromList hs)) (goalSequent goal) + in return (sqt', structuralEvidence sqt') + +retain_hyps :: [Integer] -> ProofScript () +retain_hyps hs = + execTactic $ tacticChange $ \goal -> + let sqt' = filterHyps (WhiteList (Set.fromList hs)) (goalSequent goal) + in return (sqt', structuralEvidence sqt') + +delete_concl :: [Integer] -> ProofScript () +delete_concl gs = + execTactic $ tacticChange $ \goal -> + let sqt' = filterGoals (BlackList (Set.fromList gs)) (goalSequent goal) + in return (sqt', structuralEvidence sqt') + +retain_concl :: [Integer] -> ProofScript () +retain_concl gs = + execTactic $ tacticChange $ \goal -> + let sqt' = filterGoals (WhiteList (Set.fromList gs)) (goalSequent goal) + in return (sqt', structuralEvidence sqt') + + +goal_cut :: Term -> ProofScript () +goal_cut tm = + do -- TODO? Theres a bit of duplicated work here + -- and in boolToProp, termToProp. + -- maybe we can consolatate + sc <- SV.scriptTopLevel getSharedContext + p <- SV.scriptTopLevel $ io $ + do tp <- scWhnf sc =<< scTypeOf sc tm + case () of + _ | Just () <- asBoolType tp + -> boolToProp sc [] tm + + | Just s <- asSort tp, s == propSort + -> termToProp sc tm + + | otherwise + -> fail "goal_cut: expected Bool or Prop term" + execTactic (tacticCut sc p) + +normalize_sequent :: ProofScript () +normalize_sequent = + execTactic $ tacticChange $ \goal -> + do sc <- getSharedContext + sqt' <- io $ normalizeSequent sc (goalSequent goal) + return (sqt', NormalizeSequentEvidence sqt') + unfoldGoal :: [String] -> ProofScript () unfoldGoal unints = execTactic $ tacticChange $ \goal -> do sc <- getSharedContext unints' <- resolveNames unints - sqt' <- traverseSequent (io . unfoldProp sc unints') (goalSequent goal) + sqt' <- traverseSequentWithFocus (io . unfoldProp sc unints') (goalSequent goal) return (sqt', UnfoldEvidence unints') simplifyGoal :: SV.SAWSimpset -> ProofScript () simplifyGoal ss = execTactic $ tacticChange $ \goal -> do sc <- getSharedContext - sqt' <- traverseSequent (\p -> snd <$> io (simplifyProp sc ss p)) (goalSequent goal) + sqt' <- traverseSequentWithFocus (\p -> snd <$> io (simplifyProp sc ss p)) (goalSequent goal) return (sqt', RewriteEvidence ss) hoistIfsInGoalPrim :: ProofScript () hoistIfsInGoalPrim = execTactic $ tacticChange $ \goal -> do sc <- getSharedContext - sqt' <- traverseSequent (io . hoistIfsInGoal sc) (goalSequent goal) + sqt' <- traverseSequentWithFocus (io . hoistIfsInGoal sc) (goalSequent goal) return (sqt', HoistIfsEvidence) term_type :: TypedTerm -> TopLevel C.Schema @@ -579,7 +660,7 @@ goal_eval unints = execTactic $ tacticChange $ \goal -> do sc <- getSharedContext unintSet <- resolveNames unints - sqt' <- traverseSequent (io . evalProp sc unintSet) (goalSequent goal) + sqt' <- traverseSequentWithFocus (io . evalProp sc unintSet) (goalSequent goal) return (sqt', EvalEvidence unintSet) extract_uninterp :: @@ -708,7 +789,7 @@ beta_reduce_goal :: ProofScript () beta_reduce_goal = execTactic $ tacticChange $ \goal -> do sc <- getSharedContext - sqt' <- traverseSequent (io . betaReduceProp sc) (goalSequent goal) + sqt' <- traverseSequentWithFocus (io . betaReduceProp sc) (goalSequent goal) return (sqt', ConversionEvidence sqt') goal_apply :: Theorem -> ProofScript () @@ -760,14 +841,14 @@ goal_has_tags tags = do s <- get case psGoals s of g : _ | Set.isSubsetOf (Set.fromList tags) (goalTags g) -> return True - _ -> return False + _ -> return False goal_has_some_tag :: [String] -> ProofScript Bool goal_has_some_tag tags = do s <- get case psGoals s of g : _ | not $ Set.disjoint (Set.fromList tags) (goalTags g) -> return True - _ -> return False + _ -> return False goal_num_ite :: Int -> ProofScript SV.Value -> ProofScript SV.Value -> ProofScript SV.Value goal_num_ite n s1 s2 = @@ -1036,7 +1117,7 @@ provePrim script t = do , goalSequent = propToSequent prop , goalTags = mempty } - res <- SV.runProofScript script goal Nothing "prove_prim" + res <- SV.runProofScript script prop goal Nothing "prove_prim" case res of UnfinishedProof pst -> printOutLnTop Info $ "prove: " ++ show (length (psGoals pst)) ++ " unsolved subgoal(s)" @@ -1063,7 +1144,7 @@ proveHelper nm script t f = do , goalTags = mempty } opts <- rwPPOpts <$> getTopLevelRW - res <- SV.runProofScript script goal Nothing (Text.pack nm) + res <- SV.runProofScript script prop goal Nothing (Text.pack nm) let failProof pst = fail $ "prove: " ++ show (length (psGoals pst)) ++ " unsolved subgoal(s)\n" ++ SV.showsProofResult opts res "" @@ -1108,7 +1189,7 @@ satPrim script t = , goalSequent = propToSequent prop , goalTags = mempty } - res <- SV.runProofScript script goal Nothing "sat" + res <- SV.runProofScript script prop goal Nothing "sat" case res of InvalidProof stats cex _ -> return (SV.Sat stats cex) ValidProof stats _thm -> return (SV.Unsat stats) @@ -1632,7 +1713,7 @@ prove_core script input = , goalSequent = propToSequent p , goalTags = mempty } - res <- SV.runProofScript script goal Nothing "prove_core" + res <- SV.runProofScript script p goal Nothing "prove_core" let failProof pst = fail $ "prove_core: " ++ show (length (psGoals pst)) ++ " unsolved subgoal(s)\n" ++ SV.showsProofResult opts res "" diff --git a/src/SAWScript/Crucible/JVM/Builtins.hs b/src/SAWScript/Crucible/JVM/Builtins.hs index 218c27e438..b263eac1f1 100644 --- a/src/SAWScript/Crucible/JVM/Builtins.hs +++ b/src/SAWScript/Crucible/JVM/Builtins.hs @@ -316,7 +316,7 @@ verifyObligations cc mspec tactic assumes asserts = , goalSequent = propToSequent goal' , goalTags = MS.conditionTags md } - res <- runProofScript tactic proofgoal (Just ploc) $ Text.unwords + res <- runProofScript tactic goal' proofgoal (Just ploc) $ Text.unwords ["JVM verification condition:", Text.pack (show n), Text.pack goalname] case res of ValidProof stats thm -> return (stats, thmNonce thm) diff --git a/src/SAWScript/Crucible/LLVM/Builtins.hs b/src/SAWScript/Crucible/LLVM/Builtins.hs index 21f9b76de1..c616cd767e 100644 --- a/src/SAWScript/Crucible/LLVM/Builtins.hs +++ b/src/SAWScript/Crucible/LLVM/Builtins.hs @@ -780,12 +780,18 @@ verifyObligations cc mspec tactic assumes asserts = do let sym = cc^.ccSym st <- io $ Common.sawCoreState sym let sc = saw_ctx st - assume <- io $ scAndList sc (toListOf (folded . Crucible.labeledPred) assumes) + useSequentGoals <- rwSequentGoals <$> getTopLevelRW + let assumeTerms = toListOf (folded . Crucible.labeledPred) assumes + assume <- io $ scAndList sc assumeTerms let nm = mspec ^. csName outs <- forM (zip [(0::Int)..] asserts) $ \(n, (msg, md, assert)) -> - do goal <- io $ scImplies sc assume assert - goal' <- io $ boolToProp sc [] goal + do goal <- io $ scImplies sc assume assert + goal' <- io $ boolToProp sc [] goal + sqt <- if useSequentGoals then + io $ booleansToSequent sc assumeTerms [assert] + else + return (propToSequent goal') let ploc = MS.conditionLoc md let gloc = (unwords [show (W4.plSourceLoc ploc) ,"in" @@ -799,10 +805,10 @@ verifyObligations cc mspec tactic assumes asserts = , goalName = nm , goalLoc = gloc , goalDesc = msg - , goalSequent = propToSequent goal' + , goalSequent = sqt , goalTags = MS.conditionTags md } - res <- runProofScript tactic proofgoal (Just ploc) $ Text.unwords + res <- runProofScript tactic goal' proofgoal (Just ploc) $ Text.unwords ["LLVM verification condition", Text.pack (show n), Text.pack goalname] case res of ValidProof stats thm -> return (stats, thmNonce thm) @@ -969,14 +975,15 @@ assumptionsContainContradiction cc methodSpec tactic assumptions = st <- io $ Common.sawCoreState sym let sc = saw_ctx st let ploc = methodSpec^.MS.csLoc - pgl <- io $ + (goal',pgl) <- io $ do -- conjunction of all assumptions assume <- scAndList sc (toListOf (folded . Crucible.labeledPred) assumptions) -- implies falsehood goal <- scImplies sc assume =<< toSC sym st (W4.falsePred sym) goal' <- boolToProp sc [] goal - return $ ProofGoal + return $ (goal', + ProofGoal { goalNum = 0 , goalType = "vacuousness check" , goalName = show (methodSpec^.MS.csMethod) @@ -984,8 +991,8 @@ assumptionsContainContradiction cc methodSpec tactic assumptions = , goalDesc = "vacuousness check" , goalSequent = propToSequent goal' , goalTags = mempty - } - res <- runProofScript tactic pgl Nothing "vacuousness check" + }) + res <- runProofScript tactic goal' pgl Nothing "vacuousness check" case res of ValidProof _ _ -> return True InvalidProof _ _ _ -> return False diff --git a/src/SAWScript/Crucible/LLVM/X86.hs b/src/SAWScript/Crucible/LLVM/X86.hs index e715833395..8b94a9fc8d 100644 --- a/src/SAWScript/Crucible/LLVM/X86.hs +++ b/src/SAWScript/Crucible/LLVM/X86.hs @@ -1199,7 +1199,7 @@ checkGoals bak opts nm sc tactic mdMap = do , goalSequent = propToSequent term , goalTags = MS.conditionTags md } - res <- runProofScript tactic proofgoal (Just (gLoc g)) $ Text.unwords + res <- runProofScript tactic term proofgoal (Just (gLoc g)) $ Text.unwords ["X86 verification condition", Text.pack (show n), Text.pack (show (gMessage g))] case res of ValidProof stats thm -> return (stats, thmNonce thm) diff --git a/src/SAWScript/Interpreter.hs b/src/SAWScript/Interpreter.hs index 37dbaaf94f..4800c2d85f 100644 --- a/src/SAWScript/Interpreter.hs +++ b/src/SAWScript/Interpreter.hs @@ -502,6 +502,7 @@ buildTopLevelEnv proxy opts = , rwPathSatSolver = CC.PathSat_Z3 , rwSkipSafetyProofs = False , rwSingleOverrideSpecialCase = False + , rwSequentGoals = False } return (bic, ro0, rw0) @@ -553,6 +554,16 @@ disable_safety_proofs = do rw <- getTopLevelRW putTopLevelRW rw{ rwSkipSafetyProofs = True } +enable_sequent_goals :: TopLevel () +enable_sequent_goals = do + rw <- getTopLevelRW + putTopLevelRW rw{ rwSequentGoals = True } + +disable_sequent_goals :: TopLevel () +disable_sequent_goals = do + rw <- getTopLevelRW + putTopLevelRW rw{ rwSequentGoals = False } + enable_smt_array_memory_model :: TopLevel () enable_smt_array_memory_model = do rw <- getTopLevelRW @@ -948,6 +959,20 @@ primitives = Map.fromList Current [ "Disable the SMT array memory model." ] + , prim "enable_sequent_goals" "TopLevel ()" + (pureVal enable_sequent_goals) + Experimental + [ "When verifying proof obligations arising from `llvm_verify` and similar" + , "generate sequents for the proof obligations instead of a single boolean goal." + ] + + , prim "disable_sequent_goals" "TopLevel ()" + (pureVal disable_sequent_goals) + Experimental + [ "Restore the default behavior, which is to generate single boolean goals" + , "for proof obligations arising from verification commands." + ] + , prim "enable_safety_proofs" "TopLevel ()" (pureVal enable_safety_proofs) Experimental @@ -1558,10 +1583,61 @@ primitives = Map.fromList Current [ "Apply the given simplifier rule set to the current goal." ] + , prim "unfocus" "ProofScript ()" + (pureVal unfocus) + Experimental + [ "Remove any sequent focus point." ] + + , prim "focus_concl" "Int -> ProofScript ()" + (pureVal focus_concl) + Experimental + [ "Focus on the numbered conclusion within a sequent. This will fail if there are" + , "not enough goals." + ] + + , prim "focus_hyp" "Int -> ProofScript ()" + (pureVal focus_hyp) + Experimental + [ "Focus on the numbered conclusion with a sequent. This will fail if there are" + , "enough hypotheses." + ] + + , prim "normalize_sequent" "ProofScript ()" + (pureVal normalize_sequent) + Experimental + [ "Normalize the current goal sequent by applying reversable sequent calculus rules." + , "The resulting sequent will be unfocused." + ] + + , prim "goal_cut" "Term -> ProofScript ()" + (pureVal goal_cut) + Experimental + [ "TODO, write docs" ] + + , prim "retain_hyps" "[Int] -> ProofScript ()" + (pureVal retain_hyps) + Experimental + [ "Remove all hypotheses from the current sequent other than the ones listed." ] + + , prim "delete_hyps" "[Int] -> ProofScript ()" + (pureVal delete_hyps) + Experimental + [ "Remove the numbered hypotheses from the current sequent." ] + + , prim "retain_concl" "[Int] -> ProofScript ()" + (pureVal retain_concl) + Experimental + [ "Remove all conclusions from the current sequent other than the ones listed." ] + + , prim "delete_concl" "[Int] -> ProofScript ()" + (pureVal delete_concl) + Experimental + [ "Remove the numbered conclusions from the current sequent." ] + , prim "hoist_ifs_in_goal" "ProofScript ()" (pureVal hoistIfsInGoalPrim) Experimental - [ "hoist ifs in the current proof goal" ] + [ "Hoist ifs in the current proof goal." ] , prim "normalize_term" "Term -> Term" (funVal1 normalize_term) @@ -1575,6 +1651,14 @@ primitives = Map.fromList , "The named values will be treated opaquely and not unfolded during evaluation." ] + , prim "goal_normalize" "[String] -> ProofScript ()" + (pureVal goal_normalize) + Experimental + [ "Evaluate the current proof goal by performing evaluation in SAWCore." + , "The currently-focused term will be evaluted. If the sequent is unfocused" + , "all terms will be evaluated. The given names will be treated as uninterpreted." + ] + , prim "goal_eval" "ProofScript ()" (pureVal (goal_eval [])) Current diff --git a/src/SAWScript/Proof.hs b/src/SAWScript/Proof.hs index 1ab1f7c7f7..7ab1a243cd 100644 --- a/src/SAWScript/Proof.hs +++ b/src/SAWScript/Proof.hs @@ -31,6 +31,7 @@ module SAWScript.Proof , prettyProp , ppProp , propToSATQuery + , normalizeProp , checkProp , Sequent @@ -43,8 +44,19 @@ module SAWScript.Proof , ppSequent , propToSequent , traverseSequent + , traverseSequentWithFocus , checkSequent , sequentConstantSet + , booleansToSequent + , unfocusSequent + , focusOnGoal + , focusOnHyp + , normalizeSequent + , filterHyps + , filterGoals + + , CofinSet(..) + , cofinSetMember , TheoremDB , newTheoremDB @@ -73,6 +85,7 @@ module SAWScript.Proof , Evidence(..) , checkEvidence + , structuralEvidence , Tactic , withFirstGoal @@ -81,6 +94,7 @@ module SAWScript.Proof -- , tacticAssume , tacticApply , tacticSplit + , tacticCut , tacticTrivial , tacticId , tacticChange @@ -111,6 +125,7 @@ import qualified Control.Monad.Fail as F import Control.Monad.Except import Data.IORef import qualified Data.Foldable as Fold +import Data.List import Data.Maybe (fromMaybe) import Data.Map (Map) import qualified Data.Map as Map @@ -120,6 +135,8 @@ import Data.Text (Text) import qualified Data.Text as Text import Data.Time.Clock +import Prettyprinter + import Data.Parameterized.Nonce import Verifier.SAW.Prelude (scApplyPrelude_False) @@ -131,7 +148,8 @@ import Verifier.SAW.SharedTerm import Verifier.SAW.TypedAST import Verifier.SAW.TypedTerm import Verifier.SAW.FiniteValue (FirstOrderValue) -import Verifier.SAW.Term.Pretty (SawDoc, renderSawDoc, ppTermWithNames, ppTermContainerWithNames) +import Verifier.SAW.Term.Pretty + (SawDoc, renderSawDoc, ppTermWithNames, ppTermContainerWithNames) import qualified Verifier.SAW.SCTypeCheck as TC import Verifier.SAW.Simulator.Concrete (evalSharedTerm) @@ -142,6 +160,7 @@ import What4.ProgramLoc (ProgramLoc) import SAWScript.Position import SAWScript.Prover.SolverStats import SAWScript.Crucible.Common as Common +import qualified Verifier.SAW.Simulator.TermModel as TM import qualified Verifier.SAW.Simulator.What4 as W4Sim import qualified Verifier.SAW.Simulator.What4.ReturnTrip as W4Sim import SAWScript.Panic(panic) @@ -350,6 +369,11 @@ trivialProofTerm sc (Prop p) = runExceptT (loop =<< lift (scWhnf sc p)) , showTerm p ] +normalizeProp :: SharedContext -> ModuleMap -> Set VarIndex -> Prop -> IO Prop +normalizeProp sc modmap opaqueSet (Prop tm) = + do tm' <- TM.normalizeSharedTerm sc modmap mempty mempty opaqueSet tm + termToProp sc tm' + -- | Pretty print the given proposition as a string. prettyProp :: PPOpts -> SAWNamingEnv -> Prop -> String prettyProp opts nenv p = renderSawDoc opts (ppProp opts nenv p) @@ -363,25 +387,42 @@ type SequentBranch = Prop data Sequent = UnfocusedSequent [SequentBranch] [SequentBranch] - | GoalFocusedSequent [SequentBranch] ([SequentBranch], SequentBranch, [SequentBranch]) - | HypFocusedSequent ([SequentBranch], SequentBranch, [SequentBranch]) [SequentBranch] - -sequentToRawSequent :: Sequent -> RawSequent Term + | GoalFocusedSequent [SequentBranch] ([SequentBranch], SequentBranch, [SequentBranch]) + | HypFocusedSequent ([SequentBranch], SequentBranch, [SequentBranch]) [SequentBranch] + +unfocus :: Sequent -> ([SequentBranch],[SequentBranch]) +unfocus (UnfocusedSequent hs gs) = (hs,gs) +unfocus (GoalFocusedSequent hs (gs1,g,gs2)) = (hs, gs1 ++ g : gs2) +unfocus (HypFocusedSequent (hs1,h,hs2) gs) = (hs1 ++ h : hs2, gs) + +unfocusSequent :: Sequent -> Sequent +unfocusSequent sqt = UnfocusedSequent hs gs + where (hs,gs) = unfocus sqt + +focusOnGoal :: Integer -> Sequent -> Maybe Sequent +focusOnGoal i sqt = + let (hs,gs) = unfocus sqt in + case genericDrop i gs of + (g:gs2) -> Just (GoalFocusedSequent hs (genericTake i gs, g, gs2)) + [] -> Nothing + +focusOnHyp :: Integer -> Sequent -> Maybe Sequent +focusOnHyp i sqt = + let (hs,gs) = unfocus sqt in + case genericDrop i hs of + (h:hs2) -> Just (HypFocusedSequent (genericTake i hs, h, hs2) gs) + [] -> Nothing + +sequentToRawSequent :: Sequent -> RawSequent Prop sequentToRawSequent sqt = case sqt of - UnfocusedSequent hs gs -> f hs gs - GoalFocusedSequent hs (gs1, g, gs2) -> f hs (gs1 ++ g : gs2) - HypFocusedSequent (hs1, h, hs2) gs -> f (hs1 ++ h : hs2) gs + UnfocusedSequent hs gs -> RawSequent hs gs + GoalFocusedSequent hs (gs1, g, gs2) -> RawSequent hs (gs1 ++ g : gs2) + HypFocusedSequent (hs1, h, hs2) gs -> RawSequent (hs1 ++ h : hs2) gs - where - f hs gs = RawSequent (map toRaw hs) (map toRaw gs) - toRaw (Prop p) = - case asEqTrue p of - Just p' -> p' - Nothing -> p sequentConstantSet :: Sequent -> Map VarIndex (NameInfo, Term, Maybe Term) -sequentConstantSet sqt = foldr (\t m -> Map.union (getConstantSet t) m) mempty (hs++gs) +sequentConstantSet sqt = foldr (\p m -> Map.union (getConstantSet (unProp p)) m) mempty (hs++gs) where RawSequent hs gs = sequentToRawSequent sqt @@ -394,89 +435,25 @@ instance Foldable RawSequent where instance Traversable RawSequent where traverse f (RawSequent hs gs) = RawSequent <$> traverse f hs <*> traverse f gs -data NormalizedSequent = NormSeq (Set Term) (Set Term) - -normalizedSequentSubsumes :: NormalizedSequent -> NormalizedSequent -> Bool -normalizedSequentSubsumes (NormSeq h1 g1) (NormSeq h2 g2) = - (h1 `Set.isSubsetOf` h2) && (g1 `Set.isSubsetOf` g2) -normalizedSequentIsAxiom :: SharedContext -> NormalizedSequent -> IO Bool -normalizedSequentIsAxiom sc (NormSeq hset gset) = - loop [ (h,g) | h <- Set.toList hset, g <- Set.toList gset ] - where - loop [] = return False - loop ((h,g):xs) = - do ok <- scConvertible sc False h g - if ok then return True else loop xs - -convertibleTerms :: SharedContext -> [Term] -> [Term] -> IO Bool -convertibleTerms _sc [] [] = return True -convertibleTerms sc (p1:ps1) (p2:ps2) = - do ok1 <- scConvertible sc False p1 p2 - ok2 <- convertibleTerms sc ps1 ps2 +convertibleProps :: SharedContext -> [Prop] -> [Prop] -> IO Bool +convertibleProps _sc [] [] = return True +convertibleProps sc (p1:ps1) (p2:ps2) = + do ok1 <- scConvertible sc True (unProp p1) (unProp p2) + ok2 <- convertibleProps sc ps1 ps2 return (ok1 && ok2) -convertibleTerms _sc _ _ = return False +convertibleProps _sc _ _ = return False convertibleSequents :: SharedContext -> Sequent -> Sequent -> IO Bool convertibleSequents sc sqt1 sqt2 = - do ok1 <- convertibleTerms sc hs1 hs2 - ok2 <- convertibleTerms sc gs1 gs2 + do ok1 <- convertibleProps sc hs1 hs2 + ok2 <- convertibleProps sc gs1 gs2 return (ok1 && ok2) where RawSequent hs1 gs1 = sequentToRawSequent sqt1 RawSequent hs2 gs2 = sequentToRawSequent sqt2 -normalizeSequent :: SharedContext -> RawSequent Term -> IO NormalizedSequent -normalizeSequent sc = loop (NormSeq mempty mempty) - where - loop (NormSeq hset gset) (RawSequent (h:hs) gs) = - do body <- scWhnf sc h - case () of - _ | Just (_ :*: p1) <- (isGlobalDef "Prelude.not" <@> return) body - -> loop (NormSeq hset gset) (RawSequent hs (p1 : gs)) - - | Just (_ :*: p1 :*: p2) <- (isGlobalDef "Prelude.and" <@> return <@> return) body - -> loop (NormSeq hset gset) (RawSequent (p1 : p2 : hs) gs) - - | Just (_ :*: p1 :*: p2) <- (isGlobalDef "Prelude.xor" <@> return <@> return) body - -> do g1 <- scBoolEq sc p1 p2 - loop (NormSeq hset gset) (RawSequent hs (g1:gs)) - - | Just _ <- (isGlobalDef "Prelude.True") body - -> loop (NormSeq hset gset) (RawSequent hs gs) - - | Just _ <- (isGlobalDef "Prelude.False") body - -> return (NormSeq (Set.singleton body) (Set.singleton body)) - - | otherwise -> - loop (NormSeq (Set.insert h hset) gset) (RawSequent hs gs) - - loop (NormSeq hset gset) (RawSequent [] (g:gs)) = - do body <- scWhnf sc g - case () of - _ | Just (_ :*: p1) <- (isGlobalDef "Prelude.not" <@> return) body - -> loop (NormSeq hset gset) (RawSequent [p1] gs) - - | Just (_ :*: p1 :*: p2) <- (isGlobalDef "Prelude.or" <@> return <@> return) body - -> loop (NormSeq hset gset) (RawSequent [] (p1 : p2 : gs)) - - | Just (_ :*: p1 :*: p2) <- (isGlobalDef "Prelude.xor" <@> return <@> return) body - -> do h1 <- scBoolEq sc p1 p2 - loop (NormSeq hset gset) (RawSequent [h1] gs) - - | Just _ <- (isGlobalDef "Prelude.False") body - -> loop (NormSeq hset gset) (RawSequent [] gs) - - | Just _ <- (isGlobalDef "Prelude.True") body - -> return (NormSeq (Set.singleton body) (Set.singleton body)) - - | otherwise -> - loop (NormSeq hset (Set.insert g gset)) (RawSequent [] gs) - - loop (NormSeq hset gset) (RawSequent [] []) = return (NormSeq hset gset) - - data SequentState = Unfocused @@ -486,13 +463,23 @@ data SequentState propToSequent :: Prop -> Sequent propToSequent p = GoalFocusedSequent [] ([], p, []) +booleansToSequent :: SharedContext -> [Term] -> [Term] -> IO Sequent +booleansToSequent sc hs gs = + do hs' <- mapM (boolToProp sc []) hs + gs' <- mapM (boolToProp sc []) gs + case gs' of + [g] -> return (GoalFocusedSequent hs' ([],g,[])) + _ -> return (UnfocusedSequent hs' gs') + sequentToProp :: SharedContext -> Sequent -> IO Prop sequentToProp sc sqt = - case sqt of - UnfocusedSequent hs [g] -> loop hs g - GoalFocusedSequent hs ([],g,[]) -> loop hs g - HypFocusedSequent (hs1,h,hs2) [g] -> loop (hs1++h:hs2) g - _ -> fail "sequentToProp cannot currently handle multi-conclusion sequents FIXME" + do let RawSequent hs gs = sequentToRawSequent sqt + case gs of + [] -> do g <- boolToProp sc [] =<< scBool sc False + loop hs g + [g] -> loop hs g + -- TODO, we should add a prop-level disjunction to the SAWCore prelude + _ -> fail "seqentToProp: cannot handle multi-conclusion sequents" where loop [] g = return g @@ -500,10 +487,6 @@ sequentToProp sc sqt = do g' <- loop hs g Prop <$> scFun sc (unProp h) (unProp g') -sequentToSATQuery :: SharedContext -> Set VarIndex -> Sequent -> IO SATQuery -sequentToSATQuery sc unintSet sqt = - sequentToProp sc sqt >>= propToSATQuery sc unintSet - -- | Pretty print the given proposition as a string. prettySequent :: PPOpts -> SAWNamingEnv -> Sequent -> String prettySequent opts nenv sqt = renderSawDoc opts (ppSequent opts nenv sqt) @@ -511,11 +494,90 @@ prettySequent opts nenv sqt = renderSawDoc opts (ppSequent opts nenv sqt) -- | Pretty print the given proposition as a @SawDoc@. ppSequent :: PPOpts -> SAWNamingEnv -> Sequent -> SawDoc ppSequent opts nenv sqt = - ppTermContainerWithNames ppRawSequent opts nenv (sequentToRawSequent sqt) + ppTermContainerWithNames + (ppRawSequent sqt) + opts + nenv + (fmap unProp (sequentToRawSequent sqt)) + +ppRawSequent :: Sequent -> RawSequent SawDoc -> SawDoc +ppRawSequent _sqt (RawSequent [] [g]) = g +ppRawSequent sqt (RawSequent hs gs) = + align (vcat (map ppHyp (zip [0..] hs) ++ turnstile ++ map ppGoal (zip [0..] gs))) + where + turnstile = [ pretty (take 40 (repeat '=')) ] + focused doc = "<<" <> doc <> ">>" + ppHyp (i, tm) + | HypFocusedSequent (hs1,_h,_hs2) _gs <- sqt + , length hs1 == i + = focused ("H" <> pretty i) <+> tm + + | otherwise + = "H" <> pretty i <> ":" <+> tm -ppRawSequent :: RawSequent SawDoc -> SawDoc -ppRawSequent (RawSequent [] [g]) = g -ppRawSequent (RawSequent hs gs) = error "ppRawSequent! implement nontrivial cases!" + ppGoal (i, tm) + | GoalFocusedSequent _hs (gs1,_g,_gs2) <- sqt + , length gs1 == i + = focused ("G" <> pretty i) <+> tm + + | otherwise + = "G" <> pretty i <> ":" <+> tm + + +data CofinSet a + = WhiteList (Set a) + | BlackList (Set a) + +cofinSetMember :: Ord a => a -> CofinSet a -> Bool +cofinSetMember a (WhiteList xs) = Set.member a xs +cofinSetMember a (BlackList xs) = not (Set.member a xs) + +filterPosList :: CofinSet Integer -> [a] -> [a] +filterPosList pss xs = map snd $ filter f $ zip [0..] xs + where + f (i,_) = cofinSetMember i pss + +filterFocusedList :: CofinSet Integer -> ([a],a,[a]) -> Either [a] ([a],a,[a]) +filterFocusedList pss (xs1,x,xs2) = + if cofinSetMember idx pss then + Right (xs1',x,xs2') + else + Left (xs1' ++ xs2') + where + f (i,_) = cofinSetMember i pss + idx = genericLength xs1 + xs1' = map snd $ filter f $ zip [0..] xs1 + xs2' = map snd $ filter f $ zip [idx+1..] xs2 + +filterHyps :: CofinSet Integer -> Sequent -> Sequent +filterHyps pss (UnfocusedSequent hs gs) = + UnfocusedSequent (filterPosList pss hs) gs +filterHyps pss (GoalFocusedSequent hs gs) = + GoalFocusedSequent (filterPosList pss hs) gs +filterHyps pss (HypFocusedSequent hs gs) = + case filterFocusedList pss hs of + Left hs' -> UnfocusedSequent hs' gs + Right hs' -> HypFocusedSequent hs' gs + +filterGoals :: CofinSet Integer -> Sequent -> Sequent +filterGoals pss (UnfocusedSequent hs gs) = + UnfocusedSequent hs (filterPosList pss gs) +filterGoals pss (HypFocusedSequent hs gs) = + HypFocusedSequent hs (filterPosList pss gs) +filterGoals pss (GoalFocusedSequent hs gs) = + case filterFocusedList pss gs of + Left gs' -> UnfocusedSequent hs gs' + Right gs' -> GoalFocusedSequent hs gs' + +addHypothesis :: Prop -> Sequent -> Sequent +addHypothesis p (UnfocusedSequent hs gs) = UnfocusedSequent (hs ++ [p]) gs +addHypothesis p (GoalFocusedSequent hs gs) = GoalFocusedSequent (hs ++ [p]) gs +addHypothesis p (HypFocusedSequent (hs1,h,hs2) gs) = HypFocusedSequent (hs1,h,hs2++[p]) gs + +addNewFocusedGoal :: Prop -> Sequent -> Sequent +addNewFocusedGoal p sqt = + let RawSequent hs gs = sequentToRawSequent sqt + in GoalFocusedSequent hs (gs,p,[]) sequentState :: Sequent -> SequentState sequentState (UnfocusedSequent _ _) = Unfocused @@ -525,22 +587,35 @@ sequentState (HypFocusedSequent (hs1,h,hs2) gs) = HypFocus h (\h' -> HypFocusedSequent (hs1,h',hs2) gs) sequentSharedSize :: Sequent -> Integer -sequentSharedSize sqt = scSharedSizeMany (hs ++ gs) +sequentSharedSize sqt = scSharedSizeMany (map unProp (hs ++ gs)) where RawSequent hs gs = sequentToRawSequent sqt sequentTreeSize :: Sequent -> Integer -sequentTreeSize sqt = scTreeSizeMany (hs ++ gs) +sequentTreeSize sqt = scTreeSizeMany (map unProp (hs ++ gs)) where RawSequent hs gs = sequentToRawSequent sqt +traverseSequentWithFocus :: Applicative m => (Prop -> m Prop) -> Sequent -> m Sequent +traverseSequentWithFocus f (UnfocusedSequent hs gs) = + UnfocusedSequent <$> traverse f hs <*> traverse f gs +traverseSequentWithFocus f (GoalFocusedSequent hs (gs1, g, gs2)) = + (\g' -> GoalFocusedSequent hs (gs1, g', gs2)) <$> f g +traverseSequentWithFocus f (HypFocusedSequent (hs1, h, hs2) gs) = + (\h' -> HypFocusedSequent (hs1, h', hs2) gs) <$> f h + traverseSequent :: Applicative m => (Prop -> m Prop) -> Sequent -> m Sequent traverseSequent f (UnfocusedSequent hs gs) = UnfocusedSequent <$> traverse f hs <*> traverse f gs traverseSequent f (GoalFocusedSequent hs (gs1, g, gs2)) = - (\g' -> GoalFocusedSequent hs (gs1, g', gs2)) <$> f g + GoalFocusedSequent <$> + (traverse f hs) <*> + ( (,,) <$> traverse f gs1 <*> f g <*> traverse f gs2) + traverseSequent f (HypFocusedSequent (hs1, h, hs2) gs) = - (\h' -> HypFocusedSequent (hs1, h', hs2) gs) <$> f h + HypFocusedSequent <$> + ( (,,) <$> traverse f hs1 <*> f h <*> traverse f hs2) <*> + (traverse f gs) checkSequent :: SharedContext -> PPOpts -> Sequent -> IO () checkSequent sc ppOpts (UnfocusedSequent hs gs) = @@ -711,9 +786,10 @@ data Evidence -- | This type of evidence is used to prove a universally-quantified statement. | IntroEvidence (ExtCns Term) Evidence - -- | This type of evidence is used to weaken a goal by adding a hypothesis, - -- where the hypothesis is proved by the given theorem. - -- | CutEvidence Theorem Evidence + -- | This type of evidence is used to apply the "cut rule" of sequent calculus. + -- The given proposition is added to the hypothesis list in the first + -- deriviation, and into the conclusion list in the second, where it is focused. + | CutEvidence Prop Evidence Evidence -- | This type of evidence is used to modify a goal to prove via rewriting. -- The goal to prove is rewritten by the given simpset; then the provided @@ -741,11 +817,21 @@ data Evidence -- 'hoistIfsInGoal'. | HoistIfsEvidence Evidence - -- | Change the state of the sequence in some "structural" way. This - -- can involve changing focus, or applying reversable sequent calculus - -- rules. + -- | Change the state of the sequent in some "structural" way. This + -- can involve changing focus, reordering or applying weakening rules. | StructuralEvidence Sequent Evidence + -- | Change the state of the sequent in some way that is governed by + -- the "reversable" L/R rules of the sequent calculus, e.g., + -- conjunctions in hypotheses can be split into multiple hypotheses, + -- negated conclusions become positive hypotheses, etc. + | NormalizeSequentEvidence Sequent Evidence + + -- | Change the sate of th sequent by invoking the term evaluator + -- on the focused sequent branch (or all branches, if unfocused). + -- Treat the given variable indexes as opaque. + | NormalizePropEvidence (Set VarIndex) Evidence + -- | This type of evidence is used when the current sequent, after -- applying structural rules, is an instance of the basic -- sequent calculus axiom, which connects a hypothesis to a goal. @@ -815,11 +901,13 @@ introEvidence :: ExtCns Term -> [Evidence] -> IO Evidence introEvidence x [e] = pure (IntroEvidence x e) introEvidence _ _ = fail "introEvidence: expected one evidence value" -{- -cutEvidence :: Theorem -> [Evidence] -> IO Evidence -cutEvidence thm [e] = pure (CutEvidence thm e) -cutEvidence _ _ = fail "cutEvidence: expected one evidence value" --} +cutEvidence :: Prop -> [Evidence] -> IO Evidence +cutEvidence p [e1,e2] = pure (CutEvidence p e1 e2) +cutEvidence _ _ = fail "cutEvidence: expected two evidence values" + +structuralEvidence :: Sequent -> Evidence -> Evidence +structuralEvidence _sqt (StructuralEvidence sqt' e) = StructuralEvidence sqt' e +structuralEvidence sqt e = StructuralEvidence sqt e -- | Construct a theorem directly via a proof term. proofByTerm :: SharedContext -> TheoremDB -> Term -> Pos -> Text -> IO Theorem @@ -1013,20 +1101,122 @@ psGoals = _psGoals psStats :: ProofState -> SolverStats psStats = _psStats +-- forall x in ps1, exists y in ps2 where x == y +propsSubset :: SharedContext -> [Prop] -> [Prop] -> IO Bool +propsSubset sc ps1 ps2 = + and <$> sequence [ propsElem sc x ps2 | x <- ps1 ] + +-- exists y in ps where x == y +propsElem :: SharedContext -> Prop -> [Prop] -> IO Bool +propsElem sc x ps = + or <$> sequence [ scConvertible sc True (unProp x) (unProp y) | y <- ps ] + +sequentIsAxiom :: SharedContext -> Sequent -> IO Bool +sequentIsAxiom sc sqt = + do let RawSequent hs gs = sequentToRawSequent sqt + or <$> sequence [ scConvertible sc True (unProp x) (unProp y) | x <- hs, y <- gs ] + -- | Test if the first given sequent subsumes the -- second given sequent. This is a shallow syntactic -- check that is sufficent to show that a proof -- of the first sequent is sufficent to prove the second sequentSubsumes :: SharedContext -> Sequent -> Sequent -> IO Bool sequentSubsumes sc sqt1 sqt2 = - do sqt1' <- normalizeSequent sc (sequentToRawSequent sqt1) - sqt2' <- normalizeSequent sc (sequentToRawSequent sqt2) - return (normalizedSequentSubsumes sqt1' sqt2') + do let RawSequent hs1 gs1 = sequentToRawSequent sqt1 + let RawSequent hs2 gs2 = sequentToRawSequent sqt2 + hypsOK <- propsSubset sc hs1 hs2 + conclOK <- propsSubset sc gs1 gs2 + return (hypsOK && conclOK) + +-- | Test if the first given sequent subsumes the +-- second given sequent. This is a shallow syntactic +-- check that is sufficent to show that a proof +-- of the first sequent is sufficent to prove the second +normalizeSequentSubsumes :: SharedContext -> Sequent -> Sequent -> IO Bool +normalizeSequentSubsumes sc sqt1 sqt2 = + do RawSequent hs1 gs1 <- normalizeRawSequent sc (sequentToRawSequent sqt1) + RawSequent hs2 gs2 <- normalizeRawSequent sc (sequentToRawSequent sqt2) + hypsOK <- propsSubset sc hs1 hs2 + conclOK <- propsSubset sc gs1 gs2 + return (hypsOK && conclOK) + +normalizeSequent :: SharedContext -> Sequent -> IO Sequent +normalizeSequent sc sqt = + -- TODO, if/when we add metadata to sequent branches, this will need to change + do RawSequent hs gs <- normalizeRawSequent sc (sequentToRawSequent sqt) + return (UnfocusedSequent hs gs) + +normalizeRawSequent :: SharedContext -> RawSequent Prop -> IO (RawSequent Prop) +normalizeRawSequent sc (RawSequent hs gs) = + do hs' <- mapM (normalizeHyp sc) hs + gs' <- mapM (normalizeGoal sc) gs + return (joinSequents (hs' ++ gs')) + +joinSequent :: RawSequent Prop -> RawSequent Prop -> RawSequent Prop +joinSequent (RawSequent hs1 gs1) (RawSequent hs2 gs2) = RawSequent (hs1 ++ hs2) (gs1 ++ gs2) + +joinSequents :: [RawSequent Prop] -> RawSequent Prop +joinSequents = foldl joinSequent (RawSequent [] []) + + +normalizeHyp :: SharedContext -> Prop -> IO (RawSequent Prop) +normalizeHyp sc p = + do t <- scWhnf sc (unProp p) + case asEqTrue t of + Just b -> normalizeHypBool sc b >>= \case + Just sqt -> return sqt + Nothing -> return (RawSequent [p] []) + _ -> return (RawSequent [p] []) + +normalizeGoal :: SharedContext -> Prop -> IO (RawSequent Prop) +normalizeGoal sc p = + do t <- scWhnf sc (unProp p) + case asEqTrue t of + Just b -> normalizeGoalBool sc b >>= \case + Just sqt -> return sqt + Nothing -> return (RawSequent [] [p]) + _ -> return (RawSequent [] [p]) + +normalizeHypBool :: SharedContext -> Term -> IO (Maybe (RawSequent Prop)) +normalizeHypBool sc b = + do body <- scWhnf sc b + case () of + _ | Just (_ :*: p1) <- (isGlobalDef "Prelude.not" <@> return) body + -> Just <$> normalizeGoalBoolCommit sc p1 + + | Just (_ :*: p1 :*: p2) <- (isGlobalDef "Prelude.and" <@> return <@> return) body + -> Just <$> (joinSequent <$> normalizeHypBoolCommit sc p1 <*> normalizeHypBoolCommit sc p2) + + | otherwise + -> return Nothing + +normalizeHypBoolCommit :: SharedContext -> Term -> IO (RawSequent Prop) +normalizeHypBoolCommit sc b = + normalizeHypBool sc b >>= \case + Just sqt -> return sqt + Nothing -> do p <- boolToProp sc [] b + return (RawSequent [p] []) + +normalizeGoalBool :: SharedContext -> Term -> IO (Maybe (RawSequent Prop)) +normalizeGoalBool sc b = + do body <- scWhnf sc b + case () of + _ | Just (_ :*: p1) <- (isGlobalDef "Prelude.not" <@> return) body + -> Just <$> normalizeHypBoolCommit sc p1 + + | Just (_ :*: p1 :*: p2) <- (isGlobalDef "Prelude.or" <@> return <@> return) body + -> Just <$> (joinSequent <$> normalizeGoalBoolCommit sc p1 <*> normalizeGoalBoolCommit sc p2) + + | otherwise + -> return Nothing + +normalizeGoalBoolCommit :: SharedContext -> Term -> IO (RawSequent Prop) +normalizeGoalBoolCommit sc b = + normalizeGoalBool sc b >>= \case + Just sqt -> return sqt + Nothing -> do p <- boolToProp sc [] b + return (RawSequent [] [p]) -sequentIsAxiom :: SharedContext -> Sequent -> IO Bool -sequentIsAxiom sc sqt = - do sqt' <- normalizeSequent sc (sequentToRawSequent sqt) - normalizedSequentIsAxiom sc sqt' -- | Verify that the given evidence in fact supports the given proposition. -- Returns the identifers of all the theorems depended on while checking evidence. @@ -1158,16 +1348,13 @@ checkEvidence sc db = \e p -> do hyps <- Map.keysSet <$> readIORef (theoremMap d , prettySequent defaultPPOpts nenv sqt ] -{- - CutEvidence thm e' -> - do checkTheorem hyps thm - p' <- scFun sc (unProp (thmProp thm)) ptm - (d,sy) <- check hyps e' (Prop p') - return (Set.insert (thmNonce thm) d, sy) --} - UnfoldEvidence vars e' -> - do sqt' <- traverseSequent (unfoldProp sc vars) sqt + do sqt' <- traverseSequentWithFocus (unfoldProp sc vars) sqt + check nenv hyps e' sqt' + + NormalizePropEvidence opqueSet e' -> + do modmap <- scGetModuleMap sc + sqt' <- traverseSequentWithFocus (normalizeProp sc modmap opqueSet) sqt check nenv hyps e' sqt' RewriteEvidence ss e' -> @@ -1180,11 +1367,11 @@ checkEvidence sc db = \e p -> do hyps <- Map.keysSet <$> readIORef (theoremMap d return (Set.union d1 d2, sy) HoistIfsEvidence e' -> - do sqt' <- traverseSequent (hoistIfsInGoal sc) sqt + do sqt' <- traverseSequentWithFocus (hoistIfsInGoal sc) sqt check nenv hyps e' sqt' EvalEvidence vars e' -> - do sqt' <- traverseSequent (evalProp sc vars) sqt + do sqt' <- traverseSequentWithFocus (evalProp sc vars) sqt check nenv hyps e' sqt' ConversionEvidence sqt' e' -> @@ -1196,10 +1383,19 @@ checkEvidence sc db = \e p -> do hyps <- Map.keysSet <$> readIORef (theoremMap d ] check nenv hyps e' sqt' + NormalizeSequentEvidence sqt' e' -> + do ok <- normalizeSequentSubsumes sc sqt' sqt + unless ok $ fail $ unlines + [ "Normalized sequent does not subsume goal" + , prettySequent defaultPPOpts nenv sqt + , prettySequent defaultPPOpts nenv sqt' + ] + check nenv hyps e' sqt' + StructuralEvidence sqt' e' -> do ok <- sequentSubsumes sc sqt' sqt unless ok $ fail $ unlines - [ "Restated sequents does not subsume goal" + [ "Sequent does not subsume goal" , prettySequent defaultPPOpts nenv sqt , prettySequent defaultPPOpts nenv sqt' ] @@ -1232,6 +1428,11 @@ checkEvidence sc db = \e p -> do hyps <- Map.keysSet <$> readIORef (theoremMap d ] return (mempty, ProvedTheorem mempty) + CutEvidence p ehyp egl -> + do d1 <- check nenv hyps ehyp (addHypothesis p sqt) + d2 <- check nenv hyps egl (addNewFocusedGoal p sqt) + return (d1 <> d2) + IntroEvidence x e' -> -- TODO! Check that the given ExtCns is fresh for the sequent case sequentState sqt of @@ -1277,20 +1478,20 @@ startProof g pos ploc rsn = -- and validate the computed evidence to ensure that it supports the original -- proposition. If successful, return the completed @Theorem@ and a summary -- of solver resources used in the proof. -finishProof :: SharedContext -> TheoremDB -> ProofState -> IO ProofResult -finishProof sc db ps@(ProofState gs (concl,loc,ploc,rsn) stats _ checkEv start) = +finishProof :: SharedContext -> TheoremDB -> Prop -> ProofState -> IO ProofResult +finishProof sc db conclProp ps@(ProofState gs (concl,loc,ploc,rsn) stats _ checkEv start) = case gs of [] -> do e <- checkEv [] - conclProp <- sequentToProp sc concl - (deps,sy) <- checkEvidence sc db e conclProp + let e' = NormalizeSequentEvidence concl e + (deps,sy) <- checkEvidence sc db e' conclProp n <- freshNonce globalNonceGenerator end <- getCurrentTime thm <- recordTheorem db Theorem { _thmProp = conclProp , _thmStats = stats - , _thmEvidence = e + , _thmEvidence = e' , _thmLocation = loc , _thmProgramLoc = ploc , _thmReason = rsn @@ -1387,15 +1588,24 @@ predicateToSATQuery sc unintSet tm0 = -- | Given a proposition, compute a SAT query which will prove the proposition -- iff the SAT query is unsatisfiable. propToSATQuery :: SharedContext -> Set VarIndex -> Prop -> IO SATQuery -propToSATQuery sc unintSet prop = - do mmap <- scGetModuleMap sc - tm <- propToTerm sc prop - (initVars, abstractVars) <- filterFirstOrderVars mmap mempty mempty (getAllExts tm) - (finalVars, asserts) <- processTerm mmap initVars [] tm +propToSATQuery sc unintSet prop = sequentToSATQuery sc unintSet (propToSequent prop) + +-- | Given a proposition, compute a SAT query which will prove the proposition +-- iff the SAT query is unsatisfiable. +sequentToSATQuery :: SharedContext -> Set VarIndex -> Sequent -> IO SATQuery +sequentToSATQuery sc unintSet sqt = + do let RawSequent hs gs = sequentToRawSequent sqt + mmap <- scGetModuleMap sc + let exts = foldMap getAllExtSet (map unProp (hs ++ gs)) + (initVars, abstractVars) <- filterFirstOrderVars mmap mempty mempty (Set.toList exts) + -- NB, the following reversals make the order of assertions more closely match the input sequent, + -- but should otherwise not be semantically relevant + hypAsserts <- mapM processHyp (reverse (map unProp hs)) + (finalVars, asserts) <- foldM (processGoal mmap) (initVars, hypAsserts) (map unProp gs) return SATQuery { satVariables = finalVars , satUninterp = Set.union unintSet abstractVars - , satAsserts = asserts + , satAsserts = reverse asserts } where @@ -1408,7 +1618,20 @@ propToSATQuery sc unintSet prop = Nothing -> filterFirstOrderVars mmap fovars (Set.insert (ecVarIndex e) absvars) es Just fot -> filterFirstOrderVars mmap (Map.insert e fot fovars) absvars es - processTerm mmap vars xs tm = + processHyp tm = + 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 + + -- TODO? Allow universal hypotheses... + case asEqTrue tm' of + Nothing -> fail $ "sequentToSATQuery : expected EqTrue in hypothesis, actual " ++ showTerm tm' + Just tmBool -> return tmBool + + processGoal mmap (vars,xs) tm = 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 @@ -1423,7 +1646,7 @@ propToSATQuery sc unintSet prop = let tp' = tp case asEqTrue tp' of Just x | looseVars body == emptyBitSet -> - processTerm mmap vars (x:xs) body + processGoal mmap (vars, x:xs) body -- TODO? Allow universal hypotheses... @@ -1434,14 +1657,14 @@ propToSATQuery sc unintSet prop = 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' + processGoal 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)) + return (vars, tmNeg:xs) -- | Given a goal to prove, attempt to apply the given proposition, producing -- new subgoals for any necessary hypotheses of the proposition. Returns @@ -1525,13 +1748,6 @@ tacticAssume _sc loc = Tactic \goal -> _ -> fail "assume tactic failed: not a function, or a dependent function" --- | Attempt to prove a goal by weakening it with a new hypothesis, which is --- justified by the given theorem. -tacticCut :: (F.MonadFail m, MonadIO m) => SharedContext -> Theorem -> Tactic m () -tacticCut sc thm = Tactic \goal -> - do body' <- liftIO (scFun sc (unProp (thmProp thm)) (unProp (goalProp goal))) - let goal' = goal{ goalProp = Prop body' } - return ((), mempty, [goal'], cutEvidence thm) -} -- | Attempt to prove a goal by applying the given theorem. Any hypotheses of @@ -1580,6 +1796,14 @@ tacticSplit sc = Tactic \gl -> let g2 = gl{ goalType = goalType gl ++ ".right", goalSequent = mkSqt p2 } return ((), mempty, [g1,g2], splitEvidence) +tacticCut :: (F.MonadFail m, MonadIO m) => SharedContext -> Prop -> Tactic m () +tacticCut _sc p = Tactic \gl -> + let sqt1 = addHypothesis p (goalSequent gl) + sqt2 = addNewFocusedGoal p (goalSequent gl) + g1 = gl{ goalType = goalType gl ++ ".cutH", goalSequent = sqt1 } + g2 = gl{ goalType = goalType gl ++ ".cutG", goalSequent = sqt2 } + in return ((), mempty, [g1, g2], cutEvidence p) + -- | Attempt to solve a goal by recognizing it as a trivially true proposition. tacticTrivial :: (F.MonadFail m, MonadIO m) => SharedContext -> Tactic m () tacticTrivial sc = Tactic \goal -> diff --git a/src/SAWScript/Value.hs b/src/SAWScript/Value.hs index 1e281761d9..476f4bc8e8 100644 --- a/src/SAWScript/Value.hs +++ b/src/SAWScript/Value.hs @@ -533,6 +533,7 @@ data TopLevelRW = , rwPathSatSolver :: Common.PathSatSolver , rwSkipSafetyProofs :: Bool , rwSingleOverrideSpecialCase :: Bool + , rwSequentGoals :: Bool } newtype TopLevel a = @@ -831,8 +832,8 @@ newtype ProofScript a = ProofScript { unProofScript :: ExceptT (SolverStats, CEX -- TODO: remove the "reason" parameter and compute it from the -- initial proof goal instead -runProofScript :: ProofScript a -> ProofGoal -> Maybe ProgramLoc -> Text -> TopLevel ProofResult -runProofScript (ProofScript m) gl ploc rsn = +runProofScript :: ProofScript a -> Prop -> ProofGoal -> Maybe ProgramLoc -> Text -> TopLevel ProofResult +runProofScript (ProofScript m) concl gl ploc rsn = do pos <- getPosition ps <- io (startProof gl pos ploc rsn) (r,pstate) <- runStateT (runExceptT m) ps @@ -841,7 +842,7 @@ runProofScript (ProofScript m) gl ploc rsn = Right _ -> do sc <- getSharedContext db <- rwTheoremDB <$> getTopLevelRW - io (finishProof sc db pstate) + io (finishProof sc db concl pstate) scriptTopLevel :: TopLevel a -> ProofScript a scriptTopLevel m = ProofScript (lift (lift m)) From 3d715c22e1e8dc7ea19aeae9783cca46eb7ff01e Mon Sep 17 00:00:00 2001 From: Rob Dockins Date: Thu, 9 Jun 2022 15:48:06 -0700 Subject: [PATCH 07/35] Update saw-remote-api --- saw-remote-api/src/SAWServer.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/saw-remote-api/src/SAWServer.hs b/saw-remote-api/src/SAWServer.hs index 260a338356..1ff758ea1a 100644 --- a/saw-remote-api/src/SAWServer.hs +++ b/saw-remote-api/src/SAWServer.hs @@ -246,6 +246,7 @@ initialState readFileFn = , rwPathSatSolver = CC.PathSat_Z3 , rwSkipSafetyProofs = False , rwSingleOverrideSpecialCase = False + , rwSequentGoals = False } return (SAWState emptyEnv bic [] ro rw M.empty) From aaa398a15aafef1ae543ebce3677c8d38448f073 Mon Sep 17 00:00:00 2001 From: Rob Dockins Date: Tue, 5 Jul 2022 10:30:54 -0700 Subject: [PATCH 08/35] Add strictness annotations to some of the proof data structures. Perhaps this will plug some space leaks. --- src/SAWScript/Proof.hs | 122 +++++++++++++++++++++-------------------- 1 file changed, 62 insertions(+), 60 deletions(-) diff --git a/src/SAWScript/Proof.hs b/src/SAWScript/Proof.hs index 7ab1a243cd..0e6eadc76b 100644 --- a/src/SAWScript/Proof.hs +++ b/src/SAWScript/Proof.hs @@ -290,12 +290,12 @@ simplifySequent sc ss (UnfocusedSequent hs gs) = do (a, hs') <- simplifyProps sc ss hs (b, gs') <- simplifyProps sc ss gs return (Set.union a b, UnfocusedSequent hs' gs') -simplifySequent sc ss (GoalFocusedSequent hs (gs1,g,gs2)) = +simplifySequent sc ss (GoalFocusedSequent hs (FB gs1 g gs2)) = do (a, g') <- simplifyProp sc ss g - return (a, GoalFocusedSequent hs (gs1, g', gs2)) -simplifySequent sc ss (HypFocusedSequent (hs1, h, hs2) gs) = + return (a, GoalFocusedSequent hs (FB gs1 g' gs2)) +simplifySequent sc ss (HypFocusedSequent (FB hs1 h hs2) gs) = do (a, h') <- simplifyProp sc ss h - return (a, HypFocusedSequent (hs1, h', hs2) gs) + return (a, HypFocusedSequent (FB hs1 h' hs2) gs) hoistIfsInGoal :: SharedContext -> Prop -> IO Prop @@ -385,15 +385,17 @@ ppProp opts nenv (Prop tm) = ppTermWithNames opts nenv tm -- TODO, I'd like to add metadata here type SequentBranch = Prop +data FocusedBranch = FB ![SequentBranch] !SequentBranch ![SequentBranch] + data Sequent - = UnfocusedSequent [SequentBranch] [SequentBranch] - | GoalFocusedSequent [SequentBranch] ([SequentBranch], SequentBranch, [SequentBranch]) - | HypFocusedSequent ([SequentBranch], SequentBranch, [SequentBranch]) [SequentBranch] + = UnfocusedSequent ![SequentBranch] ![SequentBranch] + | GoalFocusedSequent ![SequentBranch] !FocusedBranch + | HypFocusedSequent !FocusedBranch ![SequentBranch] unfocus :: Sequent -> ([SequentBranch],[SequentBranch]) unfocus (UnfocusedSequent hs gs) = (hs,gs) -unfocus (GoalFocusedSequent hs (gs1,g,gs2)) = (hs, gs1 ++ g : gs2) -unfocus (HypFocusedSequent (hs1,h,hs2) gs) = (hs1 ++ h : hs2, gs) +unfocus (GoalFocusedSequent hs (FB gs1 g gs2)) = (hs, gs1 ++ g : gs2) +unfocus (HypFocusedSequent (FB hs1 h hs2) gs) = (hs1 ++ h : hs2, gs) unfocusSequent :: Sequent -> Sequent unfocusSequent sqt = UnfocusedSequent hs gs @@ -403,22 +405,22 @@ focusOnGoal :: Integer -> Sequent -> Maybe Sequent focusOnGoal i sqt = let (hs,gs) = unfocus sqt in case genericDrop i gs of - (g:gs2) -> Just (GoalFocusedSequent hs (genericTake i gs, g, gs2)) + (g:gs2) -> Just (GoalFocusedSequent hs (FB (genericTake i gs) g gs2)) [] -> Nothing focusOnHyp :: Integer -> Sequent -> Maybe Sequent focusOnHyp i sqt = let (hs,gs) = unfocus sqt in case genericDrop i hs of - (h:hs2) -> Just (HypFocusedSequent (genericTake i hs, h, hs2) gs) + (h:hs2) -> Just (HypFocusedSequent (FB (genericTake i hs) h hs2) gs) [] -> Nothing sequentToRawSequent :: Sequent -> RawSequent Prop sequentToRawSequent sqt = case sqt of - UnfocusedSequent hs gs -> RawSequent hs gs - GoalFocusedSequent hs (gs1, g, gs2) -> RawSequent hs (gs1 ++ g : gs2) - HypFocusedSequent (hs1, h, hs2) gs -> RawSequent (hs1 ++ h : hs2) gs + UnfocusedSequent hs gs -> RawSequent hs gs + GoalFocusedSequent hs (FB gs1 g gs2) -> RawSequent hs (gs1 ++ g : gs2) + HypFocusedSequent (FB hs1 h hs2) gs -> RawSequent (hs1 ++ h : hs2) gs sequentConstantSet :: Sequent -> Map VarIndex (NameInfo, Term, Maybe Term) @@ -454,21 +456,20 @@ convertibleSequents sc sqt1 sqt2 = RawSequent hs2 gs2 = sequentToRawSequent sqt2 - data SequentState = Unfocused | GoalFocus Prop (Prop -> Sequent) | HypFocus Prop (Prop -> Sequent) propToSequent :: Prop -> Sequent -propToSequent p = GoalFocusedSequent [] ([], p, []) +propToSequent p = GoalFocusedSequent [] (FB [] p []) booleansToSequent :: SharedContext -> [Term] -> [Term] -> IO Sequent booleansToSequent sc hs gs = do hs' <- mapM (boolToProp sc []) hs gs' <- mapM (boolToProp sc []) gs case gs' of - [g] -> return (GoalFocusedSequent hs' ([],g,[])) + [g] -> return (GoalFocusedSequent hs' (FB [] g [])) _ -> return (UnfocusedSequent hs' gs') sequentToProp :: SharedContext -> Sequent -> IO Prop @@ -508,7 +509,7 @@ ppRawSequent sqt (RawSequent hs gs) = turnstile = [ pretty (take 40 (repeat '=')) ] focused doc = "<<" <> doc <> ">>" ppHyp (i, tm) - | HypFocusedSequent (hs1,_h,_hs2) _gs <- sqt + | HypFocusedSequent (FB hs1 _h _hs2) _gs <- sqt , length hs1 == i = focused ("H" <> pretty i) <+> tm @@ -516,7 +517,7 @@ ppRawSequent sqt (RawSequent hs gs) = = "H" <> pretty i <> ":" <+> tm ppGoal (i, tm) - | GoalFocusedSequent _hs (gs1,_g,_gs2) <- sqt + | GoalFocusedSequent _hs (FB gs1 _g _gs2) <- sqt , length gs1 == i = focused ("G" <> pretty i) <+> tm @@ -537,10 +538,10 @@ filterPosList pss xs = map snd $ filter f $ zip [0..] xs where f (i,_) = cofinSetMember i pss -filterFocusedList :: CofinSet Integer -> ([a],a,[a]) -> Either [a] ([a],a,[a]) -filterFocusedList pss (xs1,x,xs2) = +filterFocusedList :: CofinSet Integer -> FocusedBranch -> Either [SequentBranch] FocusedBranch +filterFocusedList pss (FB xs1 x xs2) = if cofinSetMember idx pss then - Right (xs1',x,xs2') + Right (FB xs1' x xs2') else Left (xs1' ++ xs2') where @@ -572,19 +573,19 @@ filterGoals pss (GoalFocusedSequent hs gs) = addHypothesis :: Prop -> Sequent -> Sequent addHypothesis p (UnfocusedSequent hs gs) = UnfocusedSequent (hs ++ [p]) gs addHypothesis p (GoalFocusedSequent hs gs) = GoalFocusedSequent (hs ++ [p]) gs -addHypothesis p (HypFocusedSequent (hs1,h,hs2) gs) = HypFocusedSequent (hs1,h,hs2++[p]) gs +addHypothesis p (HypFocusedSequent (FB hs1 h hs2) gs) = HypFocusedSequent (FB hs1 h (hs2++[p])) gs addNewFocusedGoal :: Prop -> Sequent -> Sequent addNewFocusedGoal p sqt = let RawSequent hs gs = sequentToRawSequent sqt - in GoalFocusedSequent hs (gs,p,[]) + in GoalFocusedSequent hs (FB gs p []) sequentState :: Sequent -> SequentState sequentState (UnfocusedSequent _ _) = Unfocused -sequentState (GoalFocusedSequent hs (gs1,g,gs2)) = - GoalFocus g (\g' -> GoalFocusedSequent hs (gs1,g',gs2)) -sequentState (HypFocusedSequent (hs1,h,hs2) gs) = - HypFocus h (\h' -> HypFocusedSequent (hs1,h',hs2) gs) +sequentState (GoalFocusedSequent hs (FB gs1 g gs2)) = + GoalFocus g (\g' -> GoalFocusedSequent hs (FB gs1 g' gs2)) +sequentState (HypFocusedSequent (FB hs1 h hs2) gs) = + HypFocus h (\h' -> HypFocusedSequent (FB hs1 h' hs2) gs) sequentSharedSize :: Sequent -> Integer sequentSharedSize sqt = scSharedSizeMany (map unProp (hs ++ gs)) @@ -599,34 +600,34 @@ sequentTreeSize sqt = scTreeSizeMany (map unProp (hs ++ gs)) traverseSequentWithFocus :: Applicative m => (Prop -> m Prop) -> Sequent -> m Sequent traverseSequentWithFocus f (UnfocusedSequent hs gs) = UnfocusedSequent <$> traverse f hs <*> traverse f gs -traverseSequentWithFocus f (GoalFocusedSequent hs (gs1, g, gs2)) = - (\g' -> GoalFocusedSequent hs (gs1, g', gs2)) <$> f g -traverseSequentWithFocus f (HypFocusedSequent (hs1, h, hs2) gs) = - (\h' -> HypFocusedSequent (hs1, h', hs2) gs) <$> f h +traverseSequentWithFocus f (GoalFocusedSequent hs (FB gs1 g gs2)) = + (\g' -> GoalFocusedSequent hs (FB gs1 g' gs2)) <$> f g +traverseSequentWithFocus f (HypFocusedSequent (FB hs1 h hs2) gs) = + (\h' -> HypFocusedSequent (FB hs1 h' hs2) gs) <$> f h traverseSequent :: Applicative m => (Prop -> m Prop) -> Sequent -> m Sequent traverseSequent f (UnfocusedSequent hs gs) = UnfocusedSequent <$> traverse f hs <*> traverse f gs -traverseSequent f (GoalFocusedSequent hs (gs1, g, gs2)) = +traverseSequent f (GoalFocusedSequent hs (FB gs1 g gs2)) = GoalFocusedSequent <$> (traverse f hs) <*> - ( (,,) <$> traverse f gs1 <*> f g <*> traverse f gs2) + ( FB <$> traverse f gs1 <*> f g <*> traverse f gs2) -traverseSequent f (HypFocusedSequent (hs1, h, hs2) gs) = +traverseSequent f (HypFocusedSequent (FB hs1 h hs2) gs) = HypFocusedSequent <$> - ( (,,) <$> traverse f hs1 <*> f h <*> traverse f hs2) <*> + ( FB <$> traverse f hs1 <*> f h <*> traverse f hs2) <*> (traverse f gs) checkSequent :: SharedContext -> PPOpts -> Sequent -> IO () checkSequent sc ppOpts (UnfocusedSequent hs gs) = do forM_ hs (checkProp sc ppOpts) forM_ gs (checkProp sc ppOpts) -checkSequent sc ppOpts (GoalFocusedSequent hs (gs1,g,gs2)) = +checkSequent sc ppOpts (GoalFocusedSequent hs (FB gs1 g gs2)) = do forM_ hs (checkProp sc ppOpts) forM_ gs1 (checkProp sc ppOpts) checkProp sc ppOpts g forM_ gs2 (checkProp sc ppOpts) -checkSequent sc ppOpts (HypFocusedSequent (hs1,h,hs2) gs) = +checkSequent sc ppOpts (HypFocusedSequent (FB hs1 h hs2) gs) = do forM_ hs1 (checkProp sc ppOpts) checkProp sc ppOpts h forM_ hs2 (checkProp sc ppOpts) @@ -740,34 +741,34 @@ instance Semigroup TheoremSummary where data Evidence = -- | The given term provides a direct programs-as-proofs witness -- for the truth of its type (qua proposition). - ProofTerm Term + ProofTerm !Term -- | This type of evidence refers to a local assumption that -- must have been introduced by a surrounding @AssumeEvidence@ -- constructor. - | LocalAssumptionEvidence Prop TheoremNonce + | LocalAssumptionEvidence !Prop !TheoremNonce -- | This type of evidence is produced when the given proposition -- has been dispatched to a solver which has indicated that it -- was able to prove the proposition. The included @SolverStats@ -- give some details about the solver run. - | SolverEvidence SolverStats Sequent + | SolverEvidence !SolverStats !Sequent -- | This type of evidence is produced when the given proposition -- has been randomly tested against input vectors in the style -- of quickcheck. The included number is the number of successfully -- passed test vectors. - | QuickcheckEvidence Integer Sequent + | QuickcheckEvidence !Integer !Sequent -- | This type of evidence is produced when the given proposition -- has been explicitly assumed without other evidence at the -- user's direction. - | Admitted Text Pos Sequent + | Admitted !Text !Pos !Sequent -- | This type of evidence is produced when a proposition can be deconstructed -- along a conjunction into two subgoals, each of which is supported by -- the included evidence. - | SplitEvidence Evidence Evidence + | SplitEvidence !Evidence !Evidence -- | This type of evidence is produced when a previously-proved theorem is -- applied via backward reasoning to prove a goal. Pi-quantified variables @@ -775,7 +776,7 @@ data Evidence -- 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] + | 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 @@ -784,53 +785,53 @@ data Evidence -- | AssumeEvidence TheoremNonce Prop Evidence -- | This type of evidence is used to prove a universally-quantified statement. - | IntroEvidence (ExtCns Term) Evidence + | IntroEvidence !(ExtCns Term) !Evidence -- | This type of evidence is used to apply the "cut rule" of sequent calculus. -- The given proposition is added to the hypothesis list in the first -- deriviation, and into the conclusion list in the second, where it is focused. - | CutEvidence Prop Evidence Evidence + | CutEvidence !Prop !Evidence !Evidence -- | This type of evidence is used to modify a goal to prove via rewriting. -- The goal to prove is rewritten by the given simpset; then the provided -- evidence is used to check the modified goal. - | RewriteEvidence (Simpset TheoremNonce) Evidence + | RewriteEvidence !(Simpset TheoremNonce) !Evidence -- | This type of evidence is used to modify a goal to prove via unfolding -- constant definitions. The goal to prove is modified by unfolding -- constants identified via the given set of @VarIndex@; then the provided -- evidence is used to check the modified goal. - | UnfoldEvidence (Set VarIndex) Evidence + | UnfoldEvidence !(Set VarIndex) !Evidence -- | This type of evidence is used to modify a goal to prove via evaluation -- into the the What4 formula representation. During evaluation, the -- constants identified by the given set of @VarIndex@ are held -- uninterpreted (i.e., will not be unfolded). Then, the provided -- evidence is use to check the modified goal. - | EvalEvidence (Set VarIndex) Evidence + | EvalEvidence !(Set VarIndex) !Evidence -- | This type of evidence is used to modify a focused part of the goal. -- The modified goal should be equivalent up to conversion. - | ConversionEvidence Sequent Evidence + | ConversionEvidence !Sequent !Evidence -- | This type of evidence is used to modify a goal to prove by applying -- 'hoistIfsInGoal'. - | HoistIfsEvidence Evidence + | HoistIfsEvidence !Evidence -- | Change the state of the sequent in some "structural" way. This -- can involve changing focus, reordering or applying weakening rules. - | StructuralEvidence Sequent Evidence + | StructuralEvidence !Sequent !Evidence -- | Change the state of the sequent in some way that is governed by -- the "reversable" L/R rules of the sequent calculus, e.g., -- conjunctions in hypotheses can be split into multiple hypotheses, -- negated conclusions become positive hypotheses, etc. - | NormalizeSequentEvidence Sequent Evidence + | NormalizeSequentEvidence !Sequent !Evidence -- | Change the sate of th sequent by invoking the term evaluator -- on the focused sequent branch (or all branches, if unfocused). -- Treat the given variable indexes as opaque. - | NormalizePropEvidence (Set VarIndex) Evidence + | NormalizePropEvidence !(Set VarIndex) !Evidence -- | This type of evidence is used when the current sequent, after -- applying structural rules, is an instance of the basic @@ -1044,7 +1045,7 @@ data ProofGoal = , goalLoc :: String , goalDesc :: String , goalTags :: Set String - , goalSequent :: Sequent + , goalSequent :: !Sequent } @@ -1080,11 +1081,11 @@ predicateToProp sc quant = loop [] Prop <$> toPi argTs t --- | A ProofState represents a sequent, where the collection of goals --- implies the conclusion. +-- | A ProofState consists of a sequents of goals, represented by sequents. +-- If each subgoal is provable, that implies the ultimate conclusion. data ProofState = ProofState - { _psGoals :: [ProofGoal] + { _psGoals :: ![ProofGoal] , _psConcl :: (Sequent,Pos,Maybe ProgramLoc,Text) , _psStats :: SolverStats , _psTimeout :: Maybe Integer @@ -1541,7 +1542,8 @@ withFirstGoal (Tactic f) (ProofState goals concl stats timeout evidenceCont star do let (es1, es2) = splitAt (length gs') es e <- buildTacticEvidence es1 evidenceCont (e:es2) - return (Right (x, ProofState (gs' <> gs) concl (stats <> stats') timeout evidenceCont' start)) + let ps' = ProofState (gs' <> gs) concl (stats <> stats') timeout evidenceCont' start + seq ps' (return (Right (x, ps'))) predicateToSATQuery :: SharedContext -> Set VarIndex -> Term -> IO SATQuery predicateToSATQuery sc unintSet tm0 = From b44b54a580d32829ecdad85c416ed13728bfa812 Mon Sep 17 00:00:00 2001 From: Robert Dockins Date: Wed, 20 Jul 2022 09:39:09 -0700 Subject: [PATCH 09/35] Add the ability to rewrite by "shallow" rewrite rules. These prevent the rewriter from continuting to rewrite in the result. --- saw-core/src/Verifier/SAW/Rewriter.hs | 77 ++++++++++++++++++--------- 1 file changed, 51 insertions(+), 26 deletions(-) diff --git a/saw-core/src/Verifier/SAW/Rewriter.hs b/saw-core/src/Verifier/SAW/Rewriter.hs index 4d267f3435..e03f1872c9 100644 --- a/saw-core/src/Verifier/SAW/Rewriter.hs +++ b/saw-core/src/Verifier/SAW/Rewriter.hs @@ -45,6 +45,7 @@ module Verifier.SAW.Rewriter , addConvs , scSimpset , listRules + , shallowRule -- * Term rewriting , rewriteSharedTerm , rewriteSharedTermTypeSafe @@ -85,15 +86,22 @@ import qualified Verifier.SAW.TermNet as Net import Verifier.SAW.Prelude.Constants data RewriteRule a - = RewriteRule { ctxt :: [Term], lhs :: Term, rhs :: Term, permutative :: Bool, annotation :: Maybe a } + = RewriteRule + { ctxt :: [Term] + , lhs :: Term + , rhs :: Term + , permutative :: Bool + , shallow :: Bool + , annotation :: Maybe a + } deriving (Show) -- ^ Invariant: The set of loose variables in @lhs@ must be exactly -- @[0 .. length ctxt - 1]@. The @rhs@ may contain a subset of these. -- NB, exclude the annotation from equality tests instance Eq (RewriteRule a) where - RewriteRule c1 l1 r1 p1 _a1 == RewriteRule c2 l2 r2 p2 _a2 = - c1 == c2 && l1 == l2 && r1 == r2 && p1 == p2 + RewriteRule c1 l1 r1 p1 s1 _a1 == RewriteRule c2 l2 r2 p2 s2 _a2 = + c1 == c2 && l1 == l2 && r1 == r2 && p1 == p2 && s1 == s2 ctxtRewriteRule :: RewriteRule a -> [Term] ctxtRewriteRule = ctxt @@ -108,7 +116,7 @@ annRewriteRule :: RewriteRule a -> Maybe a annRewriteRule = annotation instance Net.Pattern (RewriteRule a) where - toPat (RewriteRule _ lhs _ _ _) = Net.toPat lhs + toPat (RewriteRule _ lhs _ _ _ _) = Net.toPat lhs ---------------------------------------------------------------------- -- Matching @@ -316,7 +324,7 @@ ruleOfTerm t ann = -- NOTE: this assumes the Coq-style equality type Eq X x y, where both X -- (the type of x and y) and x are parameters, and y is an index FTermF (DataTypeApp dt [_, x] [y]) - | primName dt == eqIdent -> mkRewriteRule [] x y ann + | primName dt == eqIdent -> mkRewriteRule [] x y False ann Pi _ ty body -> rule { ctxt = ty : ctxt rule } where rule = ruleOfTerm body ann _ -> error "ruleOfSharedTerm: Illegal argument" @@ -332,14 +340,21 @@ rulePermutes lhs rhs = Nothing -> False -- but here we have a looping rule, not good! Just _ -> True -mkRewriteRule :: [Term] -> Term -> Term -> Maybe a -> RewriteRule a -mkRewriteRule c l r ann = - RewriteRule {ctxt = c, lhs = l, rhs = r , permutative = rulePermutes l r, annotation = ann} +mkRewriteRule :: [Term] -> Term -> Term -> Bool -> Maybe a -> RewriteRule a +mkRewriteRule c l r shallow ann = + RewriteRule + { ctxt = c + , lhs = l + , rhs = r + , permutative = rulePermutes l r + , shallow = shallow + , annotation = ann + } -- | Converts a universally quantified equality proposition between the -- two given terms to a RewriteRule. ruleOfTerms :: Term -> Term -> RewriteRule a -ruleOfTerms l r = mkRewriteRule [] l r Nothing +ruleOfTerms l r = mkRewriteRule [] l r False Nothing -- | Converts a parameterized equality predicate to a RewriteRule, -- returning 'Nothing' if the predicate is not an equation. @@ -351,24 +366,24 @@ ruleOfProp (R.asLambda -> Just (_, ty, body)) ann = do rule <- ruleOfProp body ann Just rule { ctxt = ty : ctxt rule } ruleOfProp (R.asApplyAll -> (R.isGlobalDef ecEqIdent -> Just (), [_, _, x, y])) ann = - Just $ mkRewriteRule [] x y ann + Just $ mkRewriteRule [] x y False ann ruleOfProp (R.asApplyAll -> (R.isGlobalDef bvEqIdent -> Just (), [_, x, y])) ann = - Just $ mkRewriteRule [] x y ann + Just $ mkRewriteRule [] x y False ann ruleOfProp (R.asApplyAll -> (R.isGlobalDef equalNatIdent -> Just (), [x, y])) ann = - Just $ mkRewriteRule [] x y ann + Just $ mkRewriteRule [] x y False ann ruleOfProp (R.asApplyAll -> (R.isGlobalDef boolEqIdent -> Just (), [x, y])) ann = - Just $ mkRewriteRule [] x y ann + Just $ mkRewriteRule [] x y False ann ruleOfProp (R.asApplyAll -> (R.isGlobalDef vecEqIdent -> Just (), [_, _, _, x, y])) ann = - Just $ mkRewriteRule [] x y ann + Just $ mkRewriteRule [] x y False ann ruleOfProp (R.asApplyAll -> (R.isGlobalDef arrayEqIdent -> Just (), [_, _, x, y])) ann = - Just $ mkRewriteRule [] x y ann + Just $ mkRewriteRule [] x y False ann ruleOfProp (R.asApplyAll -> (R.isGlobalDef intEqIdent -> Just (), [x, y])) ann = - Just $ mkRewriteRule [] x y ann + Just $ mkRewriteRule [] x y False ann ruleOfProp (R.asApplyAll -> (R.isGlobalDef intModEqIdent -> Just (), [_, x, y])) ann = - Just $ mkRewriteRule [] x y ann + Just $ mkRewriteRule [] x y False ann ruleOfProp (unwrapTermF -> Constant _ (Just body)) ann = ruleOfProp body ann ruleOfProp (R.asEq -> Just (_, x, y)) ann = - Just $ mkRewriteRule [] x y ann + Just $ mkRewriteRule [] x y False ann ruleOfProp (R.asEqTrue -> Just body) ann = ruleOfProp body ann ruleOfProp _ _ = Nothing @@ -387,18 +402,18 @@ scEqsRewriteRules sc = mapM (scEqRewriteRule sc) -- * If the rhs is a recursor, then split into a separate rule for each constructor. -- * If the rhs is a record, then split into a separate rule for each accessor. scExpandRewriteRule :: SharedContext -> RewriteRule a -> IO (Maybe [RewriteRule a]) -scExpandRewriteRule sc (RewriteRule ctxt lhs rhs _ ann) = +scExpandRewriteRule sc (RewriteRule ctxt lhs rhs _ shallow ann) = case rhs of (R.asLambda -> Just (_, ty, body)) -> do let ctxt' = ctxt ++ [ty] lhs1 <- incVars sc 0 1 lhs var0 <- scLocalVar sc 0 lhs' <- scApply sc lhs1 var0 - return $ Just [mkRewriteRule ctxt' lhs' body ann] + return $ Just [mkRewriteRule ctxt' lhs' body shallow ann] (R.asRecordValue -> Just m) -> do let mkRule (k, x) = do l <- scRecordSelect sc lhs k - return (mkRewriteRule ctxt l x ann) + return (mkRewriteRule ctxt l x shallow ann) Just <$> traverse mkRule (Map.assocs m) (R.asApplyAll -> (R.asRecursorApp -> Just (rec, crec, _ixs, R.asLocalVar -> Just i), @@ -439,9 +454,9 @@ scExpandRewriteRule sc (RewriteRule ctxt lhs rhs _ ann) = rhs2 <- scApplyAll sc rhs1 more' rhs3 <- betaReduce rhs2 -- re-fold recursive occurrences of the original rhs - let ss = addRule (mkRewriteRule ctxt rhs lhs Nothing) emptySimpset + let ss = addRule (mkRewriteRule ctxt rhs lhs shallow Nothing) emptySimpset (_,rhs') <- rewriteSharedTerm sc (ss :: Simpset ()) rhs3 - return (mkRewriteRule ctxt' lhs' rhs' ann) + return (mkRewriteRule ctxt' lhs' rhs' shallow ann) dt <- scRequireDataType sc (primName (recursorDataType crec)) rules <- traverse ctorRule (dtCtors dt) return (Just rules) @@ -482,8 +497,14 @@ scDefRewriteRules _ (Def { defBody = Nothing }) = return [] scDefRewriteRules sc (Def { defIdent = ident, defBody = Just body }) = do lhs <- scGlobalDef sc ident rhs <- scSharedTerm sc body - scExpandRewriteRules sc [mkRewriteRule [] lhs rhs Nothing] + scExpandRewriteRules sc [mkRewriteRule [] lhs rhs False Nothing] + +-- | A "shallow" rule is one where further +-- rewrites are not applied to the result +-- of a rewrite. +shallowRule :: RewriteRule a -> RewriteRule a +shallowRule r = r{ shallow = True } ---------------------------------------------------------------------- -- Simpsets @@ -662,7 +683,7 @@ rewriteSharedTerm sc ss t0 = apply :: (?cache :: Cache IO TermIndex Term, ?annSet :: IORef (Set a)) => [Either (RewriteRule a) Conversion] -> Term -> IO Term apply [] t = return t - apply (Left (RewriteRule {ctxt, lhs, rhs, permutative, annotation}) : rules) t = do + apply (Left (RewriteRule {ctxt, lhs, rhs, permutative, shallow, annotation}) : rules) t = do result <- scMatch sc lhs t case result of Nothing -> apply rules t @@ -683,6 +704,10 @@ rewriteSharedTerm sc ss t0 = case termWeightLt t' t of True -> recordAnn annotation >> rewriteAll t' -- keep the result only if it is "smaller" False -> apply rules t + | shallow -> + -- do not to further rewriting to the result of a "shallow" rule + do recordAnn annotation + instantiateVarList sc 0 (Map.elems inst) rhs | otherwise -> do -- putStrLn "REWRITING:" -- print lhs @@ -807,7 +832,7 @@ rewritingSharedContext sc ss = sc' Term -> IO Term apply [] (Unshared tf) = scTermF sc tf apply [] STApp{ stAppTermF = tf } = scTermF sc tf - apply (Left (RewriteRule _ l r _ _ann) : rules) t = + apply (Left (RewriteRule _ l r _ _shallow _ann) : rules) t = case first_order_match l t of Nothing -> apply rules t Just inst From cb1295076758ed97f33a3cc89ff4f373b3cb5d78 Mon Sep 17 00:00:00 2001 From: Robert Dockins Date: Wed, 20 Jul 2022 09:42:28 -0700 Subject: [PATCH 10/35] Various fixes/improvements to the proof tactic system. Notably, add the ability to perform rewrites using local sequent assumptions. --- src/SAWScript/Builtins.hs | 37 ++++++++++- src/SAWScript/Interpreter.hs | 22 +++++++ src/SAWScript/Proof.hs | 116 ++++++++++++++++++++++++++--------- 3 files changed, 145 insertions(+), 30 deletions(-) diff --git a/src/SAWScript/Builtins.hs b/src/SAWScript/Builtins.hs index e170f7dc44..5bf03d58a6 100644 --- a/src/SAWScript/Builtins.hs +++ b/src/SAWScript/Builtins.hs @@ -468,6 +468,23 @@ print_goal_summary = execTactic $ tacticId $ \goal -> printOutLnTop Info (goalSummary goal) +print_focus :: ProofScript () +print_focus = + execTactic $ tacticId $ \goal -> + do opts <- getTopLevelPPOpts + sc <- getSharedContext + nenv <- io (scGetNamingEnv sc) + case sequentGetFocus (goalSequent goal) of + Nothing -> + printOutLnTop Warn "Sequent is not focused" + Just (Left (i,h)) -> + let output = ppProp opts nenv h in + printOutLnTop Info (unlines ["Hypothesis " ++ show i, show output]) + Just (Right (i,c)) -> + let output = ppProp opts nenv c in + printOutLnTop Info (unlines ["Conclusion " ++ show i, show output]) + + goal_num :: ProofScript Int goal_num = execTactic $ tacticId $ \goal -> @@ -569,7 +586,7 @@ focus_concl i = focus_hyp :: Integer -> ProofScript () focus_hyp i = execTactic $ tacticChange $ \goal -> - case focusOnGoal i (goalSequent goal) of + case focusOnHyp i (goalSequent goal) of Nothing -> fail "focus_hyp : not enough hypotheses" Just sqt' -> return (sqt', structuralEvidence sqt') @@ -637,7 +654,16 @@ simplifyGoal ss = execTactic $ tacticChange $ \goal -> do sc <- getSharedContext sqt' <- traverseSequentWithFocus (\p -> snd <$> io (simplifyProp sc ss p)) (goalSequent goal) - return (sqt', RewriteEvidence ss) + return (sqt', RewriteEvidence [] ss) + +simplifyGoalWithLocals :: [Integer] -> SV.SAWSimpset -> ProofScript () +simplifyGoalWithLocals hs ss = + execTactic $ tacticChange $ \goal -> + do sc <- getSharedContext + ss' <- io (localHypSimpset (goalSequent goal) hs ss) + sqt' <- traverseSequentWithFocus + (\p -> snd <$> io (simplifyProp sc ss' p)) (goalSequent goal) + return (sqt', RewriteEvidence hs ss) hoistIfsInGoalPrim :: ProofScript () hoistIfsInGoalPrim = @@ -1284,6 +1310,13 @@ addsimp thm ss = Nothing -> fail "addsimp: theorem not an equation" Just rule -> pure (addRule rule ss) +addsimp_shallow :: Theorem -> SV.SAWSimpset -> TopLevel SV.SAWSimpset +addsimp_shallow thm ss = + do sc <- getSharedContext + io (propToRewriteRule sc (thmProp thm) (Just (thmNonce thm))) >>= \case + Nothing -> fail "addsimp: theorem not an equation" + Just rule -> pure (addRule (shallowRule rule) ss) + -- TODO: remove this, it implicitly adds axioms addsimp' :: Term -> SV.SAWSimpset -> TopLevel SV.SAWSimpset addsimp' t ss = diff --git a/src/SAWScript/Interpreter.hs b/src/SAWScript/Interpreter.hs index 4800c2d85f..f216532649 100644 --- a/src/SAWScript/Interpreter.hs +++ b/src/SAWScript/Interpreter.hs @@ -1583,6 +1583,13 @@ primitives = Map.fromList Current [ "Apply the given simplifier rule set to the current goal." ] + , prim "simplify_local" "[Int] -> Simpset -> ProofScript ()" + (pureVal simplifyGoalWithLocals) + Current + [ "Apply the given simplifier rule set to the current goal." + , "Also, use the given numbered hypotheses as rewrites." + ] + , prim "unfocus" "ProofScript ()" (pureVal unfocus) Experimental @@ -1760,6 +1767,13 @@ primitives = Map.fromList [ "Print the number and description of the goal that a proof script" , "is attempting to prove." ] + , prim "print_focus" "ProofScript ()" + (pureVal print_focus) + Experimental + [ "Print just the focused part of the current goal." + , "Prints a message without failing if there is no current focus." + ] + , prim "goal_num" "ProofScript Int" (pureVal goal_num) Current @@ -2134,6 +2148,14 @@ primitives = Map.fromList Current [ "Add a proved equality theorem to a given simplification rule set." ] + , prim "addsimp_shallow" "Theorem -> Simpset -> Simpset" + (funVal2 addsimp_shallow) + Current + [ "Add a proved equality theorem to a given simplification rule set." + , "The rule is treated as a 'shallow' rewrite, which means that further" + , "rewrite rules will not be applied to the result if this rule fires." + ] + , prim "addsimps" "[Theorem] -> Simpset -> Simpset" (funVal2 addsimps) Current diff --git a/src/SAWScript/Proof.hs b/src/SAWScript/Proof.hs index 0e6eadc76b..50badd866d 100644 --- a/src/SAWScript/Proof.hs +++ b/src/SAWScript/Proof.hs @@ -35,7 +35,7 @@ module SAWScript.Proof , checkProp , Sequent - , SequentState(..) + , sequentGetFocus , sequentToProp , sequentToSATQuery , sequentSharedSize @@ -54,6 +54,7 @@ module SAWScript.Proof , normalizeSequent , filterHyps , filterGoals + , localHypSimpset , CofinSet(..) , cofinSetMember @@ -227,6 +228,22 @@ propToRewriteRule _sc (Prop tm) ann = Nothing -> pure Nothing Just r -> pure (Just r) +-- | Attempt to split an if/then/else goal. +-- If it succeeds to find a term like "EqTrue (ite Bool b x y)", +-- then it returns to pairs consisting of "(EqTrue b, EqTrue x)" +-- and "(EqTrue (not b), EqTrue y)" +splitIte :: SharedContext -> Prop -> IO (Maybe ((Prop, Prop), (Prop, Prop))) +splitIte sc (Prop p) = + case (isGlobalDef "Prelude.ite" <@> return <@> return <@> return <@> return) =<< asEqTrue p of + Nothing -> pure Nothing + Just (_ :*: _tp :*: b :*: x :*: y) -> -- tp must be "Bool" + do nb <- scNot sc b + b' <- scEqTrue sc b + nb' <- scEqTrue sc nb + x' <- scEqTrue sc x + y' <- scEqTrue sc y + return (Just ((Prop b', Prop x'), (Prop nb', Prop y'))) + -- | Attempt to split a conjunctive proposition into two propositions. splitConj :: SharedContext -> Prop -> IO (Maybe (Prop, Prop)) splitConj sc (Prop p) = @@ -252,16 +269,36 @@ splitDisj sc (Prop p) = splitSequent :: SharedContext -> Sequent -> IO (Maybe (Sequent, Sequent)) splitSequent sc sqt = - case sequentState sqt of - GoalFocus g mkSqt -> + case sqt of + GoalFocusedSequent hs (FB gs1 g gs2) -> splitConj sc g >>= \case - Nothing -> return Nothing - Just (x, y) -> return (Just (mkSqt x, mkSqt y)) - HypFocus h mkSqt -> + Just (x, y) -> + return (Just ( GoalFocusedSequent hs (FB gs1 x gs2) + , GoalFocusedSequent hs (FB gs1 y gs2) + )) + Nothing -> + splitIte sc g >>= \case + Just ((b, x), (nb, y)) -> + return (Just ( GoalFocusedSequent (hs ++ [b]) (FB gs1 x gs2) + , GoalFocusedSequent (hs ++ [nb]) (FB gs1 y gs2) + )) + Nothing -> return Nothing + + HypFocusedSequent (FB hs1 h hs2) gs -> splitDisj sc h >>= \case - Nothing -> return Nothing - Just (x, y) -> return (Just (mkSqt x, mkSqt y)) - Unfocused -> fail "split tactic: focus required" + Just (x, y) -> + return (Just ( HypFocusedSequent (FB hs1 x hs2) gs + , HypFocusedSequent (FB hs1 y hs2) gs + )) + Nothing -> + splitIte sc h >>= \case + Just ((b,x), (nb, y)) -> + return (Just ( HypFocusedSequent (FB hs1 x (hs2 ++ [b])) gs + , HypFocusedSequent (FB hs1 y (hs2 ++ [nb])) gs + )) + Nothing -> return Nothing + + UnfocusedSequent _ _ -> fail "split tactic: focus required" -- | Unfold all the constants appearing in the proposition -- whose VarIndex is found in the given set. @@ -284,6 +321,24 @@ simplifyProps sc ss (p:ps) = (b, ps') <- simplifyProps sc ss ps return (Set.union a b, p' : ps') +-- | Add hypotheses from the given sequent as rewrite rules +-- to the given simpset. +localHypSimpset :: Sequent -> [Integer] -> Simpset a -> IO (Simpset a) +localHypSimpset sqt hs ss0 = Fold.foldlM processHyp ss0 nhyps + + where + processHyp ss (n,h) = + case ruleOfProp (unProp h) Nothing of + Nothing -> fail $ "Hypothesis " ++ show n ++ "cannot be used as a rewrite rule." + Just r -> return (addRule r ss) + + nhyps = [ (n,h) + | (n,h) <- zip [0..] hyps + , Set.member n hset + ] + RawSequent hyps _ = sequentToRawSequent sqt + hset = Set.fromList hs + -- | Rewrite in the sequent using the provided Simpset simplifySequent :: Ord a => SharedContext -> Simpset a -> Sequent -> IO (Set a, Sequent) simplifySequent sc ss (UnfocusedSequent hs gs) = @@ -580,6 +635,18 @@ addNewFocusedGoal p sqt = let RawSequent hs gs = sequentToRawSequent sqt in GoalFocusedSequent hs (FB gs p []) +-- | If the sequent is focused, return the prop under focus, +-- together with it's index value. +-- A @Left@ value indicates a hypothesis under focus, and +-- a @Right@ value is a goal under focus. +sequentGetFocus :: Sequent -> Maybe (Either (Integer,Prop) (Integer, Prop)) +sequentGetFocus (UnfocusedSequent _ _) = + Nothing +sequentGetFocus (HypFocusedSequent (FB hs1 h _) _) = + Just (Left (genericLength hs1, h)) +sequentGetFocus (GoalFocusedSequent _ (FB gs1 g _)) = + Just (Right (genericLength gs1, g)) + sequentState :: Sequent -> SequentState sequentState (UnfocusedSequent _ _) = Unfocused sequentState (GoalFocusedSequent hs (FB gs1 g gs2)) = @@ -795,7 +862,9 @@ data Evidence -- | This type of evidence is used to modify a goal to prove via rewriting. -- The goal to prove is rewritten by the given simpset; then the provided -- evidence is used to check the modified goal. - | RewriteEvidence !(Simpset TheoremNonce) !Evidence + -- The list of integers indicate local hypotheses that should also + -- be treated as rewrites. + | RewriteEvidence ![Integer] !(Simpset TheoremNonce) !Evidence -- | This type of evidence is used to modify a goal to prove via unfolding -- constant definitions. The goal to prove is modified by unfolding @@ -1358,8 +1427,9 @@ checkEvidence sc db = \e p -> do hyps <- Map.keysSet <$> readIORef (theoremMap d sqt' <- traverseSequentWithFocus (normalizeProp sc modmap opqueSet) sqt check nenv hyps e' sqt' - RewriteEvidence ss e' -> - do (d1,sqt') <- simplifySequent sc ss sqt + RewriteEvidence hs ss e' -> + do ss' <- localHypSimpset sqt hs ss + (d1,sqt') <- simplifySequent sc ss' sqt unless (Set.isSubsetOf d1 hyps) $ fail $ unlines [ "Rewrite step used theorem not in hypothesis database" , show (Set.difference d1 hyps) @@ -1781,22 +1851,12 @@ tacticApply sc thm = Tactic \goal -> -- two subgoals will be produced, representing the two conjuncts to be proved. tacticSplit :: (F.MonadFail m, MonadIO m) => SharedContext -> Tactic m () tacticSplit sc = Tactic \gl -> - case sequentState (goalSequent gl) of - Unfocused -> fail "split tactic: focus required" - HypFocus h mkSqt -> - liftIO (splitDisj sc h) >>= \case - Nothing -> fail "split tactic failed: hypothesis not a disjunction" - Just (p1,p2) -> - do let g1 = gl{ goalType = goalType gl ++ ".left", goalSequent = mkSqt p1 } - let g2 = gl{ goalType = goalType gl ++ ".right", goalSequent = mkSqt p2 } - return ((), mempty, [g1,g2], splitEvidence) - GoalFocus g mkSqt -> - liftIO (splitConj sc g) >>= \case - Nothing -> fail "split tactic failed: goal not a conjunction" - Just (p1,p2) -> - do let g1 = gl{ goalType = goalType gl ++ ".left", goalSequent = mkSqt p1 } - let g2 = gl{ goalType = goalType gl ++ ".right", goalSequent = mkSqt p2 } - return ((), mempty, [g1,g2], splitEvidence) + liftIO (splitSequent sc (goalSequent gl)) >>= \case + Just (sqt1, sqt2) -> + do let g1 = gl{ goalType = goalType gl ++ ".l", goalSequent = sqt1 } + let g2 = gl{ goalType = goalType gl ++ ".r", goalSequent = sqt2 } + return ((), mempty, [g1,g2], splitEvidence) + Nothing -> fail "split tactic failed" tacticCut :: (F.MonadFail m, MonadIO m) => SharedContext -> Prop -> Tactic m () tacticCut _sc p = Tactic \gl -> From d3f40dc08401ab072ec85bb5661891d83f6bd811 Mon Sep 17 00:00:00 2001 From: Rob Dockins Date: Mon, 25 Jul 2022 14:56:42 -0700 Subject: [PATCH 11/35] Allow proofs to skip being recorded in the theorem database. This is useful to save on resident memory for verification conditions, which are never directly used to prove later theorems. --- src/SAWScript/Builtins.hs | 8 ++++---- src/SAWScript/Crucible/JVM/Builtins.hs | 6 ++++-- src/SAWScript/Crucible/LLVM/Builtins.hs | 8 +++++--- src/SAWScript/Crucible/LLVM/X86.hs | 6 ++++-- src/SAWScript/Proof.hs | 17 ++++++++++++++--- src/SAWScript/Value.hs | 13 ++++++++++--- 6 files changed, 41 insertions(+), 17 deletions(-) diff --git a/src/SAWScript/Builtins.hs b/src/SAWScript/Builtins.hs index 5bf03d58a6..fea3e628a3 100644 --- a/src/SAWScript/Builtins.hs +++ b/src/SAWScript/Builtins.hs @@ -1143,7 +1143,7 @@ provePrim script t = do , goalSequent = propToSequent prop , goalTags = mempty } - res <- SV.runProofScript script prop goal Nothing "prove_prim" + res <- SV.runProofScript script prop goal Nothing "prove_prim" True case res of UnfinishedProof pst -> printOutLnTop Info $ "prove: " ++ show (length (psGoals pst)) ++ " unsolved subgoal(s)" @@ -1170,7 +1170,7 @@ proveHelper nm script t f = do , goalTags = mempty } opts <- rwPPOpts <$> getTopLevelRW - res <- SV.runProofScript script prop goal Nothing (Text.pack nm) + res <- SV.runProofScript script prop goal Nothing (Text.pack nm) True let failProof pst = fail $ "prove: " ++ show (length (psGoals pst)) ++ " unsolved subgoal(s)\n" ++ SV.showsProofResult opts res "" @@ -1215,7 +1215,7 @@ satPrim script t = , goalSequent = propToSequent prop , goalTags = mempty } - res <- SV.runProofScript script prop goal Nothing "sat" + res <- SV.runProofScript script prop goal Nothing "sat" False case res of InvalidProof stats cex _ -> return (SV.Sat stats cex) ValidProof stats _thm -> return (SV.Unsat stats) @@ -1746,7 +1746,7 @@ prove_core script input = , goalSequent = propToSequent p , goalTags = mempty } - res <- SV.runProofScript script p goal Nothing "prove_core" + res <- SV.runProofScript script p goal Nothing "prove_core" True let failProof pst = fail $ "prove_core: " ++ show (length (psGoals pst)) ++ " unsolved subgoal(s)\n" ++ SV.showsProofResult opts res "" diff --git a/src/SAWScript/Crucible/JVM/Builtins.hs b/src/SAWScript/Crucible/JVM/Builtins.hs index b263eac1f1..a853a84491 100644 --- a/src/SAWScript/Crucible/JVM/Builtins.hs +++ b/src/SAWScript/Crucible/JVM/Builtins.hs @@ -316,8 +316,10 @@ verifyObligations cc mspec tactic assumes asserts = , goalSequent = propToSequent goal' , goalTags = MS.conditionTags md } - res <- runProofScript tactic goal' proofgoal (Just ploc) $ Text.unwords - ["JVM verification condition:", Text.pack (show n), Text.pack goalname] + res <- runProofScript tactic goal' proofgoal (Just ploc) + (Text.unwords + ["JVM verification condition:", Text.pack (show n), Text.pack goalname]) + False -- do not record in the theorem database case res of ValidProof stats thm -> return (stats, thmNonce thm) InvalidProof stats vals _pst -> do diff --git a/src/SAWScript/Crucible/LLVM/Builtins.hs b/src/SAWScript/Crucible/LLVM/Builtins.hs index c616cd767e..6fef0606fa 100644 --- a/src/SAWScript/Crucible/LLVM/Builtins.hs +++ b/src/SAWScript/Crucible/LLVM/Builtins.hs @@ -808,8 +808,10 @@ verifyObligations cc mspec tactic assumes asserts = , goalSequent = sqt , goalTags = MS.conditionTags md } - res <- runProofScript tactic goal' proofgoal (Just ploc) $ Text.unwords - ["LLVM verification condition", Text.pack (show n), Text.pack goalname] + res <- runProofScript tactic goal' proofgoal (Just ploc) + (Text.unwords + ["LLVM verification condition", Text.pack (show n), Text.pack goalname]) + False -- do not record this theorem in the database case res of ValidProof stats thm -> return (stats, thmNonce thm) UnfinishedProof pst -> @@ -992,7 +994,7 @@ assumptionsContainContradiction cc methodSpec tactic assumptions = , goalSequent = propToSequent goal' , goalTags = mempty }) - res <- runProofScript tactic goal' pgl Nothing "vacuousness check" + res <- runProofScript tactic goal' pgl Nothing "vacuousness check" False case res of ValidProof _ _ -> return True InvalidProof _ _ _ -> return False diff --git a/src/SAWScript/Crucible/LLVM/X86.hs b/src/SAWScript/Crucible/LLVM/X86.hs index 8b94a9fc8d..c4dffc0b2d 100644 --- a/src/SAWScript/Crucible/LLVM/X86.hs +++ b/src/SAWScript/Crucible/LLVM/X86.hs @@ -1199,8 +1199,10 @@ checkGoals bak opts nm sc tactic mdMap = do , goalSequent = propToSequent term , goalTags = MS.conditionTags md } - res <- runProofScript tactic term proofgoal (Just (gLoc g)) $ Text.unwords - ["X86 verification condition", Text.pack (show n), Text.pack (show (gMessage g))] + res <- runProofScript tactic term proofgoal (Just (gLoc g)) + (Text.unwords + ["X86 verification condition", Text.pack (show n), Text.pack (show (gMessage g))]) + False -- do no record this theorem in the database case res of ValidProof stats thm -> return (stats, thmNonce thm) UnfinishedProof pst -> do diff --git a/src/SAWScript/Proof.hs b/src/SAWScript/Proof.hs index 50badd866d..6b2f7f7329 100644 --- a/src/SAWScript/Proof.hs +++ b/src/SAWScript/Proof.hs @@ -1549,8 +1549,19 @@ startProof g pos ploc rsn = -- and validate the computed evidence to ensure that it supports the original -- proposition. If successful, return the completed @Theorem@ and a summary -- of solver resources used in the proof. -finishProof :: SharedContext -> TheoremDB -> Prop -> ProofState -> IO ProofResult -finishProof sc db conclProp ps@(ProofState gs (concl,loc,ploc,rsn) stats _ checkEv start) = +-- +-- If the final boolean argument is False, the resulting theorem will not be +-- recored in the theorem database. This should only be done when you are +-- sure that the theorem will not be used as part of the proof of other theorems, +-- or later steps will fail. +finishProof :: + SharedContext -> + TheoremDB -> + Prop -> + ProofState -> + Bool {- ^ should we record the theorem in the database? -} -> + IO ProofResult +finishProof sc db conclProp ps@(ProofState gs (concl,loc,ploc,rsn) stats _ checkEv start) recordThm = case gs of [] -> do e <- checkEv [] @@ -1558,7 +1569,7 @@ finishProof sc db conclProp ps@(ProofState gs (concl,loc,ploc,rsn) stats _ check (deps,sy) <- checkEvidence sc db e' conclProp n <- freshNonce globalNonceGenerator end <- getCurrentTime - thm <- recordTheorem db + thm <- (if recordThm then recordTheorem db else return) Theorem { _thmProp = conclProp , _thmStats = stats diff --git a/src/SAWScript/Value.hs b/src/SAWScript/Value.hs index 476f4bc8e8..075edae37b 100644 --- a/src/SAWScript/Value.hs +++ b/src/SAWScript/Value.hs @@ -832,8 +832,15 @@ newtype ProofScript a = ProofScript { unProofScript :: ExceptT (SolverStats, CEX -- TODO: remove the "reason" parameter and compute it from the -- initial proof goal instead -runProofScript :: ProofScript a -> Prop -> ProofGoal -> Maybe ProgramLoc -> Text -> TopLevel ProofResult -runProofScript (ProofScript m) concl gl ploc rsn = +runProofScript :: + ProofScript a -> + Prop -> + ProofGoal -> + Maybe ProgramLoc -> + Text -> + Bool {- ^ record the theorem in the database? -} -> + TopLevel ProofResult +runProofScript (ProofScript m) concl gl ploc rsn recordThm = do pos <- getPosition ps <- io (startProof gl pos ploc rsn) (r,pstate) <- runStateT (runExceptT m) ps @@ -842,7 +849,7 @@ runProofScript (ProofScript m) concl gl ploc rsn = Right _ -> do sc <- getSharedContext db <- rwTheoremDB <$> getTopLevelRW - io (finishProof sc db concl pstate) + io (finishProof sc db concl pstate recordThm) scriptTopLevel :: TopLevel a -> ProofScript a scriptTopLevel m = ProofScript (lift (lift m)) From bcc713114ef776a399d5ede1630629cf793f8f24 Mon Sep 17 00:00:00 2001 From: Rob Dockins Date: Mon, 25 Jul 2022 16:26:12 -0700 Subject: [PATCH 12/35] Update metadata tracking for verification conditions. This avoids entering the statements of verification conditions into the "theorem database", and tracks data about their proofs separately. This is primarily to avoid retaining the terms representing these conditions throughout the run of a proof, as the VCs can get quite large, and are never directly used in the proof of another theorem. --- src/SAWScript/Crucible/Common/MethodSpec.hs | 14 ++-- src/SAWScript/Crucible/JVM/Builtins.hs | 13 ++-- src/SAWScript/Crucible/LLVM/Builtins.hs | 29 ++++---- src/SAWScript/Crucible/LLVM/X86.hs | 13 ++-- src/SAWScript/VerificationSummary.hs | 31 +++++--- verif-viewer/tools/VerifViewer.hs | 79 ++++++++++++++------- 6 files changed, 113 insertions(+), 66 deletions(-) diff --git a/src/SAWScript/Crucible/Common/MethodSpec.hs b/src/SAWScript/Crucible/Common/MethodSpec.hs index a9cc7e7135..9962484da7 100644 --- a/src/SAWScript/Crucible/Common/MethodSpec.hs +++ b/src/SAWScript/Crucible/Common/MethodSpec.hs @@ -53,7 +53,7 @@ import Verifier.SAW.SharedTerm as SAWVerifier import SAWScript.Options import SAWScript.Prover.SolverStats import SAWScript.Utils (bullets) -import SAWScript.Proof (TheoremNonce) +import SAWScript.Proof (TheoremNonce, TheoremSummary) -- | How many allocations have we made in this method spec? newtype AllocIndex = AllocIndex Int @@ -362,13 +362,17 @@ data ProofMethod type SpecNonce ext = Nonce GlobalNonceGenerator (ProvedSpec ext) +type VCStats = (ConditionMetadata, SolverStats, TheoremSummary, TheoremNonce, Set TheoremNonce, NominalDiffTime) + data ProvedSpec ext = ProvedSpec { _psSpecIdent :: Nonce GlobalNonceGenerator (ProvedSpec ext) , _psProofMethod :: ProofMethod , _psSpec :: CrucibleMethodSpecIR ext , _psSolverStats :: SolverStats -- ^ statistics about the proof that produced this - , _psTheoremDeps :: Set TheoremNonce -- ^ theorems depended on by this proof + , _psVCStats :: [VCStats] + -- ^ Stats about the individual verification conditions produced + -- by the proof of this specification , _psSpecDeps :: Set (SpecNonce ext) -- ^ Other proved specifications this proof depends on , _psElapsedTime :: NominalDiffTime -- ^ The time elapsed during the proof of this specification @@ -380,13 +384,13 @@ mkProvedSpec :: ProofMethod -> CrucibleMethodSpecIR ext -> SolverStats -> - Set TheoremNonce -> + [VCStats] -> Set (SpecNonce ext) -> NominalDiffTime -> IO (ProvedSpec ext) -mkProvedSpec m mspec stats thms sps elapsed = +mkProvedSpec m mspec stats vcStats sps elapsed = do n <- freshNonce globalNonceGenerator - let ps = ProvedSpec n m mspec stats thms sps elapsed + let ps = ProvedSpec n m mspec stats vcStats sps elapsed return ps -- TODO: remove when what4 switches to prettyprinter diff --git a/src/SAWScript/Crucible/JVM/Builtins.hs b/src/SAWScript/Crucible/JVM/Builtins.hs index a853a84491..f00c57ea40 100644 --- a/src/SAWScript/Crucible/JVM/Builtins.hs +++ b/src/SAWScript/Crucible/JVM/Builtins.hs @@ -256,13 +256,13 @@ jvm_verify cls nm lemmas checkSat setup tactic = _ <- io $ Crucible.popAssumptionFrame bak frameIdent -- attempt to verify the proof obligations - (stats,thms) <- verifyObligations cc methodSpec tactic assumes asserts + (stats,vcstats) <- verifyObligations cc methodSpec tactic assumes asserts io $ writeFinalProfile let lemmaSet = Set.fromList (map (view MS.psSpecIdent) lemmas) end <- io getCurrentTime let diff = diffUTCTime end start - ps <- io (MS.mkProvedSpec MS.SpecProved methodSpec stats thms lemmaSet diff) + ps <- io (MS.mkProvedSpec MS.SpecProved methodSpec stats vcstats lemmaSet diff) returnProof ps @@ -290,7 +290,7 @@ verifyObligations :: ProofScript () -> [Crucible.LabeledPred Term AssumptionReason] -> [(String, MS.ConditionMetadata, Term)] -> - TopLevel (SolverStats, Set TheoremNonce) + TopLevel (SolverStats, [MS.VCStats]) verifyObligations cc mspec tactic assumes asserts = do let sym = cc^.jccSym st <- io $ sawCoreState sym @@ -321,7 +321,8 @@ verifyObligations cc mspec tactic assumes asserts = ["JVM verification condition:", Text.pack (show n), Text.pack goalname]) False -- do not record in the theorem database case res of - ValidProof stats thm -> return (stats, thmNonce thm) + ValidProof stats thm -> + return (stats, (md, stats, thmSummary thm, thmNonce thm, thmDepends thm, thmElapsedTime thm)) InvalidProof stats vals _pst -> do printOutLnTop Info $ unwords ["Subgoal failed:", nm, msg] printOutLnTop Info (show stats) @@ -337,8 +338,8 @@ verifyObligations cc mspec tactic assumes asserts = printOutLnTop Info $ unwords ["Proof succeeded!", nm] let stats = mconcat (map fst outs) - let thms = mconcat (map (Set.singleton . snd) outs) - return (stats, thms) + let vcstats = map snd outs + return (stats, vcstats) -- | Evaluate the precondition part of a Crucible method spec: -- diff --git a/src/SAWScript/Crucible/LLVM/Builtins.hs b/src/SAWScript/Crucible/LLVM/Builtins.hs index 6fef0606fa..b702166c2b 100644 --- a/src/SAWScript/Crucible/LLVM/Builtins.hs +++ b/src/SAWScript/Crucible/LLVM/Builtins.hs @@ -293,11 +293,11 @@ llvm_verify (Some lm) nm lemmas checkSat setup tactic = do start <- io getCurrentTime lemmas' <- checkModuleCompatibility lm lemmas withMethodSpec checkSat lm nm setup $ \cc method_spec -> - do (stats, deps, _) <- verifyMethodSpec cc method_spec lemmas' checkSat tactic Nothing + do (stats, vcs, _) <- verifyMethodSpec cc method_spec lemmas' checkSat tactic Nothing let lemmaSet = Set.fromList (map (view MS.psSpecIdent) lemmas') end <- io getCurrentTime let diff = diffUTCTime end start - ps <- io (MS.mkProvedSpec MS.SpecProved method_spec stats deps lemmaSet diff) + ps <- io (MS.mkProvedSpec MS.SpecProved method_spec stats vcs lemmaSet diff) returnProof $ SomeLLVM ps llvm_refine_spec :: @@ -420,7 +420,7 @@ llvm_compositional_extract (Some lm) nm func_name lemmas checkSat setup tactic = , "An output parameter must be bound by llvm_return or llvm_points_to." ] - (stats, deps, post_override_state) <- + (stats, vcs, post_override_state) <- verifyMethodSpec cc method_spec lemmas' checkSat tactic Nothing shared_context <- getSharedContext @@ -488,7 +488,7 @@ llvm_compositional_extract (Some lm) nm func_name lemmas checkSat setup tactic = end <- io getCurrentTime let diff = diffUTCTime end start - ps <- io (MS.mkProvedSpec MS.SpecProved extracted_method_spec stats deps lemmaSet diff) + ps <- io (MS.mkProvedSpec MS.SpecProved extracted_method_spec stats vcs lemmaSet diff) returnProof (SomeLLVM ps) setupValueAsExtCns :: SetupValue (LLVM arch) -> Maybe (ExtCns Term) @@ -598,7 +598,7 @@ verifyMethodSpec :: Bool -> ProofScript () -> Maybe (IORef (Map Text.Text [Crucible.FunctionProfile])) -> - TopLevel (SolverStats, Set TheoremNonce, OverrideState (LLVM arch)) + TopLevel (SolverStats, [MS.VCStats], OverrideState (LLVM arch)) verifyMethodSpec cc methodSpec lemmas checkSat tactic asp = ccWithBackend cc $ \bak -> do printOutLnTop Info $ @@ -660,11 +660,11 @@ verifyMethodSpec cc methodSpec lemmas checkSat tactic asp = -- attempt to verify the proof obligations printOutLnTop Info $ unwords ["Checking proof obligations", (methodSpec ^. csName), "..."] - (stats, deps) <- verifyObligations cc methodSpec tactic assumes asserts + (stats, vcstats) <- verifyObligations cc methodSpec tactic assumes asserts io $ writeFinalProfile return ( stats - , deps + , vcstats , post_override_state ) @@ -684,7 +684,7 @@ refineMethodSpec :: MS.CrucibleMethodSpecIR (LLVM arch) -> [MS.ProvedSpec (LLVM arch)] -> ProofScript () -> - TopLevel (SolverStats, Set TheoremNonce) + TopLevel (SolverStats, [MS.VCStats]) refineMethodSpec cc methodSpec lemmas tactic = ccWithBackend cc $ \bak -> do let sym = cc^.ccSym @@ -762,11 +762,11 @@ refineMethodSpec cc methodSpec lemmas tactic = -- attempt to verify the proof obligations printOutLnTop Info $ unwords ["Checking proof obligations", (methodSpec ^. csName), "..."] - (stats, deps) <- verifyObligations cc methodSpec tactic assumes asserts + (stats, vcstats) <- verifyObligations cc methodSpec tactic assumes asserts io $ writeFinalProfile return ( stats - , deps + , vcstats ) @@ -775,7 +775,7 @@ verifyObligations :: LLVMCrucibleContext arch -> ProofScript () -> [Crucible.LabeledPred Term AssumptionReason] -> [(String, MS.ConditionMetadata, Term)] - -> TopLevel (SolverStats, Set TheoremNonce) + -> TopLevel (SolverStats, [MS.VCStats]) verifyObligations cc mspec tactic assumes asserts = do let sym = cc^.ccSym st <- io $ Common.sawCoreState sym @@ -813,7 +813,8 @@ verifyObligations cc mspec tactic assumes asserts = ["LLVM verification condition", Text.pack (show n), Text.pack goalname]) False -- do not record this theorem in the database case res of - ValidProof stats thm -> return (stats, thmNonce thm) + ValidProof stats thm -> + return (stats, (md, stats, thmSummary thm, thmNonce thm, thmDepends thm, thmElapsedTime thm)) UnfinishedProof pst -> do printOutLnTop Info $ unwords ["Subgoal failed:", nm, msg] throwTopLevel $ "Proof failed " ++ show (length (psGoals pst)) ++ " goals remaining." @@ -833,8 +834,8 @@ verifyObligations cc mspec tactic assumes asserts = printOutLnTop Info $ unwords ["Proof succeeded!", nm] let stats = mconcat (map fst outs) - let deps = mconcat (map (Set.singleton . snd) outs) - return (stats, deps) + let vcstats = map snd outs + return (stats, vcstats) throwMethodSpec :: MS.CrucibleMethodSpecIR (LLVM arch) -> String -> IO a throwMethodSpec mspec msg = X.throw $ LLVMMethodSpecException (mspec ^. MS.csLoc) msg diff --git a/src/SAWScript/Crucible/LLVM/X86.hs b/src/SAWScript/Crucible/LLVM/X86.hs index c4dffc0b2d..c25afdcab9 100644 --- a/src/SAWScript/Crucible/LLVM/X86.hs +++ b/src/SAWScript/Crucible/LLVM/X86.hs @@ -537,11 +537,11 @@ llvm_verify_x86_common (Some (llvmModule :: LLVMModule x)) path nm globsyms chec ar C.TimeoutResult{} -> fail "Execution timed out" - (stats,thms) <- checkGoals bak opts nm sc tactic mdMap + (stats,vcstats) <- checkGoals bak opts nm sc tactic mdMap end <- io getCurrentTime let diff = diffUTCTime end start - ps <- io (MS.mkProvedSpec MS.SpecProved methodSpec stats thms mempty diff) + ps <- io (MS.mkProvedSpec MS.SpecProved methodSpec stats vcstats mempty diff) returnProof $ SomeLLVM ps | otherwise = fail "LLVM module must be 64-bit" @@ -1173,7 +1173,7 @@ checkGoals :: SharedContext -> ProofScript () -> IORef MetadataMap {- ^ metadata map -} -> - TopLevel (SolverStats, Set TheoremNonce) + TopLevel (SolverStats, [MS.VCStats]) checkGoals bak opts nm sc tactic mdMap = do gs <- liftIO $ getGoals (SomeBackend bak) mdMap liftIO . printOutLn opts Info $ mconcat @@ -1204,7 +1204,8 @@ checkGoals bak opts nm sc tactic mdMap = do ["X86 verification condition", Text.pack (show n), Text.pack (show (gMessage g))]) False -- do no record this theorem in the database case res of - ValidProof stats thm -> return (stats, thmNonce thm) + ValidProof stats thm -> + return (stats, (md, stats, thmSummary thm, thmNonce thm, thmDepends thm, thmElapsedTime thm)) UnfinishedProof pst -> do printOutLnTop Info $ unwords ["Subgoal failed:", show $ gMessage g] printOutLnTop Info (show (psStats pst)) @@ -1225,5 +1226,5 @@ checkGoals bak opts nm sc tactic mdMap = do liftIO $ printOutLn opts Info "All goals succeeded" let stats = mconcat (map fst outs) - let thms = mconcat (map (Set.singleton . snd) outs) - return (stats, thms) + let vcstats = map snd outs + return (stats, vcstats) diff --git a/src/SAWScript/VerificationSummary.hs b/src/SAWScript/VerificationSummary.hs index b7e8744400..2962e67a62 100644 --- a/src/SAWScript/VerificationSummary.hs +++ b/src/SAWScript/VerificationSummary.hs @@ -18,6 +18,7 @@ module SAWScript.VerificationSummary import Control.Lens ((^.)) import qualified Data.Map as Map import qualified Data.Set as Set +import Data.Text (Text) import Data.String import Prettyprinter import Data.Aeson (encode, (.=), Value(..), object, toJSON) @@ -62,8 +63,8 @@ vsAllSolvers vs = Set.union (vsVerifSolvers vs) (vsTheoremSolvers vs) computeVerificationSummary :: TheoremDB -> [JVMTheorem] -> [LLVMTheorem] -> [Theorem] -> IO VerificationSummary computeVerificationSummary db js ls thms = do let roots = mconcat ( - [ j ^. psTheoremDeps | j <- js ] ++ - [ l ^. psTheoremDeps | CMSLLVM.SomeLLVM l <- ls ] ++ + [ xs | j <- js, (_,_,_,_,xs,_) <- j^.psVCStats ] ++ + [ xs | CMSLLVM.SomeLLVM l <- ls, (_,_,_,_,xs,_) <- l^.psVCStats ] ++ [ Set.singleton (thmNonce t) | t <- thms ]) thms' <- Map.elems <$> reachableTheorems db roots pure (VerificationSummary js ls thms') @@ -79,11 +80,22 @@ msToJSON cms = object [ SpecAdmitted -> "assumed" :: String SpecProved -> "verified") -- , ("specification" .= ("unknown" :: String)) -- TODO - , ("dependencies" .= toJSON - (map indexValue (Set.toList (cms ^. psSpecDeps)) ++ - map indexValue (Set.toList (cms ^. psTheoremDeps)))) + , ("dependencies" .= toJSON (map indexValue (Set.toList (cms ^. psSpecDeps)))) + , ("vcs" .= toJSON (map vcToJSON (cms ^. psVCStats))) , ("elapsedtime" .= toJSON (cms ^. psElapsedTime)) - ] + ] + +vcToJSON :: CMS.VCStats -> Value +vcToJSON (cmd, _stats, thmsummary, nonce, deps, elapsedtime) = object ([ + ("type" .= ("vc" :: String)) + , ("id" .= indexValue nonce) + , ("loc" .= show (conditionLoc cmd)) + , ("reason" .= conditionType cmd) + , ("elapsedtime" .= toJSON elapsedtime) + , ("dependencies" .= toJSON (map indexValue (Set.toList deps))) + , ("tags" .= toJSON (Set.toList (conditionTags cmd))) + ] ++ theoremStatus thmsummary + ) thmToJSON :: Theorem -> Value thmToJSON thm = object ([ @@ -93,13 +105,14 @@ thmToJSON thm = object ([ , ("reason" .= (thmReason thm)) , ("dependencies" .= toJSON (map indexValue (Set.toList (thmDepends thm)))) , ("elapsedtime" .= toJSON (thmElapsedTime thm)) - ] ++ theoremStatus + ] ++ (theoremStatus (thmSummary thm)) ++ case thmProgramLoc thm of Nothing -> [] Just ploc -> [("ploc" .= plocToJSON ploc)] ) - where - theoremStatus = case thmSummary thm of + +theoremStatus :: TheoremSummary -> [(Text,Value)] +theoremStatus summary = case summary of ProvedTheorem stats -> [ ("status" .= ("verified" :: String)) , ("provers" .= toJSON (Set.toList (solverStatsSolvers stats))) diff --git a/verif-viewer/tools/VerifViewer.hs b/verif-viewer/tools/VerifViewer.hs index 0d8ddef5e3..9e453e0801 100644 --- a/verif-viewer/tools/VerifViewer.hs +++ b/verif-viewer/tools/VerifViewer.hs @@ -55,30 +55,17 @@ handleNodes o ns = TL.writeFile o (GV.renderDot (GV.toDot dot)) nodeMap :: Map Integer SummaryNode nodeMap = Map.fromList [ (summaryNodeId n, n) | n <- ns ] - revMethodDep :: Map Integer Integer - revMethodDep = Map.fromList $ - do MethodSummary i s <- ns - t <- methodDeps s - Just (TheoremSummary _ _) <- pure (Map.lookup t nodeMap) - pure (t, i) - nodes :: [(Integer,SummaryNode)] nodes = do n <- ns - if isVCGoal (summaryNodeId n) then [] else pure (summaryNodeId n, n) - - isVCGoal :: Integer -> Bool - isVCGoal i = isJust (Map.lookup i revMethodDep) + pure (summaryNodeId n, n) uniqEdges :: [(Integer,Integer,())] uniqEdges = Set.toList (Set.fromList edges) edges :: [(Integer,Integer,())] edges = do n <- ns - let i = case n of - TheoremSummary i thm - | Just parent <- Map.lookup i revMethodDep -> parent - _ -> summaryNodeId n - n' <- filter (not . isVCGoal) (summaryNodeDeps n) + let i = summaryNodeId n + n' <- summaryNodeDeps n pure (i,n',()) fmt :: (Integer, SummaryNode) -> GV.Attributes @@ -117,24 +104,22 @@ fmtMethod nodeMap mn = [ GV.Label (GV.HtmlLabel top), GV.Shape GV.PlainText ] subsTab :: HTML.Cell subsTab = HTML.LabelCell [] (HTML.Table (HTML.HTable Nothing [HTML.Border 0, HTML.CellBorder 1] [HTML.Cells subs])) - vcs = do d <- methodDeps mn - Just (TheoremSummary i thm) <- pure (Map.lookup d nodeMap) - pure (i,thm) + vcs = methodVCs mn subs :: [HTML.Cell] - subs = map (uncurry mkSub) vcs + subs = map mkSub vcs - mkSub :: Integer -> TheoremNode -> HTML.Cell - mkSub i thm = HTML.LabelCell attrs (HTML.Text [ HTML.Str (TL.fromStrict (T.pack (show (thmElapsedTime thm)))) ]) + mkSub :: VCNode -> HTML.Cell + mkSub vc = HTML.LabelCell attrs (HTML.Text [ HTML.Str (TL.fromStrict (T.pack (show (vcElapsedTime vc)))) ]) where attrs = - [ HTML.BGColor (thmColor thm) - , HTML.Title (TL.fromStrict (thmStatusText thm <> "\n" <> thmTooltip thm)) + [ HTML.BGColor (vcColor vc) + , HTML.Title (TL.fromStrict (vcTooltip vc)) , HTML.HRef "#" ] fillcol = statusColor $ - foldr (<>) (methodToStatus mn) (map (thmToStatus . snd) vcs) + foldr (<>) (methodToStatus mn) (map vcToStatus vcs) maintext = T.intercalate "\n" @@ -165,6 +150,12 @@ thmToStatus thm = case thmStatus thm of TheoremTested{} -> Tested TheoremAdmitted{} -> Assumed +vcToStatus :: VCNode -> Status +vcToStatus vc = case vcStatus vc of + TheoremVerified{} -> Proved + TheoremTested{} -> Tested + TheoremAdmitted{} -> Assumed + methodToStatus :: MethodNode -> Status methodToStatus mn = case methodStatus mn of MethodAssumed -> Assumed @@ -173,6 +164,9 @@ methodToStatus mn = case methodStatus mn of thmColor :: TheoremNode -> GV.Color thmColor = statusColor . thmToStatus +vcColor :: VCNode -> GV.Color +vcColor = statusColor . vcToStatus + thmStatusText :: TheoremNode -> Text thmStatusText thm = T.intercalate "\n" $ case thmStatus thm of @@ -180,6 +174,11 @@ thmStatusText thm = T.intercalate "\n" $ TheoremTested nm -> [T.unwords ["tested:", T.pack (show nm)]] TheoremAdmitted msg -> ["Admitted!", msg] +vcTooltip :: VCNode -> Text +vcTooltip vc = T.intercalate "\n" $ + [ vcReason vc + , vcLoc vc + ] thmTooltip :: TheoremNode -> Text thmTooltip thm = T.intercalate "\n" $ @@ -210,6 +209,7 @@ parseMethodNode o = o .: "loc" <*> parseMethodStatus o <*> parseDeps o <*> + parseVCs o <*> o .: "elapsedtime" parseMethodStatus :: Object -> Parser MethodStatus @@ -220,9 +220,23 @@ parseMethodStatus o = "verified" -> pure MethodVerified _ -> fail ("Unexpected moethod status " ++ show st) +parseVCs :: Object -> Parser [VCNode] +parseVCs o = + (o .: "vcs") >>= parseJSONList >>= mapM parseVCNode + parseDeps :: Object -> Parser [Integer] parseDeps o = (o .: "dependencies") >>= parseJSONList +parseVCNode :: Object -> Parser VCNode +parseVCNode o = + VCNode <$> + o .: "loc" <*> + parseTheoremStatus o <*> + o .: "reason" <*> + o .: "elapsedtime" <*> + parseDeps o <*> + o .: "tags" + parseTheoremNode :: Object -> Parser TheoremNode parseTheoremNode o = TheoremNode <$> @@ -259,7 +273,8 @@ summaryNodeId (MethodSummary i _) = i summaryNodeDeps :: SummaryNode -> [Integer] summaryNodeDeps (TheoremSummary _ s) = thmDeps s -summaryNodeDeps (MethodSummary _ s) = methodDeps s +summaryNodeDeps (MethodSummary _ s) = + methodDeps s ++ (vcDeps =<< methodVCs s) data TheoremNode = @@ -270,6 +285,17 @@ data TheoremNode = , thmStatus :: TheoremStatus , thmPLoc :: Maybe (Text, Text) , thmDeps :: [Integer] + } + deriving (Show) + +data VCNode = + VCNode + { vcLoc :: Text + , vcStatus :: TheoremStatus + , vcReason :: Text + , vcElapsedTime :: NominalDiffTime + , vcDeps :: [Integer] + , vcTags :: [String] } deriving (Show) @@ -285,6 +311,7 @@ data MethodNode = , methodLoc :: Text , methodStatus :: MethodStatus , methodDeps :: [Integer] + , methodVCs :: [VCNode] , methodElapsedtime :: NominalDiffTime } deriving (Show) From 537a719a0dc4a376aad0b497ea738db5016cf76d Mon Sep 17 00:00:00 2001 From: Rob Dockins Date: Mon, 25 Jul 2022 18:13:46 -0700 Subject: [PATCH 13/35] squash a warning --- src/SAWScript/Crucible/LLVM/Builtins.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/SAWScript/Crucible/LLVM/Builtins.hs b/src/SAWScript/Crucible/LLVM/Builtins.hs index b702166c2b..fd2e09b06a 100644 --- a/src/SAWScript/Crucible/LLVM/Builtins.hs +++ b/src/SAWScript/Crucible/LLVM/Builtins.hs @@ -113,7 +113,6 @@ import Data.Map (Map) import qualified Data.Map as Map import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap -import Data.Set (Set) import qualified Data.Set as Set import Data.Sequence (Seq) import qualified Data.Sequence as Seq From a259da77be2d577756a0e5d0379ba78e34e9b3cc Mon Sep 17 00:00:00 2001 From: Robert Dockins Date: Tue, 2 Aug 2022 17:05:22 -0700 Subject: [PATCH 14/35] Add a few new tactics for introducing and reverting hypotheses in sequents. --- src/SAWScript/Builtins.hs | 10 ++++++ src/SAWScript/Interpreter.hs | 10 ++++++ src/SAWScript/Proof.hs | 70 ++++++++++++++++++++++++++++++++++++ 3 files changed, 90 insertions(+) diff --git a/src/SAWScript/Builtins.hs b/src/SAWScript/Builtins.hs index fea3e628a3..ec83aa1ccb 100644 --- a/src/SAWScript/Builtins.hs +++ b/src/SAWScript/Builtins.hs @@ -828,6 +828,16 @@ goal_exact tm = do sc <- SV.scriptTopLevel getSharedContext execTactic (tacticExact sc (ttTerm tm)) +goal_intro_hyps :: Integer -> ProofScript () +goal_intro_hyps n = + do sc <- SV.scriptTopLevel getSharedContext + execTactic (tacticIntroHyps sc n) + +goal_revert_hyp :: Integer -> ProofScript () +goal_revert_hyp i = + do sc <- SV.scriptTopLevel getSharedContext + execTactic (tacticRevertHyp sc i) + {- goal_assume :: ProofScript Theorem goal_assume = diff --git a/src/SAWScript/Interpreter.hs b/src/SAWScript/Interpreter.hs index f216532649..fbc0cff2e0 100644 --- a/src/SAWScript/Interpreter.hs +++ b/src/SAWScript/Interpreter.hs @@ -1696,6 +1696,16 @@ primitives = Map.fromList , "This will succeed if the type of the given term matches the current goal." ] + , prim "goal_intro_hyps" "Int -> ProofScript ()" + (pureVal goal_intro_hyps) + Experimental + [ "TODO "] + + , prim "goal_revert_hyp" "Int -> ProofScript ()" + (pureVal goal_revert_hyp) + Experimental + [ "TODO "] + {- , prim "goal_assume" "ProofScript Theorem" (pureVal goal_assume) diff --git a/src/SAWScript/Proof.hs b/src/SAWScript/Proof.hs index 6b2f7f7329..354f009e21 100644 --- a/src/SAWScript/Proof.hs +++ b/src/SAWScript/Proof.hs @@ -101,6 +101,8 @@ module SAWScript.Proof , tacticChange , tacticSolve , tacticExact + , tacticIntroHyps + , tacticRevertHyp , Quantification(..) , predicateToProp @@ -266,6 +268,34 @@ splitDisj sc (Prop p) = t2 <- scPiList sc vars =<< scEqTrue sc p2 return (Just (Prop t1,Prop t2)) +-- | Attempt to split an implication into a hypothesis and a conclusion +splitImpl :: SharedContext -> Prop -> IO (Maybe (Prop, Prop)) +splitImpl sc (Prop p) + | Just ( _ :*: h :*: c) <- (isGlobalDef "Prelude.implies" <@> return <@> return) =<< asEqTrue p + = do h' <- scEqTrue sc h + c' <- scEqTrue sc c + return (Just (Prop h', Prop c')) + + | Just ( _ :*: (_ :*: h) :*: c) <- (isGlobalDef "Prelude.or" <@> (isGlobalDef "Prelude.not" <@> return) <@> return) =<< asEqTrue p + = do h' <- scEqTrue sc h + c' <- scEqTrue sc c + return (Just (Prop h', Prop c')) + + | Just ( _ :*: c :*: (_ :*: h)) <- (isGlobalDef "Prelude.or" <@> return <@> (isGlobalDef "Prelude.not" <@> return)) =<< asEqTrue p + = do h' <- scEqTrue sc h + c' <- scEqTrue sc c + return (Just (Prop h', Prop c')) + +{- TODO? sequent normalization doesn't decompose arrows... + + | Just (_nm, h, c ) <- asPi p + , looseVars c == emptyBitSet + = return (Just (Prop h, Prop c)) +-} + + | otherwise + = return Nothing + splitSequent :: SharedContext -> Sequent -> IO (Maybe (Sequent, Sequent)) splitSequent sc sqt = @@ -1813,6 +1843,45 @@ tacticIntro sc usernm = Tactic \goal -> HypFocus _ _ -> fail "TODO: implement intro on hyps" Unfocused -> fail "intro tactic: focus required" + +tacticIntroHyps :: (F.MonadFail m, MonadIO m) => SharedContext -> Integer -> Tactic m () +tacticIntroHyps sc n = Tactic \goal -> + case goalSequent goal of + GoalFocusedSequent hs (FB gs1 g gs2) -> + do (newhs, g') <- liftIO (loop n g) + let sqt' = GoalFocusedSequent (hs ++ newhs) (FB gs1 g' gs2) + let goal' = goal{ goalSequent = sqt' } + return ((), mempty, [goal'], updateEvidence (NormalizeSequentEvidence sqt')) + _ -> fail "goal_intro_hyps: conclusion focus required" + + where + loop i g + | i <= 0 = return ([],g) + | otherwise = + splitImpl sc g >>= \case + Nothing -> fail "intro_hyps: could not find enough hypotheses to introduce" + Just (h,g') -> + do (hs,g'') <- loop (i-1) g' + return (h:hs, g'') + +tacticRevertHyp :: (F.MonadFail m, MonadIO m) => SharedContext -> Integer -> Tactic m () +tacticRevertHyp sc i = Tactic \goal -> + case goalSequent goal of + GoalFocusedSequent hs (FB gs1 g gs2) -> + case genericDrop i hs of + (h:_) -> + case (asEqTrue (unProp h), asEqTrue (unProp g)) of + (Just h', Just g') -> + do g'' <- liftIO (Prop <$> (scEqTrue sc =<< scImplies sc h' g')) + let sqt' = GoalFocusedSequent hs (FB gs1 g'' gs2) + let goal' = goal{ goalSequent = sqt' } + return ((), mempty, [goal'], updateEvidence (NormalizeSequentEvidence sqt')) + + _ -> fail "goal_revert_hyp: expected EqTrue props" + _ -> fail "goal_revert_hyp: not enough hypotheses" + _ -> fail "goal_revert_hyp: conclusion focus required" + + {- -- | Attempt to prove an implication goal by introducing a local assumption for -- hypothesis. Return a @Theorem@ representing this local assumption. @@ -1869,6 +1938,7 @@ tacticSplit sc = Tactic \gl -> return ((), mempty, [g1,g2], splitEvidence) Nothing -> fail "split tactic failed" + tacticCut :: (F.MonadFail m, MonadIO m) => SharedContext -> Prop -> Tactic m () tacticCut _sc p = Tactic \gl -> let sqt1 = addHypothesis p (goalSequent gl) From 30ee6227158cf8ce15320968693de5b0fbde1215 Mon Sep 17 00:00:00 2001 From: Robert Dockins Date: Sat, 13 Aug 2022 13:13:18 -0700 Subject: [PATCH 15/35] Remove aspects of the proof checking-system that were related to the old `goal_assume` tactic. It was never much used, and the use-cases it aimed to serve are better handled by sequents. --- src/SAWScript/Proof.hs | 160 ++++++++--------------------------------- 1 file changed, 31 insertions(+), 129 deletions(-) diff --git a/src/SAWScript/Proof.hs b/src/SAWScript/Proof.hs index 354f009e21..c7e234ee43 100644 --- a/src/SAWScript/Proof.hs +++ b/src/SAWScript/Proof.hs @@ -91,8 +91,6 @@ module SAWScript.Proof , Tactic , withFirstGoal , tacticIntro --- , tacticCut --- , tacticAssume , tacticApply , tacticSplit , tacticCut @@ -756,10 +754,6 @@ data Theorem = , _thmSummary :: TheoremSummary } -- INVARIANT: the provided evidence is valid for the included proposition - | LocalAssumption Prop Pos TheoremNonce - -- This constructor is used to construct "hypothetical" theorems that - -- are intended to be used in local scopes when proving implications. - data TheoremDB = TheoremDB -- TODO, maybe this should be a summary or something simpler? @@ -770,8 +764,6 @@ newTheoremDB :: IO TheoremDB newTheoremDB = TheoremDB <$> newIORef mempty recordTheorem :: TheoremDB -> Theorem -> IO Theorem -recordTheorem _ (LocalAssumption _ pos _) = - panic "recordTheorem" ["Tried to record a local assumption as a top-level", show pos] recordTheorem db thm@Theorem{ _thmNonce = n } = do modifyIORef (theoremMap db) (Map.insert n thm) return thm @@ -805,15 +797,10 @@ reachableTheorems db roots = -- propositions and quickchecked propositions as valid. validateTheorem :: SharedContext -> TheoremDB -> Theorem -> IO () -validateTheorem _ _ (LocalAssumption p loc _n) = - fail $ unlines - [ "Illegal use of unbound local hypothesis generated at " ++ show loc - , showTerm (unProp p) - ] - validateTheorem sc db Theorem{ _thmProp = p, _thmEvidence = e, _thmDepends = thmDep } = - do (deps,_) <- checkEvidence sc db e p - unless (Set.isSubsetOf deps thmDep) + do hyps <- Map.keysSet <$> readIORef (theoremMap db) + (deps,_) <- checkEvidence sc e p + unless (Set.isSubsetOf deps thmDep && Set.isSubsetOf thmDep hyps) (fail $ unlines ["Theorem failed to declare its depencences correctly" , show deps, show thmDep ]) @@ -840,11 +827,6 @@ data Evidence -- for the truth of its type (qua proposition). ProofTerm !Term - -- | This type of evidence refers to a local assumption that - -- must have been introduced by a surrounding @AssumeEvidence@ - -- constructor. - | LocalAssumptionEvidence !Prop !TheoremNonce - -- | This type of evidence is produced when the given proposition -- has been dispatched to a solver which has indicated that it -- was able to prove the proposition. The included @SolverStats@ @@ -939,64 +921,48 @@ data Evidence -- | The the proposition proved by a given theorem. thmProp :: Theorem -> Prop -thmProp (LocalAssumption p _loc _n) = p thmProp Theorem{ _thmProp = p } = p -- | Retrieve any solver stats from the proved theorem. thmStats :: Theorem -> SolverStats -thmStats (LocalAssumption _ _ _) = mempty thmStats Theorem{ _thmStats = stats } = stats -- | Retrive the evidence associated with this theorem. thmEvidence :: Theorem -> Evidence -thmEvidence (LocalAssumption p _ n) = LocalAssumptionEvidence p n thmEvidence Theorem{ _thmEvidence = e } = e -- | The SAW source location that generated this theorem thmLocation :: Theorem -> Pos -thmLocation (LocalAssumption _p loc _) = loc thmLocation Theorem{ _thmLocation = loc } = loc -- | The program location (if any) of the program under -- verification giving rise to this theorem thmProgramLoc :: Theorem -> Maybe ProgramLoc -thmProgramLoc (LocalAssumption{}) = Nothing thmProgramLoc Theorem{ _thmProgramLoc = ploc } = ploc -- | Describes the reason this theorem was generated thmReason :: Theorem -> Text -thmReason (LocalAssumption _ _ _) = "local assumption" thmReason Theorem{ _thmReason = r } = r -- | Returns a unique identifier for this theorem thmNonce :: Theorem -> TheoremNonce -thmNonce (LocalAssumption _ _ n) = n thmNonce Theorem{ _thmNonce = n } = n -- | Returns the set of theorem identifiers that this theorem depends on thmDepends :: Theorem -> Set TheoremNonce -thmDepends LocalAssumption{} = mempty thmDepends Theorem { _thmDepends = s } = s -- | Returns the amount of time elapsed during the proof of this theorem thmElapsedTime :: Theorem -> NominalDiffTime -thmElapsedTime LocalAssumption{} = 0 thmElapsedTime Theorem{ _thmElapsedTime = tm } = tm thmSummary :: Theorem -> TheoremSummary -thmSummary LocalAssumption{} = mempty thmSummary Theorem { _thmSummary = sy } = sy splitEvidence :: [Evidence] -> IO Evidence splitEvidence [e1,e2] = pure (SplitEvidence e1 e2) splitEvidence _ = fail "splitEvidence: expected two evidence values" -{- -assumeEvidence :: TheoremNonce -> Prop -> [Evidence] -> IO Evidence -assumeEvidence n p [e] = pure (AssumeEvidence n p e) -assumeEvidence _ _ _ = fail "assumeEvidence: expected one evidence value" --} - introEvidence :: ExtCns Term -> [Evidence] -> IO Evidence introEvidence x [e] = pure (IntroEvidence x e) introEvidence _ _ = fail "introEvidence: expected one evidence value" @@ -1044,7 +1010,7 @@ constructTheorem :: NominalDiffTime -> IO Theorem constructTheorem sc db p e loc ploc rsn elapsed = - do (deps,sy) <- checkEvidence sc db e p + do (deps,sy) <- checkEvidence sc e p n <- freshNonce globalNonceGenerator recordTheorem db Theorem @@ -1320,23 +1286,22 @@ normalizeGoalBoolCommit sc b = -- | Verify that the given evidence in fact supports the given proposition. -- 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) - nenv <- scGetNamingEnv sc - check nenv hyps e (propToSequent p) +checkEvidence :: SharedContext -> Evidence -> Prop -> IO (Set TheoremNonce, TheoremSummary) +checkEvidence sc = \e p -> do nenv <- scGetNamingEnv sc + check nenv e (propToSequent p) where - checkApply _nenv _hyps _mkSqt (Prop p) [] = return (mempty, mempty, p) + checkApply _nenv _mkSqt (Prop p) [] = return (mempty, mempty, p) -- 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 nenv hyps mkSqt (Prop p) (Right e:es) + checkApply nenv mkSqt (Prop p) (Right e:es) | Just (_lnm, tp, body) <- asPi p , looseVars body == emptyBitSet - = do (d1,sy1) <- check nenv hyps e . mkSqt =<< termToProp sc tp - (d2,sy2,p') <- checkApply nenv hyps mkSqt (Prop body) es + = do (d1,sy1) <- check nenv e . mkSqt =<< termToProp sc tp + (d2,sy2,p') <- checkApply nenv mkSqt (Prop body) es return (Set.union d1 d2, sy1 <> sy2, p') | otherwise = fail $ unlines [ "Apply evidence mismatch: non-function or dependent function" @@ -1345,7 +1310,7 @@ checkEvidence sc db = \e p -> do hyps <- Map.keysSet <$> readIORef (theoremMap d -- Check a theorem applied to a term. This explicity instantiates -- a Pi binder with the given term. - checkApply nenv hyps mkSqt (Prop p) (Left tm:es) = + checkApply nenv mkSqt (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' @@ -1353,24 +1318,14 @@ checkEvidence sc db = \e p -> do hyps <- Map.keysSet <$> readIORef (theoremMap d res <- TC.runTCM m sc Nothing [] case res of Left msg -> fail (unlines (TC.prettyTCError msg)) - Right p' -> checkApply nenv hyps mkSqt (Prop p') es - - checkTheorem :: Set TheoremNonce -> Theorem -> IO () - checkTheorem hyps (LocalAssumption p loc n) = - unless (Set.member n hyps) $ fail $ unlines - [ "Attempt to reference a local hypothesis that is not in scope" - , "Generated at " ++ show loc - , showTerm (unProp p) - ] - checkTheorem _hyps Theorem{} = return () + Right p' -> checkApply nenv mkSqt (Prop p') es check :: SAWNamingEnv -> - Set TheoremNonce -> Evidence -> Sequent -> IO (Set TheoremNonce, TheoremSummary) - check nenv hyps e sqt = case e of + check nenv e sqt = case e of ProofTerm tm -> case sequentState sqt of GoalFocus (Prop ptm) _ -> @@ -1384,14 +1339,6 @@ checkEvidence sc db = \e p -> do hyps <- Map.keysSet <$> readIORef (theoremMap d return (mempty, ProvedTheorem mempty) _ -> fail "Sequent must be goal-focused for proof term evidence" - - LocalAssumptionEvidence (Prop l) n -> - do unless (Set.member n hyps) $ fail $ unlines - [ "Illegal use of local hypothesis" - , showTerm l - ] - return (Set.singleton n, ProvedTheorem mempty) - SolverEvidence stats sqt' -> do ok <- sequentSubsumes sc sqt' sqt unless ok $ fail $ unlines @@ -1427,15 +1374,14 @@ checkEvidence sc db = \e p -> do hyps <- Map.keysSet <$> readIORef (theoremMap d , prettySequent defaultPPOpts nenv sqt ] Just (sqt1,sqt2) -> - do d1 <- check nenv hyps e1 sqt1 - d2 <- check nenv hyps e2 sqt2 + do d1 <- check nenv e1 sqt1 + d2 <- check nenv e2 sqt2 return (d1 <> d2) ApplyEvidence thm es -> case sequentState sqt of GoalFocus p mkSqt -> - do checkTheorem hyps thm - (d,sy,p') <- checkApply nenv hyps mkSqt (thmProp thm) es + do (d,sy,p') <- checkApply nenv mkSqt (thmProp thm) es ok <- scConvertible sc False (unProp p) p' unless ok $ fail $ unlines [ "Apply evidence does not match the required proposition" @@ -1450,30 +1396,26 @@ checkEvidence sc db = \e p -> do hyps <- Map.keysSet <$> readIORef (theoremMap d UnfoldEvidence vars e' -> do sqt' <- traverseSequentWithFocus (unfoldProp sc vars) sqt - check nenv hyps e' sqt' + check nenv e' sqt' NormalizePropEvidence opqueSet e' -> do modmap <- scGetModuleMap sc sqt' <- traverseSequentWithFocus (normalizeProp sc modmap opqueSet) sqt - check nenv hyps e' sqt' + check nenv e' sqt' RewriteEvidence hs ss e' -> do ss' <- localHypSimpset sqt hs ss (d1,sqt') <- simplifySequent sc ss' sqt - unless (Set.isSubsetOf d1 hyps) $ fail $ unlines - [ "Rewrite step used theorem not in hypothesis database" - , show (Set.difference d1 hyps) - ] - (d2,sy) <- check nenv hyps e' sqt' + (d2,sy) <- check nenv e' sqt' return (Set.union d1 d2, sy) HoistIfsEvidence e' -> do sqt' <- traverseSequentWithFocus (hoistIfsInGoal sc) sqt - check nenv hyps e' sqt' + check nenv e' sqt' EvalEvidence vars e' -> do sqt' <- traverseSequentWithFocus (evalProp sc vars) sqt - check nenv hyps e' sqt' + check nenv e' sqt' ConversionEvidence sqt' e' -> do ok <- convertibleSequents sc sqt sqt' @@ -1482,7 +1424,7 @@ checkEvidence sc db = \e p -> do hyps <- Map.keysSet <$> readIORef (theoremMap d , prettySequent defaultPPOpts nenv sqt , prettySequent defaultPPOpts nenv sqt' ] - check nenv hyps e' sqt' + check nenv e' sqt' NormalizeSequentEvidence sqt' e' -> do ok <- normalizeSequentSubsumes sc sqt' sqt @@ -1491,7 +1433,7 @@ checkEvidence sc db = \e p -> do hyps <- Map.keysSet <$> readIORef (theoremMap d , prettySequent defaultPPOpts nenv sqt , prettySequent defaultPPOpts nenv sqt' ] - check nenv hyps e' sqt' + check nenv e' sqt' StructuralEvidence sqt' e' -> do ok <- sequentSubsumes sc sqt' sqt @@ -1500,26 +1442,7 @@ checkEvidence sc db = \e p -> do hyps <- Map.keysSet <$> readIORef (theoremMap d , prettySequent defaultPPOpts nenv sqt , prettySequent defaultPPOpts nenv sqt' ] - check nenv hyps e' sqt' - -{- - AssumeEvidence n (Prop p') e' -> - case asPi ptm of - Nothing -> fail $ unlines ["Assume evidence expected function prop", showTerm ptm] - Just (_lnm, ty, body) -> - do ok <- scConvertible sc False ty p' - unless ok $ fail $ unlines - [ "Assume evidence types do not match" - , showTerm ty - , showTerm p' - ] - unless (looseVars body == emptyBitSet) $ fail $ unlines - [ "Assume evidence cannot be used on a dependent proposition" - , showTerm ptm - ] - (d,sy) <- check (Set.insert n hyps) e' (Prop body) - return (Set.delete n d, sy) --} + check nenv e' sqt' AxiomEvidence -> do ok <- sequentIsAxiom sc sqt @@ -1530,15 +1453,15 @@ checkEvidence sc db = \e p -> do hyps <- Map.keysSet <$> readIORef (theoremMap d return (mempty, ProvedTheorem mempty) CutEvidence p ehyp egl -> - do d1 <- check nenv hyps ehyp (addHypothesis p sqt) - d2 <- check nenv hyps egl (addNewFocusedGoal p sqt) + do d1 <- check nenv ehyp (addHypothesis p sqt) + d2 <- check nenv egl (addNewFocusedGoal p sqt) return (d1 <> d2) IntroEvidence x e' -> -- TODO! Check that the given ExtCns is fresh for the sequent case sequentState sqt of Unfocused -> fail "Intro evidence requires a focused sequent" - HypFocus _ _ -> fail "Intro evidence apply in hypothesis: TODO: apply to existentials" + HypFocus _ _ -> fail "Intro evidence apply in hypothesis" GoalFocus (Prop ptm) mkSqt -> case asPi ptm of Nothing -> fail $ unlines ["Intro evidence expected function prop", showTerm ptm] @@ -1552,7 +1475,7 @@ checkEvidence sc db = \e p -> do hyps <- Map.keysSet <$> readIORef (theoremMap d ] x' <- scExtCns sc x body' <- instantiateVar sc 0 x' body - check nenv hyps e' (mkSqt (Prop body')) + check nenv e' (mkSqt (Prop body')) passthroughEvidence :: [Evidence] -> IO Evidence passthroughEvidence [e] = pure e @@ -1596,7 +1519,7 @@ finishProof sc db conclProp ps@(ProofState gs (concl,loc,ploc,rsn) stats _ check [] -> do e <- checkEv [] let e' = NormalizeSequentEvidence concl e - (deps,sy) <- checkEvidence sc db e' conclProp + (deps,sy) <- checkEvidence sc e' conclProp n <- freshNonce globalNonceGenerator end <- getCurrentTime thm <- (if recordThm then recordTheorem db else return) @@ -1840,8 +1763,7 @@ tacticIntro sc usernm = Tactic \goal -> _ -> fail "intro tactic failed: not a function" - HypFocus _ _ -> fail "TODO: implement intro on hyps" - Unfocused -> fail "intro tactic: focus required" + _ -> fail "intro tactic: conclusion focus required" tacticIntroHyps :: (F.MonadFail m, MonadIO m) => SharedContext -> Integer -> Tactic m () @@ -1882,26 +1804,6 @@ tacticRevertHyp sc i = Tactic \goal -> _ -> fail "goal_revert_hyp: conclusion focus required" -{- --- | Attempt to prove an implication goal by introducing a local assumption for --- hypothesis. Return a @Theorem@ representing this local assumption. --- This hypothesis should only be used for proving subgoals arising --- from this call to @tacticAssume@ or evidence verification will later fail. -tacticAssume :: (F.MonadFail m, MonadIO m) => SharedContext -> Pos -> Tactic m Theorem -tacticAssume _sc loc = Tactic \goal -> - case asPi (unProp (goalProp goal)) of - Just (_nm, tp, body) - | looseVars body == emptyBitSet -> - do let goal' = goal{ goalProp = Prop body } - let p = Prop tp - n <- liftIO (freshNonce globalNonceGenerator) - let thm' = LocalAssumption p loc n - return (thm', mempty, [goal'], assumeEvidence n p) - - _ -> fail "assume tactic failed: not a function, or a dependent function" - --} - -- | Attempt to prove a goal by applying the given theorem. Any hypotheses of -- the theorem will generate additional subgoals. tacticApply :: (F.MonadFail m, MonadIO m) => SharedContext -> Theorem -> Tactic m () From 09b0edb700cc2d90144a26cf89e2beae72900428 Mon Sep 17 00:00:00 2001 From: Robert Dockins Date: Sat, 13 Aug 2022 13:16:53 -0700 Subject: [PATCH 16/35] Allow arrow types (nondependent Pi) to participate in sequent normalization. --- src/SAWScript/Proof.hs | 22 ++++++++++++++++------ 1 file changed, 16 insertions(+), 6 deletions(-) diff --git a/src/SAWScript/Proof.hs b/src/SAWScript/Proof.hs index c7e234ee43..effa68fb3b 100644 --- a/src/SAWScript/Proof.hs +++ b/src/SAWScript/Proof.hs @@ -284,12 +284,12 @@ splitImpl sc (Prop p) c' <- scEqTrue sc c return (Just (Prop h', Prop c')) -{- TODO? sequent normalization doesn't decompose arrows... - - | Just (_nm, h, c ) <- asPi p + -- Handle the case of (H1 -> H2), where H1 and H2 are in Prop + | Just (_nm, arg, c) <- asPi p , looseVars c == emptyBitSet - = return (Just (Prop h, Prop c)) --} + = termToMaybeProp sc arg >>= \case + Nothing -> return Nothing + Just h -> return (Just (h, Prop c)) | otherwise = return Nothing @@ -1241,7 +1241,17 @@ normalizeGoal sc p = Just b -> normalizeGoalBool sc b >>= \case Just sqt -> return sqt Nothing -> return (RawSequent [] [p]) - _ -> return (RawSequent [] [p]) + _ -> + -- handle the case of (H1 -> H2), where H1 and H2 are in Prop + case asPi t of + Just (_nm, arg, body) | looseVars body == emptyBitSet -> + termToMaybeProp sc arg >>= \case + Nothing -> return (RawSequent [] [p]) + Just h -> + do hsqt <- normalizeHyp sc h + gsqt <- normalizeGoal sc (Prop body) + return (joinSequent hsqt gsqt) + _ -> return (RawSequent [] [p]) normalizeHypBool :: SharedContext -> Term -> IO (Maybe (RawSequent Prop)) normalizeHypBool sc b = From b66cca95bc0b5d4c96ffabc3cd36ec3225c15af3 Mon Sep 17 00:00:00 2001 From: Robert Dockins Date: Sat, 13 Aug 2022 17:33:32 -0700 Subject: [PATCH 17/35] Add some additional tactics to assist proving inductive facts. Reimplement `goal_insert` based on cut. This tactic was removed in an earlier phase, but here we can add it back fairly easily. Add the ability to apply local hypotheses in addition to theorems, via `goal_apply_hyp`. Add the ability to specialize a local hypothesis via `goal_specialize_hyp`. This is especially useful for specializing an inductive hypothesis in the (unfortunatly common) case where solvers cannot figure out the correct instantiations. The `split_goal` tactic now works on hypotheses that represent SAWCore implications (i.e., nondependent functions between Props), which provides the standard modus ponens rule. --- src/SAWScript/Builtins.hs | 22 +++---- src/SAWScript/Interpreter.hs | 21 ++++--- src/SAWScript/Proof.hs | 119 +++++++++++++++++++++++++++++++---- 3 files changed, 131 insertions(+), 31 deletions(-) diff --git a/src/SAWScript/Builtins.hs b/src/SAWScript/Builtins.hs index ec83aa1ccb..a0543c255a 100644 --- a/src/SAWScript/Builtins.hs +++ b/src/SAWScript/Builtins.hs @@ -838,25 +838,25 @@ goal_revert_hyp i = do sc <- SV.scriptTopLevel getSharedContext execTactic (tacticRevertHyp sc i) -{- -goal_assume :: ProofScript Theorem -goal_assume = - do sc <- SV.scriptTopLevel getSharedContext - pos <- SV.scriptTopLevel SV.getPosition - execTactic (tacticAssume sc pos) --} - goal_intro :: Text -> ProofScript TypedTerm goal_intro s = do sc <- SV.scriptTopLevel getSharedContext execTactic (tacticIntro sc s) -{- goal_insert :: Theorem -> ProofScript () goal_insert thm = do sc <- SV.scriptTopLevel getSharedContext - execTactic (tacticCut sc thm) --} + execTactic (tacticInsert sc thm) + +goal_specialize_hyp :: [TypedTerm] -> ProofScript () +goal_specialize_hyp ts = + do sc <- SV.scriptTopLevel getSharedContext + execTactic (tacticSpecializeHyp sc (map ttTerm ts)) + +goal_apply_hyp :: Integer -> ProofScript () +goal_apply_hyp n = + do sc <- SV.scriptTopLevel getSharedContext + execTactic (tacticApplyHyp sc n) goal_num_when :: Int -> ProofScript () -> ProofScript () goal_num_when n script = diff --git a/src/SAWScript/Interpreter.hs b/src/SAWScript/Interpreter.hs index fbc0cff2e0..07209d6488 100644 --- a/src/SAWScript/Interpreter.hs +++ b/src/SAWScript/Interpreter.hs @@ -1706,19 +1706,24 @@ primitives = Map.fromList Experimental [ "TODO "] -{- - , prim "goal_assume" "ProofScript Theorem" - (pureVal goal_assume) - Experimental - [ "Convert the first hypothesis in the current proof goal into a" - , "local Theorem." - ] , prim "goal_insert" "Theorem -> ProofScript ()" (pureVal goal_insert) Experimental [ "Insert a Theorem as a new hypothesis in the current proof goal." ] --} + + , prim "goal_apply_hyp" "Int -> ProofScript ()" + (pureVal goal_apply_hyp) + Experimental + [ "Apply the numbered local hypothesis to the focused conclusion." ] + + , prim "goal_specialize_hyp" "[Term] -> ProofScript ()" + (pureVal goal_specialize_hyp) + Experimental + [ "Specialize the focused local hypothesis by supplying the values" + , "for universal quantifiers. A new specialized hypothesis will be" + , "added to the sequent." + ] , prim "goal_intro" "String -> ProofScript Term" (pureVal goal_intro) diff --git a/src/SAWScript/Proof.hs b/src/SAWScript/Proof.hs index effa68fb3b..e6c8bf8d7e 100644 --- a/src/SAWScript/Proof.hs +++ b/src/SAWScript/Proof.hs @@ -92,6 +92,7 @@ module SAWScript.Proof , withFirstGoal , tacticIntro , tacticApply + , tacticApplyHyp , tacticSplit , tacticCut , tacticTrivial @@ -101,6 +102,8 @@ module SAWScript.Proof , tacticExact , tacticIntroHyps , tacticRevertHyp + , tacticInsert + , tacticSpecializeHyp , Quantification(..) , predicateToProp @@ -324,7 +327,13 @@ splitSequent sc sqt = return (Just ( HypFocusedSequent (FB hs1 x (hs2 ++ [b])) gs , HypFocusedSequent (FB hs1 y (hs2 ++ [nb])) gs )) - Nothing -> return Nothing + Nothing -> + splitImpl sc h >>= \case + Just (x, y) -> + return (Just ( HypFocusedSequent (FB hs1 y hs2) gs + , GoalFocusedSequent (hs1 ++ [h] ++ hs2) (FB gs x []) + )) + Nothing -> return Nothing UnfocusedSequent _ _ -> fail "split tactic: focus required" @@ -857,11 +866,13 @@ data Evidence -- 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 - -- evidence must match the conclusion of the goal. The proposition is - -- allowed to appear inside the evidence as a local assumption. --- | AssumeEvidence TheoremNonce Prop Evidence + -- | This type of evidence is produced when a local hypothesis is applied + -- via backward reasoning to prove a goal. Pi-quantified variables + -- of the hypothesis 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. + | ApplyHypEvidence Integer ![Either Term Evidence] -- | This type of evidence is used to prove a universally-quantified statement. | IntroEvidence !(ExtCns Term) !Evidence @@ -971,6 +982,14 @@ cutEvidence :: Prop -> [Evidence] -> IO Evidence cutEvidence p [e1,e2] = pure (CutEvidence p e1 e2) cutEvidence _ _ = fail "cutEvidence: expected two evidence values" +insertEvidence :: Theorem -> [Evidence] -> IO Evidence +insertEvidence thm [e] = pure (CutEvidence (_thmProp thm) e (ApplyEvidence thm [])) +insertEvidence _ _ = fail "insertEvidence: expected one evidence value" + +specializeHypEvidence :: Integer -> Prop -> [Term] -> [Evidence] -> IO Evidence +specializeHypEvidence n h ts [e] = pure (CutEvidence h e (ApplyHypEvidence n (map Left ts))) +specializeHypEvidence _ _ _ _ = fail "specializeHypEvidence: expected one evidence value" + structuralEvidence :: Sequent -> Evidence -> Evidence structuralEvidence _sqt (StructuralEvidence sqt' e) = StructuralEvidence sqt' e structuralEvidence sqt e = StructuralEvidence sqt e @@ -1033,16 +1052,17 @@ constructTheorem sc db p e loc ploc rsn elapsed = -- 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 [] +specializeTheorem sc db loc rsn thm ts = + do res <- specializeProp sc (_thmProp thm) ts 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 + constructTheorem sc db p' (ApplyEvidence thm (map Left ts)) loc Nothing rsn 0 +specializeProp :: SharedContext -> Prop -> [Term] -> IO (Either TC.TCError Prop) +specializeProp sc (Prop p0) ts0 = TC.runTCM (loop p0 ts0) sc Nothing [] where - loop p [] = return p + loop p [] = return (Prop p) loop p (t:ts) = do prop <- liftIO (scSort sc propSort) t' <- TC.typeInferComplete t @@ -1388,6 +1408,29 @@ checkEvidence sc = \e p -> do nenv <- scGetNamingEnv sc d2 <- check nenv e2 sqt2 return (d1 <> d2) + ApplyHypEvidence n es -> + case sqt of + GoalFocusedSequent hs (FB gs1 g gs2) -> + case genericDrop n hs of + (h:_) -> + do (d,sy,p') <- checkApply nenv (\g' -> GoalFocusedSequent hs (FB gs1 g' gs2)) h es + ok <- scConvertible sc False (unProp g) p' + unless ok $ fail $ unlines + [ "Apply evidence does not match the required proposition" + , showTerm (unProp g) + , showTerm p' + ] + return (d, sy) + + _ -> fail $ unlines $ + [ "Not enough hypotheses in apply hypothesis: " ++ show n + , prettySequent defaultPPOpts nenv sqt + ] + _ -> fail $ unlines $ + [ "Apply hypothesis evidence requires a goal-focused sequent." + , prettySequent defaultPPOpts nenv sqt + ] + ApplyEvidence thm es -> case sequentState sqt of GoalFocus p mkSqt -> @@ -1532,7 +1575,7 @@ finishProof sc db conclProp ps@(ProofState gs (concl,loc,ploc,rsn) stats _ check (deps,sy) <- checkEvidence sc e' conclProp n <- freshNonce globalNonceGenerator end <- getCurrentTime - thm <- (if recordThm then recordTheorem db else return) + thm <- (if recordThm then recordTheorem db else return) Theorem { _thmProp = conclProp , _thmStats = stats @@ -1814,6 +1857,37 @@ tacticRevertHyp sc i = Tactic \goal -> _ -> fail "goal_revert_hyp: conclusion focus required" +-- | Attempt to prove a goal by applying a local hypothesis. Any hypotheses of +-- the applied proposition will generate additional subgoals. +tacticApplyHyp :: (F.MonadFail m, MonadIO m) => SharedContext -> Integer -> Tactic m () +tacticApplyHyp sc n = Tactic \goal -> + case goalSequent goal of + UnfocusedSequent{} -> fail "apply hyp tactic: focus required" + HypFocusedSequent{} -> fail "apply hyp tactic: cannot apply in a hypothesis" + GoalFocusedSequent hs (FB gs1 g gs2) -> + case genericDrop n hs of + (h:_) -> + liftIO (goalApply sc h g) >>= \case + Nothing -> fail "apply hyp tactic: no match" + Just newterms -> + let newgoals = + [ goal{ goalSequent = GoalFocusedSequent hs (FB gs1 p gs2) + , goalType = goalType goal ++ ".subgoal" ++ show i + } + | Right p <- newterms + | i <- [0::Integer ] + ] in + return ((), mempty, newgoals, \es -> ApplyHypEvidence n <$> processEvidence newterms es) + _ -> fail "apply hyp tactic: not enough hypotheses" + + 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 hyp tactic failed: evidence mismatch" + + -- | Attempt to prove a goal by applying the given theorem. Any hypotheses of -- the theorem will generate additional subgoals. tacticApply :: (F.MonadFail m, MonadIO m) => SharedContext -> Theorem -> Tactic m () @@ -1851,6 +1925,27 @@ tacticSplit sc = Tactic \gl -> Nothing -> fail "split tactic failed" +tacticSpecializeHyp :: + (F.MonadFail m, MonadIO m) => SharedContext -> [Term] -> Tactic m () +tacticSpecializeHyp sc ts = Tactic \gl -> + case goalSequent gl of + HypFocusedSequent (FB hs1 h hs2) gs -> + do res <- liftIO (specializeProp sc h ts) + case res of + Left err -> + fail (unlines (["specialize_hyp tactic: failed to specialize"] ++ TC.prettyTCError err)) + Right h' -> + do let gl' = gl{ goalSequent = HypFocusedSequent (FB hs1 h (hs2++[h'])) gs } + return ((), mempty, [gl'], specializeHypEvidence (genericLength hs1) h' ts) + _ -> fail "specialize_hyp tactic failed: requires hypothesis focus" + + +tacticInsert :: (F.MonadFail m, MonadIO m) => SharedContext -> Theorem -> Tactic m () +tacticInsert _sc thm = Tactic \gl -> + let sqt = addHypothesis (_thmProp thm) (goalSequent gl) + gl' = gl{ goalSequent = sqt } + in return ((), mempty, [gl'], insertEvidence thm) + tacticCut :: (F.MonadFail m, MonadIO m) => SharedContext -> Prop -> Tactic m () tacticCut _sc p = Tactic \gl -> let sqt1 = addHypothesis p (goalSequent gl) From b34a1e423a0819d526a3410cdd31a968e354b9f4 Mon Sep 17 00:00:00 2001 From: Rob Dockins Date: Tue, 9 Aug 2022 00:00:04 -0700 Subject: [PATCH 18/35] Add some direct SAWCore proofs of facts leading to the complete induction principle for natural numbers, and for bitvectors. This adds no additional axioms over those alreay present in the system. --- saw-core/prelude/Prelude.sawcore | 104 ++++++++++++++++++++++++++++++- 1 file changed, 103 insertions(+), 1 deletion(-) diff --git a/saw-core/prelude/Prelude.sawcore b/saw-core/prelude/Prelude.sawcore index 0751d2846a..9d697af083 100644 --- a/saw-core/prelude/Prelude.sawcore +++ b/saw-core/prelude/Prelude.sawcore @@ -797,6 +797,15 @@ data IsLeNat (n:Nat) : Nat -> Prop where { IsLtNat : Nat -> Nat -> Prop; IsLtNat m n = IsLeNat (Succ m) n; +-- | Restate the recursor on IsLeNat +IsLeNat__rec : + (n : Nat) -> + (p : (x : Nat) -> IsLeNat n x -> Prop) -> + (Hbase : p n (IsLeNat_base n)) -> + (Hstep : (x : Nat) -> (H : IsLeNat n x) -> p x H -> p (Succ x) (IsLeNat_succ n x H)) -> + (m : Nat) -> (Hm : IsLeNat n m) -> p m Hm; +IsLeNat__rec n p Hbase Hstep m Hm = IsLeNat#rec n p Hbase Hstep m Hm; + -- | Test if m < n or n <= m -- FIXME: implement this! primitive natCompareLe : (m n : Nat) -> Either (IsLtNat m n) (IsLeNat n m); @@ -936,6 +945,77 @@ if0Nat a n x y = natCase (\ (_:Nat) -> a) x (\ (_:Nat) -> y) n; -- and the number of times to multiply. primitive expByNat : (a:sort 0) -> a -> (a -> a -> a) -> a -> Nat -> a; + +-- | LeNat is transitive +IsLeNat_transitive : + (n m o:Nat) -> + IsLeNat n m -> + IsLeNat m o -> + IsLeNat n o; +IsLeNat_transitive n m o Hnm Hmo = + IsLeNat__rec m + (\ (x:Nat) -> \(H:IsLeNat m x) -> IsLeNat n x) + Hnm + (\ (x:Nat) -> \ (H1:IsLeNat m x) -> \ (H2:IsLeNat n x) -> IsLeNat_succ n x H2) + o Hmo; + +-- No Nat is strictly less than zero +IsLtNat_Zero_absurd : + (p:Prop) -> + (m:Nat) -> + IsLtNat m Zero -> + p; +IsLtNat_Zero_absurd p m HSmZ = + IsLeNat__rec (Succ m) + ( \ (x : Nat) -> \ (H:IsLeNat (Succ m) x) -> if0Nat Prop x p TrueProp) + TrueI + ( \ (x : Nat) -> \ (H1:IsLeNat (Succ m) x) -> \ (H2 : if0Nat Prop x p TrueProp) -> TrueI) + Zero HSmZ; + +IsLeNat_SuccSucc : + (n m:Nat) -> + IsLeNat (Succ n) (Succ m) -> + IsLeNat n m; +IsLeNat_SuccSucc n m HSS = + IsLeNat__rec (Succ n) + ( \ (x : Nat) -> \ (H:IsLeNat (Succ n) x) -> IsLeNat n (pred x)) + (IsLeNat_base n) + (Nat__rec + ( \ (x : Nat) -> IsLeNat (Succ n) x -> IsLeNat n (pred x) -> IsLeNat n x) + ( \ (H1 : IsLeNat (Succ n) Zero) -> \ (H2 : IsLeNat n (pred Zero)) -> H2) + ( \ (x : Nat) -> + \ (Hind : IsLeNat (Succ n) x -> IsLeNat n (pred x) -> IsLeNat n x) -> + \ (H1 : IsLeNat (Succ n) (Succ x)) -> + \ (H2 : IsLeNat n (pred (Succ x))) -> + IsLeNat_succ n x H2) + ) + (Succ m) HSS; + +-- | The complete induction principle on natural numbers +Nat_complete_induction : + (p : Nat -> Prop) -> + ((n : Nat) -> ((m : Nat) -> IsLtNat m n -> p m) -> p n) -> + (n : Nat) -> p n; + +Nat_complete_induction p f n0 = + Nat__rec ( \ (n:Nat) -> (m:Nat) -> IsLeNat m n -> p m) + (\ (n:Nat) -> + \ (Hn:IsLeNat n 0) -> + f n (\ (m:Nat) -> \ (Hm : IsLeNat (Succ m) n) -> + IsLtNat_Zero_absurd (p m) m (IsLeNat_transitive (Succ m) n 0 Hm Hn)) + ) + (\ (n:Nat) -> + \ (Hind : (m:Nat) -> IsLeNat m n -> p m) -> + \ (r:Nat) -> + \ (Hr:IsLeNat r (Succ n)) -> + f r (\ (m:Nat) -> \ (Hm: IsLeNat (Succ m) r) -> + Hind m (IsLeNat_SuccSucc m n (IsLeNat_transitive (Succ m) r (Succ n) Hm Hr))) + ) + n0 n0 (IsLeNat_base n0); + + + + -------------------------------------------------------------------------------- -- Operations on string values @@ -1764,7 +1844,6 @@ primitive updSliceWithProof : (a : sort 0) -> (n off len : Nat) -> IsLeNat (addNat off len) n -> Vec n a -> Vec len a -> Vec n a; - -------------------------------------------------------------------------------- -- Vectors indexed by bitvectors @@ -1947,6 +2026,29 @@ appendBVVec n len1 len2 a v1 v2 = (Refl Bool (bvult n i len1))); +-- | The complete induction principle on bitvectors +BV_complete_induction : + (w: Nat) -> + (p: Vec w Bool -> Prop) -> + ((x : Vec w Bool) -> ((y: Vec w Bool) -> is_bvult w y x -> p y) -> p x) -> + (x : Vec w Bool) -> p x; +BV_complete_induction w p f x0 = + Nat_complete_induction + (\ (n:Nat) -> (x:Vec w Bool) -> IsLeNat (bvToNat w x) n -> p x) + (\ (n:Nat) -> + \ (Hind : (m : Nat) -> (Hm : IsLtNat m n) -> (y : Vec w Bool) -> + (Hy : IsLeNat (bvToNat w y) m) -> p y) -> + \ (x : Vec w Bool) -> + \ (Hx : IsLeNat (bvToNat w x) n) -> + f x (\ (y:Vec w Bool) -> \ (Hult : is_bvult w y x) -> + Hind (bvToNat w y) + (IsLeNat_transitive (Succ (bvToNat w y)) (bvToNat w x) n (bvultToIsLtNat w y x Hult) Hx) + y (IsLeNat_base (bvToNat w y)) + ) + ) + (bvToNat w x0) x0 (IsLeNat_base (bvToNat w x0)); + + -------------------------------------------------------------------------------- -- Iso-recursive types From 09b764217dedab5d6bd886edbc1e2f7450210383 Mon Sep 17 00:00:00 2001 From: Rob Dockins Date: Thu, 11 Aug 2022 23:02:57 -0700 Subject: [PATCH 19/35] Add the `prove_by_bv_induction` command for proving facts by induction on bitvector values. --- src/SAWScript/Builtins.hs | 165 +++++++++++++++++++++++++++++++++-- src/SAWScript/Interpreter.hs | 7 ++ 2 files changed, 167 insertions(+), 5 deletions(-) diff --git a/src/SAWScript/Builtins.hs b/src/SAWScript/Builtins.hs index a0543c255a..3e8ee86ff2 100644 --- a/src/SAWScript/Builtins.hs +++ b/src/SAWScript/Builtins.hs @@ -1164,11 +1164,11 @@ provePrim script t = do proveHelper :: String -> ProofScript () -> - TypedTerm -> + Term -> (Term -> TopLevel Prop) -> TopLevel Theorem proveHelper nm script t f = do - prop <- f $ ttTerm t + prop <- f t pos <- SV.getPosition let goal = ProofGoal { goalNum = 0 @@ -1186,18 +1186,173 @@ proveHelper nm script t f = do ++ SV.showsProofResult opts res "" case res of ValidProof _stats thm -> - do printOutLnTop Debug $ "Valid: " ++ show (ppTerm (SV.sawPPOpts opts) $ ttTerm t) + do printOutLnTop Debug $ "Valid: " ++ show (ppTerm (SV.sawPPOpts opts) $ t) SV.returnProof thm InvalidProof _stats _cex pst -> failProof pst UnfinishedProof pst -> failProof pst +proveByBVInduction :: + ProofScript () -> + TypedTerm -> + TopLevel Theorem +proveByBVInduction script t = + do sc <- getSharedContext + opts <- rwPPOpts <$> getTopLevelRW + ty <- io $ scTypeCheckError sc (ttTerm t) + io (checkInductionScheme sc opts [] ty) >>= \case + Nothing -> badTy opts ty + Just ([],_) -> badTy opts ty + Just (pis,w) -> + + -- This is a whole bunch of gross SAWCore manipulation to build a custom + -- induction principle for the user-given theorem statement. + -- I don't know offhand of a less gross way to do this. + + do wt <- io $ scNat sc w + natty <- io $ scNatType sc + toNat <- io $ scGlobalDef sc "Prelude.bvToNat" + thmResult <- io $ + do vars <- reverse <$> mapM (scLocalVar sc) [ 0 .. length pis - 1] + t1 <- scApplyAllBeta sc (ttTerm t) vars + t2 <- scEqTrue sc =<< scTupleSelector sc t1 2 2 -- rightmost tuple element + t3 <- scPiList sc pis t2 + _ <- scTypeCheckError sc t3 -- sanity check + return t3 + + thmHyp <- io $ + do vars <- reverse <$> mapM (scLocalVar sc) [ 0 .. length pis - 1] + t1 <- scApplyAllBeta sc (ttTerm t) vars + tsz <- scTupleSelector sc t1 1 2 -- left element + tbody <- scEqTrue sc =<< scTupleSelector sc t1 2 2 -- rightmost tuple element + tsz_shft <- incVars sc 0 (length pis) tsz + + bvult <- scGlobalDef sc "Prelude.bvult" + islt <- scEqTrue sc =<< scApplyAll sc bvult [wt, tsz, tsz_shft] + + tinner <- scPi sc "_" islt =<< incVars sc 0 1 tbody + thyp <- scPiList sc [ ("i_" <> nm, z) | (nm,z) <- pis ] tinner + + touter <- scPi sc "_" thyp =<< incVars sc 0 1 tbody + scPiList sc pis touter + + indMotive <- io $ + do vars <- reverse <$> mapM (scLocalVar sc) [ 0 .. length pis-1 ] + indVar <- scLocalVar sc (length pis) + t1 <- scApplyAllBeta sc (ttTerm t) vars + tsz <- scTupleSelector sc t1 1 2 -- left element + tsz' <- scApplyAll sc toNat [wt, tsz] + teq <- scDataTypeApp sc "Prelude.IsLeNat" [tsz', indVar] + tbody <- scEqTrue sc =<< scTupleSelector sc t1 2 2 -- right element + t2 <- scPi sc "_" teq =<< incVars sc 0 1 tbody + t3 <- scPiList sc pis t2 + scLambda sc "inductionVar" natty t3 + + indHyp <- io $ + do var0 <- scLocalVar sc 0 + var1 <- scLocalVar sc 1 + lt <- scGlobalApply sc "Prelude.IsLtNat" [var0, var1] + inner <- scPi sc "m" natty =<< scPi sc "_" lt =<< scApplyBeta sc indMotive var1 + scPi sc "n" natty =<< scPi sc "_" inner =<< scApplyBeta sc indMotive var1 + + indHypProof <- io $ -- scFreshGlobal sc "H" =<< scPi sc "_" thmHyp indHyp + do hEC <- scFreshEC sc "H" thmHyp + hVar <- scExtCns sc hEC + nEC <- scFreshEC sc "n" natty + nVar <- scExtCns sc nEC + hindEC <- scFreshEC sc "Hind" =<< + do var0 <- scLocalVar sc 0 + var1 <- scLocalVar sc 1 + lt <- scGlobalApply sc "Prelude.IsLtNat" [var0, nVar] + scPi sc "m" natty =<< scPi sc "_" lt =<< scApplyBeta sc indMotive var1 + hindVar <- scExtCns sc hindEC + varECs <- mapM (uncurry (scFreshEC sc)) pis + vars <- mapM (scExtCns sc) varECs + + innerVarECs <- mapM (uncurry (scFreshEC sc)) [ ("i_" <> nm, z) | (nm,z) <- pis ] + innerVars <- mapM (scExtCns sc) innerVarECs + + outersz <- do t1 <- scApplyAllBeta sc (ttTerm t) vars + scTupleSelector sc t1 1 2 -- left element + natoutersz <- scApplyAll sc toNat [wt, outersz] + + innersz <- do t1 <- scApplyAllBeta sc (ttTerm t) innerVars + scTupleSelector sc t1 1 2 -- left element + natinnersz <- scApplyAll sc toNat [wt, innersz] + + succinnersz <- scCtorApp sc "Prelude.Succ" [natinnersz] + + bvltEC <- scFreshEC sc "Hult" =<< scEqTrue sc =<< scBvULt sc wt innersz outersz + bvltVar <- scExtCns sc bvltEC + + leEC <- scFreshEC sc "Hle" =<< + scDataTypeApp sc "Prelude.IsLeNat" [natoutersz, nVar] + leVar <- scExtCns sc leEC + + refl_inner <- scCtorApp sc "Prelude.IsLeNat_base" [natinnersz] + + prf <- do hyx <- scGlobalApply sc "Prelude.bvultToIsLtNat" [wt,innersz,outersz,bvltVar] + scGlobalApply sc "Prelude.IsLeNat_transitive" [succinnersz, natoutersz, nVar, hyx, leVar] + inner <- do body <- scApplyAll sc hindVar ([natinnersz,prf]++innerVars++[refl_inner]) + scAbstractExts sc (innerVarECs ++ [bvltEC]) body + + body <- scApplyAll sc hVar (vars ++ [inner]) + + scAbstractExts sc ([hEC, nEC, hindEC] ++ varECs ++ [leEC]) body + + indApp <- io $ + do vars <- reverse <$> mapM (scLocalVar sc) [ 0 .. length pis-1 ] + varH <- scLocalVar sc (length pis) + t1 <- scApplyAllBeta sc (ttTerm t) vars + tsz <- scTupleSelector sc t1 1 2 -- left element + tsz' <- scApplyAll sc toNat [wt, tsz] + trefl <- scCtorApp sc "Prelude.IsLeNat_base" [tsz'] + indHypArg <- scApplyBeta sc indHypProof varH + ind <- scGlobalApply sc "Prelude.Nat_complete_induction" ([indMotive,indHypArg,tsz'] ++ vars ++ [trefl]) + ind' <- scLambdaList sc pis ind + ind'' <- scLambda sc "Hind" thmHyp ind' + + _tp <- scTypeCheckError sc ind'' -- sanity check + return ind'' + + indAppTT <- io $ mkTypedTerm sc indApp + + ind_scheme_goal <- io $ scFun sc thmHyp thmResult + ind_scheme_theorem <- proveHelper "bv_induction_scheme" (goal_exact indAppTT) ind_scheme_goal (io . termToProp sc) + let script' = goal_apply ind_scheme_theorem >> script + proveHelper "prove_by_bv_induction" script' thmResult (io . termToProp sc) + + where + checkInductionScheme sc opts pis ty = + do ty' <- scWhnf sc ty + case asPi ty' of + Just (nm,tp,body) -> checkInductionScheme sc opts ((nm,tp):pis) body + Nothing -> + case asTupleType ty' of + Just [bv, bool] -> + do bool' <- scWhnf sc bool + bv' <- scWhnf sc bv + case (asVectorType bv', asBoolType bool') of + (Just (w,vbool), Just ()) -> + do w' <- scWhnf sc w + vbool' <- scWhnf sc vbool + case (asNat w', asBoolType vbool') of + (Just n, Just ()) -> return (Just (reverse pis, n)) + _ -> return Nothing + _ -> return Nothing + _ -> return Nothing + + badTy opts ty = + fail $ unlines [ "Incorrect type for proof by induction" + , show (ppTerm (SV.sawPPOpts opts) ty) + ] + provePrintPrim :: ProofScript () -> TypedTerm -> TopLevel Theorem provePrintPrim script t = do sc <- getSharedContext - proveHelper "prove_print" script t $ io . predicateToProp sc Universal + proveHelper "prove_print" script (ttTerm t) $ io . predicateToProp sc Universal provePropPrim :: ProofScript () -> @@ -1205,7 +1360,7 @@ provePropPrim :: TopLevel Theorem provePropPrim script t = do sc <- getSharedContext - proveHelper "prove_extcore" script t $ io . termToProp sc + proveHelper "prove_extcore" script (ttTerm t) $ io . termToProp sc satPrim :: ProofScript () -> diff --git a/src/SAWScript/Interpreter.hs b/src/SAWScript/Interpreter.hs index 07209d6488..fee5a2d16d 100644 --- a/src/SAWScript/Interpreter.hs +++ b/src/SAWScript/Interpreter.hs @@ -1527,6 +1527,13 @@ primitives = Map.fromList , "if unsuccessful." ] + , prim "prove_by_bv_induction" "ProofScript () -> Term -> TopLevel Theorem" + (pureVal proveByBVInduction) + Experimental + [ "TODO, real docs. Attempt to prove a fact by induction on the less-than" + , "order on bitvectors." + ] + , prim "prove_extcore" "ProofScript () -> Term -> TopLevel Theorem" (pureVal provePropPrim) Current From 3e2e449a2a1b2454bac1432a80f91ddde498abfa Mon Sep 17 00:00:00 2001 From: Rob Dockins Date: Fri, 12 Aug 2022 09:25:01 -0700 Subject: [PATCH 20/35] Add infrastructure to allow universally-quantified assertions to be passed to solvers. --- .../src/Verifier/SAW/Simulator/SBV.hs | 3 +- .../src/Verifier/SAW/Simulator/What4.hs | 98 +++++++++++++++++-- saw-core/src/Verifier/SAW/SATQuery.hs | 28 ++++-- src/SAWScript/Builtins.hs | 7 -- src/SAWScript/Proof.hs | 76 ++++++++------ src/SAWScript/Prover/Exporter.hs | 8 +- src/SAWScript/Prover/What4.hs | 21 ++-- 7 files changed, 177 insertions(+), 64 deletions(-) diff --git a/saw-core-sbv/src/Verifier/SAW/Simulator/SBV.hs b/saw-core-sbv/src/Verifier/SAW/Simulator/SBV.hs index db209362ca..9dc2bcb09b 100644 --- a/saw-core-sbv/src/Verifier/SAW/Simulator/SBV.hs +++ b/saw-core-sbv/src/Verifier/SAW/Simulator/SBV.hs @@ -664,8 +664,7 @@ mkUninterpreted k args nm = svUninterpreted k nm' Nothing args sbvSATQuery :: SharedContext -> Map Ident SPrim -> SATQuery -> IO ([Labeler], [ExtCns Term], Symbolic SBool) sbvSATQuery sc addlPrims query = - do true <- liftIO (scBool sc True) - t <- liftIO (foldM (scAnd sc) true (satAsserts query)) + do t <- liftIO (satQueryAsTerm sc query) let qvars = Map.toList (satVariables query) let unintSet = satUninterp query let ecVars (ec, fot) = newVars (Text.unpack (toShortName (ecName ec))) fot diff --git a/saw-core-what4/src/Verifier/SAW/Simulator/What4.hs b/saw-core-what4/src/Verifier/SAW/Simulator/What4.hs index f106645b9e..c6405a6c23 100644 --- a/saw-core-what4/src/Verifier/SAW/Simulator/What4.hs +++ b/saw-core-what4/src/Verifier/SAW/Simulator/What4.hs @@ -96,7 +96,7 @@ import Verifier.SAW.TypedAST (FieldName, ModuleMap, toShortName, ctorPrimName, i import qualified What4.Expr.Builder as B import What4.Expr.GroundEval import What4.Interface(SymExpr,Pred,SymInteger, IsExpr, - IsExprBuilder,IsSymExprBuilder) + IsExprBuilder,IsSymExprBuilder, BoundVar) import qualified What4.Interface as W import What4.BaseTypes import qualified What4.SWord as SW @@ -983,17 +983,101 @@ w4Solve :: forall sym. sym -> SharedContext -> SATQuery -> - IO ([(ExtCns Term, (Labeler sym, SValue sym))], SBool sym) + IO ([(ExtCns Term, (Labeler sym, SValue sym))], [SBool sym]) w4Solve sym sc satq = - do t <- satQueryAsTerm sc satq - let varList = Map.toList (satVariables satq) + do let varList = Map.toList (satVariables satq) vars <- evalStateT (traverse (traverse (newVarFOT sym)) varList) 0 let varMap = Map.fromList [ (ecVarIndex ec, v) | (ec, (_,v)) <- vars ] ref <- newIORef Map.empty - bval <- w4SolveBasic sym sc mempty varMap ref (satUninterp satq) t + + bvals <- mapM (w4SolveAssert sym sc varMap ref (satUninterp satq)) (satAsserts satq) + return (vars, bvals) + + +w4SolveAssert :: forall sym. + IsSymExprBuilder sym => + sym -> + SharedContext -> + Map VarIndex (SValue sym) {- ^ bindings for ExtCns values -} -> + IORef (SymFnCache sym) {- ^ cache for uninterpreted function symbols -} -> + Set VarIndex {- ^ variables to hold uninterpreted -} -> + SATAssert -> + IO (SBool sym) +w4SolveAssert sym sc varMap ref uninterp (BoolAssert x) = + do bval <- w4SolveBasic sym sc mempty varMap ref uninterp x + case bval of + VBool v -> return v + _ -> fail $ "w4SolveAssert: non-boolean result type. " ++ show bval + +w4SolveAssert sym sc varMap ref uninterp (UniversalAssert vars hyps concl) = + do g <- case hyps of + [] -> return concl + _ -> do h <- scAndList sc hyps + scImplies sc h concl + (svals,bndvars) <- boundFOTs sym vars + let varMap' = foldl (\m ((ec,_fot), sval) -> Map.insert (ecVarIndex ec) sval m) + varMap + (zip vars svals) + bval <- w4SolveBasic sym sc mempty varMap' ref uninterp g case bval of - VBool v -> return (vars, v) - _ -> fail $ "w4Solve: non-boolean result type. " ++ show bval + VBool v -> + do final <- foldM (\p (Some bndvar) -> W.forallPred sym bndvar p) v bndvars + return final + + _ -> fail $ "w4SolveAssert: non-boolean result type. " ++ show bval + +boundFOTs :: forall sym. + IsSymExprBuilder sym => + sym -> + [(ExtCns Term, FirstOrderType)] -> + IO ([SValue sym], [Some (BoundVar sym)]) +boundFOTs sym vars = + do (svals,(bndvars,_)) <- runStateT (mapM (uncurry handleVar) vars) ([], 0) + return (svals, bndvars) + + where + freshBnd :: ExtCns Term -> W.BaseTypeRepr tp -> StateT ([Some (BoundVar sym)],Integer) IO (SymExpr sym tp) + freshBnd ec tpr = + do (vs,n) <- get + let nm = Text.unpack (toShortName (ecName ec)) ++ "." ++ show n + bvar <- lift (W.freshBoundVar sym (W.safeSymbol nm) tpr) + put (Some bvar : vs, n+1) + return (W.varExpr sym bvar) + + handleVar :: ExtCns Term -> FirstOrderType -> StateT ([Some (BoundVar sym)], Integer) IO (SValue sym) + handleVar ec fot = + case fot of + FOTBit -> VBool <$> freshBnd ec BaseBoolRepr + FOTInt -> VInt <$> freshBnd ec BaseIntegerRepr + FOTIntMod m -> VIntMod m <$> freshBnd ec BaseIntegerRepr + FOTVec 0 FOTBit -> return (VWord ZBV) + FOTVec n FOTBit + | Just (Some (PosNat nr)) <- somePosNat n -> + VWord . DBV <$> freshBnd ec (BaseBVRepr nr) + + FOTVec n tp -> -- NB, not Bit + do vs <- V.replicateM (fromIntegral n) (handleVar ec tp) + vs' <- traverse (return . ready) vs + return (VVector vs') + + FOTRec tm -> + do vs <- traverse (handleVar ec) tm + vs' <- traverse (return . ready) vs + return (vRecord vs') + + FOTTuple ts -> + do vs <- traverse (handleVar ec) ts + vs' <- traverse (return . ready) vs + return (vTuple vs') + + FOTArray idx res + | Just (Some idx_repr) <- fotToBaseType idx + , Just (Some res_repr) <- fotToBaseType res + + -> VArray . SArray <$> freshBnd ec (BaseArrayRepr (Ctx.Empty Ctx.:> idx_repr) res_repr) + + _ -> fail ("boundFOTs: cannot handle " ++ show fot) + -- -- Pull out argument types until bottoming out at a non-Pi type diff --git a/saw-core/src/Verifier/SAW/SATQuery.hs b/saw-core/src/Verifier/SAW/SATQuery.hs index dea328a621..66153f8bf5 100644 --- a/saw-core/src/Verifier/SAW/SATQuery.hs +++ b/saw-core/src/Verifier/SAW/SATQuery.hs @@ -1,10 +1,10 @@ module Verifier.SAW.SATQuery ( SATQuery(..) , SATResult(..) +, SATAssert(..) , satQueryAsTerm ) where -import Control.Monad (foldM) import Data.Map (Map) import Data.Set (Set) @@ -42,13 +42,19 @@ data SATQuery = -- the solver. Models will not report values -- for uninterpreted values. - , satAsserts :: [Term] + , satAsserts :: [SATAssert] -- ^ A collection of assertions. These should -- all be terms of type @Bool@. The overall -- query should be understood as the conjunction -- of these terms. } --- TODO, allow first-order propositions in addition to Boolean terms. + +data SATAssert + = BoolAssert Term -- ^ A boolean term to be asserted + | UniversalAssert [(ExtCns Term, FirstOrderType)] [Term] Term + -- ^ A univesally-quantified assertion, consisting of a + -- collection of first-order variables, a sequence + -- of boolean hypotheses, and a boolean conclusion -- | The result of a sat query. In the event a model is found, -- return a mapping from the @ExtCns@ variables to values. @@ -59,10 +65,20 @@ data SATResult -- | Compute the conjunction of all the assertions -- in this SAT query as a single term of type Bool. +-- +-- This method of reducing a sat query to a boolean +-- cannot be used for univerally-quantified assertions. satQueryAsTerm :: SharedContext -> SATQuery -> IO Term satQueryAsTerm sc satq = case satAsserts satq of [] -> scBool sc True - (x:xs) -> foldM (scAnd sc) x xs --- TODO, we may have to rethink this function --- once we allow first-order statements. + (BoolAssert x:xs) -> loop x xs + (UniversalAssert{} : _) -> univFail + where + univFail = fail "satQueryAsTerm : Solver backend cannot handle universally-quantifed assertions" + + loop x [] = return x + loop x (BoolAssert y:xs) = + do x' <- scAnd sc x y + loop x' xs + loop _ (UniversalAssert{} : _) = univFail diff --git a/src/SAWScript/Builtins.hs b/src/SAWScript/Builtins.hs index 3e8ee86ff2..35cd764354 100644 --- a/src/SAWScript/Builtins.hs +++ b/src/SAWScript/Builtins.hs @@ -1247,13 +1247,6 @@ proveByBVInduction script t = t3 <- scPiList sc pis t2 scLambda sc "inductionVar" natty t3 - indHyp <- io $ - do var0 <- scLocalVar sc 0 - var1 <- scLocalVar sc 1 - lt <- scGlobalApply sc "Prelude.IsLtNat" [var0, var1] - inner <- scPi sc "m" natty =<< scPi sc "_" lt =<< scApplyBeta sc indMotive var1 - scPi sc "n" natty =<< scPi sc "_" inner =<< scApplyBeta sc indMotive var1 - indHypProof <- io $ -- scFreshGlobal sc "H" =<< scPi sc "_" thmHyp indHyp do hEC <- scFreshEC sc "H" thmHyp hVar <- scExtCns sc hEC diff --git a/src/SAWScript/Proof.hs b/src/SAWScript/Proof.hs index e6c8bf8d7e..361c43ac1c 100644 --- a/src/SAWScript/Proof.hs +++ b/src/SAWScript/Proof.hs @@ -1640,7 +1640,7 @@ predicateToSATQuery sc unintSet tm0 = return SATQuery { satVariables = finalVars , satUninterp = Set.union unintSet abstractVars - , satAsserts = [tm'] + , satAsserts = [BoolAssert tm'] } where evalFOT mmap t = @@ -1689,12 +1689,12 @@ sequentToSATQuery sc unintSet sqt = (initVars, abstractVars) <- filterFirstOrderVars mmap mempty mempty (Set.toList exts) -- NB, the following reversals make the order of assertions more closely match the input sequent, -- but should otherwise not be semantically relevant - hypAsserts <- mapM processHyp (reverse (map unProp hs)) + hypAsserts <- mapM (processAssert mmap) (reverse (map unProp hs)) (finalVars, asserts) <- foldM (processGoal mmap) (initVars, hypAsserts) (map unProp gs) return SATQuery { satVariables = finalVars , satUninterp = Set.union unintSet abstractVars - , satAsserts = reverse asserts + , satAsserts = asserts } where @@ -1707,18 +1707,38 @@ sequentToSATQuery sc unintSet sqt = Nothing -> filterFirstOrderVars mmap fovars (Set.insert (ecVarIndex e) absvars) es Just fot -> filterFirstOrderVars mmap (Map.insert e fot fovars) absvars es - processHyp tm = - 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 + processAssert mmap tp = + case asEqTrue tp of + Just x -> return (BoolAssert x) + _ -> processUnivAssert mmap [] [] tp + + processUnivAssert mmap vars xs tm = + do -- TODO: See related TODO in processTerm let tm' = tm - -- TODO? Allow universal hypotheses... - case asEqTrue tm' of - Nothing -> fail $ "sequentToSATQuery : expected EqTrue in hypothesis, actual " ++ showTerm tm' - Just tmBool -> return tmBool + case asPi tm' of + Just (lnm, tp, body) -> + do -- TOOD, same issure + let tp' = tp + case evalFOT mmap tp' of + Just fot -> + do ec <- scFreshEC sc lnm tp' + etm <- scExtCns sc ec + body' <- instantiateVar sc 0 etm body + processUnivAssert mmap ((ec,fot):vars) xs body' + Nothing + | looseVars body == emptyBitSet -> + case asEqTrue tp' of + Just x -> processUnivAssert mmap vars (x:xs) body + Nothing -> + fail ("sequentToSATQuery: expected first order type or assertion:\n" ++ showTerm tp') + | otherwise -> + fail ("sequentToSATQuery: expected first order type or assertion:\n" ++ showTerm tp') + + Nothing -> + case asEqTrue tm' of + Nothing -> fail $ "sequentToSATQuery: expected EqTrue, actual:\n" ++ showTerm tm' + Just tmBool -> return (UniversalAssert (reverse vars) (reverse xs) tmBool) processGoal mmap (vars,xs) tm = do -- TODO: I would like to WHNF here, but that evalutes too aggressively @@ -1733,27 +1753,25 @@ sequentToSATQuery sc unintSet sqt = do -- same issue with WHNF -- tp' <- scWhnf sc tp let tp' = tp - case asEqTrue tp' of - Just x | looseVars body == emptyBitSet -> - processGoal 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 - processGoal mmap (Map.insert ec fot vars, xs) body' + case evalFOT mmap tp' of + Just fot -> + do ec <- scFreshEC sc lnm tp' + etm <- scExtCns sc ec + body' <- instantiateVar sc 0 etm body + processGoal mmap (Map.insert ec fot vars, xs) body' + Nothing + | looseVars body == emptyBitSet -> + do asrt <- processAssert mmap tp + processGoal mmap (vars, asrt : xs) body + | otherwise -> + fail ("sequentToSATQuery: expected first order type or assertion:\n" ++ showTerm tp') Nothing -> case asEqTrue tm' of - Nothing -> fail $ "propToSATQuery: expected EqTrue, actual " ++ showTerm tm' + Nothing -> fail $ "sequentToSATQuery: expected EqTrue, actual:\n" ++ showTerm tm' Just tmBool -> do tmNeg <- scNot sc tmBool - return (vars, tmNeg:xs) + return (vars, reverse (BoolAssert tmNeg : xs)) -- | Given a goal to prove, attempt to apply the given proposition, producing -- new subgoals for any necessary hypotheses of the proposition. Returns diff --git a/src/SAWScript/Prover/Exporter.hs b/src/SAWScript/Prover/Exporter.hs index d42b5514d0..a08a87d054 100644 --- a/src/SAWScript/Prover/Exporter.hs +++ b/src/SAWScript/Prover/Exporter.hs @@ -96,6 +96,7 @@ import SAWScript.Prover.Util import SAWScript.Prover.What4 import SAWScript.Value +import qualified What4.Interface as W4 import qualified What4.Expr.Builder as W4 import What4.Config (extendConfig) import What4.Interface (getConfiguration, IsSymExprBuilder) @@ -304,11 +305,11 @@ writeSMTLib2 f satq = getSharedContext >>= \sc -> io $ writeSMTLib2What4 :: FilePath -> SATQuery -> TopLevel () writeSMTLib2What4 f satq = getSharedContext >>= \sc -> io $ do sym <- W4.newExprBuilder W4.FloatRealRepr St globalNonceGenerator - (_varMap, lit) <- W.w4Solve sym sc satq + (_varMap, lits) <- W.w4Solve sym sc satq let cfg = getConfiguration sym extendConfig smtParseOptions cfg withFile f WriteMode $ \h -> - writeDefaultSMT2 () "Offline SMTLib2" defaultWriteSMTLIB2Features Nothing sym h [lit] + writeDefaultSMT2 () "Offline SMTLib2" defaultWriteSMTLIB2Features Nothing sym h lits writeCore :: FilePath -> Term -> TopLevel () writeCore path t = io $ writeFile path (scWriteExternal t) @@ -325,7 +326,8 @@ writeVerilogSAT path satq = getSharedContext >>= \sc -> io $ let varList = Map.toList (satVariables satq) let argNames = map fst varList let argTys = map snd varList - (vars, bval) <- W.w4Solve sym sc satq + (vars, bvals) <- W.w4Solve sym sc satq + bval <- W4.andAllOf sym traverse bvals let f fot = case toFiniteType fot of Nothing -> fail $ "writeVerilogSAT: Unsupported argument type " ++ show fot Just ft -> return ft diff --git a/src/SAWScript/Prover/What4.hs b/src/SAWScript/Prover/What4.hs index 0ee9e6d1e0..2ee794f40a 100644 --- a/src/SAWScript/Prover/What4.hs +++ b/src/SAWScript/Prover/What4.hs @@ -8,6 +8,7 @@ module SAWScript.Prover.What4 where import Control.Lens ((^.)) +import Data.List (nub) import Data.Set (Set) import qualified Data.Map as Map import qualified Data.Text as Text @@ -60,9 +61,9 @@ what4Theories unintSet hashConsing goal = getSharedContext >>= \sc -> io $ do sym <- setupWhat4_sym hashConsing satq <- sequentToSATQuery sc unintSet goal - (_varMap, lit) <- W.w4Solve sym sc satq - let pf = (predicateVarInfo lit)^.problemFeatures - return (evalTheories pf) + (_varMap, lits) <- W.w4Solve sym sc satq + let pf lit = (predicateVarInfo lit)^.problemFeatures + return (nub (concatMap evalTheories (map pf lits))) evalTheories :: ProblemFeatures -> [String] evalTheories pf = [ nm | (nm,f) <- xs, hasProblemFeature pf f ] @@ -103,9 +104,9 @@ proveExportWhat4_sym solver un hashConsing outFilePath t = do sym <- setupWhat4_sym hashConsing -- Write smt out - (_, _, lit, stats) <- setupWhat4_solver solver sym un sc t + (_, _, lits, stats) <- setupWhat4_solver solver sym un sc t withFile outFilePath WriteMode $ \handle -> - solver_adapter_write_smt2 solver sym handle [lit] + solver_adapter_write_smt2 solver sym handle lits -- Assume unsat return (Nothing, stats) @@ -164,7 +165,7 @@ setupWhat4_solver :: forall st t ff. Sequent {- ^ A proposition to be proved/checked. -} -> IO ( [ExtCns Term] , [W.Labeler (B.ExprBuilder t st ff)] - , Pred (B.ExprBuilder t st ff) + , [Pred (B.ExprBuilder t st ff)] , SolverStats) setupWhat4_solver solver sym unintSet sc goal = do @@ -172,7 +173,7 @@ setupWhat4_solver solver sym unintSet sc goal = satq <- sequentToSATQuery sc unintSet goal let varList = Map.toList (satVariables satq) let argNames = map fst varList - (varMap, lit) <- W.w4Solve sym sc satq + (varMap, lits) <- W.w4Solve sym sc satq let bvs = map (fst . snd) varMap extendConfig (solver_adapter_config_options solver) @@ -181,7 +182,7 @@ setupWhat4_solver solver sym unintSet sc goal = let stats = solverStats ("W4 ->" ++ solver_adapter_name solver) (sequentSharedSize goal) - return (argNames, bvs, lit, stats) + return (argNames, bvs, lits, stats) -- | Check the validity of a proposition using What4. @@ -196,7 +197,7 @@ proveWhat4_solver :: forall st t ff. -- ^ (example/counter-example, solver statistics) proveWhat4_solver solver sym unintSet sc goal extraSetup = do - (argNames, bvs, lit, stats) <- setupWhat4_solver solver sym unintSet sc goal + (argNames, bvs, lits, stats) <- setupWhat4_solver solver sym unintSet sc goal extraSetup -- log to stdout @@ -205,7 +206,7 @@ proveWhat4_solver solver sym unintSet sc goal extraSetup = , logReason = "SAW proof" } -- run solver - solver_adapter_check_sat solver sym logData [lit] $ \ r -> case r of + solver_adapter_check_sat solver sym logData lits $ \ r -> case r of Sat (gndEvalFcn,_) -> do mvals <- mapM (getValues @(B.ExprBuilder t st ff) gndEvalFcn) (zip bvs argNames) From b7168afcff99ffe218b1fa411c599f62233fce85 Mon Sep 17 00:00:00 2001 From: Rob Dockins Date: Fri, 12 Aug 2022 13:45:52 -0700 Subject: [PATCH 21/35] Add a test case for asserting universally-quantified statements. Fixes #1037 --- intTests/test_univ_assert/README | 4 ++++ intTests/test_univ_assert/test.saw | 33 ++++++++++++++++++++++++++++++ intTests/test_univ_assert/test.sh | 1 + 3 files changed, 38 insertions(+) create mode 100644 intTests/test_univ_assert/README create mode 100644 intTests/test_univ_assert/test.saw create mode 100644 intTests/test_univ_assert/test.sh diff --git a/intTests/test_univ_assert/README b/intTests/test_univ_assert/README new file mode 100644 index 0000000000..eab6f5c36f --- /dev/null +++ b/intTests/test_univ_assert/README @@ -0,0 +1,4 @@ +This is a test of the capability to assert first-order statements +to the solver. Here, we are reasoning abstractly over about +generic properties of addition and multiplication (essentially, +some of the ring axioms). diff --git a/intTests/test_univ_assert/test.saw b/intTests/test_univ_assert/test.saw new file mode 100644 index 0000000000..7e97ced8fa --- /dev/null +++ b/intTests/test_univ_assert/test.saw @@ -0,0 +1,33 @@ +enable_experimental; + +let {{ + type vec_t = [384] + mul : vec_t -> vec_t -> vec_t + mul x y = undefined // this would be e.g. multiplication modulo p + add : vec_t -> vec_t -> vec_t + add x y = undefined + + term1 x y z1 z2 z3 = add (mul (add (mul (add (mul x y) z1) x) z2) x) z3 + term2 x y z1 z2 z3 = add (mul y (mul x (mul x x))) (add (mul z1 (mul x x)) (add (mul z2 x) z3)) +}}; + +// Assume some of the ring axioms +lemmas <- for + [ {{ \x y -> mul x y == mul y x }} + , {{ \x y -> add x y == add y x }} + , {{ \x y z -> mul (mul x y) z == mul x (mul y z) }} + , {{ \x y z -> add (add x y) z == add x (add y z) }} + , {{ \x y z -> mul (add x y) z == add (mul x z) (mul y z) }} + ] + (prove_print assume_unsat); + +// Use those axioms to prove a nonmtrivial equality +thm <- prove_print + (do { + unfolding ["term1","term2"]; + for lemmas goal_insert; + w4_unint_z3 ["mul","add"]; + }) + {{ \x y z1 z2 z3 -> term1 x y z1 z2 z3 == term2 x y z1 z2 z3 }}; + +print thm; diff --git a/intTests/test_univ_assert/test.sh b/intTests/test_univ_assert/test.sh new file mode 100644 index 0000000000..0b864017cd --- /dev/null +++ b/intTests/test_univ_assert/test.sh @@ -0,0 +1 @@ +$SAW test.saw From 38bb0cd7b2b5c1387dfbe747bdfcb94ed04fdb1d Mon Sep 17 00:00:00 2001 From: Rob Dockins Date: Mon, 15 Aug 2022 22:18:12 -0700 Subject: [PATCH 22/35] Now that the `IsLeNat` datatype is being used in the SAWCore prelude, we need a way to translate it into Coq. This patch redirects the definition to the standard Coq `le` predicate and directly implements its recursor, which differs somewhat from the usual `le_ind` recursor automatically generated by Coq. --- .../CryptolToCoq/SAWCoreScaffolding.v | 17 +++++++++++++++++ .../SAW/Translation/Coq/SpecialTreatment.hs | 8 ++++++++ 2 files changed, 25 insertions(+) diff --git a/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCoreScaffolding.v b/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCoreScaffolding.v index 36503eafd7..c6316a50ef 100644 --- a/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCoreScaffolding.v +++ b/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCoreScaffolding.v @@ -84,6 +84,7 @@ Instance Inhabited_unit : Inhabited unit := Instance Inhabited_bool : Inhabited bool := MkInhabited bool false. + (* SAW uses an alternate form of eq_rect where the motive function P also depends on the equality proof itself *) Definition Eq__rec (A : Type) (x : A) (P: forall y, x=y -> Type) (p:P x eq_refl) y (e:x=y) : @@ -172,6 +173,22 @@ Instance Inhabited_nat : Inhabited nat := Global Hint Resolve (0%nat : nat) : inh. Global Hint Resolve (0%nat : Nat) : inh. +Definition IsLeNat := @le. +Definition IsLeNat_base (n:Nat) : IsLeNat n n := le_n n. +Definition IsLeNat_succ (n m:Nat) : IsLeNat n m -> IsLeNat n (S m) := le_S n m. + +Definition IsLeNat__rec + (n : Nat) + (p : forall (x : Nat), IsLeNat n x -> Prop) + (Hbase : p n (IsLeNat_base n)) + (Hstep : forall (x : Nat) (H : IsLeNat n x), p x H -> p (S x) (IsLeNat_succ n x H)) + : forall (m : Nat) (Hm : IsLeNat n m), p m Hm := + fix rec (m:Nat) (Hm : IsLeNat n m) {struct Hm} : p m Hm := + match Hm as Hm' in le _ m' return p m' Hm' with + | le_n _ => Hbase + | le_S _ m H => Hstep m H (rec m H) + end. + (* Definition minNat := Nat.min. *) Definition uncurry (a b c : Type) (f : a -> b -> c) (p : a * (b * unit)) : c := 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 5a2ce82d12..bd353971fa 100644 --- a/saw-core-coq/src/Verifier/SAW/Translation/Coq/SpecialTreatment.hs +++ b/saw-core-coq/src/Verifier/SAW/Translation/Coq/SpecialTreatment.hs @@ -302,6 +302,14 @@ sawCorePreludeSpecialTreatmentMap configuration = , ("Refl", mapsTo sawDefinitionsModule "Refl") ] + -- Nat le + ++ + [ ("IsLeNat" , mapsTo sawDefinitionsModule "IsLeNat") + , ("IsLeNat__rec", mapsTo sawDefinitionsModule "IsLeNat__rec") + , ("IsLeNat_base", mapsTo sawDefinitionsModule "IsLeNat_base") + , ("IsLeNat_succ", mapsTo sawDefinitionsModule "IsLeNat_succ") + ] + -- Strings ++ [ ("String", mapsTo sawDefinitionsModule "String") From 143f7dd358ed223a9940999581719694546760dd Mon Sep 17 00:00:00 2001 From: Robert Dockins Date: Tue, 16 Aug 2022 17:35:04 -0700 Subject: [PATCH 23/35] Add some additional utilities for constructing SAWCore terms, this time for implication and Pi-types/universal quantification. --- src/SAWScript/Builtins.hs | 25 ++++++++++++++++++++++++- src/SAWScript/Interpreter.hs | 14 ++++++++++++++ 2 files changed, 38 insertions(+), 1 deletion(-) diff --git a/src/SAWScript/Builtins.hs b/src/SAWScript/Builtins.hs index 35cd764354..9237b609c3 100644 --- a/src/SAWScript/Builtins.hs +++ b/src/SAWScript/Builtins.hs @@ -1469,7 +1469,7 @@ addsimp thm ss = Just rule -> pure (addRule rule ss) addsimp_shallow :: Theorem -> SV.SAWSimpset -> TopLevel SV.SAWSimpset -addsimp_shallow thm ss = +addsimp_shallow thm ss = do sc <- getSharedContext io (propToRewriteRule sc (thmProp thm) (Just (thmNonce thm))) >>= \case Nothing -> fail "addsimp: theorem not an equation" @@ -1552,6 +1552,29 @@ lambdas vars tt = Just tec -> pure tec Nothing -> fail "lambda: argument not a valid symbolic variable" +implies_term :: TypedTerm -> TypedTerm -> TopLevel TypedTerm +implies_term x y = + do sc <- getSharedContext + -- check that the given terms are props (TODO? should we relax this?) + _ <- io $ termToProp sc (ttTerm x) + _ <- io $ termToProp sc (ttTerm y) + z <- io $ scFun sc (ttTerm x) (ttTerm y) + io $ mkTypedTerm sc z + +generalize_term :: [TypedTerm] -> TypedTerm -> TopLevel TypedTerm +generalize_term vars tt = + do tecs <- traverse checkVar vars + sc <- getSharedContext + tm <- io $ scGeneralizeExts sc (map tecExt tecs) (ttTerm tt) + _tp <- io $ scTypeCheckError sc tm -- sanity check the term + io $ mkTypedTerm sc tm + + where + checkVar v = + case asTypedExtCns v of + Just tec -> pure tec + Nothing -> fail "generalize_term: argument not a valid symbolic variable" + -- | Apply the given Term to the given values, and evaluate to a -- final value. cexEvalFn :: SharedContext -> [(ExtCns Term, FirstOrderValue)] -> Term diff --git a/src/SAWScript/Interpreter.hs b/src/SAWScript/Interpreter.hs index fee5a2d16d..a2ef116e3e 100644 --- a/src/SAWScript/Interpreter.hs +++ b/src/SAWScript/Interpreter.hs @@ -1214,6 +1214,20 @@ primitives = Map.fromList , "variables." ] + , prim "generalize_term" "[Term] -> Term -> Term" + (funVal2 generalize_term) + Experimental + [ "Take a list of 'fresh_symbolic' variables and another term containing those" + , "variables, and return a new Pi generalization over the list of variables." + ] + + , prim "implies_term" "Term -> Term -> Term" + (funVal2 implies_term) + Experimental + [ "Given to terms, which must be Prop terms, construct the SAWCore implication" + , "of those terms." + ] + , prim "size_to_term" "Type -> Term" (funVal1 size_to_term) Current From e53e5fcb9a3db5c8ae33b25e091ddef01cc3c8f4 Mon Sep 17 00:00:00 2001 From: Robert Dockins Date: Tue, 23 Aug 2022 15:04:56 -0700 Subject: [PATCH 24/35] Previously, the evidence checking step that follows a successful proof would force a sequent normalization. This was to account for the case where the "enable_sequent_goals" option was set, which requires a little additional work to match up the statement of a lemma with the initial sequent that was proved. However, in some cases, this normalization step can be quite expensive, so now we only insert this additional normalization step when the sequent goals option is active. --- src/SAWScript/Builtins.hs | 8 ++++---- src/SAWScript/Crucible/JVM/Builtins.hs | 1 + src/SAWScript/Crucible/LLVM/Builtins.hs | 4 +++- src/SAWScript/Crucible/LLVM/X86.hs | 1 + src/SAWScript/Proof.hs | 9 +++++++-- src/SAWScript/Value.hs | 5 +++-- 6 files changed, 19 insertions(+), 9 deletions(-) diff --git a/src/SAWScript/Builtins.hs b/src/SAWScript/Builtins.hs index 9237b609c3..f5cc50d40c 100644 --- a/src/SAWScript/Builtins.hs +++ b/src/SAWScript/Builtins.hs @@ -1153,7 +1153,7 @@ provePrim script t = do , goalSequent = propToSequent prop , goalTags = mempty } - res <- SV.runProofScript script prop goal Nothing "prove_prim" True + res <- SV.runProofScript script prop goal Nothing "prove_prim" True False case res of UnfinishedProof pst -> printOutLnTop Info $ "prove: " ++ show (length (psGoals pst)) ++ " unsolved subgoal(s)" @@ -1180,7 +1180,7 @@ proveHelper nm script t f = do , goalTags = mempty } opts <- rwPPOpts <$> getTopLevelRW - res <- SV.runProofScript script prop goal Nothing (Text.pack nm) True + res <- SV.runProofScript script prop goal Nothing (Text.pack nm) True False let failProof pst = fail $ "prove: " ++ show (length (psGoals pst)) ++ " unsolved subgoal(s)\n" ++ SV.showsProofResult opts res "" @@ -1373,7 +1373,7 @@ satPrim script t = , goalSequent = propToSequent prop , goalTags = mempty } - res <- SV.runProofScript script prop goal Nothing "sat" False + res <- SV.runProofScript script prop goal Nothing "sat" False False case res of InvalidProof stats cex _ -> return (SV.Sat stats cex) ValidProof stats _thm -> return (SV.Unsat stats) @@ -1927,7 +1927,7 @@ prove_core script input = , goalSequent = propToSequent p , goalTags = mempty } - res <- SV.runProofScript script p goal Nothing "prove_core" True + res <- SV.runProofScript script p goal Nothing "prove_core" True False let failProof pst = fail $ "prove_core: " ++ show (length (psGoals pst)) ++ " unsolved subgoal(s)\n" ++ SV.showsProofResult opts res "" diff --git a/src/SAWScript/Crucible/JVM/Builtins.hs b/src/SAWScript/Crucible/JVM/Builtins.hs index f00c57ea40..483ff2e2cc 100644 --- a/src/SAWScript/Crucible/JVM/Builtins.hs +++ b/src/SAWScript/Crucible/JVM/Builtins.hs @@ -320,6 +320,7 @@ verifyObligations cc mspec tactic assumes asserts = (Text.unwords ["JVM verification condition:", Text.pack (show n), Text.pack goalname]) False -- do not record in the theorem database + False -- TODO, useSequentGoals... case res of ValidProof stats thm -> return (stats, (md, stats, thmSummary thm, thmNonce thm, thmDepends thm, thmElapsedTime thm)) diff --git a/src/SAWScript/Crucible/LLVM/Builtins.hs b/src/SAWScript/Crucible/LLVM/Builtins.hs index fd2e09b06a..0f1867546e 100644 --- a/src/SAWScript/Crucible/LLVM/Builtins.hs +++ b/src/SAWScript/Crucible/LLVM/Builtins.hs @@ -811,6 +811,7 @@ verifyObligations cc mspec tactic assumes asserts = (Text.unwords ["LLVM verification condition", Text.pack (show n), Text.pack goalname]) False -- do not record this theorem in the database + useSequentGoals case res of ValidProof stats thm -> return (stats, (md, stats, thmSummary thm, thmNonce thm, thmDepends thm, thmElapsedTime thm)) @@ -994,7 +995,8 @@ assumptionsContainContradiction cc methodSpec tactic assumptions = , goalSequent = propToSequent goal' , goalTags = mempty }) - res <- runProofScript tactic goal' pgl Nothing "vacuousness check" False + res <- runProofScript tactic goal' pgl Nothing + "vacuousness check" False False case res of ValidProof _ _ -> return True InvalidProof _ _ _ -> return False diff --git a/src/SAWScript/Crucible/LLVM/X86.hs b/src/SAWScript/Crucible/LLVM/X86.hs index c25afdcab9..2cc9772b07 100644 --- a/src/SAWScript/Crucible/LLVM/X86.hs +++ b/src/SAWScript/Crucible/LLVM/X86.hs @@ -1203,6 +1203,7 @@ checkGoals bak opts nm sc tactic mdMap = do (Text.unwords ["X86 verification condition", Text.pack (show n), Text.pack (show (gMessage g))]) False -- do no record this theorem in the database + False -- TODO! useSequentGoals case res of ValidProof stats thm -> return (stats, (md, stats, thmSummary thm, thmNonce thm, thmDepends thm, thmElapsedTime thm)) diff --git a/src/SAWScript/Proof.hs b/src/SAWScript/Proof.hs index 361c43ac1c..30c2d75983 100644 --- a/src/SAWScript/Proof.hs +++ b/src/SAWScript/Proof.hs @@ -1566,12 +1566,17 @@ finishProof :: Prop -> ProofState -> Bool {- ^ should we record the theorem in the database? -} -> + Bool {- ^ do we need to normalize the sequent to match the final goal ? -} -> IO ProofResult -finishProof sc db conclProp ps@(ProofState gs (concl,loc,ploc,rsn) stats _ checkEv start) recordThm = +finishProof sc db conclProp + ps@(ProofState gs (concl,loc,ploc,rsn) stats _ checkEv start) + recordThm useSequentGoals = case gs of [] -> do e <- checkEv [] - let e' = NormalizeSequentEvidence concl e + let e' = if useSequentGoals + then NormalizeSequentEvidence concl e + else e (deps,sy) <- checkEvidence sc e' conclProp n <- freshNonce globalNonceGenerator end <- getCurrentTime diff --git a/src/SAWScript/Value.hs b/src/SAWScript/Value.hs index 075edae37b..8fe5baec77 100644 --- a/src/SAWScript/Value.hs +++ b/src/SAWScript/Value.hs @@ -839,8 +839,9 @@ runProofScript :: Maybe ProgramLoc -> Text -> Bool {- ^ record the theorem in the database? -} -> + Bool {- ^ do we need to normalize the sequent goal? -} -> TopLevel ProofResult -runProofScript (ProofScript m) concl gl ploc rsn recordThm = +runProofScript (ProofScript m) concl gl ploc rsn recordThm useSequentGoals = do pos <- getPosition ps <- io (startProof gl pos ploc rsn) (r,pstate) <- runStateT (runExceptT m) ps @@ -849,7 +850,7 @@ runProofScript (ProofScript m) concl gl ploc rsn recordThm = Right _ -> do sc <- getSharedContext db <- rwTheoremDB <$> getTopLevelRW - io (finishProof sc db concl pstate recordThm) + io (finishProof sc db concl pstate recordThm useSequentGoals) scriptTopLevel :: TopLevel a -> ProofScript a scriptTopLevel m = ProofScript (lift (lift m)) From 6cbe29b06d76325de481a45082aa0c25b37df719 Mon Sep 17 00:00:00 2001 From: Rob Dockins Date: Tue, 23 Aug 2022 15:35:04 -0700 Subject: [PATCH 25/35] Add help documentation for some of the new commands. Minor other docuemenation tweaks. --- src/SAWScript/Interpreter.hs | 37 ++++++++++++++++++++++++++++-------- 1 file changed, 29 insertions(+), 8 deletions(-) diff --git a/src/SAWScript/Interpreter.hs b/src/SAWScript/Interpreter.hs index a2ef116e3e..66f73e37d5 100644 --- a/src/SAWScript/Interpreter.hs +++ b/src/SAWScript/Interpreter.hs @@ -1544,8 +1544,17 @@ primitives = Map.fromList , prim "prove_by_bv_induction" "ProofScript () -> Term -> TopLevel Theorem" (pureVal proveByBVInduction) Experimental - [ "TODO, real docs. Attempt to prove a fact by induction on the less-than" - , "order on bitvectors." + [ "Attempt to prove a fact by induction on the less-than order on bitvectors." + , "The give term is expected to be a function of one or more arguments" + , "which returns a tuple containing two values: first, a bitvector expression" + , "(which will be expression we perform induction on) second, a boolean value" + , "defining the theorem to prove." + , "" + , "This command will attempt to prove the theorem expressed in the second" + , "element of the tuple by induction. The goal presented to the user-provided" + , "tactic will ask to prove the stated goal and will be provided with an induction" + , "hypothesis which states that the goal holds for all values of the varibles" + , "where the expression given in the first element of the tuple has decreased." ] , prim "prove_extcore" "ProofScript () -> Term -> TopLevel Theorem" @@ -1553,15 +1562,15 @@ primitives = Map.fromList Current [ "Use the given proof script to attempt to prove that a term representing" , "a proposition is valid. For example, this is useful for proving a goal" - , "obtained with 'offline_extcore'. Returns a Theorem if successful, and" - , "aborts if unsuccessful." + , "obtained with 'offline_extcore' or 'parse_core'. Returns a Theorem if" + , "successful, and aborts if unsuccessful." ] , prim "sat" "ProofScript () -> Term -> TopLevel SatResult" (pureVal satPrim) Current [ "Use the given proof script to attempt to prove that a term is" - , "satisfiable (true for any input). Returns a proof result that can" + , "satisfiable (is true for some input). Returns a proof result that can" , "be analyzed with 'caseSatResult' to determine whether it represents" , "a satisfying assignment or an indication of unsatisfiability." ] @@ -1640,7 +1649,12 @@ primitives = Map.fromList , prim "goal_cut" "Term -> ProofScript ()" (pureVal goal_cut) Experimental - [ "TODO, write docs" ] + [ "Given a term provided by the user (which must be a boolean expression" + , "or a Prop) the current goal is split into two subgoals. In the first subgoal," + , "the given proposition is assumed as a new hypothesis. In the second subgoal," + , "the given proposition is a new focused, conclusion. This implements the" + , "usual cut rule of sequent calculus." + ] , prim "retain_hyps" "[Int] -> ProofScript ()" (pureVal retain_hyps) @@ -1720,12 +1734,19 @@ primitives = Map.fromList , prim "goal_intro_hyps" "Int -> ProofScript ()" (pureVal goal_intro_hyps) Experimental - [ "TODO "] + [ "When focused on a conclusion that represents an implication," + , "simplify the conclusion by removing the implication and introducing" + , "a new sequent hypothesis instead. The given number indicates how many" + , "hypotheses to introduce." + ] , prim "goal_revert_hyp" "Int -> ProofScript ()" (pureVal goal_revert_hyp) Experimental - [ "TODO "] + [ "When focused on a conclusion, weaken the focused conclustion" + , "by introducing an implication using the numbered sequent hypothesis." + , "This is essentially the reverse of 'gooal_intro_hyps'." + ] , prim "goal_insert" "Theorem -> ProofScript ()" (pureVal goal_insert) From e6b8ee96f2d2f29ebcc486390668c2a7cd3811ea Mon Sep 17 00:00:00 2001 From: robdockins Date: Wed, 24 Aug 2022 13:14:21 -0700 Subject: [PATCH 26/35] Apply suggestions from code review Co-authored-by: Ryan Scott --- saw-core/src/Verifier/SAW/SATQuery.hs | 4 ++-- src/SAWScript/Builtins.hs | 2 +- src/SAWScript/Interpreter.hs | 10 +++++----- 3 files changed, 8 insertions(+), 8 deletions(-) diff --git a/saw-core/src/Verifier/SAW/SATQuery.hs b/saw-core/src/Verifier/SAW/SATQuery.hs index 66153f8bf5..22aed1f9c9 100644 --- a/saw-core/src/Verifier/SAW/SATQuery.hs +++ b/saw-core/src/Verifier/SAW/SATQuery.hs @@ -52,7 +52,7 @@ data SATQuery = data SATAssert = BoolAssert Term -- ^ A boolean term to be asserted | UniversalAssert [(ExtCns Term, FirstOrderType)] [Term] Term - -- ^ A univesally-quantified assertion, consisting of a + -- ^ A universally-quantified assertion, consisting of a -- collection of first-order variables, a sequence -- of boolean hypotheses, and a boolean conclusion @@ -67,7 +67,7 @@ data SATResult -- in this SAT query as a single term of type Bool. -- -- This method of reducing a sat query to a boolean --- cannot be used for univerally-quantified assertions. +-- cannot be used for universally-quantified assertions. satQueryAsTerm :: SharedContext -> SATQuery -> IO Term satQueryAsTerm sc satq = case satAsserts satq of diff --git a/src/SAWScript/Builtins.hs b/src/SAWScript/Builtins.hs index f5cc50d40c..32cc492703 100644 --- a/src/SAWScript/Builtins.hs +++ b/src/SAWScript/Builtins.hs @@ -1186,7 +1186,7 @@ proveHelper nm script t f = do ++ SV.showsProofResult opts res "" case res of ValidProof _stats thm -> - do printOutLnTop Debug $ "Valid: " ++ show (ppTerm (SV.sawPPOpts opts) $ t) + do printOutLnTop Debug $ "Valid: " ++ show (ppTerm (SV.sawPPOpts opts) t) SV.returnProof thm InvalidProof _stats _cex pst -> failProof pst UnfinishedProof pst -> failProof pst diff --git a/src/SAWScript/Interpreter.hs b/src/SAWScript/Interpreter.hs index 66f73e37d5..a0bc4c38b6 100644 --- a/src/SAWScript/Interpreter.hs +++ b/src/SAWScript/Interpreter.hs @@ -962,7 +962,7 @@ primitives = Map.fromList , prim "enable_sequent_goals" "TopLevel ()" (pureVal enable_sequent_goals) Experimental - [ "When verifying proof obligations arising from `llvm_verify` and similar" + [ "When verifying proof obligations arising from `llvm_verify` and similar commands," , "generate sequents for the proof obligations instead of a single boolean goal." ] @@ -1545,9 +1545,9 @@ primitives = Map.fromList (pureVal proveByBVInduction) Experimental [ "Attempt to prove a fact by induction on the less-than order on bitvectors." - , "The give term is expected to be a function of one or more arguments" + , "The given term is expected to be a function of one or more arguments" , "which returns a tuple containing two values: first, a bitvector expression" - , "(which will be expression we perform induction on) second, a boolean value" + , "(which will be the expression we perform induction on), and second, a boolean value" , "defining the theorem to prove." , "" , "This command will attempt to prove the theorem expressed in the second" @@ -1697,7 +1697,7 @@ primitives = Map.fromList (pureVal goal_normalize) Experimental [ "Evaluate the current proof goal by performing evaluation in SAWCore." - , "The currently-focused term will be evaluted. If the sequent is unfocused" + , "The currently-focused term will be evaluated. If the sequent is unfocused" , "all terms will be evaluated. The given names will be treated as uninterpreted." ] @@ -1743,7 +1743,7 @@ primitives = Map.fromList , prim "goal_revert_hyp" "Int -> ProofScript ()" (pureVal goal_revert_hyp) Experimental - [ "When focused on a conclusion, weaken the focused conclustion" + [ "When focused on a conclusion, weaken the focused conclusion" , "by introducing an implication using the numbered sequent hypothesis." , "This is essentially the reverse of 'gooal_intro_hyps'." ] From 39f80d940931f138128656d96df09bb9b5c8fcc7 Mon Sep 17 00:00:00 2001 From: Rob Dockins Date: Thu, 25 Aug 2022 16:03:23 -0700 Subject: [PATCH 27/35] Lots of additional comments and minor fixes. Also! Fix a bug in the tactic for applying local hypotheses. Previously it would only generate a single subgoal, even if the applied hypotheses generated more than that. This would lead to prematurely-finished proofs and evidence checking failures. --- src/SAWScript/Proof.hs | 403 +++++++++++++++++++++++++++++------------ 1 file changed, 290 insertions(+), 113 deletions(-) diff --git a/src/SAWScript/Proof.hs b/src/SAWScript/Proof.hs index 30c2d75983..23b097f444 100644 --- a/src/SAWScript/Proof.hs +++ b/src/SAWScript/Proof.hs @@ -209,7 +209,7 @@ termToMaybeProp sc tm = -- | Turn a boolean-valued saw-core term into a proposition by asserting -- that it is equal to the true boolean value. Generalize the proposition --- by universally quantifing over the variables given in the list. +-- by universally quantifying over the variables given in the list. boolToProp :: SharedContext -> [ExtCns Term] -> Term -> IO Prop boolToProp sc vars tm = do mmap <- scGetModuleMap sc @@ -231,9 +231,9 @@ propToRewriteRule _sc (Prop tm) ann = Nothing -> pure Nothing Just r -> pure (Just r) --- | Attempt to split an if/then/else goal. +-- | Attempt to split an if/then/else proposition. -- If it succeeds to find a term like "EqTrue (ite Bool b x y)", --- then it returns to pairs consisting of "(EqTrue b, EqTrue x)" +-- then it returns two pairs consisting of "(EqTrue b, EqTrue x)" -- and "(EqTrue (not b), EqTrue y)" splitIte :: SharedContext -> Prop -> IO (Maybe ((Prop, Prop), (Prop, Prop))) splitIte sc (Prop p) = @@ -277,11 +277,13 @@ splitImpl sc (Prop p) c' <- scEqTrue sc c return (Just (Prop h', Prop c')) + -- or (not h) c == implies h c | Just ( _ :*: (_ :*: h) :*: c) <- (isGlobalDef "Prelude.or" <@> (isGlobalDef "Prelude.not" <@> return) <@> return) =<< asEqTrue p = do h' <- scEqTrue sc h c' <- scEqTrue sc c return (Just (Prop h', Prop c')) + -- or c (not h) == implies h c | Just ( _ :*: c :*: (_ :*: h)) <- (isGlobalDef "Prelude.or" <@> return <@> (isGlobalDef "Prelude.not" <@> return)) =<< asEqTrue p = do h' <- scEqTrue sc h c' <- scEqTrue sc c @@ -289,7 +291,7 @@ splitImpl sc (Prop p) -- Handle the case of (H1 -> H2), where H1 and H2 are in Prop | Just (_nm, arg, c) <- asPi p - , looseVars c == emptyBitSet + , looseVars c == emptyBitSet -- make sure this is a nondependent Pi (AKA arrow type) = termToMaybeProp sc arg >>= \case Nothing -> return Nothing Just h -> return (Just (h, Prop c)) @@ -298,17 +300,33 @@ splitImpl sc (Prop p) = return Nothing +-- | Attempt to split a sequent into two subgoals. This will only work +-- on focused sequents. If the sequent is focused on a hypothesis, +-- the hypothesis must be a disjunction, if/then/else, or implication term. +-- If the sequent is focused on a conclusion, the conclusion must be +-- a conjunction or if/then/else. +-- +-- If this process succeeds, then a proof of the two included sequents +-- should be sufficient to prove the input sequent. splitSequent :: SharedContext -> Sequent -> IO (Maybe (Sequent, Sequent)) splitSequent sc sqt = case sqt of GoalFocusedSequent hs (FB gs1 g gs2) -> splitConj sc g >>= \case + -- HS |- GS1, X, GS2 + -- HS |- GS1, Y, GS2 + -- --------------------------- (Conj-R) + -- HS |- GS1, X /\ Y, GS2 Just (x, y) -> return (Just ( GoalFocusedSequent hs (FB gs1 x gs2) , GoalFocusedSequent hs (FB gs1 y gs2) )) Nothing -> splitIte sc g >>= \case + -- HS, B |- GS1, X, GS2 + -- HS, not B |- GS1, Y, GS2 + -- -------------------------------------- (Ite-R) + -- HS |- GS1, if B then X else Y, GS2 Just ((b, x), (nb, y)) -> return (Just ( GoalFocusedSequent (hs ++ [b]) (FB gs1 x gs2) , GoalFocusedSequent (hs ++ [nb]) (FB gs1 y gs2) @@ -317,17 +335,29 @@ splitSequent sc sqt = HypFocusedSequent (FB hs1 h hs2) gs -> splitDisj sc h >>= \case + -- HS1, X, HS2 |- GS + -- HS1, Y, HS2 |- GS + -- --------------------------- (Disj-L) + -- HS1, X \/ Y, HS2 |- GS Just (x, y) -> return (Just ( HypFocusedSequent (FB hs1 x hs2) gs , HypFocusedSequent (FB hs1 y hs2) gs )) Nothing -> + -- HS1, X, HS2, B |- GS + -- HS1, Y, HS2, not B |- GS + -- ------------------------------------- (Ite-L) + -- HS1, if B then X else Y, HS2 |- GS splitIte sc h >>= \case Just ((b,x), (nb, y)) -> return (Just ( HypFocusedSequent (FB hs1 x (hs2 ++ [b])) gs , HypFocusedSequent (FB hs1 y (hs2 ++ [nb])) gs )) Nothing -> + -- HS1, Y, HS2 |- GS + -- HS1, X -> Y, HS2 |- GS, X + -- ------------------------------ (Impl-L) AKA modus ponens + -- HS1, X -> Y, HS2 |- GS splitImpl sc h >>= \case Just (x, y) -> return (Just ( HypFocusedSequent (FB hs1 y hs2) gs @@ -335,7 +365,7 @@ splitSequent sc sqt = )) Nothing -> return Nothing - UnfocusedSequent _ _ -> fail "split tactic: focus required" + UnfocusedSequent _ _ -> return Nothing -- | Unfold all the constants appearing in the proposition -- whose VarIndex is found in the given set. @@ -477,35 +507,67 @@ ppProp opts nenv (Prop tm) = ppTermWithNames opts nenv tm -- TODO, I'd like to add metadata here type SequentBranch = Prop +-- | The representation of either hypotheses or conclusions with a focus +-- point. A @FB xs y zs@ represents a collection of propositions +-- where @xs@ come before the focus point @y@, and @zs@ is the +-- collection of propositions following the focus point. data FocusedBranch = FB ![SequentBranch] !SequentBranch ![SequentBranch] +-- | This datatype represents sequents in the style of Gentzen. Sequents +-- are used to represent the intermediate states of a proof, and are the +-- primary objects manipulated by the proof tactic system. +-- +-- A sequent essentially represents a logical claim which is in the process +-- of being proved. A sequent has some (possibly 0) number of +-- "hypotheses" and some number (possibly 0) of "conclusions". In mathematical +-- notation, the hypotheses are separated from the conclusions by a turnstile +-- character, and the individual hypotheses and conclusions are separated from +-- each other by a comma. So, a typical sequent may look like: +-- +-- H1, H2, H3, |- C1, C2 +-- +-- The logical meaning of a sequent is that the conjunction of all the hypotheses +-- implies the disjunction of the conclusions. The multi-conclusion form +-- of sequent (as is presented here) is typical of a classical logic. +-- +-- In a Gentzen-style proof system (such as the sequent calculus), the method by +-- which proof proceeds is to apply inference rules. Each rule applies to a goal +-- sequent (the thing to be proved) and has 0 or more subgoals that must be proved +-- to apply the rule. Part of a proof is completed when a rule is applied which has 0 +-- subgoals. When doing proofs in SAW using the tactic system, there is a stack of +-- currently outstanding proof goals (each in the form of a sequent to be proved). +-- Executing a tactic will modify or apply a proof rule to the top goal on the stack; +-- if that subgoal is finished, then the next subgoal becomes active. +-- If applying a rule causes more than one subgoal to be generated, the remaining +-- ones are pushed onto the stack of goals to be proved. An entire proof is completed +-- when the stack of outstanding goals to prove is empty. +-- +-- This particular presentation of sequents is a "focused" sequent calculus. +-- This means that a sequent may optionally have a focus on a particular +-- hypothesis or conclusion. Some manipulations of sequents require a focus +-- point to indicate where some manipulation should be carried out, and others +-- will apply in both focused or unfocused states. data Sequent - = UnfocusedSequent ![SequentBranch] ![SequentBranch] + = -- | A sequent in the unfocused state + UnfocusedSequent ![SequentBranch] ![SequentBranch] + -- | A sequent focused on a particular conclusion | GoalFocusedSequent ![SequentBranch] !FocusedBranch + -- | A sequent focused on a particular hypothesis | HypFocusedSequent !FocusedBranch ![SequentBranch] -unfocus :: Sequent -> ([SequentBranch],[SequentBranch]) -unfocus (UnfocusedSequent hs gs) = (hs,gs) -unfocus (GoalFocusedSequent hs (FB gs1 g gs2)) = (hs, gs1 ++ g : gs2) -unfocus (HypFocusedSequent (FB hs1 h hs2) gs) = (hs1 ++ h : hs2, gs) - -unfocusSequent :: Sequent -> Sequent -unfocusSequent sqt = UnfocusedSequent hs gs - where (hs,gs) = unfocus sqt - -focusOnGoal :: Integer -> Sequent -> Maybe Sequent -focusOnGoal i sqt = - let (hs,gs) = unfocus sqt in - case genericDrop i gs of - (g:gs2) -> Just (GoalFocusedSequent hs (FB (genericTake i gs) g gs2)) - [] -> Nothing +-- | A RawSequent is a data-structure representing a sequent, but without +-- the ability to focus on a particular hypothesis or conclusion. +-- +-- This data-structure is parametric in the type of propositions, +-- which enables some convenient patterns using traversals, etc. +data RawSequent a = RawSequent [a] [a] -focusOnHyp :: Integer -> Sequent -> Maybe Sequent -focusOnHyp i sqt = - let (hs,gs) = unfocus sqt in - case genericDrop i hs of - (h:hs2) -> Just (HypFocusedSequent (FB (genericTake i hs) h hs2) gs) - [] -> Nothing +instance Functor RawSequent where + fmap f (RawSequent hs gs) = RawSequent (fmap f hs) (fmap f gs) +instance Foldable RawSequent where + foldMap f (RawSequent hs gs) = Fold.foldMap f (hs ++ gs) +instance Traversable RawSequent where + traverse f (RawSequent hs gs) = RawSequent <$> traverse f hs <*> traverse f gs sequentToRawSequent :: Sequent -> RawSequent Prop sequentToRawSequent sqt = @@ -514,22 +576,29 @@ sequentToRawSequent sqt = GoalFocusedSequent hs (FB gs1 g gs2) -> RawSequent hs (gs1 ++ g : gs2) HypFocusedSequent (FB hs1 h hs2) gs -> RawSequent (hs1 ++ h : hs2) gs +unfocusSequent :: Sequent -> Sequent +unfocusSequent sqt = UnfocusedSequent hs gs + where RawSequent hs gs = sequentToRawSequent sqt + +focusOnGoal :: Integer -> Sequent -> Maybe Sequent +focusOnGoal i sqt = + let RawSequent hs gs = sequentToRawSequent sqt in + case genericSplitAt i gs of + (gs1, g:gs2) -> Just (GoalFocusedSequent hs (FB gs1 g gs2)) + (_ , []) -> Nothing + +focusOnHyp :: Integer -> Sequent -> Maybe Sequent +focusOnHyp i sqt = + let RawSequent hs gs = sequentToRawSequent sqt in + case genericSplitAt i hs of + (hs1,h:hs2) -> Just (HypFocusedSequent (FB hs1 h hs2) gs) + (_ , []) -> Nothing sequentConstantSet :: Sequent -> Map VarIndex (NameInfo, Term, Maybe Term) sequentConstantSet sqt = foldr (\p m -> Map.union (getConstantSet (unProp p)) m) mempty (hs++gs) where RawSequent hs gs = sequentToRawSequent sqt -data RawSequent a = RawSequent [a] [a] - -instance Functor RawSequent where - fmap f (RawSequent hs gs) = RawSequent (fmap f hs) (fmap f gs) -instance Foldable RawSequent where - foldMap f (RawSequent hs gs) = Fold.foldMap f (hs ++ gs) -instance Traversable RawSequent where - traverse f (RawSequent hs gs) = RawSequent <$> traverse f hs <*> traverse f gs - - convertibleProps :: SharedContext -> [Prop] -> [Prop] -> IO Bool convertibleProps _sc [] [] = return True convertibleProps sc (p1:ps1) (p2:ps2) = @@ -548,14 +617,24 @@ convertibleSequents sc sqt1 sqt2 = RawSequent hs2 gs2 = sequentToRawSequent sqt2 +-- | A helper data structure for working with sequents when a focus +-- point is expected. When a conclusion or hypothesis is focused, +-- return the focused proposition; and return a function which +-- allows building a new sequent by replacing the proposition under +-- focus. data SequentState = Unfocused | GoalFocus Prop (Prop -> Sequent) - | HypFocus Prop (Prop -> Sequent) + | HypFocus Prop (Prop -> Sequent) +-- | Build a sequent with the given proposition as the +-- only conclusion, and place it under focus. propToSequent :: Prop -> Sequent propToSequent p = GoalFocusedSequent [] (FB [] p []) +-- | Give in a collection of boolean terms, construct a sequent +-- with corresponding hypotheses and conclusions. If there +-- is exactly one conclusion term, put it under focus. booleansToSequent :: SharedContext -> [Term] -> [Term] -> IO Sequent booleansToSequent sc hs gs = do hs' <- mapM (boolToProp sc []) hs @@ -564,6 +643,15 @@ booleansToSequent sc hs gs = [g] -> return (GoalFocusedSequent hs' (FB [] g [])) _ -> return (UnfocusedSequent hs' gs') +-- | Given a sequent, render its semantics as a proposition. +-- +-- Currently this can only handle sequents with 0 or 1 conclusion +-- (this is not a fundamental limitation, but we need a Prop-level disjunction +-- in SAWCore to fix this). +-- +-- Given a sequent like @H1, H2 ..., Hn |- C@, this will build a corresponding +-- proposition @H1 -> H2 -> ... Hn -> C@. If the list of conclusions is empty, +-- the proposition will be @H1 -> H2 -> ... Hn -> False@. sequentToProp :: SharedContext -> Sequent -> IO Prop sequentToProp sc sqt = do let RawSequent hs gs = sequentToRawSequent sqt @@ -617,19 +705,33 @@ ppRawSequent sqt (RawSequent hs gs) = = "G" <> pretty i <> ":" <+> tm +-- | A datatype for representing finte or cofinite sets. data CofinSet a - = WhiteList (Set a) + = -- | A whitelist represents exactly the values in the given set + WhiteList (Set a) + -- | A blacklist represents all the values NOT found in the given set. | BlackList (Set a) +-- | Test for membership in a finite/cofinite set cofinSetMember :: Ord a => a -> CofinSet a -> Bool cofinSetMember a (WhiteList xs) = Set.member a xs -cofinSetMember a (BlackList xs) = not (Set.member a xs) - -filterPosList :: CofinSet Integer -> [a] -> [a] -filterPosList pss xs = map snd $ filter f $ zip [0..] xs +cofinSetMember a (BlackList xs) = not (Set.member a xs) + +-- | Given a set of positions, filter the given list +-- so that it retains just those values that are in +-- positions contained in the set. The given integer +-- indicates what position to start counting at. +filterPosList :: CofinSet Integer -> Integer -> [a] -> [a] +filterPosList pss start xs = map snd $ filter f $ zip [start..] xs where f (i,_) = cofinSetMember i pss +-- | Given a set of positions, filter the given focused branch +-- and retain just those positions in the set. +-- If the given branch was focused and the focus point was retained, +-- return a @Right@ value with the new focused branch. If the +-- given branch was unfocused to start, or of the focused point +-- was removed, return a @Left@ value with a bare list. filterFocusedList :: CofinSet Integer -> FocusedBranch -> Either [SequentBranch] FocusedBranch filterFocusedList pss (FB xs1 x xs2) = if cofinSetMember idx pss then @@ -637,45 +739,50 @@ filterFocusedList pss (FB xs1 x xs2) = else Left (xs1' ++ xs2') where - f (i,_) = cofinSetMember i pss idx = genericLength xs1 - xs1' = map snd $ filter f $ zip [0..] xs1 - xs2' = map snd $ filter f $ zip [idx+1..] xs2 + xs1' = filterPosList pss 0 xs1 + xs2' = filterPosList pss (idx+1) xs2 +-- | Filter the list of hypotheses in a sequent, retaining +-- only those in the given set. filterHyps :: CofinSet Integer -> Sequent -> Sequent filterHyps pss (UnfocusedSequent hs gs) = - UnfocusedSequent (filterPosList pss hs) gs + UnfocusedSequent (filterPosList pss 0 hs) gs filterHyps pss (GoalFocusedSequent hs gs) = - GoalFocusedSequent (filterPosList pss hs) gs + GoalFocusedSequent (filterPosList pss 0 hs) gs filterHyps pss (HypFocusedSequent hs gs) = case filterFocusedList pss hs of - Left hs' -> UnfocusedSequent hs' gs + Left hs' -> UnfocusedSequent hs' gs Right hs' -> HypFocusedSequent hs' gs +-- | Filter the list of conclusions in a sequent, retaining +-- only those in the given set. filterGoals :: CofinSet Integer -> Sequent -> Sequent filterGoals pss (UnfocusedSequent hs gs) = - UnfocusedSequent hs (filterPosList pss gs) + UnfocusedSequent hs (filterPosList pss 0 gs) filterGoals pss (HypFocusedSequent hs gs) = - HypFocusedSequent hs (filterPosList pss gs) + HypFocusedSequent hs (filterPosList pss 0 gs) filterGoals pss (GoalFocusedSequent hs gs) = case filterFocusedList pss gs of - Left gs' -> UnfocusedSequent hs gs' + Left gs' -> UnfocusedSequent hs gs' Right gs' -> GoalFocusedSequent hs gs' +-- | Add a new hypothesis to the list of hypotheses in a sequent addHypothesis :: Prop -> Sequent -> Sequent addHypothesis p (UnfocusedSequent hs gs) = UnfocusedSequent (hs ++ [p]) gs addHypothesis p (GoalFocusedSequent hs gs) = GoalFocusedSequent (hs ++ [p]) gs addHypothesis p (HypFocusedSequent (FB hs1 h hs2) gs) = HypFocusedSequent (FB hs1 h (hs2++[p])) gs +-- | Add a new conclusion to the end of the conclusion list and focus on it addNewFocusedGoal :: Prop -> Sequent -> Sequent addNewFocusedGoal p sqt = let RawSequent hs gs = sequentToRawSequent sqt in GoalFocusedSequent hs (FB gs p []) -- | If the sequent is focused, return the prop under focus, --- together with it's index value. +-- together with its index value. -- A @Left@ value indicates a hypothesis under focus, and --- a @Right@ value is a goal under focus. +-- a @Right@ value is a conclusion under focus. sequentGetFocus :: Sequent -> Maybe (Either (Integer,Prop) (Integer, Prop)) sequentGetFocus (UnfocusedSequent _ _) = Nothing @@ -701,6 +808,10 @@ sequentTreeSize sqt = scTreeSizeMany (map unProp (hs ++ gs)) where RawSequent hs gs = sequentToRawSequent sqt +-- | Given an operation on propositions, apply the operation to the sequent. +-- If the sequent is focused, apply the operation just to the focused +-- hypothesis or conclusion. If the sequent is unfocused, apply the operation +-- to all the hypotheses and conclusions in the sequent. traverseSequentWithFocus :: Applicative m => (Prop -> m Prop) -> Sequent -> m Sequent traverseSequentWithFocus f (UnfocusedSequent hs gs) = UnfocusedSequent <$> traverse f hs <*> traverse f gs @@ -709,6 +820,8 @@ traverseSequentWithFocus f (GoalFocusedSequent hs (FB gs1 g gs2)) = traverseSequentWithFocus f (HypFocusedSequent (FB hs1 h hs2) gs) = (\h' -> HypFocusedSequent (FB hs1 h' hs2) gs) <$> f h +-- | Given an operation on propositions, apply the operation to all the +-- hypotheses and conclusions in the sequent. traverseSequent :: Applicative m => (Prop -> m Prop) -> Sequent -> m Sequent traverseSequent f (UnfocusedSequent hs gs) = UnfocusedSequent <$> traverse f hs <*> traverse f gs @@ -716,12 +829,15 @@ traverseSequent f (GoalFocusedSequent hs (FB gs1 g gs2)) = GoalFocusedSequent <$> (traverse f hs) <*> ( FB <$> traverse f gs1 <*> f g <*> traverse f gs2) - traverseSequent f (HypFocusedSequent (FB hs1 h hs2) gs) = HypFocusedSequent <$> ( FB <$> traverse f hs1 <*> f h <*> traverse f hs2) <*> (traverse f gs) +-- | Typecheck a sequent. This will typecheck all the terms +-- appearing in the sequent to ensure that they are propositions. +-- This check should always succeed, unless some programming +-- mistake has allowed us to build an ill-typed sequent. checkSequent :: SharedContext -> PPOpts -> Sequent -> IO () checkSequent sc ppOpts (UnfocusedSequent hs gs) = do forM_ hs (checkProp sc ppOpts) @@ -737,6 +853,9 @@ checkSequent sc ppOpts (HypFocusedSequent (FB hs1 h hs2) gs) = forM_ hs2 (checkProp sc ppOpts) forM_ gs (checkProp sc ppOpts) +-- | Check that a @Prop@ value is actually a proposition. +-- This check should always succeed, unless some programming +-- mistake has allowed us to build an ill-typed Prop. checkProp :: SharedContext -> PPOpts -> Prop -> IO () checkProp sc ppOpts (Prop t) = do ty <- TC.scTypeCheckError sc t @@ -763,6 +882,10 @@ data Theorem = , _thmSummary :: TheoremSummary } -- INVARIANT: the provided evidence is valid for the included proposition +-- | A theorem database is intended to track theorems that may be used +-- in the proof of later theorems or verification conditions. This is +-- ultimately used to produce verification summaries, which capture +-- the dependency graph between theorems and verifications. data TheoremDB = TheoremDB -- TODO, maybe this should be a summary or something simpler? @@ -777,6 +900,10 @@ recordTheorem db thm@Theorem{ _thmNonce = n } = do modifyIORef (theoremMap db) (Map.insert n thm) return thm +-- | Given a set of root values, find all the theorems in this database +-- that are transitively used in the proofs of those theorems. +-- This function will panic if any of the roots or reachable theorems +-- are not found in the database. reachableTheorems :: TheoremDB -> Set TheoremNonce -> IO (Map TheoremNonce Theorem) reachableTheorems db roots = do m <- readIORef (theoremMap db) @@ -797,12 +924,10 @@ reachableTheorems db roots = -- | Check that the purported theorem is valid. -- --- This checks that the given theorem object does not correspond --- to a local assumption that has been leaked from its scope, --- and validates that the included evidence actually supports +-- This validates that the included evidence actually supports -- the proposition. Note, however, this validation procedure -- does not totally guarantee the theorem is true, as it does --- not rerun any solver-provided proofs, and it accepts admitted +-- not verify any solver-provided proofs, and it accepts admitted -- propositions and quickchecked propositions as valid. validateTheorem :: SharedContext -> TheoremDB -> Theorem -> IO () @@ -810,7 +935,7 @@ validateTheorem sc db Theorem{ _thmProp = p, _thmEvidence = e, _thmDepends = thm do hyps <- Map.keysSet <$> readIORef (theoremMap db) (deps,_) <- checkEvidence sc e p unless (Set.isSubsetOf deps thmDep && Set.isSubsetOf thmDep hyps) - (fail $ unlines ["Theorem failed to declare its depencences correctly" + (fail $ unlines ["Theorem failed to declare its dependencies correctly" , show deps, show thmDep ]) data TheoremSummary @@ -833,81 +958,89 @@ instance Semigroup TheoremSummary where -- | This datatype records evidence for the truth of a proposition. data Evidence = -- | The given term provides a direct programs-as-proofs witness - -- for the truth of its type (qua proposition). + -- for the truth of its type (qua proposition). This will + -- succeed when applied to sequent with a conclusion focus whose + -- statement matches the type of the given term. ProofTerm !Term - -- | This type of evidence is produced when the given proposition + -- | This type of evidence is produced when the given sequent -- has been dispatched to a solver which has indicated that it - -- was able to prove the proposition. The included @SolverStats@ + -- was able to prove the sequent. The included @SolverStats@ -- give some details about the solver run. | SolverEvidence !SolverStats !Sequent - -- | This type of evidence is produced when the given proposition + -- | This type of evidence is produced when the given sequent -- has been randomly tested against input vectors in the style - -- of quickcheck. The included number is the number of successfully + -- of quickcheck. The included number is the number of successfully -- passed test vectors. | QuickcheckEvidence !Integer !Sequent - -- | This type of evidence is produced when the given proposition - -- has been explicitly assumed without other evidence at the + -- | This type of evidence is produced when the given sequent + -- has been explicitly assumed without other evidence, at the -- user's direction. | Admitted !Text !Pos !Sequent - -- | This type of evidence is produced when a proposition can be deconstructed - -- along a conjunction into two subgoals, each of which is supported by - -- the included evidence. + -- | This type of evidence is produced when the focused hypothesis + -- or conclusion proposition can be deconstructed (along a + -- conjunction, disjunction, if/then/else or implication) into + -- two subgoals, each of which is supported by the included + -- evidence. | SplitEvidence !Evidence !Evidence - -- | This type of evidence is produced when a previously-proved theorem is - -- 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. + -- | This type of evidence is produced when a previously-proved + -- theorem is applied via backward reasoning to prove a focused + -- conclusion. 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 produced when a local hypothesis is applied - -- via backward reasoning to prove a goal. Pi-quantified variables - -- of the hypothesis 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. + -- | This type of evidence is produced when a local hypothesis is + -- applied via backward reasoning to prove a focused conclusion. + -- Pi-quantified variables of the hypothesis 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. | ApplyHypEvidence Integer ![Either Term Evidence] - -- | This type of evidence is used to prove a universally-quantified statement. + -- | This type of evidence is used to prove a universally-quantified conclusion. + -- The included ExtCns should be a fresh variable used to instantiate the + -- quantified proposition. | IntroEvidence !(ExtCns Term) !Evidence -- | This type of evidence is used to apply the "cut rule" of sequent calculus. -- The given proposition is added to the hypothesis list in the first - -- deriviation, and into the conclusion list in the second, where it is focused. + -- derivation, and into the conclusion list in the second, where it is focused. | CutEvidence !Prop !Evidence !Evidence - -- | This type of evidence is used to modify a goal to prove via rewriting. - -- The goal to prove is rewritten by the given simpset; then the provided - -- evidence is used to check the modified goal. - -- The list of integers indicate local hypotheses that should also - -- be treated as rewrites. + -- | This type of evidence is used to modify a sequent to prove via + -- rewriting. The sequent is rewritten by the given + -- simpset; then the provided evidence is used to check the + -- modified sequent. The list of integers indicate local + -- hypotheses that should also be treated as rewrite rules. | RewriteEvidence ![Integer] !(Simpset TheoremNonce) !Evidence - -- | This type of evidence is used to modify a goal to prove via unfolding - -- constant definitions. The goal to prove is modified by unfolding + -- | This type of evidence is used to modify a sequent via unfolding + -- constant definitions. The sequent is modified by unfolding -- constants identified via the given set of @VarIndex@; then the provided - -- evidence is used to check the modified goal. + -- evidence is used to check the modified sequent. | UnfoldEvidence !(Set VarIndex) !Evidence - -- | This type of evidence is used to modify a goal to prove via evaluation + -- | This type of evidence is used to modify a sequent via evaluation -- into the the What4 formula representation. During evaluation, the -- constants identified by the given set of @VarIndex@ are held -- uninterpreted (i.e., will not be unfolded). Then, the provided - -- evidence is use to check the modified goal. + -- evidence is use to check the modified sequent. | EvalEvidence !(Set VarIndex) !Evidence - -- | This type of evidence is used to modify a focused part of the goal. - -- The modified goal should be equivalent up to conversion. + -- | This type of evidence is used to modify a focused part of the sequent. + -- The modified sequent should be equivalent up to conversion. | ConversionEvidence !Sequent !Evidence -- | This type of evidence is used to modify a goal to prove by applying - -- 'hoistIfsInGoal'. + -- 'hoistIfsInGoal'. | HoistIfsEvidence !Evidence -- | Change the state of the sequent in some "structural" way. This @@ -915,12 +1048,12 @@ data Evidence | StructuralEvidence !Sequent !Evidence -- | Change the state of the sequent in some way that is governed by - -- the "reversable" L/R rules of the sequent calculus, e.g., + -- the "reversible" L/R rules of the sequent calculus, e.g., -- conjunctions in hypotheses can be split into multiple hypotheses, -- negated conclusions become positive hypotheses, etc. | NormalizeSequentEvidence !Sequent !Evidence - -- | Change the sate of th sequent by invoking the term evaluator + -- | Change the state of the sequent by invoking the term evaluator -- on the focused sequent branch (or all branches, if unfocused). -- Treat the given variable indexes as opaque. | NormalizePropEvidence !(Set VarIndex) !Evidence @@ -1166,7 +1299,7 @@ predicateToProp sc quant = loop [] Prop <$> toPi argTs t --- | A ProofState consists of a sequents of goals, represented by sequents. +-- | A ProofState consists of a sequence of goals, each represented by a sequent. -- If each subgoal is provable, that implies the ultimate conclusion. data ProofState = ProofState @@ -1197,6 +1330,9 @@ propsElem :: SharedContext -> Prop -> [Prop] -> IO Bool propsElem sc x ps = or <$> sequence [ scConvertible sc True (unProp x) (unProp y) | y <- ps ] +-- | Test if a sequent is an instance of the sequent calculus axiom. +-- This occurs precisely when some hypothesis is convertible +-- to some conclusion. sequentIsAxiom :: SharedContext -> Sequent -> IO Bool sequentIsAxiom sc sqt = do let RawSequent hs gs = sequentToRawSequent sqt @@ -1204,8 +1340,8 @@ sequentIsAxiom sc sqt = -- | Test if the first given sequent subsumes the -- second given sequent. This is a shallow syntactic --- check that is sufficent to show that a proof --- of the first sequent is sufficent to prove the second +-- check that is sufficient to show that a proof +-- of the first sequent is sufficient to prove the second sequentSubsumes :: SharedContext -> Sequent -> Sequent -> IO Bool sequentSubsumes sc sqt1 sqt2 = do let RawSequent hs1 gs1 = sequentToRawSequent sqt1 @@ -1216,8 +1352,8 @@ sequentSubsumes sc sqt1 sqt2 = -- | Test if the first given sequent subsumes the -- second given sequent. This is a shallow syntactic --- check that is sufficent to show that a proof --- of the first sequent is sufficent to prove the second +-- check that is sufficient to show that a proof +-- of the first sequent is sufficient to prove the second normalizeSequentSubsumes :: SharedContext -> Sequent -> Sequent -> IO Bool normalizeSequentSubsumes sc sqt1 sqt2 = do RawSequent hs1 gs1 <- normalizeRawSequent sc (sequentToRawSequent sqt1) @@ -1226,6 +1362,29 @@ normalizeSequentSubsumes sc sqt1 sqt2 = conclOK <- propsSubset sc gs1 gs2 return (hypsOK && conclOK) +-- | Computes a "normalized" sequent. This applies the reversible +-- L/R sequent calculus rules listed below. The resulting sequent +-- is always unfocused. +-- +-- HS1, X, Y, HS2 |- GS +-- ---------------------- (Conj-L) +-- HS1, X /\ Y, HS2 |- GS +-- +-- HS |- GS1, X, Y, GS2 +-- ---------------------- (Disj-R) +-- HS |- GS1, X \/ Y, GS2 +-- +-- HS, X |- GS1, GS2 +-- -------------------------- (Neg-R) +-- HS |- GS1, not X, GS2 +-- +-- HS1, HS2 |- GS, X +-- -------------------------- (Neg-L) +-- HS1, not X, HS2 |- GS +-- +-- HS, X |- GS1, Y, GS2 +-- -------------------------- (Impl-R) +-- HS |- GS1, X -> Y, GS2 normalizeSequent :: SharedContext -> Sequent -> IO Sequent normalizeSequent sc sqt = -- TODO, if/when we add metadata to sequent branches, this will need to change @@ -1264,7 +1423,9 @@ normalizeGoal sc p = _ -> -- handle the case of (H1 -> H2), where H1 and H2 are in Prop case asPi t of - Just (_nm, arg, body) | looseVars body == emptyBitSet -> + Just (_nm, arg, body) + -- check that this is non-dependent Pi (AKA arrow type) + | looseVars body == emptyBitSet -> termToMaybeProp sc arg >>= \case Nothing -> return (RawSequent [] [p]) Just h -> @@ -1315,7 +1476,7 @@ normalizeGoalBoolCommit sc b = -- | Verify that the given evidence in fact supports the given proposition. --- Returns the identifers of all the theorems depended on while checking evidence. +-- Returns the identifiers of all the theorems depended on while checking evidence. checkEvidence :: SharedContext -> Evidence -> Prop -> IO (Set TheoremNonce, TheoremSummary) checkEvidence sc = \e p -> do nenv <- scGetNamingEnv sc check nenv e (propToSequent p) @@ -1338,7 +1499,7 @@ checkEvidence sc = \e p -> do nenv <- scGetNamingEnv sc , showTerm p ] - -- Check a theorem applied to a term. This explicity instantiates + -- Check a theorem applied to a term. This explicitly instantiates -- a Pi binder with the given term. checkApply nenv mkSqt (Prop p) (Left tm:es) = do propTerm <- scSort sc propSort @@ -1556,10 +1717,17 @@ startProof g pos ploc rsn = -- proposition. If successful, return the completed @Theorem@ and a summary -- of solver resources used in the proof. -- --- If the final boolean argument is False, the resulting theorem will not be +-- If first boolean argument is False, the resulting theorem will not be -- recored in the theorem database. This should only be done when you are -- sure that the theorem will not be used as part of the proof of other theorems, --- or later steps will fail. +-- or later steps will fail. This is intended for proofs of verification conditions, +-- which are not exposed for reuse, and where it requires a significant memory +-- burden to record them. +-- +-- The final boolean argument indicates if the proof state needs a sequent normalization +-- step as the final step in its evidence chain to check. This is useful for goals that +-- start with a nontrivial sequent (e.g., when enable_sequent_goals is turned on). For some +-- goals, this step is expensive, so we avoid it unless necessary. finishProof :: SharedContext -> TheoremDB -> @@ -1718,12 +1886,12 @@ sequentToSATQuery sc unintSet sqt = _ -> processUnivAssert mmap [] [] tp processUnivAssert mmap vars xs tm = - do -- TODO: See related TODO in processTerm + do -- TODO: See related TODO in processGoal let tm' = tm case asPi tm' of Just (lnm, tp, body) -> - do -- TOOD, same issure + do -- TOOD, same issue let tp' = tp case evalFOT mmap tp' of Just fot -> @@ -1746,7 +1914,7 @@ sequentToSATQuery sc unintSet sqt = Just tmBool -> return (UniversalAssert (reverse vars) (reverse xs) tmBool) processGoal mmap (vars,xs) tm = - do -- TODO: I would like to WHNF here, but that evalutes too aggressively + do -- TODO: I would like to WHNF here, but that evaluates too aggressively -- because scWhnf evaluates strictly through the `Eq` datatype former. -- This breaks some proof examples by unfolding things that need to -- be uninterpreted. @@ -1898,7 +2066,7 @@ tacticApplyHyp sc n = Tactic \goal -> , goalType = goalType goal ++ ".subgoal" ++ show i } | Right p <- newterms - | i <- [0::Integer ] + | i <- [0::Integer ..] ] in return ((), mempty, newgoals, \es -> ApplyHypEvidence n <$> processEvidence newterms es) _ -> fail "apply hyp tactic: not enough hypotheses" @@ -1969,6 +2137,15 @@ tacticInsert _sc thm = Tactic \gl -> gl' = gl{ goalSequent = sqt } in return ((), mempty, [gl'], insertEvidence thm) +-- | This tactic implements the "cut rule" of sequent calculus. The given +-- proposition is used to split the current goal into two goals, one where +-- the given proposition is assumed as a new hypothesis, and a second +-- where the proposition is added as a new conclusion to prove. +-- +-- HS, X |- GS +-- HS |- GS, X +-- ------------------ (Cut) +-- HS |- GS tacticCut :: (F.MonadFail m, MonadIO m) => SharedContext -> Prop -> Tactic m () tacticCut _sc p = Tactic \gl -> let sqt1 = addHypothesis p (goalSequent gl) From a0e5d5107b042054a88139b503fe617a33d1e6eb Mon Sep 17 00:00:00 2001 From: Rob Dockins Date: Thu, 25 Aug 2022 16:05:32 -0700 Subject: [PATCH 28/35] Introduce a record type for `VCStats` and add comments. --- src/SAWScript/Crucible/Common/MethodSpec.hs | 14 +++++++++++++- src/SAWScript/Crucible/JVM/Builtins.hs | 2 +- src/SAWScript/Crucible/LLVM/Builtins.hs | 2 +- src/SAWScript/Crucible/LLVM/X86.hs | 2 +- src/SAWScript/VerificationSummary.hs | 20 ++++++++++---------- 5 files changed, 26 insertions(+), 14 deletions(-) diff --git a/src/SAWScript/Crucible/Common/MethodSpec.hs b/src/SAWScript/Crucible/Common/MethodSpec.hs index 9962484da7..f80c3c24e0 100644 --- a/src/SAWScript/Crucible/Common/MethodSpec.hs +++ b/src/SAWScript/Crucible/Common/MethodSpec.hs @@ -362,7 +362,19 @@ data ProofMethod type SpecNonce ext = Nonce GlobalNonceGenerator (ProvedSpec ext) -type VCStats = (ConditionMetadata, SolverStats, TheoremSummary, TheoremNonce, Set TheoremNonce, NominalDiffTime) +-- | Data collected about discharged verification conditions (VCs). +-- Verification conditions arise when proving function specifications +-- due to, e.g., safety conditions, specification postconditions, and +-- preconditions of called override functions. +data VCStats = + VCStats + { vcMetadata :: ConditionMetadata -- ^ Metadata describing why the VC arose + , vcSolverStats :: SolverStats -- ^ Statistics about any solvers used when proving this VC + , vcThmSummary :: TheoremSummary -- ^ A summary of the proof status of this VC + , vcIdent :: TheoremNonce -- ^ A unique identifier for this VC + , vcDeps :: Set TheoremNonce -- ^ A collection of the theorems the proof of this VC relied on + , vcElapsedTime :: NominalDiffTime -- ^ The time required to prove this VC + } data ProvedSpec ext = ProvedSpec diff --git a/src/SAWScript/Crucible/JVM/Builtins.hs b/src/SAWScript/Crucible/JVM/Builtins.hs index 483ff2e2cc..e38b41555d 100644 --- a/src/SAWScript/Crucible/JVM/Builtins.hs +++ b/src/SAWScript/Crucible/JVM/Builtins.hs @@ -323,7 +323,7 @@ verifyObligations cc mspec tactic assumes asserts = False -- TODO, useSequentGoals... case res of ValidProof stats thm -> - return (stats, (md, stats, thmSummary thm, thmNonce thm, thmDepends thm, thmElapsedTime thm)) + return (stats, MS.VCStats md stats (thmSummary thm) (thmNonce thm) (thmDepends thm) (thmElapsedTime thm)) InvalidProof stats vals _pst -> do printOutLnTop Info $ unwords ["Subgoal failed:", nm, msg] printOutLnTop Info (show stats) diff --git a/src/SAWScript/Crucible/LLVM/Builtins.hs b/src/SAWScript/Crucible/LLVM/Builtins.hs index 0f1867546e..732401b9f8 100644 --- a/src/SAWScript/Crucible/LLVM/Builtins.hs +++ b/src/SAWScript/Crucible/LLVM/Builtins.hs @@ -814,7 +814,7 @@ verifyObligations cc mspec tactic assumes asserts = useSequentGoals case res of ValidProof stats thm -> - return (stats, (md, stats, thmSummary thm, thmNonce thm, thmDepends thm, thmElapsedTime thm)) + return (stats, MS.VCStats md stats (thmSummary thm) (thmNonce thm) (thmDepends thm) (thmElapsedTime thm)) UnfinishedProof pst -> do printOutLnTop Info $ unwords ["Subgoal failed:", nm, msg] throwTopLevel $ "Proof failed " ++ show (length (psGoals pst)) ++ " goals remaining." diff --git a/src/SAWScript/Crucible/LLVM/X86.hs b/src/SAWScript/Crucible/LLVM/X86.hs index 2cc9772b07..bfa5330e36 100644 --- a/src/SAWScript/Crucible/LLVM/X86.hs +++ b/src/SAWScript/Crucible/LLVM/X86.hs @@ -1206,7 +1206,7 @@ checkGoals bak opts nm sc tactic mdMap = do False -- TODO! useSequentGoals case res of ValidProof stats thm -> - return (stats, (md, stats, thmSummary thm, thmNonce thm, thmDepends thm, thmElapsedTime thm)) + return (stats, MS.VCStats md stats (thmSummary thm) (thmNonce thm) (thmDepends thm) (thmElapsedTime thm)) UnfinishedProof pst -> do printOutLnTop Info $ unwords ["Subgoal failed:", show $ gMessage g] printOutLnTop Info (show (psStats pst)) diff --git a/src/SAWScript/VerificationSummary.hs b/src/SAWScript/VerificationSummary.hs index 2962e67a62..41609d777a 100644 --- a/src/SAWScript/VerificationSummary.hs +++ b/src/SAWScript/VerificationSummary.hs @@ -63,8 +63,8 @@ vsAllSolvers vs = Set.union (vsVerifSolvers vs) (vsTheoremSolvers vs) computeVerificationSummary :: TheoremDB -> [JVMTheorem] -> [LLVMTheorem] -> [Theorem] -> IO VerificationSummary computeVerificationSummary db js ls thms = do let roots = mconcat ( - [ xs | j <- js, (_,_,_,_,xs,_) <- j^.psVCStats ] ++ - [ xs | CMSLLVM.SomeLLVM l <- ls, (_,_,_,_,xs,_) <- l^.psVCStats ] ++ + [ vcDeps vc | j <- js, vc <- j^.psVCStats ] ++ + [ vcDeps vc | CMSLLVM.SomeLLVM l <- ls, vc <- l^.psVCStats ] ++ [ Set.singleton (thmNonce t) | t <- thms ]) thms' <- Map.elems <$> reachableTheorems db roots pure (VerificationSummary js ls thms') @@ -86,15 +86,15 @@ msToJSON cms = object [ ] vcToJSON :: CMS.VCStats -> Value -vcToJSON (cmd, _stats, thmsummary, nonce, deps, elapsedtime) = object ([ +vcToJSON vc = object ([ ("type" .= ("vc" :: String)) - , ("id" .= indexValue nonce) - , ("loc" .= show (conditionLoc cmd)) - , ("reason" .= conditionType cmd) - , ("elapsedtime" .= toJSON elapsedtime) - , ("dependencies" .= toJSON (map indexValue (Set.toList deps))) - , ("tags" .= toJSON (Set.toList (conditionTags cmd))) - ] ++ theoremStatus thmsummary + , ("id" .= indexValue (vcIdent vc)) + , ("loc" .= show (conditionLoc (vcMetadata vc))) + , ("reason" .= conditionType (vcMetadata vc)) + , ("elapsedtime" .= toJSON (vcElapsedTime vc)) + , ("dependencies" .= toJSON (map indexValue (Set.toList (vcDeps vc)))) + , ("tags" .= toJSON (Set.toList (conditionTags (vcMetadata vc)))) + ] ++ theoremStatus (vcThmSummary vc) ) thmToJSON :: Theorem -> Value From 6d42e32cb97cbf4d1b598c0d1395d45b091ba0e3 Mon Sep 17 00:00:00 2001 From: Rob Dockins Date: Thu, 25 Aug 2022 16:40:27 -0700 Subject: [PATCH 29/35] More inline comments about how the bitvector induction command works. --- src/SAWScript/Builtins.hs | 53 ++++++++++++++++++++++++++++++++++++++- 1 file changed, 52 insertions(+), 1 deletion(-) diff --git a/src/SAWScript/Builtins.hs b/src/SAWScript/Builtins.hs index 32cc492703..a8efc6de7d 100644 --- a/src/SAWScript/Builtins.hs +++ b/src/SAWScript/Builtins.hs @@ -1191,6 +1191,8 @@ proveHelper nm script t f = do InvalidProof _stats _cex pst -> failProof pst UnfinishedProof pst -> failProof pst +-- | See the inline help for 'prove_by_bv_induction' in the interpreter +-- for a description of what this is doing. proveByBVInduction :: ProofScript () -> TypedTerm -> @@ -1208,9 +1210,18 @@ proveByBVInduction script t = -- induction principle for the user-given theorem statement. -- I don't know offhand of a less gross way to do this. + -- The basic pattern closely follows the definition of BV_complete_induction + -- from the SAWCore prelude. Here, we reproduce the statement of the corresponding + -- parts of BV_complete_induction to give a sense of what term we intend to produce + -- in each of the following sub-parts. + do wt <- io $ scNat sc w natty <- io $ scNatType sc toNat <- io $ scGlobalDef sc "Prelude.bvToNat" + + -- The result type of the theorem. + -- + -- (x : Vec w Bool) -> p x thmResult <- io $ do vars <- reverse <$> mapM (scLocalVar sc) [ 0 .. length pis - 1] t1 <- scApplyAllBeta sc (ttTerm t) vars @@ -1219,6 +1230,11 @@ proveByBVInduction script t = _ <- scTypeCheckError sc t3 -- sanity check return t3 + -- The type of the main hypothesis to the induction scheme. This is what + -- the user will ultimately be asked to prove. Note that this includes + -- the induction hypothesis. + -- + -- ((x : Vec w Bool) -> ((y: Vec w Bool) -> is_bvult w y x -> p y) -> p x) thmHyp <- io $ do vars <- reverse <$> mapM (scLocalVar sc) [ 0 .. length pis - 1] t1 <- scApplyAllBeta sc (ttTerm t) vars @@ -1235,6 +1251,9 @@ proveByBVInduction script t = touter <- scPi sc "_" thyp =<< incVars sc 0 1 tbody scPiList sc pis touter + -- The "motive" we will pass to the 'Nat_complete_induction' principle. + -- + -- (\ (n:Nat) -> (x:Vec w Bool) -> IsLeNat (bvToNat w x) n -> p x) indMotive <- io $ do vars <- reverse <$> mapM (scLocalVar sc) [ 0 .. length pis-1 ] indVar <- scLocalVar sc (length pis) @@ -1247,7 +1266,22 @@ proveByBVInduction script t = t3 <- scPiList sc pis t2 scLambda sc "inductionVar" natty t3 - indHypProof <- io $ -- scFreshGlobal sc "H" =<< scPi sc "_" thmHyp indHyp + -- This is the most complicated part of building the induction schema. Here we provide + -- the proof term required by 'Nat_complete_induction' that shows how to reduce our + -- current specific case to induction on natural numbers. + -- + -- \ (H: (x : Vec w Bool) -> ((y: Vec w Bool) -> is_bvult w y x -> p y) -> p x) + -- \ (n:Nat) -> + -- \ (Hind : (m : Nat) -> (Hm : IsLtNat m n) -> (y : Vec w Bool) -> + -- (Hy : IsLeNat (bvToNat w y) m) -> p y) -> + -- \ (x : Vec w Bool) -> + -- \ (Hx : IsLeNat (bvToNat w x) n) -> + -- H x (\ (y:Vec w Bool) -> \ (Hult : is_bvult w y x) -> + -- Hind (bvToNat w y) + -- (IsLeNat_transitive (Succ (bvToNat w y)) (bvToNat w x) n (bvultToIsLtNat w y x Hult) Hx) + -- y (IsLeNat_base (bvToNat w y))) + + indHypProof <- io $ do hEC <- scFreshEC sc "H" thmHyp hVar <- scExtCns sc hEC nEC <- scFreshEC sc "n" natty @@ -1292,6 +1326,11 @@ proveByBVInduction script t = scAbstractExts sc ([hEC, nEC, hindEC] ++ varECs ++ [leEC]) body + -- Now we put all the pieces together + -- + -- \ (Hind : (x : Vec w Bool) -> ((y: Vec w Bool) -> is_bvult w y x -> p y) -> p x) -> + -- \ (x : Vec x Bool) -> + -- Nat_complete_induction indMotive (indHypProof Hind) (bvToNat w x) x (IsLeNat_base (bvToNat w x)) indApp <- io $ do vars <- reverse <$> mapM (scLocalVar sc) [ 0 .. length pis-1 ] varH <- scLocalVar sc (length pis) @@ -1309,12 +1348,24 @@ proveByBVInduction script t = indAppTT <- io $ mkTypedTerm sc indApp + -- First produce a theorem value for our custom induction schemd by providing the + -- above as direct proof term. ind_scheme_goal <- io $ scFun sc thmHyp thmResult ind_scheme_theorem <- proveHelper "bv_induction_scheme" (goal_exact indAppTT) ind_scheme_goal (io . termToProp sc) + + -- Now, set up a proof to actually prove the statement of interest by first immediately applying + -- our constructed induction schema, and then using the user-provided proof script. let script' = goal_apply ind_scheme_theorem >> script proveHelper "prove_by_bv_induction" script' thmResult (io . termToProp sc) where + -- Here, we expect to see a collection of lambda bound terms, followed + -- by a tuple. The first component must be a bitvector value, defining + -- the value we are performing induction on. The second component is + -- a boolean value defining the proposition we are attempting to prove. + -- + -- Return a list of the names and types of the lambda-bound variables, + -- and the width of the bitvector we are doing induction on. checkInductionScheme sc opts pis ty = do ty' <- scWhnf sc ty case asPi ty' of From c106409d77ce27e7dc5749419b54eb3f0dd363c1 Mon Sep 17 00:00:00 2001 From: Rob Dockins Date: Thu, 25 Aug 2022 16:41:41 -0700 Subject: [PATCH 30/35] Uniformly use "conclusion" instead of "goal" where appropriate in the external API of the Proof module. We still need to correct the terminology within the module itself. --- src/SAWScript/Builtins.hs | 6 +++--- src/SAWScript/Proof.hs | 16 ++++++++-------- 2 files changed, 11 insertions(+), 11 deletions(-) diff --git a/src/SAWScript/Builtins.hs b/src/SAWScript/Builtins.hs index a8efc6de7d..7f6f799d9d 100644 --- a/src/SAWScript/Builtins.hs +++ b/src/SAWScript/Builtins.hs @@ -579,7 +579,7 @@ unfocus = focus_concl :: Integer -> ProofScript () focus_concl i = execTactic $ tacticChange $ \goal -> - case focusOnGoal i (goalSequent goal) of + case focusOnConcl i (goalSequent goal) of Nothing -> fail "focus_concl : not enough conclusions" Just sqt' -> return (sqt', structuralEvidence sqt') @@ -605,13 +605,13 @@ retain_hyps hs = delete_concl :: [Integer] -> ProofScript () delete_concl gs = execTactic $ tacticChange $ \goal -> - let sqt' = filterGoals (BlackList (Set.fromList gs)) (goalSequent goal) + let sqt' = filterConcls (BlackList (Set.fromList gs)) (goalSequent goal) in return (sqt', structuralEvidence sqt') retain_concl :: [Integer] -> ProofScript () retain_concl gs = execTactic $ tacticChange $ \goal -> - let sqt' = filterGoals (WhiteList (Set.fromList gs)) (goalSequent goal) + let sqt' = filterConcls (WhiteList (Set.fromList gs)) (goalSequent goal) in return (sqt', structuralEvidence sqt') diff --git a/src/SAWScript/Proof.hs b/src/SAWScript/Proof.hs index 23b097f444..53e0d9c1f1 100644 --- a/src/SAWScript/Proof.hs +++ b/src/SAWScript/Proof.hs @@ -49,11 +49,11 @@ module SAWScript.Proof , sequentConstantSet , booleansToSequent , unfocusSequent - , focusOnGoal + , focusOnConcl , focusOnHyp , normalizeSequent , filterHyps - , filterGoals + , filterConcls , localHypSimpset , CofinSet(..) @@ -580,8 +580,8 @@ unfocusSequent :: Sequent -> Sequent unfocusSequent sqt = UnfocusedSequent hs gs where RawSequent hs gs = sequentToRawSequent sqt -focusOnGoal :: Integer -> Sequent -> Maybe Sequent -focusOnGoal i sqt = +focusOnConcl :: Integer -> Sequent -> Maybe Sequent +focusOnConcl i sqt = let RawSequent hs gs = sequentToRawSequent sqt in case genericSplitAt i gs of (gs1, g:gs2) -> Just (GoalFocusedSequent hs (FB gs1 g gs2)) @@ -757,12 +757,12 @@ filterHyps pss (HypFocusedSequent hs gs) = -- | Filter the list of conclusions in a sequent, retaining -- only those in the given set. -filterGoals :: CofinSet Integer -> Sequent -> Sequent -filterGoals pss (UnfocusedSequent hs gs) = +filterConcls :: CofinSet Integer -> Sequent -> Sequent +filterConcls pss (UnfocusedSequent hs gs) = UnfocusedSequent hs (filterPosList pss 0 gs) -filterGoals pss (HypFocusedSequent hs gs) = +filterConcls pss (HypFocusedSequent hs gs) = HypFocusedSequent hs (filterPosList pss 0 gs) -filterGoals pss (GoalFocusedSequent hs gs) = +filterConcls pss (GoalFocusedSequent hs gs) = case filterFocusedList pss gs of Left gs' -> UnfocusedSequent hs gs' Right gs' -> GoalFocusedSequent hs gs' From 48b33ee05d23bc6e5d66d6958cb40ea53c240344 Mon Sep 17 00:00:00 2001 From: Rob Dockins Date: Thu, 25 Aug 2022 17:26:41 -0700 Subject: [PATCH 31/35] Tactic/proof system minor tweaks and improvements --- src/SAWScript/Builtins.hs | 14 ++++++-- src/SAWScript/Interpreter.hs | 17 ++++++++- src/SAWScript/Proof.hs | 69 +++++++++++++++++++++++++----------- 3 files changed, 77 insertions(+), 23 deletions(-) diff --git a/src/SAWScript/Builtins.hs b/src/SAWScript/Builtins.hs index 7f6f799d9d..5ac18764c6 100644 --- a/src/SAWScript/Builtins.hs +++ b/src/SAWScript/Builtins.hs @@ -828,6 +828,11 @@ goal_exact tm = do sc <- SV.scriptTopLevel getSharedContext execTactic (tacticExact sc (ttTerm tm)) +goal_intro_hyp :: ProofScript () +goal_intro_hyp = + do sc <- SV.scriptTopLevel getSharedContext + execTactic (tacticIntroHyps sc 1) + goal_intro_hyps :: Integer -> ProofScript () goal_intro_hyps n = do sc <- SV.scriptTopLevel getSharedContext @@ -846,7 +851,12 @@ goal_intro s = goal_insert :: Theorem -> ProofScript () goal_insert thm = do sc <- SV.scriptTopLevel getSharedContext - execTactic (tacticInsert sc thm) + execTactic (tacticInsert sc thm []) + +goal_insert_and_specialize :: Theorem -> [TypedTerm] -> ProofScript () +goal_insert_and_specialize thm tms = + do sc <- SV.scriptTopLevel getSharedContext + execTactic (tacticInsert sc thm (map ttTerm tms)) goal_specialize_hyp :: [TypedTerm] -> ProofScript () goal_specialize_hyp ts = @@ -1606,7 +1616,7 @@ lambdas vars tt = implies_term :: TypedTerm -> TypedTerm -> TopLevel TypedTerm implies_term x y = do sc <- getSharedContext - -- check that the given terms are props (TODO? should we relax this?) + -- check that the given terms are props _ <- io $ termToProp sc (ttTerm x) _ <- io $ termToProp sc (ttTerm y) z <- io $ scFun sc (ttTerm x) (ttTerm y) diff --git a/src/SAWScript/Interpreter.hs b/src/SAWScript/Interpreter.hs index a0bc4c38b6..2b59ca32ba 100644 --- a/src/SAWScript/Interpreter.hs +++ b/src/SAWScript/Interpreter.hs @@ -1629,7 +1629,7 @@ primitives = Map.fromList (pureVal focus_concl) Experimental [ "Focus on the numbered conclusion within a sequent. This will fail if there are" - , "not enough goals." + , "not enough conclusions." ] , prim "focus_hyp" "Int -> ProofScript ()" @@ -1731,6 +1731,14 @@ primitives = Map.fromList , "This will succeed if the type of the given term matches the current goal." ] + , prim "goal_intro_hyp" "ProofScript ()" + (pureVal goal_intro_hyp) + Experimental + [ "When focused on a conclusion that represents an implication," + , "simplify the conclusion by removing the implication and introducing" + , "a new sequent hypothesis instead." + ] + , prim "goal_intro_hyps" "Int -> ProofScript ()" (pureVal goal_intro_hyps) Experimental @@ -1754,6 +1762,13 @@ primitives = Map.fromList [ "Insert a Theorem as a new hypothesis in the current proof goal." ] + , prim "goal_insert_and_specialize" "Theorem -> [Term] -> ProofScript ()" + (pureVal goal_insert_and_specialize) + Experimental + [ "Insert a Theorem as a new hypothesis in the current proof goal, after" + , "specializing some of its universal quantifiers using the given terms." + ] + , prim "goal_apply_hyp" "Int -> ProofScript ()" (pureVal goal_apply_hyp) Experimental diff --git a/src/SAWScript/Proof.hs b/src/SAWScript/Proof.hs index 53e0d9c1f1..84bb8f6290 100644 --- a/src/SAWScript/Proof.hs +++ b/src/SAWScript/Proof.hs @@ -1115,9 +1115,9 @@ cutEvidence :: Prop -> [Evidence] -> IO Evidence cutEvidence p [e1,e2] = pure (CutEvidence p e1 e2) cutEvidence _ _ = fail "cutEvidence: expected two evidence values" -insertEvidence :: Theorem -> [Evidence] -> IO Evidence -insertEvidence thm [e] = pure (CutEvidence (_thmProp thm) e (ApplyEvidence thm [])) -insertEvidence _ _ = fail "insertEvidence: expected one evidence value" +insertEvidence :: Theorem -> Prop -> [Term] -> [Evidence] -> IO Evidence +insertEvidence thm h ts [e] = pure (CutEvidence h e (ApplyEvidence thm (map Left ts))) +insertEvidence _ _ _ _ = fail "insertEvidence: expected one evidence value" specializeHypEvidence :: Integer -> Prop -> [Term] -> [Evidence] -> IO Evidence specializeHypEvidence n h ts [e] = pure (CutEvidence h e (ApplyHypEvidence n (map Left ts))) @@ -1672,7 +1672,18 @@ checkEvidence sc = \e p -> do nenv <- scGetNamingEnv sc return (d1 <> d2) IntroEvidence x e' -> - -- TODO! Check that the given ExtCns is fresh for the sequent + -- TODO! Check that the given ExtCns is fresh for the sequent. + -- + -- On soundness: I am concerned that just checking that 'x' is fresh for 'sqt' + -- isn't enough, as 'x' may nonetheless appear in other values in the ambient + -- context, such as defined constants, or in the type of other things, etc. + -- + -- The most reliable way to actually do this freshness check, then, is to produce + -- a brand-new guaranteed fresh value (call it 'y') and replace 'x' with 'y' + -- everywhere in the remaining evidence checking process. This is going to require + -- quite a bit of additional infrastructure to do the necessary replacements, and we + -- will need to be pretty careful if we want to avoid repeated traversals (which + -- could cause substantial performance issues). case sequentState sqt of Unfocused -> fail "Intro evidence requires a focused sequent" HypFocus _ _ -> fail "Intro evidence apply in hypothesis" @@ -1863,7 +1874,7 @@ sequentToSATQuery sc unintSet sqt = -- NB, the following reversals make the order of assertions more closely match the input sequent, -- but should otherwise not be semantically relevant hypAsserts <- mapM (processAssert mmap) (reverse (map unProp hs)) - (finalVars, asserts) <- foldM (processGoal mmap) (initVars, hypAsserts) (map unProp gs) + (finalVars, asserts) <- foldM (processConcl mmap) (initVars, hypAsserts) (map unProp gs) return SATQuery { satVariables = finalVars , satUninterp = Set.union unintSet abstractVars @@ -1886,7 +1897,7 @@ sequentToSATQuery sc unintSet sqt = _ -> processUnivAssert mmap [] [] tp processUnivAssert mmap vars xs tm = - do -- TODO: See related TODO in processGoal + do -- TODO: See related TODO in processConcl let tm' = tm case asPi tm' of @@ -1913,7 +1924,7 @@ sequentToSATQuery sc unintSet sqt = Nothing -> fail $ "sequentToSATQuery: expected EqTrue, actual:\n" ++ showTerm tm' Just tmBool -> return (UniversalAssert (reverse vars) (reverse xs) tmBool) - processGoal mmap (vars,xs) tm = + processConcl mmap (vars,xs) tm = do -- TODO: I would like to WHNF here, but that evaluates too aggressively -- because scWhnf evaluates strictly through the `Eq` datatype former. -- This breaks some proof examples by unfolding things that need to @@ -1931,11 +1942,11 @@ sequentToSATQuery sc unintSet sqt = do ec <- scFreshEC sc lnm tp' etm <- scExtCns sc ec body' <- instantiateVar sc 0 etm body - processGoal mmap (Map.insert ec fot vars, xs) body' + processConcl mmap (Map.insert ec fot vars, xs) body' Nothing | looseVars body == emptyBitSet -> do asrt <- processAssert mmap tp - processGoal mmap (vars, asrt : xs) body + processConcl mmap (vars, asrt : xs) body | otherwise -> fail ("sequentToSATQuery: expected first order type or assertion:\n" ++ showTerm tp') @@ -1949,7 +1960,11 @@ sequentToSATQuery sc unintSet sqt = -- | 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 -> Prop -> IO (Maybe [Either Term Prop]) +goalApply :: + SharedContext -> + Prop {- ^ propsition to apply -} -> + Prop {- ^ goal to apply the proposition to -} -> + IO (Maybe [Either Term Prop]) goalApply sc rule goal = applyFirst (asPiLists (unProp rule)) where @@ -1987,7 +2002,7 @@ goalApply sc rule goal = applyFirst (asPiLists (unProp rule)) -- | Attempt to prove a universally quantified goal by introducing a fresh variable --- for the binder. Return the generated fresh term. +-- for the binder. Return the generated fresh term. tacticIntro :: (F.MonadFail m, MonadIO m) => SharedContext -> Text {- ^ Name to give to the variable. If empty, will be chosen automatically from the goal. -} -> @@ -2009,7 +2024,9 @@ tacticIntro sc usernm = Tactic \goal -> _ -> fail "intro tactic: conclusion focus required" - +-- | Given a focused conclusion, decompose the conclusion along implications by +-- introducing new hypotheses. The given integer indicates how many hypotheses +-- to introduce. tacticIntroHyps :: (F.MonadFail m, MonadIO m) => SharedContext -> Integer -> Tactic m () tacticIntroHyps sc n = Tactic \goal -> case goalSequent goal of @@ -2104,8 +2121,9 @@ tacticApply sc thm = Tactic \goal -> 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. +-- | Attempt to simplify a goal by splitting it along conjunctions, disjunctions, +-- implication or if/then/else. If successful, two subgoals will be produced, +-- representing the two subgoals that must be proved. tacticSplit :: (F.MonadFail m, MonadIO m) => SharedContext -> Tactic m () tacticSplit sc = Tactic \gl -> liftIO (splitSequent sc (goalSequent gl)) >>= \case @@ -2115,7 +2133,9 @@ tacticSplit sc = Tactic \gl -> return ((), mempty, [g1,g2], splitEvidence) Nothing -> fail "split tactic failed" - +-- | Specialize a focused hypothesis with the given terms. A new specialized +-- hypothesis will be added to the sequent; the original hypothesis will +-- remain focused. tacticSpecializeHyp :: (F.MonadFail m, MonadIO m) => SharedContext -> [Term] -> Tactic m () tacticSpecializeHyp sc ts = Tactic \gl -> @@ -2131,11 +2151,19 @@ tacticSpecializeHyp sc ts = Tactic \gl -> _ -> fail "specialize_hyp tactic failed: requires hypothesis focus" -tacticInsert :: (F.MonadFail m, MonadIO m) => SharedContext -> Theorem -> Tactic m () -tacticInsert _sc thm = Tactic \gl -> - let sqt = addHypothesis (_thmProp thm) (goalSequent gl) - gl' = gl{ goalSequent = sqt } - in return ((), mempty, [gl'], insertEvidence thm) +-- | This tactic adds a new hypothesis to the current goal by first specializing the +-- given theorem with the list of terms provided and then using cut to add the +-- hypothesis, discharging the produced additional goal by applying the theorem. +tacticInsert :: (F.MonadFail m, MonadIO m) => SharedContext -> Theorem -> [Term] -> Tactic m () +tacticInsert sc thm ts = Tactic \gl -> + do res <- liftIO (specializeProp sc (_thmProp thm) ts) + case res of + Left err -> + fail (unlines (["goal_insert_and_specialize tactic: failed to specialize"] ++ + TC.prettyTCError err)) + Right h -> + do let gl' = gl{ goalSequent = addHypothesis h (goalSequent gl) } + return ((), mempty, [gl'], insertEvidence thm h ts) -- | This tactic implements the "cut rule" of sequent calculus. The given -- proposition is used to split the current goal into two goals, one where @@ -2173,6 +2201,7 @@ tacticTrivial sc = Tactic \goal -> ] return ((), mempty, [], leafEvidence (ProofTerm pf)) +-- | Attempt to prove a goal by giving a direct proof term. tacticExact :: (F.MonadFail m, MonadIO m) => SharedContext -> Term -> Tactic m () tacticExact sc tm = Tactic \goal -> case sequentState (goalSequent goal) of From dcf32577215183aa5ce5e2d4a48d507c64937416 Mon Sep 17 00:00:00 2001 From: Rob Dockins Date: Fri, 26 Aug 2022 08:46:03 -0700 Subject: [PATCH 32/35] Whitespace, comments, minor fixes --- .../handwritten/CryptolToCoq/SAWCoreScaffolding.v | 1 - saw-core/prelude/Prelude.sawcore | 1 + saw-core/src/Verifier/SAW/SATQuery.hs | 13 +++++++++---- saw-core/src/Verifier/SAW/SharedTerm.hs | 1 + src/SAWScript/Builtins.hs | 3 ++- src/SAWScript/Crucible/LLVM/X86.hs | 2 +- src/SAWScript/Interpreter.hs | 4 +--- src/SAWScript/Proof.hs | 8 ++++++-- src/SAWScript/Prover/MRSolver/SMT.hs | 4 ++-- src/SAWScript/VerificationSummary.hs | 2 +- 10 files changed, 24 insertions(+), 15 deletions(-) diff --git a/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCoreScaffolding.v b/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCoreScaffolding.v index c6316a50ef..863033036b 100644 --- a/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCoreScaffolding.v +++ b/saw-core-coq/coq/handwritten/CryptolToCoq/SAWCoreScaffolding.v @@ -84,7 +84,6 @@ Instance Inhabited_unit : Inhabited unit := Instance Inhabited_bool : Inhabited bool := MkInhabited bool false. - (* SAW uses an alternate form of eq_rect where the motive function P also depends on the equality proof itself *) Definition Eq__rec (A : Type) (x : A) (P: forall y, x=y -> Type) (p:P x eq_refl) y (e:x=y) : diff --git a/saw-core/prelude/Prelude.sawcore b/saw-core/prelude/Prelude.sawcore index 9d697af083..62b75772bb 100644 --- a/saw-core/prelude/Prelude.sawcore +++ b/saw-core/prelude/Prelude.sawcore @@ -1844,6 +1844,7 @@ primitive updSliceWithProof : (a : sort 0) -> (n off len : Nat) -> IsLeNat (addNat off len) n -> Vec n a -> Vec len a -> Vec n a; + -------------------------------------------------------------------------------- -- Vectors indexed by bitvectors diff --git a/saw-core/src/Verifier/SAW/SATQuery.hs b/saw-core/src/Verifier/SAW/SATQuery.hs index 22aed1f9c9..1ddc69a843 100644 --- a/saw-core/src/Verifier/SAW/SATQuery.hs +++ b/saw-core/src/Verifier/SAW/SATQuery.hs @@ -43,12 +43,16 @@ data SATQuery = -- for uninterpreted values. , satAsserts :: [SATAssert] - -- ^ A collection of assertions. These should - -- all be terms of type @Bool@. The overall + -- ^ A collection of assertions. The overall -- query should be understood as the conjunction -- of these terms. } +-- | The type of assertions we can make to a solver. These +-- are either boolean terms, or universally-quantified +-- statements. At present, only the What4 backends can +-- handle universally quantified statments, and only +-- some of the solvers will accept them without errors. data SATAssert = BoolAssert Term -- ^ A boolean term to be asserted | UniversalAssert [(ExtCns Term, FirstOrderType)] [Term] Term @@ -56,7 +60,7 @@ data SATAssert -- collection of first-order variables, a sequence -- of boolean hypotheses, and a boolean conclusion --- | The result of a sat query. In the event a model is found, +-- | The result of a sat query. In the event a model is found, -- return a mapping from the @ExtCns@ variables to values. data SATResult = Unsatisfiable @@ -67,7 +71,8 @@ data SATResult -- in this SAT query as a single term of type Bool. -- -- This method of reducing a sat query to a boolean --- cannot be used for universally-quantified assertions. +-- cannot be used for universally-quantified assertions, +-- and will raise an error if it encounters one. satQueryAsTerm :: SharedContext -> SATQuery -> IO Term satQueryAsTerm sc satq = case satAsserts satq of diff --git a/saw-core/src/Verifier/SAW/SharedTerm.hs b/saw-core/src/Verifier/SAW/SharedTerm.hs index 5094aa7a87..4fe7b321bb 100644 --- a/saw-core/src/Verifier/SAW/SharedTerm.hs +++ b/saw-core/src/Verifier/SAW/SharedTerm.hs @@ -2668,6 +2668,7 @@ scTreeSizeAux = go Nothing -> (sz + sz', Map.insert idx sz' seen') where (sz', seen') = foldl' go (1, seen) tf + -- | `openTerm sc nm ty i body` replaces the loose deBruijn variable `i` -- with a fresh external constant (with name `nm`, and type `ty`) in `body`. scOpenTerm :: SharedContext diff --git a/src/SAWScript/Builtins.hs b/src/SAWScript/Builtins.hs index 5ac18764c6..44fd0da72f 100644 --- a/src/SAWScript/Builtins.hs +++ b/src/SAWScript/Builtins.hs @@ -1396,7 +1396,8 @@ proveByBVInduction script t = _ -> return Nothing badTy opts ty = - fail $ unlines [ "Incorrect type for proof by induction" + fail $ unlines [ "Incorrect type for proof by induction!" + , "Run `:help prove_by_bv_induction` to see a description of what is expected." , show (ppTerm (SV.sawPPOpts opts) ty) ] diff --git a/src/SAWScript/Crucible/LLVM/X86.hs b/src/SAWScript/Crucible/LLVM/X86.hs index bfa5330e36..7eccaba3f1 100644 --- a/src/SAWScript/Crucible/LLVM/X86.hs +++ b/src/SAWScript/Crucible/LLVM/X86.hs @@ -1202,7 +1202,7 @@ checkGoals bak opts nm sc tactic mdMap = do res <- runProofScript tactic term proofgoal (Just (gLoc g)) (Text.unwords ["X86 verification condition", Text.pack (show n), Text.pack (show (gMessage g))]) - False -- do no record this theorem in the database + False -- do not record this theorem in the database False -- TODO! useSequentGoals case res of ValidProof stats thm -> diff --git a/src/SAWScript/Interpreter.hs b/src/SAWScript/Interpreter.hs index 2b59ca32ba..1ff78d2d61 100644 --- a/src/SAWScript/Interpreter.hs +++ b/src/SAWScript/Interpreter.hs @@ -304,7 +304,6 @@ processStmtBind printBinds pat _mc expr = do -- mx mt --io $ putStrLn $ "Top-level bind: " ++ show mx --showCryptolEnv - -- Print non-unit result if it was not bound to a variable case pat of SS.PWild _ | printBinds && not (isVUnit result) -> @@ -389,7 +388,6 @@ interpretStmt printBinds stmt = do rw <- getTopLevelRW putTopLevelRW $ addTypedef (getVal name) ty rw - interpretFile :: FilePath -> Bool {- ^ run main? -} -> TopLevel () interpretFile file runMain = do opts <- getOptions @@ -1224,7 +1222,7 @@ primitives = Map.fromList , prim "implies_term" "Term -> Term -> Term" (funVal2 implies_term) Experimental - [ "Given to terms, which must be Prop terms, construct the SAWCore implication" + [ "Given two terms, which must be Prop terms, construct the SAWCore implication" , "of those terms." ] diff --git a/src/SAWScript/Proof.hs b/src/SAWScript/Proof.hs index 84bb8f6290..426c934f8e 100644 --- a/src/SAWScript/Proof.hs +++ b/src/SAWScript/Proof.hs @@ -1124,6 +1124,8 @@ specializeHypEvidence n h ts [e] = pure (CutEvidence h e (ApplyHypEvidence n (ma specializeHypEvidence _ _ _ _ = fail "specializeHypEvidence: expected one evidence value" structuralEvidence :: Sequent -> Evidence -> Evidence +-- If we apply some structural evidence to an already existing structural evidence, we can +-- just omit the new one because the checking procedure doesn't need the intermediate state. structuralEvidence _sqt (StructuralEvidence sqt' e) = StructuralEvidence sqt' e structuralEvidence sqt e = StructuralEvidence sqt e @@ -1728,12 +1730,14 @@ startProof g pos ploc rsn = -- proposition. If successful, return the completed @Theorem@ and a summary -- of solver resources used in the proof. -- --- If first boolean argument is False, the resulting theorem will not be +-- If first boolean argument is @False@, the resulting theorem will not be -- recored in the theorem database. This should only be done when you are -- sure that the theorem will not be used as part of the proof of other theorems, -- or later steps will fail. This is intended for proofs of verification conditions, -- which are not exposed for reuse, and where it requires a significant memory --- burden to record them. +-- burden to record them. In particular commands like @llvm_verify@, @jvm_verify@, etc +-- that produce and verify verification conditions should set this argument to +-- @False@ to reduce memory pressure. -- -- The final boolean argument indicates if the proof state needs a sequent normalization -- step as the final step in its evidence chain to check. This is useful for goals that diff --git a/src/SAWScript/Prover/MRSolver/SMT.hs b/src/SAWScript/Prover/MRSolver/SMT.hs index 8113158bb2..a99b7647ad 100644 --- a/src/SAWScript/Prover/MRSolver/SMT.hs +++ b/src/SAWScript/Prover/MRSolver/SMT.hs @@ -33,7 +33,6 @@ import Verifier.SAW.Recognizer import Verifier.SAW.OpenTerm import Verifier.SAW.Prim (EvalError(..)) -import Verifier.SAW.Name (emptySAWNamingEnv) import qualified Verifier.SAW.Prim as Prim import Verifier.SAW.Simulator.Value import Verifier.SAW.Simulator.TermModel @@ -286,8 +285,9 @@ mrProvableRaw prop_term = do sc <- mrSC prop <- liftSC1 termToProp prop_term unints <- Set.map ecVarIndex <$> getAllExtSet <$> liftSC1 propToTerm prop + nenv <- liftIO (scGetNamingEnv sc) debugPrint 2 ("Calling SMT solver with proposition: " ++ - prettyProp defaultPPOpts emptySAWNamingEnv prop) + prettyProp defaultPPOpts nenv prop) sym <- liftIO $ setupWhat4_sym True -- If there are any saw-core `error`s in the term, this will throw a -- Haskell error - in this case we want to just return False, not stop diff --git a/src/SAWScript/VerificationSummary.hs b/src/SAWScript/VerificationSummary.hs index 41609d777a..7a687f1396 100644 --- a/src/SAWScript/VerificationSummary.hs +++ b/src/SAWScript/VerificationSummary.hs @@ -105,7 +105,7 @@ thmToJSON thm = object ([ , ("reason" .= (thmReason thm)) , ("dependencies" .= toJSON (map indexValue (Set.toList (thmDepends thm)))) , ("elapsedtime" .= toJSON (thmElapsedTime thm)) - ] ++ (theoremStatus (thmSummary thm)) + ] ++ theoremStatus (thmSummary thm) ++ case thmProgramLoc thm of Nothing -> [] Just ploc -> [("ploc" .= plocToJSON ploc)] From 74122d9c5ba561a3c3110baa205e49f96070440b Mon Sep 17 00:00:00 2001 From: Rob Dockins Date: Fri, 26 Aug 2022 09:02:36 -0700 Subject: [PATCH 33/35] Style fixes and comments in the What4 evaluator. --- .../src/Verifier/SAW/Simulator/What4.hs | 28 +++++++++++++++---- 1 file changed, 22 insertions(+), 6 deletions(-) diff --git a/saw-core-what4/src/Verifier/SAW/Simulator/What4.hs b/saw-core-what4/src/Verifier/SAW/Simulator/What4.hs index c6405a6c23..e5789d8525 100644 --- a/saw-core-what4/src/Verifier/SAW/Simulator/What4.hs +++ b/saw-core-what4/src/Verifier/SAW/Simulator/What4.hs @@ -1017,7 +1017,7 @@ w4SolveAssert sym sc varMap ref uninterp (UniversalAssert vars hyps concl) = (svals,bndvars) <- boundFOTs sym vars let varMap' = foldl (\m ((ec,_fot), sval) -> Map.insert (ecVarIndex ec) sval m) varMap - (zip vars svals) + (zip vars svals) -- NB, boundFOTs will construct these lists to be the same length bval <- w4SolveBasic sym sc mempty varMap' ref uninterp g case bval of VBool v -> @@ -1026,6 +1026,19 @@ w4SolveAssert sym sc varMap ref uninterp (UniversalAssert vars hyps concl) = _ -> fail $ "w4SolveAssert: non-boolean result type. " ++ show bval +-- | Given a list of external constants with first-order types, +-- descend in to the structure of those types (as needed) and construct +-- corresponding What4 bound variables so we can bind them using +-- a forall quantifier. At the same time construct @SValue@s containing +-- those variables suitable for passing to the term evaluator as substituions +-- for the given @ExtCns@ values. The length of the @SValue@ list returned +-- will match the list of the input @ExtCns@ list, but the list of What4 +-- @BoundVar@s might not. +-- +-- This procedure it capable of handling most first-order types, execpt +-- that Array types must have base types as index and result types rather +-- than more general first-order types. (TODO? should we actually restrict the +-- @FirstOrderType@ in the same way?) boundFOTs :: forall sym. IsSymExprBuilder sym => sym -> @@ -1050,10 +1063,13 @@ boundFOTs sym vars = FOTBit -> VBool <$> freshBnd ec BaseBoolRepr FOTInt -> VInt <$> freshBnd ec BaseIntegerRepr FOTIntMod m -> VIntMod m <$> freshBnd ec BaseIntegerRepr - FOTVec 0 FOTBit -> return (VWord ZBV) - FOTVec n FOTBit - | Just (Some (PosNat nr)) <- somePosNat n -> - VWord . DBV <$> freshBnd ec (BaseBVRepr nr) + + FOTVec n FOTBit -> + case somePosNat n of + Nothing -> -- n == 0 + return (VWord ZBV) + Just (Some (PosNat nr)) -> + VWord . DBV <$> freshBnd ec (BaseBVRepr nr) FOTVec n tp -> -- NB, not Bit do vs <- V.replicateM (fromIntegral n) (handleVar ec tp) @@ -1076,7 +1092,7 @@ boundFOTs sym vars = -> VArray . SArray <$> freshBnd ec (BaseArrayRepr (Ctx.Empty Ctx.:> idx_repr) res_repr) - _ -> fail ("boundFOTs: cannot handle " ++ show fot) + | otherwise -> fail ("boundFOTs: cannot handle " ++ show fot) -- From e6b201e552fe9f3aaa04bb590a41f86d9f07c730 Mon Sep 17 00:00:00 2001 From: Rob Dockins Date: Fri, 26 Aug 2022 09:26:07 -0700 Subject: [PATCH 34/35] Uniformly use the term "conclusion" for propositions on the right-hand side of a sequent, reserving the term "goal" for an entire sequent. --- src/SAWScript/Builtins.hs | 2 +- src/SAWScript/Proof.hs | 172 +++++++++++++++++++------------------- 2 files changed, 88 insertions(+), 86 deletions(-) diff --git a/src/SAWScript/Builtins.hs b/src/SAWScript/Builtins.hs index 44fd0da72f..1496bc07f4 100644 --- a/src/SAWScript/Builtins.hs +++ b/src/SAWScript/Builtins.hs @@ -669,7 +669,7 @@ hoistIfsInGoalPrim :: ProofScript () hoistIfsInGoalPrim = execTactic $ tacticChange $ \goal -> do sc <- getSharedContext - sqt' <- traverseSequentWithFocus (io . hoistIfsInGoal sc) (goalSequent goal) + sqt' <- traverseSequentWithFocus (io . hoistIfsInProp sc) (goalSequent goal) return (sqt', HoistIfsEvidence) term_type :: TypedTerm -> TopLevel C.Schema diff --git a/src/SAWScript/Proof.hs b/src/SAWScript/Proof.hs index 426c934f8e..feefdc367e 100644 --- a/src/SAWScript/Proof.hs +++ b/src/SAWScript/Proof.hs @@ -19,7 +19,7 @@ module SAWScript.Proof , splitDisj , unfoldProp , simplifyProp - , hoistIfsInGoal + , hoistIfsInProp , evalProp , betaReduceProp , falseProp @@ -311,15 +311,15 @@ splitImpl sc (Prop p) splitSequent :: SharedContext -> Sequent -> IO (Maybe (Sequent, Sequent)) splitSequent sc sqt = case sqt of - GoalFocusedSequent hs (FB gs1 g gs2) -> + ConclFocusedSequent hs (FB gs1 g gs2) -> splitConj sc g >>= \case -- HS |- GS1, X, GS2 -- HS |- GS1, Y, GS2 -- --------------------------- (Conj-R) -- HS |- GS1, X /\ Y, GS2 Just (x, y) -> - return (Just ( GoalFocusedSequent hs (FB gs1 x gs2) - , GoalFocusedSequent hs (FB gs1 y gs2) + return (Just ( ConclFocusedSequent hs (FB gs1 x gs2) + , ConclFocusedSequent hs (FB gs1 y gs2) )) Nothing -> splitIte sc g >>= \case @@ -328,8 +328,8 @@ splitSequent sc sqt = -- -------------------------------------- (Ite-R) -- HS |- GS1, if B then X else Y, GS2 Just ((b, x), (nb, y)) -> - return (Just ( GoalFocusedSequent (hs ++ [b]) (FB gs1 x gs2) - , GoalFocusedSequent (hs ++ [nb]) (FB gs1 y gs2) + return (Just ( ConclFocusedSequent (hs ++ [b]) (FB gs1 x gs2) + , ConclFocusedSequent (hs ++ [nb]) (FB gs1 y gs2) )) Nothing -> return Nothing @@ -361,7 +361,7 @@ splitSequent sc sqt = splitImpl sc h >>= \case Just (x, y) -> return (Just ( HypFocusedSequent (FB hs1 y hs2) gs - , GoalFocusedSequent (hs1 ++ [h] ++ hs2) (FB gs x []) + , ConclFocusedSequent (hs1 ++ [h] ++ hs2) (FB gs x []) )) Nothing -> return Nothing @@ -412,21 +412,21 @@ simplifySequent sc ss (UnfocusedSequent hs gs) = do (a, hs') <- simplifyProps sc ss hs (b, gs') <- simplifyProps sc ss gs return (Set.union a b, UnfocusedSequent hs' gs') -simplifySequent sc ss (GoalFocusedSequent hs (FB gs1 g gs2)) = +simplifySequent sc ss (ConclFocusedSequent hs (FB gs1 g gs2)) = do (a, g') <- simplifyProp sc ss g - return (a, GoalFocusedSequent hs (FB gs1 g' gs2)) + return (a, ConclFocusedSequent hs (FB gs1 g' gs2)) simplifySequent sc ss (HypFocusedSequent (FB hs1 h hs2) gs) = do (a, h') <- simplifyProp sc ss h return (a, HypFocusedSequent (FB hs1 h' hs2) gs) -hoistIfsInGoal :: SharedContext -> Prop -> IO Prop -hoistIfsInGoal sc (Prop p) = do +hoistIfsInProp :: SharedContext -> Prop -> IO Prop +hoistIfsInProp sc (Prop p) = do let (args, body) = asPiList p body' <- case asEqTrue body of Just t -> pure t - Nothing -> fail "hoistIfsInGoal: expected EqTrue" + Nothing -> fail "hoistIfsInProp: expected EqTrue" ecs <- traverse (\(nm, ty) -> scFreshEC sc nm ty) args vars <- traverse (scExtCns sc) ecs t0 <- instantiateVarList sc 0 (reverse vars) body' @@ -483,6 +483,8 @@ trivialProofTerm sc (Prop p) = runExceptT (loop =<< lift (scWhnf sc p)) lift $ scLambda sc nm tp pf loop (asEq -> Just (tp, x, _y)) = + -- NB, we don't check if x is convertable to y here, as that will + -- be done later in @tacticTrivial@ during the type-checking step lift $ scCtorApp sc "Prelude.Refl" [tp, x] loop _ = throwError $ unlines @@ -551,7 +553,7 @@ data Sequent = -- | A sequent in the unfocused state UnfocusedSequent ![SequentBranch] ![SequentBranch] -- | A sequent focused on a particular conclusion - | GoalFocusedSequent ![SequentBranch] !FocusedBranch + | ConclFocusedSequent ![SequentBranch] !FocusedBranch -- | A sequent focused on a particular hypothesis | HypFocusedSequent !FocusedBranch ![SequentBranch] @@ -572,9 +574,9 @@ instance Traversable RawSequent where sequentToRawSequent :: Sequent -> RawSequent Prop sequentToRawSequent sqt = case sqt of - UnfocusedSequent hs gs -> RawSequent hs gs - GoalFocusedSequent hs (FB gs1 g gs2) -> RawSequent hs (gs1 ++ g : gs2) - HypFocusedSequent (FB hs1 h hs2) gs -> RawSequent (hs1 ++ h : hs2) gs + UnfocusedSequent hs gs -> RawSequent hs gs + ConclFocusedSequent hs (FB gs1 g gs2) -> RawSequent hs (gs1 ++ g : gs2) + HypFocusedSequent (FB hs1 h hs2) gs -> RawSequent (hs1 ++ h : hs2) gs unfocusSequent :: Sequent -> Sequent unfocusSequent sqt = UnfocusedSequent hs gs @@ -584,7 +586,7 @@ focusOnConcl :: Integer -> Sequent -> Maybe Sequent focusOnConcl i sqt = let RawSequent hs gs = sequentToRawSequent sqt in case genericSplitAt i gs of - (gs1, g:gs2) -> Just (GoalFocusedSequent hs (FB gs1 g gs2)) + (gs1, g:gs2) -> Just (ConclFocusedSequent hs (FB gs1 g gs2)) (_ , []) -> Nothing focusOnHyp :: Integer -> Sequent -> Maybe Sequent @@ -624,13 +626,13 @@ convertibleSequents sc sqt1 sqt2 = -- focus. data SequentState = Unfocused - | GoalFocus Prop (Prop -> Sequent) - | HypFocus Prop (Prop -> Sequent) + | ConclFocus Prop (Prop -> Sequent) + | HypFocus Prop (Prop -> Sequent) -- | Build a sequent with the given proposition as the -- only conclusion, and place it under focus. propToSequent :: Prop -> Sequent -propToSequent p = GoalFocusedSequent [] (FB [] p []) +propToSequent p = ConclFocusedSequent [] (FB [] p []) -- | Give in a collection of boolean terms, construct a sequent -- with corresponding hypotheses and conclusions. If there @@ -640,7 +642,7 @@ booleansToSequent sc hs gs = do hs' <- mapM (boolToProp sc []) hs gs' <- mapM (boolToProp sc []) gs case gs' of - [g] -> return (GoalFocusedSequent hs' (FB [] g [])) + [g] -> return (ConclFocusedSequent hs' (FB [] g [])) _ -> return (UnfocusedSequent hs' gs') -- | Given a sequent, render its semantics as a proposition. @@ -684,7 +686,7 @@ ppSequent opts nenv sqt = ppRawSequent :: Sequent -> RawSequent SawDoc -> SawDoc ppRawSequent _sqt (RawSequent [] [g]) = g ppRawSequent sqt (RawSequent hs gs) = - align (vcat (map ppHyp (zip [0..] hs) ++ turnstile ++ map ppGoal (zip [0..] gs))) + align (vcat (map ppHyp (zip [0..] hs) ++ turnstile ++ map ppConcl (zip [0..] gs))) where turnstile = [ pretty (take 40 (repeat '=')) ] focused doc = "<<" <> doc <> ">>" @@ -696,13 +698,13 @@ ppRawSequent sqt (RawSequent hs gs) = | otherwise = "H" <> pretty i <> ":" <+> tm - ppGoal (i, tm) - | GoalFocusedSequent _hs (FB gs1 _g _gs2) <- sqt + ppConcl (i, tm) + | ConclFocusedSequent _hs (FB gs1 _g _gs2) <- sqt , length gs1 == i - = focused ("G" <> pretty i) <+> tm + = focused ("C" <> pretty i) <+> tm | otherwise - = "G" <> pretty i <> ":" <+> tm + = "C" <> pretty i <> ":" <+> tm -- | A datatype for representing finte or cofinite sets. @@ -748,8 +750,8 @@ filterFocusedList pss (FB xs1 x xs2) = filterHyps :: CofinSet Integer -> Sequent -> Sequent filterHyps pss (UnfocusedSequent hs gs) = UnfocusedSequent (filterPosList pss 0 hs) gs -filterHyps pss (GoalFocusedSequent hs gs) = - GoalFocusedSequent (filterPosList pss 0 hs) gs +filterHyps pss (ConclFocusedSequent hs gs) = + ConclFocusedSequent (filterPosList pss 0 hs) gs filterHyps pss (HypFocusedSequent hs gs) = case filterFocusedList pss hs of Left hs' -> UnfocusedSequent hs' gs @@ -762,22 +764,22 @@ filterConcls pss (UnfocusedSequent hs gs) = UnfocusedSequent hs (filterPosList pss 0 gs) filterConcls pss (HypFocusedSequent hs gs) = HypFocusedSequent hs (filterPosList pss 0 gs) -filterConcls pss (GoalFocusedSequent hs gs) = +filterConcls pss (ConclFocusedSequent hs gs) = case filterFocusedList pss gs of Left gs' -> UnfocusedSequent hs gs' - Right gs' -> GoalFocusedSequent hs gs' + Right gs' -> ConclFocusedSequent hs gs' -- | Add a new hypothesis to the list of hypotheses in a sequent addHypothesis :: Prop -> Sequent -> Sequent addHypothesis p (UnfocusedSequent hs gs) = UnfocusedSequent (hs ++ [p]) gs -addHypothesis p (GoalFocusedSequent hs gs) = GoalFocusedSequent (hs ++ [p]) gs +addHypothesis p (ConclFocusedSequent hs gs) = ConclFocusedSequent (hs ++ [p]) gs addHypothesis p (HypFocusedSequent (FB hs1 h hs2) gs) = HypFocusedSequent (FB hs1 h (hs2++[p])) gs -- | Add a new conclusion to the end of the conclusion list and focus on it -addNewFocusedGoal :: Prop -> Sequent -> Sequent -addNewFocusedGoal p sqt = +addNewFocusedConcl :: Prop -> Sequent -> Sequent +addNewFocusedConcl p sqt = let RawSequent hs gs = sequentToRawSequent sqt - in GoalFocusedSequent hs (FB gs p []) + in ConclFocusedSequent hs (FB gs p []) -- | If the sequent is focused, return the prop under focus, -- together with its index value. @@ -788,13 +790,13 @@ sequentGetFocus (UnfocusedSequent _ _) = Nothing sequentGetFocus (HypFocusedSequent (FB hs1 h _) _) = Just (Left (genericLength hs1, h)) -sequentGetFocus (GoalFocusedSequent _ (FB gs1 g _)) = +sequentGetFocus (ConclFocusedSequent _ (FB gs1 g _)) = Just (Right (genericLength gs1, g)) sequentState :: Sequent -> SequentState sequentState (UnfocusedSequent _ _) = Unfocused -sequentState (GoalFocusedSequent hs (FB gs1 g gs2)) = - GoalFocus g (\g' -> GoalFocusedSequent hs (FB gs1 g' gs2)) +sequentState (ConclFocusedSequent hs (FB gs1 g gs2)) = + ConclFocus g (\g' -> ConclFocusedSequent hs (FB gs1 g' gs2)) sequentState (HypFocusedSequent (FB hs1 h hs2) gs) = HypFocus h (\h' -> HypFocusedSequent (FB hs1 h' hs2) gs) @@ -815,8 +817,8 @@ sequentTreeSize sqt = scTreeSizeMany (map unProp (hs ++ gs)) traverseSequentWithFocus :: Applicative m => (Prop -> m Prop) -> Sequent -> m Sequent traverseSequentWithFocus f (UnfocusedSequent hs gs) = UnfocusedSequent <$> traverse f hs <*> traverse f gs -traverseSequentWithFocus f (GoalFocusedSequent hs (FB gs1 g gs2)) = - (\g' -> GoalFocusedSequent hs (FB gs1 g' gs2)) <$> f g +traverseSequentWithFocus f (ConclFocusedSequent hs (FB gs1 g gs2)) = + (\g' -> ConclFocusedSequent hs (FB gs1 g' gs2)) <$> f g traverseSequentWithFocus f (HypFocusedSequent (FB hs1 h hs2) gs) = (\h' -> HypFocusedSequent (FB hs1 h' hs2) gs) <$> f h @@ -825,8 +827,8 @@ traverseSequentWithFocus f (HypFocusedSequent (FB hs1 h hs2) gs) = traverseSequent :: Applicative m => (Prop -> m Prop) -> Sequent -> m Sequent traverseSequent f (UnfocusedSequent hs gs) = UnfocusedSequent <$> traverse f hs <*> traverse f gs -traverseSequent f (GoalFocusedSequent hs (FB gs1 g gs2)) = - GoalFocusedSequent <$> +traverseSequent f (ConclFocusedSequent hs (FB gs1 g gs2)) = + ConclFocusedSequent <$> (traverse f hs) <*> ( FB <$> traverse f gs1 <*> f g <*> traverse f gs2) traverseSequent f (HypFocusedSequent (FB hs1 h hs2) gs) = @@ -842,7 +844,7 @@ checkSequent :: SharedContext -> PPOpts -> Sequent -> IO () checkSequent sc ppOpts (UnfocusedSequent hs gs) = do forM_ hs (checkProp sc ppOpts) forM_ gs (checkProp sc ppOpts) -checkSequent sc ppOpts (GoalFocusedSequent hs (FB gs1 g gs2)) = +checkSequent sc ppOpts (ConclFocusedSequent hs (FB gs1 g gs2)) = do forM_ hs (checkProp sc ppOpts) forM_ gs1 (checkProp sc ppOpts) checkProp sc ppOpts g @@ -993,7 +995,7 @@ data Evidence -- 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. + -- result must match the current focued conclusion. | ApplyEvidence !Theorem ![Either Term Evidence] -- | This type of evidence is produced when a local hypothesis is @@ -1002,7 +1004,7 @@ data Evidence -- 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. + -- the current focused conclusion. | ApplyHypEvidence Integer ![Either Term Evidence] -- | This type of evidence is used to prove a universally-quantified conclusion. @@ -1040,7 +1042,7 @@ data Evidence | ConversionEvidence !Sequent !Evidence -- | This type of evidence is used to modify a goal to prove by applying - -- 'hoistIfsInGoal'. + -- 'hoistIfsInProp'. | HoistIfsEvidence !Evidence -- | Change the state of the sequent in some "structural" way. This @@ -1060,7 +1062,7 @@ data Evidence -- | This type of evidence is used when the current sequent, after -- applying structural rules, is an instance of the basic - -- sequent calculus axiom, which connects a hypothesis to a goal. + -- sequent calculus axiom, which connects a hypothesis to a conclusion. | AxiomEvidence -- | The the proposition proved by a given theorem. @@ -1396,7 +1398,7 @@ normalizeSequent sc sqt = normalizeRawSequent :: SharedContext -> RawSequent Prop -> IO (RawSequent Prop) normalizeRawSequent sc (RawSequent hs gs) = do hs' <- mapM (normalizeHyp sc) hs - gs' <- mapM (normalizeGoal sc) gs + gs' <- mapM (normalizeConcl sc) gs return (joinSequents (hs' ++ gs')) joinSequent :: RawSequent Prop -> RawSequent Prop -> RawSequent Prop @@ -1415,11 +1417,11 @@ normalizeHyp sc p = Nothing -> return (RawSequent [p] []) _ -> return (RawSequent [p] []) -normalizeGoal :: SharedContext -> Prop -> IO (RawSequent Prop) -normalizeGoal sc p = +normalizeConcl :: SharedContext -> Prop -> IO (RawSequent Prop) +normalizeConcl sc p = do t <- scWhnf sc (unProp p) case asEqTrue t of - Just b -> normalizeGoalBool sc b >>= \case + Just b -> normalizeConclBool sc b >>= \case Just sqt -> return sqt Nothing -> return (RawSequent [] [p]) _ -> @@ -1432,7 +1434,7 @@ normalizeGoal sc p = Nothing -> return (RawSequent [] [p]) Just h -> do hsqt <- normalizeHyp sc h - gsqt <- normalizeGoal sc (Prop body) + gsqt <- normalizeConcl sc (Prop body) return (joinSequent hsqt gsqt) _ -> return (RawSequent [] [p]) @@ -1441,7 +1443,7 @@ normalizeHypBool sc b = do body <- scWhnf sc b case () of _ | Just (_ :*: p1) <- (isGlobalDef "Prelude.not" <@> return) body - -> Just <$> normalizeGoalBoolCommit sc p1 + -> Just <$> normalizeConclBoolCommit sc p1 | Just (_ :*: p1 :*: p2) <- (isGlobalDef "Prelude.and" <@> return <@> return) body -> Just <$> (joinSequent <$> normalizeHypBoolCommit sc p1 <*> normalizeHypBoolCommit sc p2) @@ -1456,22 +1458,22 @@ normalizeHypBoolCommit sc b = Nothing -> do p <- boolToProp sc [] b return (RawSequent [p] []) -normalizeGoalBool :: SharedContext -> Term -> IO (Maybe (RawSequent Prop)) -normalizeGoalBool sc b = +normalizeConclBool :: SharedContext -> Term -> IO (Maybe (RawSequent Prop)) +normalizeConclBool sc b = do body <- scWhnf sc b case () of _ | Just (_ :*: p1) <- (isGlobalDef "Prelude.not" <@> return) body -> Just <$> normalizeHypBoolCommit sc p1 | Just (_ :*: p1 :*: p2) <- (isGlobalDef "Prelude.or" <@> return <@> return) body - -> Just <$> (joinSequent <$> normalizeGoalBoolCommit sc p1 <*> normalizeGoalBoolCommit sc p2) + -> Just <$> (joinSequent <$> normalizeConclBoolCommit sc p1 <*> normalizeConclBoolCommit sc p2) | otherwise -> return Nothing -normalizeGoalBoolCommit :: SharedContext -> Term -> IO (RawSequent Prop) -normalizeGoalBoolCommit sc b = - normalizeGoalBool sc b >>= \case +normalizeConclBoolCommit :: SharedContext -> Term -> IO (RawSequent Prop) +normalizeConclBoolCommit sc b = + normalizeConclBool sc b >>= \case Just sqt -> return sqt Nothing -> do p <- boolToProp sc [] b return (RawSequent [] [p]) @@ -1521,7 +1523,7 @@ checkEvidence sc = \e p -> do nenv <- scGetNamingEnv sc check nenv e sqt = case e of ProofTerm tm -> case sequentState sqt of - GoalFocus (Prop ptm) _ -> + ConclFocus (Prop ptm) _ -> do ty <- TC.scTypeCheckError sc tm ok <- scConvertible sc True ptm ty unless ok $ fail $ unlines @@ -1530,7 +1532,7 @@ checkEvidence sc = \e p -> do nenv <- scGetNamingEnv sc , showTerm tm ] return (mempty, ProvedTheorem mempty) - _ -> fail "Sequent must be goal-focused for proof term evidence" + _ -> fail "Sequent must be conclusion-focused for proof term evidence" SolverEvidence stats sqt' -> do ok <- sequentSubsumes sc sqt' sqt @@ -1573,10 +1575,10 @@ checkEvidence sc = \e p -> do nenv <- scGetNamingEnv sc ApplyHypEvidence n es -> case sqt of - GoalFocusedSequent hs (FB gs1 g gs2) -> + ConclFocusedSequent hs (FB gs1 g gs2) -> case genericDrop n hs of (h:_) -> - do (d,sy,p') <- checkApply nenv (\g' -> GoalFocusedSequent hs (FB gs1 g' gs2)) h es + do (d,sy,p') <- checkApply nenv (\g' -> ConclFocusedSequent hs (FB gs1 g' gs2)) h es ok <- scConvertible sc False (unProp g) p' unless ok $ fail $ unlines [ "Apply evidence does not match the required proposition" @@ -1590,13 +1592,13 @@ checkEvidence sc = \e p -> do nenv <- scGetNamingEnv sc , prettySequent defaultPPOpts nenv sqt ] _ -> fail $ unlines $ - [ "Apply hypothesis evidence requires a goal-focused sequent." + [ "Apply hypothesis evidence requires a conclusion-focused sequent." , prettySequent defaultPPOpts nenv sqt ] ApplyEvidence thm es -> case sequentState sqt of - GoalFocus p mkSqt -> + ConclFocus p mkSqt -> do (d,sy,p') <- checkApply nenv mkSqt (thmProp thm) es ok <- scConvertible sc False (unProp p) p' unless ok $ fail $ unlines @@ -1606,7 +1608,7 @@ checkEvidence sc = \e p -> do nenv <- scGetNamingEnv sc ] return (Set.insert (thmNonce thm) d, sy) _ -> fail $ unlines $ - [ "Apply evidence requires a goal-focused sequent" + [ "Apply evidence requires a conclusion-focused sequent" , prettySequent defaultPPOpts nenv sqt ] @@ -1626,7 +1628,7 @@ checkEvidence sc = \e p -> do nenv <- scGetNamingEnv sc return (Set.union d1 d2, sy) HoistIfsEvidence e' -> - do sqt' <- traverseSequentWithFocus (hoistIfsInGoal sc) sqt + do sqt' <- traverseSequentWithFocus (hoistIfsInProp sc) sqt check nenv e' sqt' EvalEvidence vars e' -> @@ -1670,7 +1672,7 @@ checkEvidence sc = \e p -> do nenv <- scGetNamingEnv sc CutEvidence p ehyp egl -> do d1 <- check nenv ehyp (addHypothesis p sqt) - d2 <- check nenv egl (addNewFocusedGoal p sqt) + d2 <- check nenv egl (addNewFocusedConcl p sqt) return (d1 <> d2) IntroEvidence x e' -> @@ -1689,7 +1691,7 @@ checkEvidence sc = \e p -> do nenv <- scGetNamingEnv sc case sequentState sqt of Unfocused -> fail "Intro evidence requires a focused sequent" HypFocus _ _ -> fail "Intro evidence apply in hypothesis" - GoalFocus (Prop ptm) mkSqt -> + ConclFocus (Prop ptm) mkSqt -> case asPi ptm of Nothing -> fail $ unlines ["Intro evidence expected function prop", showTerm ptm] Just (_lnm, ty, body) -> @@ -1961,15 +1963,15 @@ sequentToSATQuery sc unintSet sqt = do tmNeg <- scNot sc tmBool return (vars, reverse (BoolAssert tmNeg : xs)) --- | Given a goal to prove, attempt to apply the given proposition, producing +-- | Given a prop to prove, attempt to apply another 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 :: +propApply :: SharedContext -> - Prop {- ^ propsition to apply -} -> + Prop {- ^ propsition to apply (usually a quantified and/or implication term) -} -> Prop {- ^ goal to apply the proposition to -} -> IO (Maybe [Either Term Prop]) -goalApply sc rule goal = applyFirst (asPiLists (unProp rule)) +propApply sc rule goal = applyFirst (asPiLists (unProp rule)) where applyFirst [] = pure Nothing @@ -2013,7 +2015,7 @@ tacticIntro :: (F.MonadFail m, MonadIO m) => Tactic m TypedTerm tacticIntro sc usernm = Tactic \goal -> case sequentState (goalSequent goal) of - GoalFocus p mkSqt -> + ConclFocus p mkSqt -> case asPi (unProp p) of Just (nm, tp, body) -> do let name = if Text.null usernm then nm else usernm @@ -2034,9 +2036,9 @@ tacticIntro sc usernm = Tactic \goal -> tacticIntroHyps :: (F.MonadFail m, MonadIO m) => SharedContext -> Integer -> Tactic m () tacticIntroHyps sc n = Tactic \goal -> case goalSequent goal of - GoalFocusedSequent hs (FB gs1 g gs2) -> + ConclFocusedSequent hs (FB gs1 g gs2) -> do (newhs, g') <- liftIO (loop n g) - let sqt' = GoalFocusedSequent (hs ++ newhs) (FB gs1 g' gs2) + let sqt' = ConclFocusedSequent (hs ++ newhs) (FB gs1 g' gs2) let goal' = goal{ goalSequent = sqt' } return ((), mempty, [goal'], updateEvidence (NormalizeSequentEvidence sqt')) _ -> fail "goal_intro_hyps: conclusion focus required" @@ -2054,13 +2056,13 @@ tacticIntroHyps sc n = Tactic \goal -> tacticRevertHyp :: (F.MonadFail m, MonadIO m) => SharedContext -> Integer -> Tactic m () tacticRevertHyp sc i = Tactic \goal -> case goalSequent goal of - GoalFocusedSequent hs (FB gs1 g gs2) -> + ConclFocusedSequent hs (FB gs1 g gs2) -> case genericDrop i hs of (h:_) -> case (asEqTrue (unProp h), asEqTrue (unProp g)) of (Just h', Just g') -> do g'' <- liftIO (Prop <$> (scEqTrue sc =<< scImplies sc h' g')) - let sqt' = GoalFocusedSequent hs (FB gs1 g'' gs2) + let sqt' = ConclFocusedSequent hs (FB gs1 g'' gs2) let goal' = goal{ goalSequent = sqt' } return ((), mempty, [goal'], updateEvidence (NormalizeSequentEvidence sqt')) @@ -2076,14 +2078,14 @@ tacticApplyHyp sc n = Tactic \goal -> case goalSequent goal of UnfocusedSequent{} -> fail "apply hyp tactic: focus required" HypFocusedSequent{} -> fail "apply hyp tactic: cannot apply in a hypothesis" - GoalFocusedSequent hs (FB gs1 g gs2) -> + ConclFocusedSequent hs (FB gs1 g gs2) -> case genericDrop n hs of (h:_) -> - liftIO (goalApply sc h g) >>= \case + liftIO (propApply sc h g) >>= \case Nothing -> fail "apply hyp tactic: no match" Just newterms -> let newgoals = - [ goal{ goalSequent = GoalFocusedSequent hs (FB gs1 p gs2) + [ goal{ goalSequent = ConclFocusedSequent hs (FB gs1 p gs2) , goalType = goalType goal ++ ".subgoal" ++ show i } | Right p <- newterms @@ -2107,8 +2109,8 @@ tacticApply sc thm = Tactic \goal -> case sequentState (goalSequent goal) of Unfocused -> fail "apply tactic: focus required" HypFocus _ _ -> fail "apply tactic: cannot apply in a hypothesis" - GoalFocus gl mkSqt -> - liftIO (goalApply sc (thmProp thm) gl) >>= \case + ConclFocus gl mkSqt -> + liftIO (propApply sc (thmProp thm) gl) >>= \case Nothing -> fail "apply tactic failed: no match" Just newterms -> let newgoals = @@ -2181,7 +2183,7 @@ tacticInsert sc thm ts = Tactic \gl -> tacticCut :: (F.MonadFail m, MonadIO m) => SharedContext -> Prop -> Tactic m () tacticCut _sc p = Tactic \gl -> let sqt1 = addHypothesis p (goalSequent gl) - sqt2 = addNewFocusedGoal p (goalSequent gl) + sqt2 = addNewFocusedConcl p (goalSequent gl) g1 = gl{ goalType = goalType gl ++ ".cutH", goalSequent = sqt1 } g2 = gl{ goalType = goalType gl ++ ".cutG", goalSequent = sqt2 } in return ((), mempty, [g1, g2], cutEvidence p) @@ -2192,7 +2194,7 @@ tacticTrivial sc = Tactic \goal -> case sequentState (goalSequent goal) of Unfocused -> fail "trivial tactic: focus required" HypFocus _ _ -> fail "trivial tactic: cannot apply trivial in a hypothesis" - GoalFocus g _ -> + ConclFocus g _ -> liftIO (trivialProofTerm sc g) >>= \case Left err -> fail err Right pf -> @@ -2211,7 +2213,7 @@ tacticExact sc tm = Tactic \goal -> case sequentState (goalSequent goal) of Unfocused -> fail "tactic exact: focus required" HypFocus _ _ -> fail "tactic exact: cannot apply exact in a hypothesis" - GoalFocus g _ -> + ConclFocus g _ -> do let gp = unProp g ty <- liftIO $ TC.scTypeCheckError sc tm ok <- liftIO $ scConvertible sc True gp ty From 58c477db4e83bc66f82aec3c6cb69d16abb7cce9 Mon Sep 17 00:00:00 2001 From: Rob Dockins Date: Fri, 26 Aug 2022 09:39:47 -0700 Subject: [PATCH 35/35] Changelog entry --- CHANGES.md | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) diff --git a/CHANGES.md b/CHANGES.md index 7ceca44dca..9bb19507d3 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -64,6 +64,28 @@ of them, or if different tactics are needed for different subgoals. Currently, this option only applies to LLVM verifications. +* Experimental interactive features. Using the new `subshell` + and `proof_subshell` commands, a user can regain a command-line + interface in the middle of a running script for experimentation + and exploration purposes. In addition `callcc` and `checkpoint` + allow the user to have more flexibility with restoring prior states + and executing the remaining context of a proof in such an + interactive session. + +* A significant overhaul of the SAW proof and tactics system. Under + the hood, tactics now manipulate _sequents_ instead of just + propositions. This allows more the user to specify more precise goal + rearrangements, and provides a much nicer interface for proof + exploration (especially with the new `proof_subshell`). There are a + variety of new tactics that provide the user with control over proof + steps that is similar to that found in an interactive theorem prover. + Proofs that do not make use of the new experimental tactics should + see no substantive changes, so this is expected to be a highly + backward-compatible change. + +* The experimental and rarely-used `goal_assume` tactic has been + removed. The use case it was targeting is better solved via sequents. + # Version 0.9 ## New Features