From 8f574a10532df09a83932ec3cb631dd3b0721f9a Mon Sep 17 00:00:00 2001 From: Robin Webbers Date: Thu, 20 Apr 2023 17:38:49 +0200 Subject: [PATCH 01/33] WIP counter example generation --- liquid-fixpoint.cabal | 1 + src/Language/Fixpoint/CounterExample.hs | 213 ++++++++++++++++++++++++ src/Language/Fixpoint/Smt/Interface.hs | 109 ++++++++---- src/Language/Fixpoint/Solver.hs | 8 + src/Language/Fixpoint/Solver/Monad.hs | 31 ++++ src/Language/Fixpoint/Solver/Solve.hs | 27 +-- tests/neg/linear.fq | 37 ++++ 7 files changed, 378 insertions(+), 48 deletions(-) create mode 100644 src/Language/Fixpoint/CounterExample.hs create mode 100644 tests/neg/linear.fq diff --git a/liquid-fixpoint.cabal b/liquid-fixpoint.cabal index afa688829..376a7aa93 100644 --- a/liquid-fixpoint.cabal +++ b/liquid-fixpoint.cabal @@ -55,6 +55,7 @@ library import: warnings exposed-modules: Data.ShareMap Language.Fixpoint.Conditional.Z3 + Language.Fixpoint.CounterExample Language.Fixpoint.Defunctionalize Language.Fixpoint.Graph Language.Fixpoint.Graph.Deps diff --git a/src/Language/Fixpoint/CounterExample.hs b/src/Language/Fixpoint/CounterExample.hs new file mode 100644 index 000000000..3a748b30e --- /dev/null +++ b/src/Language/Fixpoint/CounterExample.hs @@ -0,0 +1,213 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DeriveAnyClass #-} + +module Language.Fixpoint.CounterExample + ( hornToProg + , mainKVar + + , Prog + , Func (..) + , Decl + , Body + , Statement (..) + ) where + +import Language.Fixpoint.Types + +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as Map + +import Control.Monad.State +import Control.Monad.Reader + +import Text.PrettyPrint.HughesPJ ((<+>), ($+$)) +import qualified Text.PrettyPrint.HughesPJ as PP + +-- | A program, containing multiple function definitions +-- mapped by KVars. +data Prog = Prog (HashMap KVar Func) + +-- | A function symbol corresponding to a KVar. +data Func = Func [Decl] [Body] + deriving Show + +-- | A declaration of a Symbol with a Sort. +data Decl = Decl Symbol Sort + deriving Show + +-- | A sequence of statements. +data Body = Body [Statement] + deriving Show + +-- | A statement used to introduce/check constraints. +data Statement + = Let Decl + -- ^ Introduces a new variable. + | Assume Expr + -- ^ Constraints a variable. + | Assert Expr + -- ^ Checks whether a predicate follows given prior constraints. + | Call KVar Subst + -- ^ Call to function indexed by KVar. + deriving Show + +-- | The monad used to convert a set of horn constraints to +-- the imperative function format. +type MonadProg info m = (MonadState Prog m, MonadReader (SInfo info) m, Fixpoint info, MonadIO m) + +-- dbg :: (MonadIO m, PPrint a) => a -> m () +-- dbg = liftIO . print . pprint + +-- | Make an imperative program from horn clauses. This +-- can be used to generate a counter example. +hornToProg :: Fixpoint info => SInfo info -> IO Prog +hornToProg si = execStateT (runReaderT go si) prog + where + -- Initial program has empty main + prog = Prog $ Map.singleton mainKVar (Func [] []) + -- Add all horn clauses in SInfo to the function map + go = reader cm >>= mapM_ addHorn + +-- | Given a horn clause, generates a body for a function. +-- +-- The body is generated from the lhs of the horn clause. +-- +-- This body is added to the function given by the kvar +-- on the rhs of the horn clause. If there was no kvar, +-- it is added to the main function. +addHorn :: MonadProg info m => SimpC info -> m () +addHorn horn = do + (name, func) <- case crhs horn of + PKVar kvar sub -> do + decl <- getSig kvar + -- TODO: Use sub to add constraints to input types (specifically some equivalences) + _ <- substToBody sub + body <- hornLhsToBody horn + return (kvar, Func decl [body]) + rhs@_ -> do + Body stmts <- hornLhsToBody horn + let body = Body $ stmts <> [Assert rhs] + return (mainKVar, Func [] [body]) + addFunc name func + +getSig :: MonadProg info m => KVar -> m [Decl] +getSig kvar = do + -- Get the well foundedness constraint of the kvar + wfcs <- reader ws + let wfc = wfcs Map.! kvar + + -- Get the bind environment and bindings of the wfc + bindEnv <- reader bs + let ibinds = elemsIBindEnv . wenv $ wfc + + -- Lookup all Decl from the wfc using the ibinds + let asDecl (sym, sr, _) = Decl sym (sr_sort sr) + let decls = map (asDecl . flip lookupBindEnv bindEnv) ibinds + + -- Get the last Decl from the head of the wfc + let rhs = let (sym, sort, _) = wrft wfc in Decl sym sort + + -- Return the head + bindings as argument map + return $ rhs:decls + +substToBody :: MonadProg info m => Subst -> m Body +substToBody sub = return [] + +hornLhsToBody :: MonadProg info m => SimpC info -> m Body +hornLhsToBody horn = do + bindEnv <- reader bs + let lhs = clhs bindEnv horn + return $ lhsToBody lhs + +-- | Map a complete lhs of a horn clause to a function body +lhsToBody :: [(Symbol, SortedReft)] -> Body +lhsToBody = mconcat . map (uncurry reftToBody) + +-- | Map a refinement to a declaration and constraint pair +reftToBody :: Symbol -> SortedReft -> Body +reftToBody sym RR + { sr_sort = sort + , sr_reft = Reft (v, e) + } = Body + [ Let (Decl sym sort) + , constraint + ] + where + -- Make constraint with proper substitution + constraint = case e of + PKVar kvar (Su hm) -> Call kvar (Su . Map.map mapv $ hm) + _ -> Assume $ subst (Su . Map.singleton v $ EVar sym) e + + -- Substitution function for the kvar Subst map (the normal + -- subst we use for the other expressions doesn't work) + mapv (EVar v') | v' == v = EVar sym + mapv i@_ = i + +-- | Add a function to the function map with name KVar. +-- If an entry already exists, it will merge the function +-- bodies. +addFunc :: MonadProg info m => KVar -> Func -> m () +addFunc kvar func = do + let merge (Func _ b) (Func d b') = Func d (b <> b') + Prog prog <- get + put . Prog $ Map.insertWith merge kvar func prog + +-- | The main function, which any horn clause without a +-- KVar on the rhs will be added to. +mainKVar :: KVar +mainKVar = KV $ symbol "main" + +instance PPrint Prog where + pprintTidy tidy (Prog funcs) = PP.vcat + . PP.punctuate (PP.text "\n") + . map (uncurry $ ppfunc tidy) + . Map.toList + $ funcs + +instance PPrint Func where + pprintTidy tidy = ppfunc tidy anon + where + anon = KV $ symbol "_" + +ppfunc :: Tidy -> KVar -> Func -> PP.Doc +ppfunc tidy name (Func decls bodies) = psig $+$ pbody $+$ PP.rbrace + where + psig = fn <+> pname <+> pdecls <+> PP.lbrace + fn = PP.text "fn" + pname = pprintTidy tidy name + pdecls = PP.parens + . PP.hsep + . PP.punctuate PP.comma + . map (pprintTidy tidy) + $ decls + pbody = punctuate' (PP.text "||") + . map (PP.nest 4 . pprintTidy tidy) + $ bodies + + punctuate' _ [] = mempty + punctuate' _ (d:[]) = d + punctuate' p (d:ds) = d $+$ p $+$ punctuate' p ds + +instance PPrint Decl where + pprintTidy tidy (Decl sym sort) = (psym <> PP.colon) <+> psort + where + psym = pprintTidy tidy sym + psort = pprintTidy tidy sort + +instance PPrint Body where + pprintTidy tidy (Body stmts) = PP.vcat + . map (pprintTidy tidy) + $ stmts + +instance PPrint Statement where + pprintTidy tidy (Let decl) = PP.text "let" <+> pprintTidy tidy decl + pprintTidy tidy (Assume exprs) = PP.text "assume" <+> pprintTidy tidy exprs + pprintTidy tidy (Assert exprs) = PP.text "assert" <+> pprintTidy tidy exprs + pprintTidy tidy (Call kvar sub) = pprintTidy tidy kvar <+> pprintTidy tidy sub + +instance Semigroup Body where + Body b <> Body b' = Body $ b <> b' + +instance Monoid Body where + mempty = Body [] diff --git a/src/Language/Fixpoint/Smt/Interface.hs b/src/Language/Fixpoint/Smt/Interface.hs index 1601325ea..5228e7ef1 100644 --- a/src/Language/Fixpoint/Smt/Interface.hs +++ b/src/Language/Fixpoint/Smt/Interface.hs @@ -52,6 +52,7 @@ module Language.Fixpoint.Smt.Interface ( , smtBracket, smtBracketAt , smtDistinct , smtPush, smtPop + , smtGetValues -- * Check Validity , checkValid @@ -85,6 +86,7 @@ import qualified Data.ByteString.Lazy.Char8 as Char8 import Data.Char import qualified Data.HashMap.Strict as M import Data.Maybe (fromMaybe) +import Data.List (foldl') import qualified Data.Text as T import qualified Data.Text.Encoding as TE import qualified Data.Text.IO @@ -170,15 +172,11 @@ command Ctx {..} !cmd = do LBS.hPutStr h "\n" case cmd of CheckSat -> commandRaw - GetValue _ -> commandRaw _ -> SMTLIB.Backends.command_ ctxSolver cmdBS >> return Ok where commandRaw = do resp <- SMTLIB.Backends.command ctxSolver cmdBS - let respTxt = - TE.decodeUtf8With (const $ const $ Just ' ') $ - LBS.toStrict resp - parse respTxt + parse $ bs2txt resp cmdBS = {-# SCC "Command-runSmt2" #-} runSmt2 ctxSymEnv cmd parse resp = do case A.parseOnly responseP resp of @@ -191,48 +189,85 @@ command Ctx {..} !cmd = do Data.Text.IO.putStrLn textResponse return r +bs2txt :: Char8.ByteString -> T.Text +bs2txt = TE.decodeUtf8With (const $ const $ Just ' ') . LBS.toStrict + +smtGetValues :: Context -> [Symbol] -> IO (M.HashMap Symbol Expr) +smtGetValues _ [] = return M.empty +smtGetValues Ctx {..} syms = do + -- bytestring <- SMTLIB.Backends.command ctxSolver "(get-model)" + -- print bytestring + + let cmd = key "get-value" (parenSeqs $ map (smt2 ctxSymEnv) syms) + bytestring <- SMTLIB.Backends.command ctxSolver cmd + let text = bs2txt bytestring + case A.parseOnly valuesP text of + Left err -> Misc.errorstar $ "Parse error on get-value: " ++ err ++ "\n\n" ++ show text + Right sol -> return sol + smtSetMbqi :: Context -> IO () smtSetMbqi me = interact' me SetMbqi type SmtParser a = Parser T.Text a +valuesP :: SmtParser (M.HashMap Symbol Expr) +valuesP = parenP $ do + vs <- A.many' valueP + return $ M.fromList vs + +valueP :: SmtParser (Symbol, Expr) +valueP = parenP $ do + sym <- symbolP + expr <- exprP + return (sym, expr) + +exprP :: SmtParser Expr +exprP = do + expr <- (appP <|> litP) + return expr + +appP :: SmtParser Expr +appP = do + (e:es) <- parenP $ A.many1' exprP + return $ foldl' EApp e es + +litP :: SmtParser Expr +litP = EVar <$> symbolP + +parenP :: SmtParser a -> SmtParser a +parenP inner = do + A.skipSpace + _ <- A.char '(' + res <- inner + _ <- A.char ')' + A.skipSpace + return res + +symbolP :: SmtParser Symbol +symbolP = {- SCC "symbolP" -} do + A.skipSpace + raw <- A.takeWhile1 (not . exclude) + A.skipSpace + return $ symbol raw + where + exclude x = isSpace x || x == '(' || x == ')' + responseP :: SmtParser Response -responseP = {- SCC "responseP" -} A.char '(' *> sexpP - <|> A.string "sat" *> return Sat +responseP = {- SCC "responseP" -} + A.string "sat" *> return Sat <|> A.string "unsat" *> return Unsat <|> A.string "unknown" *> return Unknown - -sexpP :: SmtParser Response -sexpP = {- SCC "sexpP" -} A.string "error" *> (Error <$> errorP) - <|> Values <$> valuesP + <|> (Error <$> errorP) errorP :: SmtParser T.Text -errorP = A.skipSpace *> A.char '"' *> A.takeWhile1 (/='"') <* A.string "\")" - -valuesP :: SmtParser [(Symbol, T.Text)] -valuesP = A.many1' pairP <* A.char ')' - -pairP :: SmtParser (Symbol, T.Text) -pairP = {- SCC "pairP" -} - do A.skipSpace - _ <- A.char '(' - !x <- symbolP - A.skipSpace - !v <- valueP - _ <- A.char ')' - return (x,v) - -symbolP :: SmtParser Symbol -symbolP = {- SCC "symbolP" -} symbol <$> A.takeWhile1 (not . isSpace) - -valueP :: SmtParser T.Text -valueP = {- SCC "valueP" -} negativeP - <|> A.takeWhile1 (\c -> not (c == ')' || isSpace c)) - -negativeP :: SmtParser T.Text -negativeP - = do v <- A.char '(' *> A.takeWhile1 (/=')') <* A.char ')' - return $ "(" <> v <> ")" +errorP = do + A.skipSpace + _ <- A.string "error" + A.skipSpace + _ <- A.string "(\"" + res <- A.takeWhile1 (/= '"') + _ <- A.string "\")" + return res -------------------------------------------------------------------------- -- | SMT Context --------------------------------------------------------- diff --git a/src/Language/Fixpoint/Solver.hs b/src/Language/Fixpoint/Solver.hs index c2b43660d..df986d69c 100644 --- a/src/Language/Fixpoint/Solver.hs +++ b/src/Language/Fixpoint/Solver.hs @@ -62,6 +62,8 @@ import Control.DeepSeq import qualified Data.ByteString as B import Data.Maybe (catMaybes) +import Language.Fixpoint.CounterExample + --------------------------------------------------------------------------- -- | Solve an .fq file ---------------------------------------------------- --------------------------------------------------------------------------- @@ -262,6 +264,12 @@ reduceFInfo cfg fi = do solveNative' !cfg !fi0 = do si6 <- simplifyFInfo cfg fi0 + -- print fi0 + -- print si6 + print fi0 + prog <- hornToProg si6 + print . pprint $ prog + res <- {- SCC "Sol.solve" -} Sol.solve cfg $!! si6 -- rnf soln `seq` donePhase Loud "Solve2" --let stat = resStatus res diff --git a/src/Language/Fixpoint/Solver/Monad.hs b/src/Language/Fixpoint/Solver/Monad.hs index 6e2456e77..9f2abc118 100644 --- a/src/Language/Fixpoint/Solver/Monad.hs +++ b/src/Language/Fixpoint/Solver/Monad.hs @@ -13,6 +13,7 @@ module Language.Fixpoint.Solver.Monad , getBinds -- * SMT Query + , checkValidity , filterRequired , filterValid , filterValidGradual @@ -48,9 +49,11 @@ import Language.Fixpoint.Graph.Types (SolverInfo (..)) -- import Language.Fixpoint.Solver.Solution -- import Data.Maybe (catMaybes) import Data.List (partition) +import Data.Either (isRight) -- import Data.Char (isUpper) import Control.Monad.State.Strict import qualified Data.HashMap.Strict as M +import qualified Data.HashSet as HashSet import Data.Maybe (catMaybes) import Control.Exception.Base (bracket) @@ -206,6 +209,34 @@ filterValid_ sp p qs me = catMaybes <$> do valid <- smtCheckUnsat me return $ if valid then Just x else Nothing +{-# SCC checkValidity #-} +checkValidity :: F.SrcSpan -> F.Expr -> F.Expr -> SolveM ann (Either () ()) +checkValidity sp lhs rhs = do + res <- withContext $ checkValidity_ sp lhs rhs + + incBrkt + incChck 1 + when (isRight res) $ incVald 1 + return res + +{-# SCC checkValidity_ #-} +checkValidity_ :: F.SrcSpan -> F.Expr -> F.Expr -> Context -> IO (Either () ()) +checkValidity_ sp lhs rhs me = smtBracketAt sp me "checkValidity" $ do + smtAssert me lhs + smtAssert me (F.PNot rhs) + valid <- smtCheckUnsat me + + case valid of + True -> return $ Right () + False -> do + let symbols = HashSet.toList $ F.exprSymbolsSet lhs `HashSet.union` F.exprSymbolsSet rhs + --print lhs + --print rhs + _ <- smtGetValues me symbols + --print $ F.pprint res + --putStrLn "-----------------------------------" + return $ Left () + -------------------------------------------------------------------------------- -- | `filterValidGradual ps [(x1, q1),...,(xn, qn)]` returns the list `[ xi | p => qi]` -- | for some p in the list ps diff --git a/src/Language/Fixpoint/Solver/Solve.hs b/src/Language/Fixpoint/Solver/Solve.hs index 02a092543..63463cd65 100644 --- a/src/Language/Fixpoint/Solver/Solve.hs +++ b/src/Language/Fixpoint/Solver/Solve.hs @@ -25,12 +25,13 @@ import qualified Language.Fixpoint.Solver.Eliminate as E import Language.Fixpoint.Solver.Monad import Language.Fixpoint.Utils.Progress import Language.Fixpoint.Graph -import Text.PrettyPrint.HughesPJ +--import Text.PrettyPrint.HughesPJ import Text.Printf import System.Console.CmdArgs.Verbosity -- (whenNormal, whenLoud) import Control.DeepSeq import qualified Data.HashMap.Strict as M import qualified Data.HashSet as S +import Data.Either (isLeft) -- import qualified Data.Maybe as Mb import qualified Data.List as L import Language.Fixpoint.Types (resStatus, FixResult(Unsafe)) @@ -45,7 +46,6 @@ mytrace _ x = {- trace -} x -------------------------------------------------------------------------------- solve :: (NFData a, F.Fixpoint a, Show a, F.Loc a) => Config -> F.SInfo a -> IO (F.Result (Integer, a)) -------------------------------------------------------------------------------- - solve cfg fi = do whenLoud $ donePhase Misc.Loud "Worklist Initialize" vb <- getVerbosity @@ -241,6 +241,11 @@ result result bindingsInSmt cfg wkl s = sendConcreteBindingsToSMT bindingsInSmt $ \bindingsInSmt2 -> do lift $ writeLoud "Computing Result" + -- liftIO $ print (pprint bindingsInSmt) + -- --liftIO $ print (pprint cfg) + -- liftIO $ print (pprint wkl) + -- liftIO $ print (pprint s) + -- liftIO $ putStrLn "------------------" stat <- result_ bindingsInSmt2 cfg wkl s lift $ whenLoud $ putStrLn $ "RESULT: " ++ show (F.sid <$> stat) @@ -313,15 +318,15 @@ isUnsat bindingsInSmt s c = do be <- getBinds let lp = S.lhsPred bindingsInSmt be s c let rp = rhsPred c - res <- not <$> isValid (cstrSpan c) lp rp - lift $ whenLoud $ showUnsat res (F.subcId c) lp rp - return res - -showUnsat :: Bool -> Integer -> F.Pred -> F.Pred -> IO () -showUnsat u i lP rP = {- when u $ -} do - putStrLn $ printf "UNSAT id %s %s" (show i) (show u) - putStrLn $ showpp $ "LHS:" <+> pprint lP - putStrLn $ showpp $ "RHS:" <+> pprint rP + res <- checkValidity (cstrSpan c) lp rp + -- lift $ whenLoud $ showUnsat res (F.subcId c) lp rp + return $ isLeft res + +-- showUnsat :: Bool -> Integer -> F.Pred -> F.Pred -> IO () +-- showUnsat u i lP rP = {- when u $ -} do +-- putStrLn $ printf "UNSAT id %s %s" (show i) (show u) +-- putStrLn $ showpp $ "LHS:" <+> pprint lP +-- putStrLn $ showpp $ "RHS:" <+> pprint rP -------------------------------------------------------------------------------- -- | Predicate corresponding to RHS of constraint in current solution diff --git a/tests/neg/linear.fq b/tests/neg/linear.fq new file mode 100644 index 000000000..5af4085da --- /dev/null +++ b/tests/neg/linear.fq @@ -0,0 +1,37 @@ +bind 0 x : {v : int | true} +bind 1 y : {v : int | true} +bind 2 y : {v : int | true} + +// constraint: +// env [0] +// lhs {v : int | x = 10} +// rhs {v : int | $k0[v:=x]} +// id 1 tag [] + +constraint: + env [1] + lhs {v : int | y <= v} + rhs {v : int | v >= 0} + id 1 tag [] + +constraint: + env [0;1] + lhs {v : int | true} + rhs {v : int | y <= x} + id 2 tag [] + +constraint: + env [0;2] + lhs {v : int | [v == y; y <= x] } + rhs {v : int | [v == y] } + id 3 tag [] + +// constraint: +// env [2] +// lhs {v : int | $k0[v:=z]} +// rhs {v : int | 10 <= z} +// id 3 tag [] + +// wf: +// env [ ] +// reft {v: int | $k0} From 61fa746b499371e0e779588edb04473e33e00f6f Mon Sep 17 00:00:00 2001 From: Robin Webbers Date: Wed, 3 May 2023 19:37:00 +0200 Subject: [PATCH 02/33] BFS Counter example generator --- src/Language/Fixpoint/CounterExample.hs | 428 +++++++++++++++++++++--- src/Language/Fixpoint/Smt/Interface.hs | 15 +- src/Language/Fixpoint/Solver.hs | 3 + 3 files changed, 396 insertions(+), 50 deletions(-) diff --git a/src/Language/Fixpoint/CounterExample.hs b/src/Language/Fixpoint/CounterExample.hs index 3a748b30e..114d679ed 100644 --- a/src/Language/Fixpoint/CounterExample.hs +++ b/src/Language/Fixpoint/CounterExample.hs @@ -1,10 +1,14 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE OverloadedStrings #-} module Language.Fixpoint.CounterExample ( hornToProg - , mainKVar + , mainName + + , counterExample + , dbg , Prog , Func (..) @@ -14,6 +18,11 @@ module Language.Fixpoint.CounterExample ) where import Language.Fixpoint.Types +import Language.Fixpoint.Types.Config (Config) +--import Language.Fixpoint.Types.Config (Config, srcFile) +import Language.Fixpoint.Solver.Sanitize (symbolEnv) + +import qualified Language.Fixpoint.Smt.Interface as SMT import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as Map @@ -25,11 +34,15 @@ import Text.PrettyPrint.HughesPJ ((<+>), ($+$)) import qualified Text.PrettyPrint.HughesPJ as PP -- | A program, containing multiple function definitions --- mapped by KVars. -data Prog = Prog (HashMap KVar Func) +-- mapped by their name. +data Prog = Prog (HashMap Name Func) --- | A function symbol corresponding to a KVar. -data Func = Func [Decl] [Body] +-- | Identifier of a function. All KVars are translated +-- into functions, so it is just an alias. +type Name = KVar + +-- | A function symbol corresponding to a Name. +data Func = Func Signature [Body] deriving Show -- | A declaration of a Symbol with a Sort. @@ -48,24 +61,187 @@ data Statement -- ^ Constraints a variable. | Assert Expr -- ^ Checks whether a predicate follows given prior constraints. - | Call KVar Subst - -- ^ Call to function indexed by KVar. + | Call Name Subst + -- ^ Call to function. deriving Show --- | The monad used to convert a set of horn constraints to --- the imperative function format. -type MonadProg info m = (MonadState Prog m, MonadReader (SInfo info) m, Fixpoint info, MonadIO m) +-- | Arguments to a function. +type Args = Subst +-- | Signature of a function. +type Signature = [Decl] --- dbg :: (MonadIO m, PPrint a) => a -> m () --- dbg = liftIO . print . pprint +-- | The monad used to convert a set of horn constraints to +-- the imperative function format. See Prog for the format. +type MonadBuild info m = (MonadState Prog m, MonadReader (SInfo info) m, Fixpoint info, MonadIO m) + +-- | Environment for the counter example generation. +data CheckEnv = CheckEnv + { program :: Prog + -- ^ The program we are checking + , context :: SMT.Context + -- ^ The SMT context we write the constraints from the program to. + } + +-- | Unique identifier used to avoid clashing names. +type UniqueId = Int + +-- | The monad used to generate counter examples from a Prog. +type MonadCheck m = (MonadReader CheckEnv m, MonadState UniqueId m, MonadIO m) + +counterExample :: Config -> SInfo info -> Prog -> IO () +counterExample cfg si prog = do + -- let file = srcFile cfg + let file = "tests/pos/testfile" + let env = symbolEnv cfg si + ctx <- SMT.makeContextWithSEnv cfg file env + + runCheck CheckEnv + { program = prog + , context = ctx + } + valid <- SMT.smtCheckUnsat ctx + + putStr "Valid: " + print valid + when (not valid) (SMT.smtGetModel ctx >>= print) + + SMT.cleanupContext ctx + +-- | Runs the program checker with the monad stack +-- unwrapped. +runCheck :: CheckEnv -> IO () +runCheck = runReaderT $ evalStateT checkProg 0 + +-- | Check the main function. +checkProg :: MonadCheck m => m () +checkProg = checkFunc mainName (Su Map.empty) + +-- TODO: Go up to k depth (per function) to avoid infinite recursion. +checkFunc :: MonadCheck m => Name -> Args -> m () +checkFunc name args = do + -- Apply arguments to function + Func sig bodies <- getFunc name + + -- Each body generates a fresh set of signature variables + subs <- forM bodies $ checkBody sig + + -- Joins all of these fresh variables to their argument. + joinSubs args sig subs + +-- | Join all substitution mappings made by running over all +-- bodies. +-- +-- The join is a conjunct of all possible assignments. +joinSubs :: MonadCheck m => Args -> Signature -> [Subst] -> m () +joinSubs args sig subs = do + possible <- forM subs $ conjunctSub args sig + smtAssert $ POr possible + +-- | Map the arguments to a substitution of a single function body. +conjunctSub :: MonadCheck m => Args -> Signature -> Subst -> m Expr +conjunctSub (Su args) sig (Su sub) = do + -- Generate symbol as shorthand for the conjunct + bool <- smtFresh boolSort + let bool' = EVar bool + + -- Generate the conjunct of the argument mapping + let eq (Decl sym _) = PAtom Eq (args Map.! sym) (sub Map.! sym) + let conjunct = PAnd $ map eq sig + + -- Assert equality between shorthand and conjunct + smtAssert $ PAtom Eq bool' conjunct + return bool' + +-- | Get a function from the program given its name. +getFunc :: MonadCheck m => Name -> m Func +getFunc name = do + Prog prog <- reader program + return $ prog Map.! name + +-- | Run the checker of a body. Creating new instances +-- of the signature +checkBody :: MonadCheck m => Signature -> Body -> m Subst +checkBody sig (Body body) = do + sub <- uniqueSig sig + _ <- foldM statementSMT sub body + return sub + +-- | Write a statement to smt solver, possibly recursing +-- if the statement was a call. +-- +-- Declarations will change the substitution map, as +-- declarations get name mangled to avoid name clashes. +statementSMT :: MonadCheck m => Subst -> Statement -> m Subst +statementSMT sub stmt = do + let stmt' = subst sub stmt + -- Run over the program and assert statements in SMT solver. + case stmt' of + Call name app -> checkFunc name app + Assume e -> smtAssert $ subst sub e + Assert e -> smtAssume $ subst sub e + _ -> return () + + -- A declaration will also adjust the substitution + -- map and is thus separated here. + case stmt of + Let decl -> smtDeclare sub decl + _ -> return sub + +-- | Generate unique symbols for a function signature. +uniqueSig :: MonadCheck m => Signature -> m Subst +uniqueSig = foldM smtDeclare (Su Map.empty) + +-- | Returns a unique version of the received symbol. +uniqueSym :: MonadCheck m => Symbol -> m Symbol +uniqueSym sym = do + -- Get unique number + unique <- get + put $ unique + 1 + + -- Apply unique number to identifier + let (<.>) = suffixSymbol + let unique' = symbol . show $ unique + return $ sym <.> "@" <.> unique' + +-- | Declare a new symbol, returning an updated substitution +-- given with this new symbol in it. The substitution map is +-- required to avoid duplicating variable names. +smtDeclare :: MonadCheck m => Subst -> Decl -> m Subst +smtDeclare (Su sub) (Decl sym sort) = do + ctx <- reader context + sym' <- uniqueSym sym + liftIO $ SMT.smtDecl ctx sym' sort + return (Su $ Map.insert sym (EVar sym') sub) + +-- | Declare a fresh symbol, not derived from a declaration. +smtFresh :: MonadCheck m => Sort -> m Symbol +smtFresh sort = do + ctx <- reader context + sym <- uniqueSym "fresh@" + liftIO $ SMT.smtDecl ctx sym sort + return sym + +-- | Assume the given expression. +smtAssume :: MonadCheck m => Expr -> m () +smtAssume = smtAssert . PNot + +-- | Assert the given expression. +smtAssert :: MonadCheck m => Expr -> m () +smtAssert e = do + ctx <- reader context + liftIO $ SMT.smtAssert ctx e + +-- TODO: remove this on code cleanup +dbg :: (MonadIO m, PPrint a) => a -> m () +dbg = liftIO . print . pprint -- | Make an imperative program from horn clauses. This -- can be used to generate a counter example. -hornToProg :: Fixpoint info => SInfo info -> IO Prog +hornToProg :: (MonadIO m, Fixpoint info) => SInfo info -> m Prog hornToProg si = execStateT (runReaderT go si) prog where -- Initial program has empty main - prog = Prog $ Map.singleton mainKVar (Func [] []) + prog = Prog $ Map.singleton mainName (Func [] []) -- Add all horn clauses in SInfo to the function map go = reader cm >>= mapM_ addHorn @@ -76,22 +252,22 @@ hornToProg si = execStateT (runReaderT go si) prog -- This body is added to the function given by the kvar -- on the rhs of the horn clause. If there was no kvar, -- it is added to the main function. -addHorn :: MonadProg info m => SimpC info -> m () +addHorn :: MonadBuild info m => SimpC info -> m () addHorn horn = do (name, func) <- case crhs horn of PKVar kvar sub -> do decl <- getSig kvar - -- TODO: Use sub to add constraints to input types (specifically some equivalences) - _ <- substToBody sub body <- hornLhsToBody horn - return (kvar, Func decl [body]) + body' <- substToBody sub + return (kvar, Func decl [body <> body']) rhs@_ -> do Body stmts <- hornLhsToBody horn let body = Body $ stmts <> [Assert rhs] - return (mainKVar, Func [] [body]) + return (mainName, Func [] [body]) addFunc name func -getSig :: MonadProg info m => KVar -> m [Decl] +-- | Gets a signature of a KVar from its well foundedness constraint +getSig :: MonadBuild info m => Name -> m Signature getSig kvar = do -- Get the well foundedness constraint of the kvar wfcs <- reader ws @@ -111,10 +287,16 @@ getSig kvar = do -- Return the head + bindings as argument map return $ rhs:decls -substToBody :: MonadProg info m => Subst -> m Body -substToBody sub = return [] +-- | Defines some equalities between local variables +-- and the passed arguments given some substitution map. +substToBody :: MonadBuild info m => Subst -> m Body +substToBody (Su sub) = do + let asEq (ksym, e) = Assume $ PAtom Eq (EVar ksym) e + return . Body . map asEq . Map.toList $ sub -hornLhsToBody :: MonadProg info m => SimpC info -> m Body +-- | Converts the left hand side of the horn clause to a list +-- of assumptions (or calls given by a Name) +hornLhsToBody :: MonadBuild info m => SimpC info -> m Body hornLhsToBody horn = do bindEnv <- reader bs let lhs = clhs bindEnv horn @@ -130,24 +312,21 @@ reftToBody sym RR { sr_sort = sort , sr_reft = Reft (v, e) } = Body - [ Let (Decl sym sort) - , constraint - ] + [ Let (Decl sym sort) + , constraint + ] where -- Make constraint with proper substitution constraint = case e of - PKVar kvar (Su hm) -> Call kvar (Su . Map.map mapv $ hm) - _ -> Assume $ subst (Su . Map.singleton v $ EVar sym) e + PKVar kvar (Su app) -> Call kvar (Su $ subst sub app) + _ -> Assume $ subst sub e - -- Substitution function for the kvar Subst map (the normal - -- subst we use for the other expressions doesn't work) - mapv (EVar v') | v' == v = EVar sym - mapv i@_ = i + sub = Su . Map.singleton v $ EVar sym --- | Add a function to the function map with name KVar. +-- | Add a function to the function map with index by its name. -- If an entry already exists, it will merge the function -- bodies. -addFunc :: MonadProg info m => KVar -> Func -> m () +addFunc :: MonadBuild info m => Name -> Func -> m () addFunc kvar func = do let merge (Func _ b) (Func d b') = Func d (b <> b') Prog prog <- get @@ -155,8 +334,8 @@ addFunc kvar func = do -- | The main function, which any horn clause without a -- KVar on the rhs will be added to. -mainKVar :: KVar -mainKVar = KV $ symbol "main" +mainName :: Name +mainName = KV "main" instance PPrint Prog where pprintTidy tidy (Prog funcs) = PP.vcat @@ -166,28 +345,28 @@ instance PPrint Prog where $ funcs instance PPrint Func where - pprintTidy tidy = ppfunc tidy anon + pprintTidy tidy = ppfunc tidy anonymous where - anon = KV $ symbol "_" + anonymous = KV "_" -ppfunc :: Tidy -> KVar -> Func -> PP.Doc -ppfunc tidy name (Func decls bodies) = psig $+$ pbody $+$ PP.rbrace +ppfunc :: Tidy -> Name -> Func -> PP.Doc +ppfunc tidy name (Func sig bodies) = pdecl $+$ pbody $+$ PP.rbrace where - psig = fn <+> pname <+> pdecls <+> PP.lbrace + pdecl = fn <+> pname <+> psig <+> PP.lbrace fn = PP.text "fn" pname = pprintTidy tidy name - pdecls = PP.parens + psig = PP.parens . PP.hsep . PP.punctuate PP.comma . map (pprintTidy tidy) - $ decls - pbody = punctuate' (PP.text "||") + $ sig + pbody = vpunctuate (PP.text "||") . map (PP.nest 4 . pprintTidy tidy) $ bodies - punctuate' _ [] = mempty - punctuate' _ (d:[]) = d - punctuate' p (d:ds) = d $+$ p $+$ punctuate' p ds + vpunctuate _ [] = mempty + vpunctuate _ (d:[]) = d + vpunctuate p (d:ds) = d $+$ p $+$ vpunctuate p ds instance PPrint Decl where pprintTidy tidy (Decl sym sort) = (psym <> PP.colon) <+> psort @@ -211,3 +390,158 @@ instance Semigroup Body where instance Monoid Body where mempty = Body [] + +instance Subable Statement where + syms (Let (Decl sym _)) = [sym] + syms (Assume e) = syms e + syms (Assert e) = syms e + syms (Call _ (Su sub)) = syms sub + + substa f (Assume e) = Assume $ substa f e + substa f (Assert e) = Assert $ substa f e + substa f (Call name (Su sub)) = Call name (Su $ substa f sub) + substa _ decl@_ = decl + + substf f (Assume e) = Assume $ substf f e + substf f (Assert e) = Assert $ substf f e + substf f (Call name (Su sub)) = Call name (Su $ substf f sub) + substf _ decl@_ = decl + + subst sub (Assume e) = Assume $ subst sub e + subst sub (Assert e) = Assert $ subst sub e + subst sub (Call name (Su sub')) = Call name (Su $ subst sub sub') + subst _ decl@_ = decl + +-- fn k1(x: Int) { +-- assume x == 11 +-- || +-- assume x == 12 +-- } +-- +-- fn k2(x: Int) { +-- assume x == 21 +-- || +-- assume x == 22 +-- } +-- +-- fn main() { +-- let y : Int +-- let z : Int +-- k1(y) +-- k2(z) +-- assert y != z +-- } +-- +-- -- BFS vs DFS +-- -- - BFS: brings much more in scope at a time +-- -- - DFS: has much more calls +-- -- +-- -- - BFS: Name clashing is much worse +-- -- - DFS: The way to explore the program is very non-obvious... +-- -- +-- -- For now do BFS as the impl seems easier +-- +-- -- Breadth First Search +-- (declare-const y Int) +-- (declare-const z Int) +-- +-- -- k1 body 0 +-- (declare-const x$b0$k1 Int) +-- (assert (= x$b0$k1 11)) +-- +-- -- k1 body 1 +-- (declare-const x$b1$k1 Int) +-- (assert (= x$b1$k1 12)) +-- +-- -- Union of k1 call (Not sure if this is sound) +-- (assert (or (= x$b0$k1 y) (= x$b1$k1 y))) +-- +-- -- k2 body 0 +-- (declare-const x$b0$k2 Int) +-- (assert (= x$b0$k1 21)) +-- +-- -- k2 body 1 +-- (declare-const x$b1$k2 Int) +-- (assert (= x$b1$k1 22)) +-- +-- -- Union of k2 call +-- (assert (or (= x$b0$k2 z) (= x$b1$k2 z))) +-- +-- -- Final assertion +-- (assert (not (!= y z))) +-- (check-sat) +-- +-- -- Depth First Search +-- (declare-const y Int) +-- (declare-const z Int) +-- +-- (push 1) -- call k1 +-- (declare-const x$k1 Int) +-- (assert (= x$k1 11)) +-- (push 1) -- call k2 +-- (declare-const x$k2 Int) +-- (assert (= x$k2 21)) +-- (assert (= x$k1 y)) +-- (assert (= x$k2 z)) +-- (assert (not (!= y z))) -- final assertion +-- (check-sat) +-- (pop 1) +-- (push 1) -- call k2 +-- (declare-const x$k2 Int) +-- (assert (= x$k2 22)) +-- (assert (= x$k1 y)) +-- (assert (= x$k2 z)) +-- (assert (not (!= y z))) -- final assertion +-- (check-sat) +-- (pop 1) +-- (pop 1) +-- +-- (push 1) -- call k1 +-- (declare-const x$k1 Int) +-- (assert (= x$k1 12)) -- +-- (push 1) -- call k2 +-- (declare-const x$k2 Int) +-- (assert (= x$k2 21)) +-- (assert (= x$k1 y)) +-- (assert (= x$k2 z)) +-- (assert (not (!= y z))) -- final assertion +-- (check-sat) +-- (pop 1) +-- (push 1) -- call k2 +-- (declare-const x$k2 Int) +-- (assert (= x$k2 22)) +-- (assert (= x$k1 y)) +-- (assert (= x$k2 z)) +-- (assert (not (!= y z))) -- final assertion +-- (check-sat) +-- (pop 1) +-- (pop 1) +-- +-- fn $k1 (lq_karg$v0: Int) { +-- let v : Int +-- assume v == 1 +-- assume v == lq_karg$v0 +-- || +-- let x : Int +-- assume v == 2 +-- assume v == lq_karg$v0 +-- } +-- +-- fn $main () { +-- let z : Int +-- $k1 [lq_karg$v0 := z] +-- assert z > 0 +-- } +-- +-- (declare-var z-->0 Int) -- From main +-- (declare-var lq_karg$v0-->1 Int) -- Unique karg from k1 call +-- (assert (= lq_karg$v0-->1 z)) -- From call to k1 substitution +-- +-- (declare-var lq_karg$v0-->2 Int) -- From first body +-- [..] +-- +-- (declare-var lq_karg$v0-->3 Int) -- From second body +-- [..] +-- +-- -- Assertion combining all versions of the karg +-- (assert (or (= lq_karg$v0-->1 lq_karg$v0-->2) (= lq_karg$v0-->1 lq_karg$v0-->3)) diff --git a/src/Language/Fixpoint/Smt/Interface.hs b/src/Language/Fixpoint/Smt/Interface.hs index 5228e7ef1..c08ac0440 100644 --- a/src/Language/Fixpoint/Smt/Interface.hs +++ b/src/Language/Fixpoint/Smt/Interface.hs @@ -53,6 +53,7 @@ module Language.Fixpoint.Smt.Interface ( , smtDistinct , smtPush, smtPop , smtGetValues + , smtGetModel -- * Check Validity , checkValid @@ -78,6 +79,7 @@ import qualified Language.Fixpoint.Smt.Theories as Thy import Language.Fixpoint.Smt.Serialize () import Control.Applicative ((<|>)) import Control.Monad +import Control.Monad.IO.Class import Control.Exception import Data.ByteString.Builder (Builder) import qualified Data.ByteString.Builder as BS @@ -180,7 +182,7 @@ command Ctx {..} !cmd = do cmdBS = {-# SCC "Command-runSmt2" #-} runSmt2 ctxSymEnv cmd parse resp = do case A.parseOnly responseP resp of - Left e -> Misc.errorstar $ "SMTREAD:" ++ e + Left e -> Misc.errorstar $ "SMTREAD: " ++ e ++ "\n" ++ T.unpack resp Right r -> do let textResponse = "; SMT Says: " <> T.pack (show r) forM_ ctxLog $ \h -> @@ -192,19 +194,26 @@ command Ctx {..} !cmd = do bs2txt :: Char8.ByteString -> T.Text bs2txt = TE.decodeUtf8With (const $ const $ Just ' ') . LBS.toStrict -smtGetValues :: Context -> [Symbol] -> IO (M.HashMap Symbol Expr) +smtGetValues :: MonadIO m => Context -> [Symbol] -> m (M.HashMap Symbol Expr) smtGetValues _ [] = return M.empty smtGetValues Ctx {..} syms = do -- bytestring <- SMTLIB.Backends.command ctxSolver "(get-model)" -- print bytestring let cmd = key "get-value" (parenSeqs $ map (smt2 ctxSymEnv) syms) - bytestring <- SMTLIB.Backends.command ctxSolver cmd + bytestring <- liftIO $ SMTLIB.Backends.command ctxSolver cmd let text = bs2txt bytestring case A.parseOnly valuesP text of Left err -> Misc.errorstar $ "Parse error on get-value: " ++ err ++ "\n\n" ++ show text Right sol -> return sol +smtGetModel :: MonadIO m => Context -> m T.Text +smtGetModel Ctx {..} = do + let cmd = "(get-model)" + bytestring <- liftIO $ SMTLIB.Backends.command ctxSolver cmd + let text = bs2txt bytestring + return text + smtSetMbqi :: Context -> IO () smtSetMbqi me = interact' me SetMbqi diff --git a/src/Language/Fixpoint/Solver.hs b/src/Language/Fixpoint/Solver.hs index df986d69c..601e7f4a9 100644 --- a/src/Language/Fixpoint/Solver.hs +++ b/src/Language/Fixpoint/Solver.hs @@ -268,7 +268,10 @@ solveNative' !cfg !fi0 = do -- print si6 print fi0 prog <- hornToProg si6 + print si6 print . pprint $ prog + counterExample cfg si6 prog + res <- {- SCC "Sol.solve" -} Sol.solve cfg $!! si6 -- rnf soln `seq` donePhase Loud "Solve2" From 991419708ce1feb0ca87534032a455706bcad3f6 Mon Sep 17 00:00:00 2001 From: Robin Webbers Date: Thu, 11 May 2023 17:18:07 +0200 Subject: [PATCH 03/33] Fixed typing issues of counter examples. Fixed issue of running multiple bodies, causing no counter example to be generated. Actually fetches counter examples from the smt solve now. --- src/Language/Fixpoint/CounterExample.hs | 421 ++++++++++++------------ src/Language/Fixpoint/Smt/Interface.hs | 57 ++-- src/Language/Fixpoint/Solver.hs | 15 +- src/Language/Fixpoint/Solver/Monad.hs | 6 +- src/Language/Fixpoint/Utils/Files.hs | 2 + 5 files changed, 247 insertions(+), 254 deletions(-) diff --git a/src/Language/Fixpoint/CounterExample.hs b/src/Language/Fixpoint/CounterExample.hs index 114d679ed..ff1a1d811 100644 --- a/src/Language/Fixpoint/CounterExample.hs +++ b/src/Language/Fixpoint/CounterExample.hs @@ -2,6 +2,8 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MultiWayIf #-} module Language.Fixpoint.CounterExample ( hornToProg @@ -18,10 +20,12 @@ module Language.Fixpoint.CounterExample ) where import Language.Fixpoint.Types -import Language.Fixpoint.Types.Config (Config) ---import Language.Fixpoint.Types.Config (Config, srcFile) +import Language.Fixpoint.Types.Config (Config, srcFile, queryFile, save) import Language.Fixpoint.Solver.Sanitize (symbolEnv) +import Language.Fixpoint.Misc (ensurePath) +import Language.Fixpoint.SortCheck (elaborate) +import qualified Language.Fixpoint.Utils.Files as Ext import qualified Language.Fixpoint.Smt.Interface as SMT import Data.HashMap.Strict (HashMap) @@ -36,6 +40,7 @@ import qualified Text.PrettyPrint.HughesPJ as PP -- | A program, containing multiple function definitions -- mapped by their name. data Prog = Prog (HashMap Name Func) + deriving Show -- | Identifier of a function. All KVars are translated -- into functions, so it is just an alias. @@ -70,9 +75,17 @@ type Args = Subst -- | Signature of a function. type Signature = [Decl] +-- | The enviroment used to build a program. +data BuildEnv info = BuildEnv + { info :: SInfo info + -- ^ The horn constraints from which we build the program. + , symbols :: SymEnv + -- ^ Contains the sorts of symbols, which we need for declarations. + } + -- | The monad used to convert a set of horn constraints to -- the imperative function format. See Prog for the format. -type MonadBuild info m = (MonadState Prog m, MonadReader (SInfo info) m, Fixpoint info, MonadIO m) +type MonadBuild info m = (MonadState Prog m, MonadReader (BuildEnv info) m, MonadIO m) -- | Environment for the counter example generation. data CheckEnv = CheckEnv @@ -88,42 +101,90 @@ type UniqueId = Int -- | The monad used to generate counter examples from a Prog. type MonadCheck m = (MonadReader CheckEnv m, MonadState UniqueId m, MonadIO m) -counterExample :: Config -> SInfo info -> Prog -> IO () -counterExample cfg si prog = do - -- let file = srcFile cfg - let file = "tests/pos/testfile" - let env = symbolEnv cfg si - ctx <- SMT.makeContextWithSEnv cfg file env +-- | Try to get a counter example for the given constraints. +counterExample :: (MonadIO m, Fixpoint info) => Config -> SInfo info -> m [Maybe Subst] +counterExample cfg si = do + prog <- hornToProg cfg si + checkProg cfg si prog - runCheck CheckEnv - { program = prog - , context = ctx - } - valid <- SMT.smtCheckUnsat ctx +-- | Checks the given program, returning a counter example +-- (if it can find one). +-- +-- TODO: Actually return a counter example! +checkProg :: MonadIO m => Config -> SInfo info -> Prog -> m [Maybe Subst] +checkProg cfg si prog = withContext cfg si check + where + check ctx = runCheck CheckEnv + { program = prog + , context = ctx + } + +-- | Run the checker with the SMT solver context. +withContext :: MonadIO m => Config -> SInfo info -> (SMT.Context -> m a) -> m a +withContext cfg si inner = do + let file = srcFile cfg <> ".prog" + let env = symbolEnv cfg si + ctx <- liftIO $ SMT.makeContextWithSEnv cfg file env - putStr "Valid: " - print valid - when (not valid) (SMT.smtGetModel ctx >>= print) + !result <- inner ctx - SMT.cleanupContext ctx + liftIO $ SMT.cleanupContext ctx + return result -- | Runs the program checker with the monad stack -- unwrapped. -runCheck :: CheckEnv -> IO () -runCheck = runReaderT $ evalStateT checkProg 0 - --- | Check the main function. -checkProg :: MonadCheck m => m () -checkProg = checkFunc mainName (Su Map.empty) - --- TODO: Go up to k depth (per function) to avoid infinite recursion. -checkFunc :: MonadCheck m => Name -> Args -> m () -checkFunc name args = do - -- Apply arguments to function +runCheck :: MonadIO m => CheckEnv -> m [Maybe Subst] +runCheck = runReaderT $ evalStateT checkMain 0 + +-- | Check the main function. Each branch in the main +-- function needs to be checked separately. +checkMain :: MonadCheck m => m [Maybe Subst] +checkMain = do + Func sig bodies <- getFunc mainName + forM bodies $ smtScope . checkBody sig + +-- | Perform a satisfiability check over the body, producing +-- a counter example if the model is not valid. +checkBody :: MonadCheck m => Signature -> Body -> m (Maybe Subst) +checkBody sig body = do + -- Produce the assertions for this body. + -- Substitution map contains (prog symbols |-> unique symbols) + Su sub <- runBody sig body + -- Get the variables of interest (the ones declared in the body). + let smtSyms = [sym | (_, EVar sym) <- Map.toList sub] + + -- Check satisfiability + ctx <- reader context + valid <- liftIO $ SMT.smtCheckUnsat ctx + + -- Get a counter example if not valid. + ex <- if | not valid -> SMT.smtGetValues ctx smtSyms >>= return . Just + | otherwise -> return Nothing + + -- Remap the counter example to program symbols. We got it in + -- smt "safe" symbols, which we cannot directly translate back. + -- Hence, we use the substitution maps we have at hand. + return $ do + -- Map from (unique safe symbols |-> instance) + Su instances <- ex + -- Rename a symbol to its smt2 version. + let rename = symbol . symbolSafeText + -- Does remapping from smt name to prog name. + let remap (EVar sym) = Map.lookup (rename sym) instances + remap _ = Nothing + -- Final map from (prog symbols |-> instance) + return $ Su (Map.mapMaybe remap sub) + +-- TODO: Go up to k depth (per function) to avoid infinite recursion +-- with cyclic kvars. +runFunc :: MonadCheck m => Name -> Args -> m () +runFunc name args = do + -- Get the function to check. Func sig bodies <- getFunc name - -- Each body generates a fresh set of signature variables - subs <- forM bodies $ checkBody sig + -- Check all bodies of this function in a breath first manner. + -- Each body generates a fresh set of signature variables. + subs <- forM bodies $ runBody sig -- Joins all of these fresh variables to their argument. joinSubs args sig subs @@ -131,24 +192,37 @@ checkFunc name args = do -- | Join all substitution mappings made by running over all -- bodies. -- --- The join is a conjunct of all possible assignments. +-- The join is a disjunct of all possible assignments. joinSubs :: MonadCheck m => Args -> Signature -> [Subst] -> m () joinSubs args sig subs = do possible <- forM subs $ conjunctSub args sig smtAssert $ POr possible -- | Map the arguments to a substitution of a single function body. +-- +-- To elaborate, given the following variables: +-- The mapping of the arguments. +-- -- ^ (sym |-> arg) :: Args +-- +-- The arguments themselves. +-- -- ^ [sym] :: Signature +-- +-- The unique mapping generated for a body. +-- -- ^ (sym |-> unique) :: Subst +-- +-- We generate a conjunct of (arg == unique) for every symbol in +-- the signature. conjunctSub :: MonadCheck m => Args -> Signature -> Subst -> m Expr conjunctSub (Su args) sig (Su sub) = do - -- Generate symbol as shorthand for the conjunct + -- Generate symbol as shorthand for the conjunct. bool <- smtFresh boolSort let bool' = EVar bool - -- Generate the conjunct of the argument mapping + -- Generate the conjunct of the argument mapping. let eq (Decl sym _) = PAtom Eq (args Map.! sym) (sub Map.! sym) let conjunct = PAnd $ map eq sig - -- Assert equality between shorthand and conjunct + -- Assert equality between shorthand and conjunct. smtAssert $ PAtom Eq bool' conjunct return bool' @@ -158,27 +232,31 @@ getFunc name = do Prog prog <- reader program return $ prog Map.! name --- | Run the checker of a body. Creating new instances --- of the signature -checkBody :: MonadCheck m => Signature -> Body -> m Subst -checkBody sig (Body body) = do +-- | Run the checker over a body. Creating new instances +-- of the signature and elaborating the statements in +-- it to the smt solver. +-- +-- The returned substitution map contains all variables +-- that were renamed during the run. This includes the +-- signature as well as all the declarations in the body. +runBody :: MonadCheck m => Signature -> Body -> m Subst +runBody sig (Body body) = do sub <- uniqueSig sig - _ <- foldM statementSMT sub body - return sub + foldM runStatement sub body -- | Write a statement to smt solver, possibly recursing -- if the statement was a call. -- -- Declarations will change the substitution map, as -- declarations get name mangled to avoid name clashes. -statementSMT :: MonadCheck m => Subst -> Statement -> m Subst -statementSMT sub stmt = do +runStatement :: MonadCheck m => Subst -> Statement -> m Subst +runStatement sub stmt = do let stmt' = subst sub stmt -- Run over the program and assert statements in SMT solver. case stmt' of - Call name app -> checkFunc name app - Assume e -> smtAssert $ subst sub e - Assert e -> smtAssume $ subst sub e + Call name app -> runFunc name app + Assume e -> smtAssume $ subst sub e + Assert e -> smtAssert $ subst sub e _ -> return () -- A declaration will also adjust the substitution @@ -217,33 +295,63 @@ smtDeclare (Su sub) (Decl sym sort) = do smtFresh :: MonadCheck m => Sort -> m Symbol smtFresh sort = do ctx <- reader context - sym <- uniqueSym "fresh@" + sym <- uniqueSym "fresh" liftIO $ SMT.smtDecl ctx sym sort return sym -- | Assume the given expression. -smtAssume :: MonadCheck m => Expr -> m () -smtAssume = smtAssert . PNot +smtAssert :: MonadCheck m => Expr -> m () +smtAssert = smtAssume . PNot -- | Assert the given expression. -smtAssert :: MonadCheck m => Expr -> m () -smtAssert e = do +smtAssume :: MonadCheck m => Expr -> m () +smtAssume e = do ctx <- reader context liftIO $ SMT.smtAssert ctx e +-- | Run the checker within a scope (i.e. a push/pop pair). +smtScope :: MonadCheck m => m a -> m a +smtScope inner = do + ctx <- reader context + liftIO $ SMT.smtPush ctx + !result <- inner + liftIO $ SMT.smtPop ctx + return result + -- TODO: remove this on code cleanup dbg :: (MonadIO m, PPrint a) => a -> m () dbg = liftIO . print . pprint -- | Make an imperative program from horn clauses. This -- can be used to generate a counter example. -hornToProg :: (MonadIO m, Fixpoint info) => SInfo info -> m Prog -hornToProg si = execStateT (runReaderT go si) prog - where - -- Initial program has empty main - prog = Prog $ Map.singleton mainName (Func [] []) - -- Add all horn clauses in SInfo to the function map - go = reader cm >>= mapM_ addHorn +hornToProg :: MonadIO m => Config -> SInfo info -> m Prog +hornToProg cfg si = do + -- Initial program is just an empty main. + let initial = Prog $ Map.singleton mainName (Func [] []) + let env = BuildEnv + { info = si + , symbols = symbolEnv cfg si + } + + -- Run monad that adds all horn clauses + prog <- evalStateT (runReaderT buildProg env) initial + + -- Save the program in a file + liftIO . when (save cfg) $ do + let file = queryFile Ext.Prog cfg + ensurePath file + writeFile file $ PP.render (pprint prog) + + -- Return the generated program + return prog + +-- | Build the entire program structure from the constraints +-- inside the monad +buildProg :: MonadBuild info m => m Prog +buildProg = do + constraints <- reader $ cm . info + mapM_ addHorn constraints + get -- | Given a horn clause, generates a body for a function. -- @@ -270,11 +378,11 @@ addHorn horn = do getSig :: MonadBuild info m => Name -> m Signature getSig kvar = do -- Get the well foundedness constraint of the kvar - wfcs <- reader ws + wfcs <- reader $ ws . info let wfc = wfcs Map.! kvar -- Get the bind environment and bindings of the wfc - bindEnv <- reader bs + bindEnv <- reader $ bs . info let ibinds = elemsIBindEnv . wenv $ wfc -- Lookup all Decl from the wfc using the ibinds @@ -298,30 +406,38 @@ substToBody (Su sub) = do -- of assumptions (or calls given by a Name) hornLhsToBody :: MonadBuild info m => SimpC info -> m Body hornLhsToBody horn = do - bindEnv <- reader bs + bindEnv <- reader $ bs . info let lhs = clhs bindEnv horn - return $ lhsToBody lhs - --- | Map a complete lhs of a horn clause to a function body -lhsToBody :: [(Symbol, SortedReft)] -> Body -lhsToBody = mconcat . map (uncurry reftToBody) + bodies <- forM lhs $ uncurry reftToBody + return $ mconcat bodies -- | Map a refinement to a declaration and constraint pair -reftToBody :: Symbol -> SortedReft -> Body +reftToBody :: MonadBuild info m => Symbol -> SortedReft -> m Body reftToBody sym RR { sr_sort = sort , sr_reft = Reft (v, e) - } = Body - [ Let (Decl sym sort) - , constraint - ] - where + } = do -- Make constraint with proper substitution - constraint = case e of - PKVar kvar (Su app) -> Call kvar (Su $ subst sub app) - _ -> Assume $ subst sub e - - sub = Su . Map.singleton v $ EVar sym + let sub = Su . Map.singleton v $ EVar sym + let constraint = case e of + PKVar kvar (Su app) -> Call kvar (Su $ subst sub app) + _ -> Assume $ subst sub e + + sort' <- elaborateSort sort + return $ Body + [ Let $ Decl sym sort' + , constraint + ] + +-- | The sorts for the apply monomorphization only match if +-- we do this elaborate on the sort. Not sure why... +-- +-- This elaboration also happens inside the declaration +-- of the symbol environment, so that where I got the idea. +elaborateSort :: MonadBuild info m => Sort -> m Sort +elaborateSort sym = do + symbols' <- reader symbols + return $ elaborate "elaborateSort" symbols' sym -- | Add a function to the function map with index by its name. -- If an entry already exists, it will merge the function @@ -392,156 +508,31 @@ instance Monoid Body where mempty = Body [] instance Subable Statement where - syms (Let (Decl sym _)) = [sym] + syms (Let decl) = syms decl syms (Assume e) = syms e syms (Assert e) = syms e syms (Call _ (Su sub)) = syms sub + substa f (Let decl) = Let $ substa f decl substa f (Assume e) = Assume $ substa f e substa f (Assert e) = Assert $ substa f e substa f (Call name (Su sub)) = Call name (Su $ substa f sub) - substa _ decl@_ = decl + substf f (Let decl) = Let $ substf f decl substf f (Assume e) = Assume $ substf f e substf f (Assert e) = Assert $ substf f e substf f (Call name (Su sub)) = Call name (Su $ substf f sub) - substf _ decl@_ = decl + subst sub (Let decl) = Let $ subst sub decl subst sub (Assume e) = Assume $ subst sub e subst sub (Assert e) = Assert $ subst sub e subst sub (Call name (Su sub')) = Call name (Su $ subst sub sub') - subst _ decl@_ = decl - --- fn k1(x: Int) { --- assume x == 11 --- || --- assume x == 12 --- } --- --- fn k2(x: Int) { --- assume x == 21 --- || --- assume x == 22 --- } --- --- fn main() { --- let y : Int --- let z : Int --- k1(y) --- k2(z) --- assert y != z --- } --- --- -- BFS vs DFS --- -- - BFS: brings much more in scope at a time --- -- - DFS: has much more calls --- -- --- -- - BFS: Name clashing is much worse --- -- - DFS: The way to explore the program is very non-obvious... --- -- --- -- For now do BFS as the impl seems easier --- --- -- Breadth First Search --- (declare-const y Int) --- (declare-const z Int) --- --- -- k1 body 0 --- (declare-const x$b0$k1 Int) --- (assert (= x$b0$k1 11)) --- --- -- k1 body 1 --- (declare-const x$b1$k1 Int) --- (assert (= x$b1$k1 12)) --- --- -- Union of k1 call (Not sure if this is sound) --- (assert (or (= x$b0$k1 y) (= x$b1$k1 y))) --- --- -- k2 body 0 --- (declare-const x$b0$k2 Int) --- (assert (= x$b0$k1 21)) --- --- -- k2 body 1 --- (declare-const x$b1$k2 Int) --- (assert (= x$b1$k1 22)) --- --- -- Union of k2 call --- (assert (or (= x$b0$k2 z) (= x$b1$k2 z))) --- --- -- Final assertion --- (assert (not (!= y z))) --- (check-sat) --- --- -- Depth First Search --- (declare-const y Int) --- (declare-const z Int) --- --- (push 1) -- call k1 --- (declare-const x$k1 Int) --- (assert (= x$k1 11)) --- (push 1) -- call k2 --- (declare-const x$k2 Int) --- (assert (= x$k2 21)) --- (assert (= x$k1 y)) --- (assert (= x$k2 z)) --- (assert (not (!= y z))) -- final assertion --- (check-sat) --- (pop 1) --- (push 1) -- call k2 --- (declare-const x$k2 Int) --- (assert (= x$k2 22)) --- (assert (= x$k1 y)) --- (assert (= x$k2 z)) --- (assert (not (!= y z))) -- final assertion --- (check-sat) --- (pop 1) --- (pop 1) --- --- (push 1) -- call k1 --- (declare-const x$k1 Int) --- (assert (= x$k1 12)) -- --- (push 1) -- call k2 --- (declare-const x$k2 Int) --- (assert (= x$k2 21)) --- (assert (= x$k1 y)) --- (assert (= x$k2 z)) --- (assert (not (!= y z))) -- final assertion --- (check-sat) --- (pop 1) --- (push 1) -- call k2 --- (declare-const x$k2 Int) --- (assert (= x$k2 22)) --- (assert (= x$k1 y)) --- (assert (= x$k2 z)) --- (assert (not (!= y z))) -- final assertion --- (check-sat) --- (pop 1) --- (pop 1) --- --- fn $k1 (lq_karg$v0: Int) { --- let v : Int --- assume v == 1 --- assume v == lq_karg$v0 --- || --- let x : Int --- assume v == 2 --- assume v == lq_karg$v0 --- } --- --- fn $main () { --- let z : Int --- $k1 [lq_karg$v0 := z] --- assert z > 0 --- } --- --- (declare-var z-->0 Int) -- From main --- (declare-var lq_karg$v0-->1 Int) -- Unique karg from k1 call --- (assert (= lq_karg$v0-->1 z)) -- From call to k1 substitution --- --- (declare-var lq_karg$v0-->2 Int) -- From first body --- [..] --- --- (declare-var lq_karg$v0-->3 Int) -- From second body --- [..] --- --- -- Assertion combining all versions of the karg --- (assert (or (= lq_karg$v0-->1 lq_karg$v0-->2) (= lq_karg$v0-->1 lq_karg$v0-->3)) + +instance Subable Decl where + syms (Decl sym _) = [sym] + + substa f (Decl sym sort) = Decl (substa f sym) sort + + substf f (Decl sym sort) = Decl (substf f sym) sort + + subst sub (Decl sym sort) = Decl (subst sub sym) sort diff --git a/src/Language/Fixpoint/Smt/Interface.hs b/src/Language/Fixpoint/Smt/Interface.hs index c08ac0440..8665c8b08 100644 --- a/src/Language/Fixpoint/Smt/Interface.hs +++ b/src/Language/Fixpoint/Smt/Interface.hs @@ -164,7 +164,7 @@ checkValids cfg f xts ps -------------------------------------------------------------------------------- {-# SCC command #-} -command :: Context -> Command -> IO Response +command :: Context -> Command -> IO Response -------------------------------------------------------------------------------- command Ctx {..} !cmd = do -- whenLoud $ do LTIO.appendFile debugFile (s <> "\n") @@ -179,7 +179,7 @@ command Ctx {..} !cmd = do commandRaw = do resp <- SMTLIB.Backends.command ctxSolver cmdBS parse $ bs2txt resp - cmdBS = {-# SCC "Command-runSmt2" #-} runSmt2 ctxSymEnv cmd + cmdBS = {-# SCC "Command-runSmt2" #-} smt2 ctxSymEnv cmd parse resp = do case A.parseOnly responseP resp of Left e -> Misc.errorstar $ "SMTREAD: " ++ e ++ "\n" ++ T.unpack resp @@ -194,12 +194,9 @@ command Ctx {..} !cmd = do bs2txt :: Char8.ByteString -> T.Text bs2txt = TE.decodeUtf8With (const $ const $ Just ' ') . LBS.toStrict -smtGetValues :: MonadIO m => Context -> [Symbol] -> m (M.HashMap Symbol Expr) -smtGetValues _ [] = return M.empty +smtGetValues :: MonadIO m => Context -> [Symbol] -> m Subst +smtGetValues _ [] = return $ Su M.empty smtGetValues Ctx {..} syms = do - -- bytestring <- SMTLIB.Backends.command ctxSolver "(get-model)" - -- print bytestring - let cmd = key "get-value" (parenSeqs $ map (smt2 ctxSymEnv) syms) bytestring <- liftIO $ SMTLIB.Backends.command ctxSolver cmd let text = bs2txt bytestring @@ -219,10 +216,10 @@ smtSetMbqi me = interact' me SetMbqi type SmtParser a = Parser T.Text a -valuesP :: SmtParser (M.HashMap Symbol Expr) +valuesP :: SmtParser Subst valuesP = parenP $ do vs <- A.many' valueP - return $ M.fromList vs + return $ Su (M.fromList vs) valueP :: SmtParser (Symbol, Expr) valueP = parenP $ do @@ -231,9 +228,7 @@ valueP = parenP $ do return (sym, expr) exprP :: SmtParser Expr -exprP = do - expr <- (appP <|> litP) - return expr +exprP = appP <|> litP appP :: SmtParser Expr appP = do @@ -241,16 +236,25 @@ appP = do return $ foldl' EApp e es litP :: SmtParser Expr -litP = EVar <$> symbolP - -parenP :: SmtParser a -> SmtParser a -parenP inner = do - A.skipSpace - _ <- A.char '(' - res <- inner - _ <- A.char ')' - A.skipSpace - return res +litP = integerP <|> realP <|> boolP <|> (EVar <$> symbolP) + +-- TODO: Parse minus as just a negative integer +integerP :: SmtParser Expr +integerP = do + int <- A.signed A.decimal + return $ ECon (I int) + +-- TODO: Parse minus as just a negative real +realP :: SmtParser Expr +realP = do + double <- A.signed A.double + return $ ECon (R double) + +boolP :: SmtParser Expr +boolP = trueP <|> falseP + where + trueP = A.string "true" >> return PTrue + falseP = A.string "false" >> return PFalse symbolP :: SmtParser Symbol symbolP = {- SCC "symbolP" -} do @@ -261,6 +265,15 @@ symbolP = {- SCC "symbolP" -} do where exclude x = isSpace x || x == '(' || x == ')' +parenP :: SmtParser a -> SmtParser a +parenP inner = do + A.skipSpace + _ <- A.char '(' + res <- inner + _ <- A.char ')' + A.skipSpace + return res + responseP :: SmtParser Response responseP = {- SCC "responseP" -} A.string "sat" *> return Sat diff --git a/src/Language/Fixpoint/Solver.hs b/src/Language/Fixpoint/Solver.hs index 601e7f4a9..3441cba5b 100644 --- a/src/Language/Fixpoint/Solver.hs +++ b/src/Language/Fixpoint/Solver.hs @@ -264,22 +264,9 @@ reduceFInfo cfg fi = do solveNative' !cfg !fi0 = do si6 <- simplifyFInfo cfg fi0 - -- print fi0 - -- print si6 - print fi0 - prog <- hornToProg si6 - print si6 - print . pprint $ prog - counterExample cfg si6 prog - - res <- {- SCC "Sol.solve" -} Sol.solve cfg $!! si6 - -- rnf soln `seq` donePhase Loud "Solve2" - --let stat = resStatus res - -- saveSolution cfg res when (save cfg) $ saveSolution cfg res - -- writeLoud $ "\nSolution:\n" ++ showpp (resSolution res) - -- colorStrLn (colorResult stat) (show stat) + when (isUnsafe res) $ counterExample cfg si6 >>= print . pprint return res -------------------------------------------------------------------------------- diff --git a/src/Language/Fixpoint/Solver/Monad.hs b/src/Language/Fixpoint/Solver/Monad.hs index 9f2abc118..6a48e824b 100644 --- a/src/Language/Fixpoint/Solver/Monad.hs +++ b/src/Language/Fixpoint/Solver/Monad.hs @@ -53,7 +53,7 @@ import Data.Either (isRight) -- import Data.Char (isUpper) import Control.Monad.State.Strict import qualified Data.HashMap.Strict as M -import qualified Data.HashSet as HashSet +--import qualified Data.HashSet as HashSet import Data.Maybe (catMaybes) import Control.Exception.Base (bracket) @@ -229,10 +229,10 @@ checkValidity_ sp lhs rhs me = smtBracketAt sp me "checkValidity" $ do case valid of True -> return $ Right () False -> do - let symbols = HashSet.toList $ F.exprSymbolsSet lhs `HashSet.union` F.exprSymbolsSet rhs + --let symbols = HashSet.toList $ F.exprSymbolsSet lhs `HashSet.union` F.exprSymbolsSet rhs --print lhs --print rhs - _ <- smtGetValues me symbols + --_ <- smtGetValues me symbols --print $ F.pprint res --putStrLn "-----------------------------------" return $ Left () diff --git a/src/Language/Fixpoint/Utils/Files.hs b/src/Language/Fixpoint/Utils/Files.hs index e9322533a..b4c751249 100644 --- a/src/Language/Fixpoint/Utils/Files.hs +++ b/src/Language/Fixpoint/Utils/Files.hs @@ -89,6 +89,7 @@ data Ext = Cgi -- ^ Constraint Generation Information | PAss | Dat | BinFq -- ^ Binary representation of .fq / FInfo + | Prog -- ^ Program file (counter example generation) | Smt2 -- ^ SMTLIB2 query file | HSmt2 -- ^ Horn query file | Min -- ^ filter constraints with delta debug @@ -122,6 +123,7 @@ extMap = go go Result = ".out" go Saved = ".bak" go Cache = ".err" + go Prog = ".prog" go Smt2 = ".smt2" go HSmt2 = ".horn.smt2" go (Auto n) = ".auto." ++ show n From 0cb062b31c746fde156a1a96e1c4e00560851dd8 Mon Sep 17 00:00:00 2001 From: Robin Webbers Date: Fri, 12 May 2023 16:22:18 +0200 Subject: [PATCH 04/33] Put counter example in output result. Only runs tests for failing clauses (if any). Put feature gate behind counter example generation. --- src/Language/Fixpoint/CounterExample.hs | 156 ++++++++++++--------- src/Language/Fixpoint/Solver.hs | 13 +- src/Language/Fixpoint/Solver/Solve.hs | 2 +- src/Language/Fixpoint/Types/Config.hs | 2 + src/Language/Fixpoint/Types/Constraints.hs | 10 +- 5 files changed, 108 insertions(+), 75 deletions(-) diff --git a/src/Language/Fixpoint/CounterExample.hs b/src/Language/Fixpoint/CounterExample.hs index ff1a1d811..4ce40f2be 100644 --- a/src/Language/Fixpoint/CounterExample.hs +++ b/src/Language/Fixpoint/CounterExample.hs @@ -9,9 +9,10 @@ module Language.Fixpoint.CounterExample ( hornToProg , mainName - , counterExample + , tryCounterExample , dbg + , CounterExample , Prog , Func (..) , Decl @@ -28,6 +29,8 @@ import Language.Fixpoint.SortCheck (elaborate) import qualified Language.Fixpoint.Utils.Files as Ext import qualified Language.Fixpoint.Smt.Interface as SMT +import Data.Maybe (fromMaybe) +import Data.List (find) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as Map @@ -37,6 +40,8 @@ import Control.Monad.Reader import Text.PrettyPrint.HughesPJ ((<+>), ($+$)) import qualified Text.PrettyPrint.HughesPJ as PP +type CounterExamples = HashMap ConstraintId CounterExample + -- | A program, containing multiple function definitions -- mapped by their name. data Prog = Prog (HashMap Name Func) @@ -55,9 +60,13 @@ data Decl = Decl Symbol Sort deriving Show -- | A sequence of statements. -data Body = Body [Statement] +data Body = Body ConstraintId [Statement] deriving Show +-- | The constraint a body originates from. +-- Used to map back counter examples back to their origin. +type ConstraintId = Integer + -- | A statement used to introduce/check constraints. data Statement = Let Decl @@ -74,6 +83,8 @@ data Statement type Args = Subst -- | Signature of a function. type Signature = [Decl] +-- | A counter example for a model. +type CounterExample = Subst -- | The enviroment used to build a program. data BuildEnv info = BuildEnv @@ -101,20 +112,32 @@ type UniqueId = Int -- | The monad used to generate counter examples from a Prog. type MonadCheck m = (MonadReader CheckEnv m, MonadState UniqueId m, MonadIO m) --- | Try to get a counter example for the given constraints. -counterExample :: (MonadIO m, Fixpoint info) => Config -> SInfo info -> m [Maybe Subst] -counterExample cfg si = do - prog <- hornToProg cfg si - checkProg cfg si prog +-- TODO: remove this on code cleanup +dbg :: (MonadIO m, PPrint a) => a -> m () +dbg = liftIO . print . pprint --- | Checks the given program, returning a counter example --- (if it can find one). --- --- TODO: Actually return a counter example! -checkProg :: MonadIO m => Config -> SInfo info -> Prog -> m [Maybe Subst] -checkProg cfg si prog = withContext cfg si check +-- | Try to get a counter example for the given unsafe clauses (if any). +tryCounterExample + :: (MonadIO m, Fixpoint info) + => Config + -> SInfo info + -> Result (ConstraintId, info) + -> m (Result (ConstraintId, info)) +tryCounterExample cfg si res@Result + { resStatus = Unsafe _ cids' + , resCntExs = cexs' + } = do + let cids = map fst cids' + prog <- hornToProg cfg si + cexs <- checkProg cfg si prog cids + return res { resCntExs = cexs <> cexs' } +tryCounterExample _ _ res@_ = return res + +-- | Check the given constraints to try and find a counter example. +checkProg :: MonadIO m => Config -> SInfo info -> Prog -> [ConstraintId] -> m CounterExamples +checkProg cfg si prog cids = withContext cfg si check where - check ctx = runCheck CheckEnv + check ctx = runCheck cids CheckEnv { program = prog , context = ctx } @@ -133,22 +156,31 @@ withContext cfg si inner = do -- | Runs the program checker with the monad stack -- unwrapped. -runCheck :: MonadIO m => CheckEnv -> m [Maybe Subst] -runCheck = runReaderT $ evalStateT checkMain 0 - --- | Check the main function. Each branch in the main --- function needs to be checked separately. -checkMain :: MonadCheck m => m [Maybe Subst] -checkMain = do +runCheck :: MonadIO m => [ConstraintId] -> CheckEnv -> m CounterExamples +runCheck cids = runReaderT $ evalStateT (checkAll cids) 0 + +-- | Try to find a counter example for all the given constraints. +checkAll :: MonadCheck m => [ConstraintId] -> m CounterExamples +checkAll cids = do + cexs <- forM cids checkConstraint + return $ Map.fromList [(cid, cex) | (cid, Just cex) <- zip cids cexs] + +-- | Check a specific constraint id. This will only do actual +-- checks for constraints without a KVar on the rhs, as we cannot +-- really generate a counter example for these constraints. +checkConstraint :: MonadCheck m => ConstraintId -> m (Maybe CounterExample) +checkConstraint cid = do Func sig bodies <- getFunc mainName - forM bodies $ smtScope . checkBody sig + let cmp (Body bid _) = bid == cid + case find cmp bodies of + Just body -> smtScope $ checkBody sig body + Nothing -> return Nothing -- | Perform a satisfiability check over the body, producing -- a counter example if the model is not valid. -checkBody :: MonadCheck m => Signature -> Body -> m (Maybe Subst) +checkBody :: MonadCheck m => Signature -> Body -> m (Maybe CounterExample) checkBody sig body = do -- Produce the assertions for this body. - -- Substitution map contains (prog symbols |-> unique symbols) Su sub <- runBody sig body -- Get the variables of interest (the ones declared in the body). let smtSyms = [sym | (_, EVar sym) <- Map.toList sub] @@ -167,13 +199,13 @@ checkBody sig body = do return $ do -- Map from (unique safe symbols |-> instance) Su instances <- ex - -- Rename a symbol to its smt2 version. - let rename = symbol . symbolSafeText - -- Does remapping from smt name to prog name. - let remap (EVar sym) = Map.lookup (rename sym) instances - remap _ = Nothing - -- Final map from (prog symbols |-> instance) - return $ Su (Map.mapMaybe remap sub) + -- Rename a symbol to its safe version. + let rename (EVar sym) = symbol $ symbolSafeText sym + rename _ = error "Rename map contained non-variable expression" + -- Substitution map contains (prog symbols |-> unique safe symbols) + let sub' = (rename <$> sub) + -- Final map (prog symbols |-> instance) + return $ Su (Map.compose instances sub') -- TODO: Go up to k depth (per function) to avoid infinite recursion -- with cyclic kvars. @@ -240,7 +272,7 @@ getFunc name = do -- that were renamed during the run. This includes the -- signature as well as all the declarations in the body. runBody :: MonadCheck m => Signature -> Body -> m Subst -runBody sig (Body body) = do +runBody sig (Body _ body) = do sub <- uniqueSig sig foldM runStatement sub body @@ -318,10 +350,6 @@ smtScope inner = do liftIO $ SMT.smtPop ctx return result --- TODO: remove this on code cleanup -dbg :: (MonadIO m, PPrint a) => a -> m () -dbg = liftIO . print . pprint - -- | Make an imperative program from horn clauses. This -- can be used to generate a counter example. hornToProg :: MonadIO m => Config -> SInfo info -> m Prog @@ -362,17 +390,20 @@ buildProg = do -- it is added to the main function. addHorn :: MonadBuild info m => SimpC info -> m () addHorn horn = do - (name, func) <- case crhs horn of + -- Make the lhs of the clause into statements + lhs <- hornLhsToStmts horn + + -- The rhs has a special case depending on + -- if it is a kvar or not. + (name, decl, rhs) <- case crhs horn of PKVar kvar sub -> do decl <- getSig kvar - body <- hornLhsToBody horn - body' <- substToBody sub - return (kvar, Func decl [body <> body']) - rhs@_ -> do - Body stmts <- hornLhsToBody horn - let body = Body $ stmts <> [Assert rhs] - return (mainName, Func [] [body]) - addFunc name func + rhs <- substToStmts sub + return (kvar, decl, rhs) + e@_ -> return (mainName, [], [Assert e]) + + let body = Body (fromMaybe (-1) $ sid horn) $ lhs <> rhs + addFunc name $ Func decl [body] -- | Gets a signature of a KVar from its well foundedness constraint getSig :: MonadBuild info m => Name -> m Signature @@ -397,23 +428,23 @@ getSig kvar = do -- | Defines some equalities between local variables -- and the passed arguments given some substitution map. -substToBody :: MonadBuild info m => Subst -> m Body -substToBody (Su sub) = do +substToStmts :: MonadBuild info m => Subst -> m [Statement] +substToStmts (Su sub) = do let asEq (ksym, e) = Assume $ PAtom Eq (EVar ksym) e - return . Body . map asEq . Map.toList $ sub + return $ map asEq (Map.toList sub) -- | Converts the left hand side of the horn clause to a list -- of assumptions (or calls given by a Name) -hornLhsToBody :: MonadBuild info m => SimpC info -> m Body -hornLhsToBody horn = do +hornLhsToStmts :: MonadBuild info m => SimpC info -> m [Statement] +hornLhsToStmts horn = do bindEnv <- reader $ bs . info let lhs = clhs bindEnv horn - bodies <- forM lhs $ uncurry reftToBody - return $ mconcat bodies + stmts <- forM lhs $ uncurry reftToStmts + return $ mconcat stmts -- | Map a refinement to a declaration and constraint pair -reftToBody :: MonadBuild info m => Symbol -> SortedReft -> m Body -reftToBody sym RR +reftToStmts :: MonadBuild info m => Symbol -> SortedReft -> m [Statement] +reftToStmts sym RR { sr_sort = sort , sr_reft = Reft (v, e) } = do @@ -424,7 +455,7 @@ reftToBody sym RR _ -> Assume $ subst sub e sort' <- elaborateSort sort - return $ Body + return [ Let $ Decl sym sort' , constraint ] @@ -491,9 +522,12 @@ instance PPrint Decl where psort = pprintTidy tidy sort instance PPrint Body where - pprintTidy tidy (Body stmts) = PP.vcat - . map (pprintTidy tidy) - $ stmts + pprintTidy tidy (Body cid stmts) = pcid $+$ pstmts + where + pcid = PP.text "// id" <+> pprintTidy tidy cid + pstmts = PP.vcat + . map (pprintTidy tidy) + $ stmts instance PPrint Statement where pprintTidy tidy (Let decl) = PP.text "let" <+> pprintTidy tidy decl @@ -501,12 +535,6 @@ instance PPrint Statement where pprintTidy tidy (Assert exprs) = PP.text "assert" <+> pprintTidy tidy exprs pprintTidy tidy (Call kvar sub) = pprintTidy tidy kvar <+> pprintTidy tidy sub -instance Semigroup Body where - Body b <> Body b' = Body $ b <> b' - -instance Monoid Body where - mempty = Body [] - instance Subable Statement where syms (Let decl) = syms decl syms (Assume e) = syms e diff --git a/src/Language/Fixpoint/Solver.hs b/src/Language/Fixpoint/Solver.hs index 3441cba5b..d4223a85b 100644 --- a/src/Language/Fixpoint/Solver.hs +++ b/src/Language/Fixpoint/Solver.hs @@ -5,6 +5,7 @@ {-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE MultiWayIf #-} {-# OPTIONS_GHC -Wno-name-shadowing #-} @@ -190,7 +191,7 @@ solveNative !cfg !fi0 = solveNative' cfg fi0 (return . crashResult (errorMap fi0)) crashResult :: (PPrint a) => ErrorMap a -> Error -> Result (Integer, a) -crashResult m e = Result res mempty mempty mempty +crashResult m e = Result res mempty mempty mempty mempty where res = Crash es msg es = catMaybes [ findError m e | e <- errs e ] @@ -266,8 +267,8 @@ solveNative' !cfg !fi0 = do si6 <- simplifyFInfo cfg fi0 res <- {- SCC "Sol.solve" -} Sol.solve cfg $!! si6 when (save cfg) $ saveSolution cfg res - when (isUnsafe res) $ counterExample cfg si6 >>= print . pprint - return res + if | counterExample cfg -> tryCounterExample cfg si6 res + | otherwise -> return res -------------------------------------------------------------------------------- -- | Parse External Qualifiers ------------------------------------------------- @@ -280,9 +281,9 @@ parseFI :: FilePath -> IO (FInfo a) parseFI f = do str <- readFile f let fi = rr' f str :: FInfo () - return $ mempty { Types.quals = Types.quals fi - , Types.gLits = Types.gLits fi - , Types.dLits = Types.dLits fi } + return $ mempty { Types.quals = Types.quals fi + , Types.gLits = Types.gLits fi + , Types.dLits = Types.dLits fi } saveSolution :: Config -> Result a -> IO () saveSolution cfg res = when (save cfg) $ do diff --git a/src/Language/Fixpoint/Solver/Solve.hs b/src/Language/Fixpoint/Solver/Solve.hs index 63463cd65..8c3681d33 100644 --- a/src/Language/Fixpoint/Solver/Solve.hs +++ b/src/Language/Fixpoint/Solver/Solve.hs @@ -249,7 +249,7 @@ result bindingsInSmt cfg wkl s = stat <- result_ bindingsInSmt2 cfg wkl s lift $ whenLoud $ putStrLn $ "RESULT: " ++ show (F.sid <$> stat) - F.Result (ci <$> stat) <$> solResult cfg s <*> solNonCutsResult s <*> return mempty + F.Result (ci <$> stat) <$> solResult cfg s <*> solNonCutsResult s <*> return mempty <*> return mempty where ci c = (F.subcId c, F.sinfo c) diff --git a/src/Language/Fixpoint/Types/Config.hs b/src/Language/Fixpoint/Types/Config.hs index 37f5ec2f4..7497040c6 100644 --- a/src/Language/Fixpoint/Types/Config.hs +++ b/src/Language/Fixpoint/Types/Config.hs @@ -91,6 +91,7 @@ data Config = Config , etaElim :: Bool -- ^ eta eliminate function definitions , gradual :: Bool -- ^ solve "gradual" constraints , ginteractive :: Bool -- ^ interactive gradual solving + , counterExample :: Bool -- ^ Tries to produce a counter example if unsafe , autoKuts :: Bool -- ^ ignore given kut variables , nonLinCuts :: Bool -- ^ Treat non-linear vars as cuts , noslice :: Bool -- ^ Disable non-concrete KVar slicing @@ -219,6 +220,7 @@ defConfig = Config { , minimalSol = False &= help "Shrink fixpoint by removing implied qualifiers" , gradual = False &= help "Solve gradual-refinement typing constraints" , ginteractive = False &= help "Interactive Gradual Solving" + , counterExample = False &= help "Tries to produce a counter example for unsafe clauses" , autoKuts = False &= help "Ignore given Kut vars, compute from scratch" , nonLinCuts = False &= help "Treat non-linear kvars as cuts" , noslice = False &= help "Disable non-concrete KVar slicing" diff --git a/src/Language/Fixpoint/Types/Constraints.hs b/src/Language/Fixpoint/Types/Constraints.hs index f9b3b71cf..2352e8e57 100644 --- a/src/Language/Fixpoint/Types/Constraints.hs +++ b/src/Language/Fixpoint/Types/Constraints.hs @@ -274,10 +274,11 @@ toGFixSol = GSol data Result a = Result - { resStatus :: !(FixResult a) - , resSolution :: !FixSolution + { resStatus :: !(FixResult a) + , resSolution :: !FixSolution , resNonCutsSolution :: !FixSolution , gresSolution :: !GFixSolution + , resCntExs :: !(M.HashMap Integer Subst) } deriving (Generic, Show, Functor) @@ -287,15 +288,16 @@ instance ToJSON a => ToJSON (Result a) where toJSON = toJSON . resStatus instance Semigroup (Result a) where - r1 <> r2 = Result stat soln nonCutsSoln gsoln + r1 <> r2 = Result stat soln nonCutsSoln gsoln cntExs where stat = resStatus r1 <> resStatus r2 soln = resSolution r1 <> resSolution r2 nonCutsSoln = resNonCutsSolution r1 <> resNonCutsSolution r2 gsoln = gresSolution r1 <> gresSolution r2 + cntExs = resCntExs r1 <> resCntExs r2 instance Monoid (Result a) where - mempty = Result mempty mempty mempty mempty + mempty = Result mempty mempty mempty mempty mempty mappend = (<>) unsafe, safe :: Result a From 37d9405d7342f766b4e28727dfb375c8580e87d6 Mon Sep 17 00:00:00 2001 From: Robin Webbers Date: Thu, 25 May 2023 14:37:40 +0200 Subject: [PATCH 05/33] Now tracks counter examples per constraint id. Added a max depth to avoid infinite recursion on cyclic kvars. --- src/Language/Fixpoint/CounterExample.hs | 189 ++++++++++++++------- src/Language/Fixpoint/Types/Config.hs | 2 +- src/Language/Fixpoint/Types/Constraints.hs | 2 +- src/Language/Fixpoint/Types/Theories.hs | 5 + 4 files changed, 130 insertions(+), 68 deletions(-) diff --git a/src/Language/Fixpoint/CounterExample.hs b/src/Language/Fixpoint/CounterExample.hs index 4ce40f2be..2715b509b 100644 --- a/src/Language/Fixpoint/CounterExample.hs +++ b/src/Language/Fixpoint/CounterExample.hs @@ -1,9 +1,7 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE MultiWayIf #-} module Language.Fixpoint.CounterExample ( hornToProg @@ -20,7 +18,7 @@ module Language.Fixpoint.CounterExample , Statement (..) ) where -import Language.Fixpoint.Types +import Language.Fixpoint.Types hiding (exit) import Language.Fixpoint.Types.Config (Config, srcFile, queryFile, save) import Language.Fixpoint.Solver.Sanitize (symbolEnv) import Language.Fixpoint.Misc (ensurePath) @@ -36,11 +34,12 @@ import qualified Data.HashMap.Strict as Map import Control.Monad.State import Control.Monad.Reader +import Control.Monad.Cont import Text.PrettyPrint.HughesPJ ((<+>), ($+$)) import qualified Text.PrettyPrint.HughesPJ as PP -type CounterExamples = HashMap ConstraintId CounterExample +type CounterExamples = HashMap SubcId CounterExample -- | A program, containing multiple function definitions -- mapped by their name. @@ -60,13 +59,9 @@ data Decl = Decl Symbol Sort deriving Show -- | A sequence of statements. -data Body = Body ConstraintId [Statement] +data Body = Body SubcId [Statement] deriving Show --- | The constraint a body originates from. --- Used to map back counter examples back to their origin. -type ConstraintId = Integer - -- | A statement used to introduce/check constraints. data Statement = Let Decl @@ -96,7 +91,7 @@ data BuildEnv info = BuildEnv -- | The monad used to convert a set of horn constraints to -- the imperative function format. See Prog for the format. -type MonadBuild info m = (MonadState Prog m, MonadReader (BuildEnv info) m, MonadIO m) +type MonadBuild info m = (MonadReader (BuildEnv info) m, MonadState Prog m, MonadIO m) -- | Environment for the counter example generation. data CheckEnv = CheckEnv @@ -104,42 +99,69 @@ data CheckEnv = CheckEnv -- ^ The program we are checking , context :: SMT.Context -- ^ The SMT context we write the constraints from the program to. + , maxDepth :: Int + -- ^ The maximum number of functions to traverse (to avoid state blow-up). } --- | Unique identifier used to avoid clashing names. -type UniqueId = Int +data CheckState = CheckState + { uniqueId :: Int + -- ^ Unique identifier used to avoid clashing names. + , depth :: Int + -- ^ Current depth (i.e. number of functions traversed) + } -- | The monad used to generate counter examples from a Prog. -type MonadCheck m = (MonadReader CheckEnv m, MonadState UniqueId m, MonadIO m) +type MonadCheck m = (MonadReader CheckEnv m, MonadState CheckState m, MonadCont m, MonadIO m) -- TODO: remove this on code cleanup dbg :: (MonadIO m, PPrint a) => a -> m () dbg = liftIO . print . pprint +-- TODO: Perhaps split the two parts (building and checking) +-- into two separate files, as they share no functions. +-- (except for the program types, which I suppose goes into a +-- separate file then.) + +-- TODO: Remove variables from the counter example that got mapped to +-- the "wrong" type in smt format (e.g. to an int while not being one). + -- | Try to get a counter example for the given unsafe clauses (if any). tryCounterExample :: (MonadIO m, Fixpoint info) => Config -> SInfo info - -> Result (ConstraintId, info) - -> m (Result (ConstraintId, info)) + -> Result (SubcId, info) + -> m (Result (SubcId, info)) tryCounterExample cfg si res@Result { resStatus = Unsafe _ cids' , resCntExs = cexs' } = do let cids = map fst cids' prog <- hornToProg cfg si - cexs <- checkProg cfg si prog cids + subs <- checkProg cfg si prog cids + let cexs = cexBindIds si <$> subs return res { resCntExs = cexs <> cexs' } tryCounterExample _ _ res@_ = return res +-- | Map a counter example to use the BindId instead of the +-- variable name as the key. +-- +-- In other words, we go from a mapping of Symbol |-> Expr to +-- BindId |-> Expr +cexBindIds :: SInfo info -> CounterExample -> BindMap Expr +cexBindIds si (Su cex) = Map.compose cex bindings + where + bindings = fst' <$> beBinds (bs si) + fst' (sym, _, _) = sym + -- | Check the given constraints to try and find a counter example. -checkProg :: MonadIO m => Config -> SInfo info -> Prog -> [ConstraintId] -> m CounterExamples +checkProg :: MonadIO m => Config -> SInfo info -> Prog -> [SubcId] -> m CounterExamples checkProg cfg si prog cids = withContext cfg si check where check ctx = runCheck cids CheckEnv { program = prog , context = ctx + , maxDepth = 100 -- TODO: Perhaps this should be a parameter for the user? } -- | Run the checker with the SMT solver context. @@ -156,11 +178,15 @@ withContext cfg si inner = do -- | Runs the program checker with the monad stack -- unwrapped. -runCheck :: MonadIO m => [ConstraintId] -> CheckEnv -> m CounterExamples -runCheck cids = runReaderT $ evalStateT (checkAll cids) 0 +runCheck :: MonadIO m => [SubcId] -> CheckEnv -> m CounterExamples +runCheck cids env = rd . st . ct $ checkAll cids + where + st = flip evalStateT $ CheckState 0 0 + rd = flip runReaderT env + ct = flip runContT return -- | Try to find a counter example for all the given constraints. -checkAll :: MonadCheck m => [ConstraintId] -> m CounterExamples +checkAll :: MonadCheck m => [SubcId] -> m CounterExamples checkAll cids = do cexs <- forM cids checkConstraint return $ Map.fromList [(cid, cex) | (cid, Just cex) <- zip cids cexs] @@ -168,7 +194,7 @@ checkAll cids = do -- | Check a specific constraint id. This will only do actual -- checks for constraints without a KVar on the rhs, as we cannot -- really generate a counter example for these constraints. -checkConstraint :: MonadCheck m => ConstraintId -> m (Maybe CounterExample) +checkConstraint :: MonadCheck m => SubcId -> m (Maybe CounterExample) checkConstraint cid = do Func sig bodies <- getFunc mainName let cmp (Body bid _) = bid == cid @@ -179,38 +205,51 @@ checkConstraint cid = do -- | Perform a satisfiability check over the body, producing -- a counter example if the model is not valid. checkBody :: MonadCheck m => Signature -> Body -> m (Maybe CounterExample) -checkBody sig body = do +checkBody sig body = callCC $ \exit -> do -- Produce the assertions for this body. Su sub <- runBody sig body -- Get the variables of interest (the ones declared in the body). + -- + -- TODO: We just get the main variables here, but this causes us + -- to sometimes miss the essential assignment of a counter example. + -- + -- Instead, I want to report on the first assignment of all variables + -- (including the ones in kvars). I stress the first, as there might + -- be many assignments to the same variable otherwise due to recursive + -- calls. The first assignment is likely then one that produces all + -- other assignments. let smtSyms = [sym | (_, EVar sym) <- Map.toList sub] -- Check satisfiability ctx <- reader context valid <- liftIO $ SMT.smtCheckUnsat ctx - -- Get a counter example if not valid. - ex <- if | not valid -> SMT.smtGetValues ctx smtSyms >>= return . Just - | otherwise -> return Nothing - - -- Remap the counter example to program symbols. We got it in - -- smt "safe" symbols, which we cannot directly translate back. - -- Hence, we use the substitution maps we have at hand. - return $ do - -- Map from (unique safe symbols |-> instance) - Su instances <- ex - -- Rename a symbol to its safe version. - let rename (EVar sym) = symbol $ symbolSafeText sym - rename _ = error "Rename map contained non-variable expression" - -- Substitution map contains (prog symbols |-> unique safe symbols) - let sub' = (rename <$> sub) - -- Final map (prog symbols |-> instance) - return $ Su (Map.compose instances sub') - --- TODO: Go up to k depth (per function) to avoid infinite recursion --- with cyclic kvars. + -- Early return if the formula was valid (thus no counter example). + when valid $ exit Nothing + + -- Counter example (unique safe symbols |-> instance) + Su ex <- SMT.smtGetValues ctx smtSyms + + -- From here, remap the counter example to program symbols. We got + -- it in smt "safe" symbols, which we cannot directly translate + -- back. Hence, we use the substitution maps we have at hand. + + -- Rename a symbol to its safe version, if applicable. + let rename (EVar sym) = Just . symbol . symbolSafeText $ sym + rename _ = Nothing + -- Rename all symbols (prog symbols |-> unique safe symbols) + let sub' = (Map.mapMaybe rename sub) + -- Final map (prog symbols |-> instance) + return $ Just (Su $ Map.compose ex sub') + +-- | Add constraints by "running" over the function. This function +-- does so in a depth first way, joining the assignments of +-- the arguments. +-- +-- To avoid infinite recursion for cyclic constraints, we stop +-- recursing on a function after running it 'maxDepth' times. runFunc :: MonadCheck m => Name -> Args -> m () -runFunc name args = do +runFunc name args = unlessMaxDepth $ do -- Get the function to check. Func sig bodies <- getFunc name @@ -221,6 +260,18 @@ runFunc name args = do -- Joins all of these fresh variables to their argument. joinSubs args sig subs +-- | Track the depth and only call the given monad if we do not +-- exceed the maximum depth. Used to avoid infinite recursion +-- and general explosion of calls. +unlessMaxDepth :: MonadCheck m => m () -> m () +unlessMaxDepth m = do + limit <- reader maxDepth + cur <- gets depth + + modify $ \s -> s { depth = cur + 1 } + when (limit > cur) $ m + modify $ \s -> s { depth = cur } + -- | Join all substitution mappings made by running over all -- bodies. -- @@ -282,20 +333,16 @@ runBody sig (Body _ body) = do -- Declarations will change the substitution map, as -- declarations get name mangled to avoid name clashes. runStatement :: MonadCheck m => Subst -> Statement -> m Subst -runStatement sub stmt = do +runStatement sub stmt = callCC $ \exit -> do let stmt' = subst sub stmt -- Run over the program and assert statements in SMT solver. case stmt' of Call name app -> runFunc name app Assume e -> smtAssume $ subst sub e Assert e -> smtAssert $ subst sub e - _ -> return () - - -- A declaration will also adjust the substitution - -- map and is thus separated here. - case stmt of - Let decl -> smtDeclare sub decl - _ -> return sub + -- We early return a new substitution map here with the continuation. + Let decl -> smtDeclare sub decl >>= exit + return sub -- | Generate unique symbols for a function signature. uniqueSig :: MonadCheck m => Signature -> m Subst @@ -305,8 +352,8 @@ uniqueSig = foldM smtDeclare (Su Map.empty) uniqueSym :: MonadCheck m => Symbol -> m Symbol uniqueSym sym = do -- Get unique number - unique <- get - put $ unique + 1 + unique <- gets uniqueId + modify $ \s -> s { uniqueId = unique + 1 } -- Apply unique number to identifier let (<.>) = suffixSymbol @@ -402,7 +449,8 @@ addHorn horn = do return (kvar, decl, rhs) e@_ -> return (mainName, [], [Assert e]) - let body = Body (fromMaybe (-1) $ sid horn) $ lhs <> rhs + let cid = fromMaybe (-1) $ sid horn + let body = Body cid $ lhs <> rhs addFunc name $ Func decl [body] -- | Gets a signature of a KVar from its well foundedness constraint @@ -450,21 +498,30 @@ reftToStmts sym RR } = do -- Make constraint with proper substitution let sub = Su . Map.singleton v $ EVar sym - let constraint = case e of - PKVar kvar (Su app) -> Call kvar (Su $ subst sub app) - _ -> Assume $ subst sub e sort' <- elaborateSort sort - return - [ Let $ Decl sym sort' - , constraint - ] + let decl = Let $ Decl sym sort' + + let constraints = case predKs e of + [] -> [Assume e] + ks -> map (\(name, app) -> Call name app) ks + + return $ decl : subst sub constraints + +-- | Get the kvars from an expression. +-- +-- I think this should be the only way in which kvars appear? +-- Otherwise, this should be changed! +predKs :: Expr -> [(KVar, Subst)] +predKs (PAnd ps) = mconcat $ map predKs ps +predKs (PKVar k su) = [(k, su)] +predKs _ = [] -- | The sorts for the apply monomorphization only match if -- we do this elaborate on the sort. Not sure why... -- -- This elaboration also happens inside the declaration --- of the symbol environment, so that where I got the idea. +-- of the symbol environment, so that's where I got the idea. elaborateSort :: MonadBuild info m => Sort -> m Sort elaborateSort sym = do symbols' <- reader symbols @@ -503,10 +560,10 @@ ppfunc tidy name (Func sig bodies) = pdecl $+$ pbody $+$ PP.rbrace fn = PP.text "fn" pname = pprintTidy tidy name psig = PP.parens - . PP.hsep - . PP.punctuate PP.comma - . map (pprintTidy tidy) - $ sig + . PP.hsep + . PP.punctuate PP.comma + . map (pprintTidy tidy) + $ sig pbody = vpunctuate (PP.text "||") . map (PP.nest 4 . pprintTidy tidy) $ bodies diff --git a/src/Language/Fixpoint/Types/Config.hs b/src/Language/Fixpoint/Types/Config.hs index 7497040c6..301fb61e4 100644 --- a/src/Language/Fixpoint/Types/Config.hs +++ b/src/Language/Fixpoint/Types/Config.hs @@ -220,7 +220,7 @@ defConfig = Config { , minimalSol = False &= help "Shrink fixpoint by removing implied qualifiers" , gradual = False &= help "Solve gradual-refinement typing constraints" , ginteractive = False &= help "Interactive Gradual Solving" - , counterExample = False &= help "Tries to produce a counter example for unsafe clauses" + , counterExample = False &= name "counter-example" &= help "Tries to produce a counter example for unsafe clauses" , autoKuts = False &= help "Ignore given Kut vars, compute from scratch" , nonLinCuts = False &= help "Treat non-linear kvars as cuts" , noslice = False &= help "Disable non-concrete KVar slicing" diff --git a/src/Language/Fixpoint/Types/Constraints.hs b/src/Language/Fixpoint/Types/Constraints.hs index 2352e8e57..03f3d2134 100644 --- a/src/Language/Fixpoint/Types/Constraints.hs +++ b/src/Language/Fixpoint/Types/Constraints.hs @@ -278,7 +278,7 @@ data Result a = Result , resSolution :: !FixSolution , resNonCutsSolution :: !FixSolution , gresSolution :: !GFixSolution - , resCntExs :: !(M.HashMap Integer Subst) + , resCntExs :: !(M.HashMap SubcId (BindMap Expr)) } deriving (Generic, Show, Functor) diff --git a/src/Language/Fixpoint/Types/Theories.hs b/src/Language/Fixpoint/Types/Theories.hs index c33681c4e..8d1b83f48 100644 --- a/src/Language/Fixpoint/Types/Theories.hs +++ b/src/Language/Fixpoint/Types/Theories.hs @@ -240,12 +240,17 @@ instance Hashable SmtSort instance NFData SmtSort instance S.Store SmtSort + + -- | The 'poly' parameter is True when we are *declaring* sorts, -- and so we need to leave the top type variables be; it is False when -- we are declaring variables etc., and there, we serialize them -- using `Int` (though really, there SHOULD BE NO floating tyVars... -- 'smtSort True msg t' serializes a sort 't' using type variables, -- 'smtSort False msg t' serializes a sort 't' using 'Int' instead of tyvars. +-- +-- Perhaps we should change this to not use ints as a default, but a new sort? +-- (i.e. declare a new sort (declare-sort Default) for this use) sortSmtSort :: Bool -> SEnv DataDecl -> Sort -> SmtSort sortSmtSort poly env t = {- tracepp ("sortSmtSort: " ++ showpp t) else id) $ -} go . unAbs $ t where From 57e55b896154b5e44f1f53fe6b018f28dc792dd2 Mon Sep 17 00:00:00 2001 From: Robin Webbers Date: Thu, 25 May 2023 14:47:24 +0200 Subject: [PATCH 06/33] Removed dead code previously introduced --- src/Language/Fixpoint/Solver/Monad.hs | 30 --------------------------- src/Language/Fixpoint/Solver/Solve.hs | 26 +++++++++-------------- 2 files changed, 10 insertions(+), 46 deletions(-) diff --git a/src/Language/Fixpoint/Solver/Monad.hs b/src/Language/Fixpoint/Solver/Monad.hs index 6a48e824b..549521a5a 100644 --- a/src/Language/Fixpoint/Solver/Monad.hs +++ b/src/Language/Fixpoint/Solver/Monad.hs @@ -13,7 +13,6 @@ module Language.Fixpoint.Solver.Monad , getBinds -- * SMT Query - , checkValidity , filterRequired , filterValid , filterValidGradual @@ -49,7 +48,6 @@ import Language.Fixpoint.Graph.Types (SolverInfo (..)) -- import Language.Fixpoint.Solver.Solution -- import Data.Maybe (catMaybes) import Data.List (partition) -import Data.Either (isRight) -- import Data.Char (isUpper) import Control.Monad.State.Strict import qualified Data.HashMap.Strict as M @@ -209,34 +207,6 @@ filterValid_ sp p qs me = catMaybes <$> do valid <- smtCheckUnsat me return $ if valid then Just x else Nothing -{-# SCC checkValidity #-} -checkValidity :: F.SrcSpan -> F.Expr -> F.Expr -> SolveM ann (Either () ()) -checkValidity sp lhs rhs = do - res <- withContext $ checkValidity_ sp lhs rhs - - incBrkt - incChck 1 - when (isRight res) $ incVald 1 - return res - -{-# SCC checkValidity_ #-} -checkValidity_ :: F.SrcSpan -> F.Expr -> F.Expr -> Context -> IO (Either () ()) -checkValidity_ sp lhs rhs me = smtBracketAt sp me "checkValidity" $ do - smtAssert me lhs - smtAssert me (F.PNot rhs) - valid <- smtCheckUnsat me - - case valid of - True -> return $ Right () - False -> do - --let symbols = HashSet.toList $ F.exprSymbolsSet lhs `HashSet.union` F.exprSymbolsSet rhs - --print lhs - --print rhs - --_ <- smtGetValues me symbols - --print $ F.pprint res - --putStrLn "-----------------------------------" - return $ Left () - -------------------------------------------------------------------------------- -- | `filterValidGradual ps [(x1, q1),...,(xn, qn)]` returns the list `[ xi | p => qi]` -- | for some p in the list ps diff --git a/src/Language/Fixpoint/Solver/Solve.hs b/src/Language/Fixpoint/Solver/Solve.hs index 8c3681d33..4c88ffb7f 100644 --- a/src/Language/Fixpoint/Solver/Solve.hs +++ b/src/Language/Fixpoint/Solver/Solve.hs @@ -25,13 +25,12 @@ import qualified Language.Fixpoint.Solver.Eliminate as E import Language.Fixpoint.Solver.Monad import Language.Fixpoint.Utils.Progress import Language.Fixpoint.Graph ---import Text.PrettyPrint.HughesPJ +import Text.PrettyPrint.HughesPJ import Text.Printf import System.Console.CmdArgs.Verbosity -- (whenNormal, whenLoud) import Control.DeepSeq import qualified Data.HashMap.Strict as M import qualified Data.HashSet as S -import Data.Either (isLeft) -- import qualified Data.Maybe as Mb import qualified Data.List as L import Language.Fixpoint.Types (resStatus, FixResult(Unsafe)) @@ -241,11 +240,6 @@ result result bindingsInSmt cfg wkl s = sendConcreteBindingsToSMT bindingsInSmt $ \bindingsInSmt2 -> do lift $ writeLoud "Computing Result" - -- liftIO $ print (pprint bindingsInSmt) - -- --liftIO $ print (pprint cfg) - -- liftIO $ print (pprint wkl) - -- liftIO $ print (pprint s) - -- liftIO $ putStrLn "------------------" stat <- result_ bindingsInSmt2 cfg wkl s lift $ whenLoud $ putStrLn $ "RESULT: " ++ show (F.sid <$> stat) @@ -318,15 +312,15 @@ isUnsat bindingsInSmt s c = do be <- getBinds let lp = S.lhsPred bindingsInSmt be s c let rp = rhsPred c - res <- checkValidity (cstrSpan c) lp rp - -- lift $ whenLoud $ showUnsat res (F.subcId c) lp rp - return $ isLeft res - --- showUnsat :: Bool -> Integer -> F.Pred -> F.Pred -> IO () --- showUnsat u i lP rP = {- when u $ -} do --- putStrLn $ printf "UNSAT id %s %s" (show i) (show u) --- putStrLn $ showpp $ "LHS:" <+> pprint lP --- putStrLn $ showpp $ "RHS:" <+> pprint rP + res <- not <$> isValid (cstrSpan c) lp rp + lift $ whenLoud $ showUnsat res (F.subcId c) lp rp + return res + +showUnsat :: Bool -> Integer -> F.Pred -> F.Pred -> IO () +showUnsat u i lP rP = {- when u $ -} do + putStrLn $ printf "UNSAT id %s %s" (show i) (show u) + putStrLn $ showpp $ "LHS:" <+> pprint lP + putStrLn $ showpp $ "RHS:" <+> pprint rP -------------------------------------------------------------------------------- -- | Predicate corresponding to RHS of constraint in current solution From 41882044db5d38835867bb4fb9ec1283044fd3b3 Mon Sep 17 00:00:00 2001 From: Robin Webbers Date: Thu, 25 May 2023 14:53:21 +0200 Subject: [PATCH 07/33] Added some comments and reduced exports for CounterExample.hs --- src/Language/Fixpoint/CounterExample.hs | 14 +++----------- 1 file changed, 3 insertions(+), 11 deletions(-) diff --git a/src/Language/Fixpoint/CounterExample.hs b/src/Language/Fixpoint/CounterExample.hs index 2715b509b..19f208acb 100644 --- a/src/Language/Fixpoint/CounterExample.hs +++ b/src/Language/Fixpoint/CounterExample.hs @@ -4,18 +4,8 @@ {-# LANGUAGE BangPatterns #-} module Language.Fixpoint.CounterExample - ( hornToProg - , mainName - - , tryCounterExample + ( tryCounterExample , dbg - - , CounterExample - , Prog - , Func (..) - , Decl - , Body - , Statement (..) ) where import Language.Fixpoint.Types hiding (exit) @@ -39,6 +29,7 @@ import Control.Monad.Cont import Text.PrettyPrint.HughesPJ ((<+>), ($+$)) import qualified Text.PrettyPrint.HughesPJ as PP +-- | Multiple counter examples indexed per constraint id. type CounterExamples = HashMap SubcId CounterExample -- | A program, containing multiple function definitions @@ -103,6 +94,7 @@ data CheckEnv = CheckEnv -- ^ The maximum number of functions to traverse (to avoid state blow-up). } +-- | State tracked when checking a program. data CheckState = CheckState { uniqueId :: Int -- ^ Unique identifier used to avoid clashing names. From 8548f4c8c348543b6246168832a788f003c33b98 Mon Sep 17 00:00:00 2001 From: Robin Webbers Date: Thu, 25 May 2023 16:33:46 +0200 Subject: [PATCH 08/33] Solved hlint warnings --- src/Language/Fixpoint/CounterExample.hs | 18 +++++++++--------- src/Language/Fixpoint/Solver.hs | 4 +--- 2 files changed, 10 insertions(+), 12 deletions(-) diff --git a/src/Language/Fixpoint/CounterExample.hs b/src/Language/Fixpoint/CounterExample.hs index 19f208acb..aee7be07f 100644 --- a/src/Language/Fixpoint/CounterExample.hs +++ b/src/Language/Fixpoint/CounterExample.hs @@ -9,7 +9,7 @@ module Language.Fixpoint.CounterExample ) where import Language.Fixpoint.Types hiding (exit) -import Language.Fixpoint.Types.Config (Config, srcFile, queryFile, save) +import Language.Fixpoint.Types.Config (Config, srcFile, queryFile, save, counterExample) import Language.Fixpoint.Solver.Sanitize (symbolEnv) import Language.Fixpoint.Misc (ensurePath) import Language.Fixpoint.SortCheck (elaborate) @@ -34,7 +34,7 @@ type CounterExamples = HashMap SubcId CounterExample -- | A program, containing multiple function definitions -- mapped by their name. -data Prog = Prog (HashMap Name Func) +newtype Prog = Prog (HashMap Name Func) deriving Show -- | Identifier of a function. All KVars are translated @@ -127,13 +127,13 @@ tryCounterExample tryCounterExample cfg si res@Result { resStatus = Unsafe _ cids' , resCntExs = cexs' - } = do + } | counterExample cfg = do let cids = map fst cids' prog <- hornToProg cfg si subs <- checkProg cfg si prog cids let cexs = cexBindIds si <$> subs return res { resCntExs = cexs <> cexs' } -tryCounterExample _ _ res@_ = return res +tryCounterExample _ _ res = return res -- | Map a counter example to use the BindId instead of the -- variable name as the key. @@ -230,7 +230,7 @@ checkBody sig body = callCC $ \exit -> do let rename (EVar sym) = Just . symbol . symbolSafeText $ sym rename _ = Nothing -- Rename all symbols (prog symbols |-> unique safe symbols) - let sub' = (Map.mapMaybe rename sub) + let sub' = Map.mapMaybe rename sub -- Final map (prog symbols |-> instance) return $ Just (Su $ Map.compose ex sub') @@ -261,7 +261,7 @@ unlessMaxDepth m = do cur <- gets depth modify $ \s -> s { depth = cur + 1 } - when (limit > cur) $ m + when (limit > cur) m modify $ \s -> s { depth = cur } -- | Join all substitution mappings made by running over all @@ -439,7 +439,7 @@ addHorn horn = do decl <- getSig kvar rhs <- substToStmts sub return (kvar, decl, rhs) - e@_ -> return (mainName, [], [Assert e]) + e -> return (mainName, [], [Assert e]) let cid = fromMaybe (-1) $ sid horn let body = Body cid $ lhs <> rhs @@ -496,7 +496,7 @@ reftToStmts sym RR let constraints = case predKs e of [] -> [Assume e] - ks -> map (\(name, app) -> Call name app) ks + ks -> map (uncurry Call) ks return $ decl : subst sub constraints @@ -561,7 +561,7 @@ ppfunc tidy name (Func sig bodies) = pdecl $+$ pbody $+$ PP.rbrace $ bodies vpunctuate _ [] = mempty - vpunctuate _ (d:[]) = d + vpunctuate _ [d] = d vpunctuate p (d:ds) = d $+$ p $+$ vpunctuate p ds instance PPrint Decl where diff --git a/src/Language/Fixpoint/Solver.hs b/src/Language/Fixpoint/Solver.hs index d4223a85b..7be90b3cb 100644 --- a/src/Language/Fixpoint/Solver.hs +++ b/src/Language/Fixpoint/Solver.hs @@ -5,7 +5,6 @@ {-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE MultiWayIf #-} {-# OPTIONS_GHC -Wno-name-shadowing #-} @@ -267,8 +266,7 @@ solveNative' !cfg !fi0 = do si6 <- simplifyFInfo cfg fi0 res <- {- SCC "Sol.solve" -} Sol.solve cfg $!! si6 when (save cfg) $ saveSolution cfg res - if | counterExample cfg -> tryCounterExample cfg si6 res - | otherwise -> return res + tryCounterExample cfg si6 res -------------------------------------------------------------------------------- -- | Parse External Qualifiers ------------------------------------------------- From 9d79fdafaaf8262f2dc54617f7b05248bdd88827 Mon Sep 17 00:00:00 2001 From: Robin Webbers Date: Tue, 13 Jun 2023 16:56:50 +0200 Subject: [PATCH 09/33] WIP Counterexample depth first run with location info --- src/Language/Fixpoint/CounterExample.hs | 251 +++++++++--------------- src/Language/Fixpoint/Smt/Interface.hs | 42 +++- tests/neg/ProgTest.fq | 24 +++ 3 files changed, 154 insertions(+), 163 deletions(-) create mode 100644 tests/neg/ProgTest.fq diff --git a/src/Language/Fixpoint/CounterExample.hs b/src/Language/Fixpoint/CounterExample.hs index aee7be07f..80a2c5411 100644 --- a/src/Language/Fixpoint/CounterExample.hs +++ b/src/Language/Fixpoint/CounterExample.hs @@ -45,16 +45,25 @@ type Name = KVar data Func = Func Signature [Body] deriving Show --- | A declaration of a Symbol with a Sort. -data Decl = Decl Symbol Sort - deriving Show - -- | A sequence of statements. data Body = Body SubcId [Statement] deriving Show --- | A statement used to introduce/check constraints. -data Statement +-- | A statement used to introduce/check constraints, +-- together with its location information +data Statement = Statement Location StatementKind + +-- | Location information for a statement. Used to map +-- a counter example from its trace. +data Location + = BindLoc BindId + -- ^ Location info that came from a binding + | HornLoc SubcId + -- ^ Location info that came from a horn clause + -- (i.e. the main variable of the constraint) + +-- | The main part of a statement +data StatementKind = Let Decl -- ^ Introduces a new variable. | Assume Expr @@ -65,6 +74,10 @@ data Statement -- ^ Call to function. deriving Show +-- | A declaration of a Symbol with a Sort. +data Decl = Decl Symbol Sort + deriving Show + -- | Arguments to a function. type Args = Subst -- | Signature of a function. @@ -98,13 +111,16 @@ data CheckEnv = CheckEnv data CheckState = CheckState { uniqueId :: Int -- ^ Unique identifier used to avoid clashing names. - , depth :: Int - -- ^ Current depth (i.e. number of functions traversed) +-- , depth :: Int +-- -- ^ Current depth (i.e. number of functions traversed) } -- | The monad used to generate counter examples from a Prog. type MonadCheck m = (MonadReader CheckEnv m, MonadState CheckState m, MonadCont m, MonadIO m) +-- TODO: I don't think we're using all values and constraints on MonadCheck anymore. +-- Check what we can remove. + -- TODO: remove this on code cleanup dbg :: (MonadIO m, PPrint a) => a -> m () dbg = liftIO . print . pprint @@ -173,7 +189,7 @@ withContext cfg si inner = do runCheck :: MonadIO m => [SubcId] -> CheckEnv -> m CounterExamples runCheck cids env = rd . st . ct $ checkAll cids where - st = flip evalStateT $ CheckState 0 0 + st = flip evalStateT $ CheckState 0 --0 rd = flip runReaderT env ct = flip runContT return @@ -188,118 +204,71 @@ checkAll cids = do -- really generate a counter example for these constraints. checkConstraint :: MonadCheck m => SubcId -> m (Maybe CounterExample) checkConstraint cid = do - Func sig bodies <- getFunc mainName + Func _ bodies <- getFunc mainName let cmp (Body bid _) = bid == cid case find cmp bodies of - Just body -> smtScope $ checkBody sig body + Just body -> runBody mempty body smtCheck Nothing -> return Nothing --- | Perform a satisfiability check over the body, producing --- a counter example if the model is not valid. -checkBody :: MonadCheck m => Signature -> Body -> m (Maybe CounterExample) -checkBody sig body = callCC $ \exit -> do - -- Produce the assertions for this body. - Su sub <- runBody sig body - -- Get the variables of interest (the ones declared in the body). - -- - -- TODO: We just get the main variables here, but this causes us - -- to sometimes miss the essential assignment of a counter example. - -- - -- Instead, I want to report on the first assignment of all variables - -- (including the ones in kvars). I stress the first, as there might - -- be many assignments to the same variable otherwise due to recursive - -- calls. The first assignment is likely then one that produces all - -- other assignments. - let smtSyms = [sym | (_, EVar sym) <- Map.toList sub] - - -- Check satisfiability +-- | The runner is a computation path in the program. We use this +-- as an argument to pass around the remainder of a computation. +-- This way, we can pop paths in the SMT due to conditionals. +-- Allowing us to retain anything prior to that. +type Runner m = m (Maybe CounterExample) + +smtCheck :: MonadCheck m => Runner m +smtCheck = callCC $ \exit -> do ctx <- reader context valid <- liftIO $ SMT.smtCheckUnsat ctx - - -- Early return if the formula was valid (thus no counter example). when valid $ exit Nothing - -- Counter example (unique safe symbols |-> instance) - Su ex <- SMT.smtGetValues ctx smtSyms - - -- From here, remap the counter example to program symbols. We got - -- it in smt "safe" symbols, which we cannot directly translate - -- back. Hence, we use the substitution maps we have at hand. - - -- Rename a symbol to its safe version, if applicable. - let rename (EVar sym) = Just . symbol . symbolSafeText $ sym - rename _ = Nothing - -- Rename all symbols (prog symbols |-> unique safe symbols) - let sub' = Map.mapMaybe rename sub - -- Final map (prog symbols |-> instance) - return $ Just (Su $ Map.compose ex sub') - --- | Add constraints by "running" over the function. This function --- does so in a depth first way, joining the assignments of --- the arguments. --- --- To avoid infinite recursion for cyclic constraints, we stop --- recursing on a function after running it 'maxDepth' times. -runFunc :: MonadCheck m => Name -> Args -> m () -runFunc name args = unlessMaxDepth $ do - -- Get the function to check. - Func sig bodies <- getFunc name - - -- Check all bodies of this function in a breath first manner. - -- Each body generates a fresh set of signature variables. - subs <- forM bodies $ runBody sig - - -- Joins all of these fresh variables to their argument. - joinSubs args sig subs - --- | Track the depth and only call the given monad if we do not --- exceed the maximum depth. Used to avoid infinite recursion --- and general explosion of calls. -unlessMaxDepth :: MonadCheck m => m () -> m () -unlessMaxDepth m = do - limit <- reader maxDepth - cur <- gets depth - - modify $ \s -> s { depth = cur + 1 } - when (limit > cur) m - modify $ \s -> s { depth = cur } - --- | Join all substitution mappings made by running over all --- bodies. --- --- The join is a disjunct of all possible assignments. -joinSubs :: MonadCheck m => Args -> Signature -> [Subst] -> m () -joinSubs args sig subs = do - possible <- forM subs $ conjunctSub args sig - smtAssert $ POr possible + cex <- liftIO $ SMT.smtGetModel ctx --- | Map the arguments to a substitution of a single function body. --- --- To elaborate, given the following variables: --- The mapping of the arguments. --- -- ^ (sym |-> arg) :: Args --- --- The arguments themselves. --- -- ^ [sym] :: Signature --- --- The unique mapping generated for a body. --- -- ^ (sym |-> unique) :: Subst --- --- We generate a conjunct of (arg == unique) for every symbol in --- the signature. -conjunctSub :: MonadCheck m => Args -> Signature -> Subst -> m Expr -conjunctSub (Su args) sig (Su sub) = do - -- Generate symbol as shorthand for the conjunct. - bool <- smtFresh boolSort - let bool' = EVar bool - - -- Generate the conjunct of the argument mapping. - let eq (Decl sym _) = PAtom Eq (args Map.! sym) (sub Map.! sym) - let conjunct = PAnd $ map eq sig - - -- Assert equality between shorthand and conjunct. - smtAssert $ PAtom Eq bool' conjunct - return bool' + -- -- Counter example (unique safe symbols |-> instance) + -- TODO: Figure out which variables to actually return here! + -- + -- I want to return a stack trace towards the counter example + -- for each binding. + return $ Just cex + +runFunc :: MonadCheck m => Name -> Args -> Runner m -> Runner m +runFunc name args runner = do + Func _ bodies <- getFunc name + + -- Generate all execution paths (as runners). + let runner' body = smtScope $ runBody args body runner + let paths = map runner' bodies + + -- Try paths, selecting the first that produces a counter example. + let select Nothing r = r + select cex _ = return cex + foldM select Nothing paths + +-- | Run the statements in the body. If there are no more statements +-- to run, this will execute the Runner that was passed as argument. +runBody :: MonadCheck m => Args -> Body -> Runner m -> Runner m +runBody _ (Body _ []) runner = runner +runBody args (Body cid (stmt:ss)) runner = do + -- The remaining statements become a new Runner + let runner' sub = runBody sub (Body cid ss) runner + -- We pass this runner, such that it can be called at a later + -- point (possibly multiple times) if we were to encounter a call. + runStatement args stmt runner' + +-- | Run the current statement. It might adjust the substitution map +-- for a portion of the statements, which is why the runner takes a +-- new substitution map as an argument. +runStatement :: MonadCheck m => Subst -> Statement -> (Subst -> Runner m) -> Runner m +runStatement sub stmt runner = do + -- Runner with the old subst map. + let runner' = runner sub + let stmt' = subst sub stmt + case stmt' of + Call name app -> runFunc name app runner' + Assume e -> smtAssume e >> runner' + Assert e -> smtAssert e >> runner' + -- Run with modified subst map. + Let decl -> smtDeclare sub decl >>= runner -- | Get a function from the program given its name. getFunc :: MonadCheck m => Name -> m Func @@ -307,39 +276,6 @@ getFunc name = do Prog prog <- reader program return $ prog Map.! name --- | Run the checker over a body. Creating new instances --- of the signature and elaborating the statements in --- it to the smt solver. --- --- The returned substitution map contains all variables --- that were renamed during the run. This includes the --- signature as well as all the declarations in the body. -runBody :: MonadCheck m => Signature -> Body -> m Subst -runBody sig (Body _ body) = do - sub <- uniqueSig sig - foldM runStatement sub body - --- | Write a statement to smt solver, possibly recursing --- if the statement was a call. --- --- Declarations will change the substitution map, as --- declarations get name mangled to avoid name clashes. -runStatement :: MonadCheck m => Subst -> Statement -> m Subst -runStatement sub stmt = callCC $ \exit -> do - let stmt' = subst sub stmt - -- Run over the program and assert statements in SMT solver. - case stmt' of - Call name app -> runFunc name app - Assume e -> smtAssume $ subst sub e - Assert e -> smtAssert $ subst sub e - -- We early return a new substitution map here with the continuation. - Let decl -> smtDeclare sub decl >>= exit - return sub - --- | Generate unique symbols for a function signature. -uniqueSig :: MonadCheck m => Signature -> m Subst -uniqueSig = foldM smtDeclare (Su Map.empty) - -- | Returns a unique version of the received symbol. uniqueSym :: MonadCheck m => Symbol -> m Symbol uniqueSym sym = do @@ -362,14 +298,6 @@ smtDeclare (Su sub) (Decl sym sort) = do liftIO $ SMT.smtDecl ctx sym' sort return (Su $ Map.insert sym (EVar sym') sub) --- | Declare a fresh symbol, not derived from a declaration. -smtFresh :: MonadCheck m => Sort -> m Symbol -smtFresh sort = do - ctx <- reader context - sym <- uniqueSym "fresh" - liftIO $ SMT.smtDecl ctx sym sort - return sym - -- | Assume the given expression. smtAssert :: MonadCheck m => Expr -> m () smtAssert = smtAssume . PNot @@ -435,12 +363,13 @@ addHorn horn = do -- The rhs has a special case depending on -- if it is a kvar or not. (name, decl, rhs) <- case crhs horn of - PKVar kvar sub -> do - decl <- getSig kvar + PKVar name sub -> do + decl <- getSig name rhs <- substToStmts sub - return (kvar, decl, rhs) + return (name, decl, rhs) e -> return (mainName, [], [Assert e]) + -- Add the horn clause as a function body let cid = fromMaybe (-1) $ sid horn let body = Body cid $ lhs <> rhs addFunc name $ Func decl [body] @@ -484,20 +413,22 @@ hornLhsToStmts horn = do -- | Map a refinement to a declaration and constraint pair reftToStmts :: MonadBuild info m => Symbol -> SortedReft -> m [Statement] +reftToStmts _ RR { sr_sort = FFunc _ _ } = return [] reftToStmts sym RR { sr_sort = sort , sr_reft = Reft (v, e) } = do - -- Make constraint with proper substitution - let sub = Su . Map.singleton v $ EVar sym - + -- Get correct sort for declaration sort' <- elaborateSort sort let decl = Let $ Decl sym sort' + -- Get constraints from the expression. let constraints = case predKs e of [] -> [Assume e] ks -> map (uncurry Call) ks + -- Do proper substitution of v in the constraints + let sub = Su . Map.singleton v $ EVar sym return $ decl : subst sub constraints -- | Get the kvars from an expression. @@ -573,7 +504,7 @@ instance PPrint Decl where instance PPrint Body where pprintTidy tidy (Body cid stmts) = pcid $+$ pstmts where - pcid = PP.text "// id" <+> pprintTidy tidy cid + pcid = PP.text "// constraint id" <+> pprintTidy tidy cid pstmts = PP.vcat . map (pprintTidy tidy) $ stmts diff --git a/src/Language/Fixpoint/Smt/Interface.hs b/src/Language/Fixpoint/Smt/Interface.hs index 8665c8b08..f1bfd1c1e 100644 --- a/src/Language/Fixpoint/Smt/Interface.hs +++ b/src/Language/Fixpoint/Smt/Interface.hs @@ -204,18 +204,40 @@ smtGetValues Ctx {..} syms = do Left err -> Misc.errorstar $ "Parse error on get-value: " ++ err ++ "\n\n" ++ show text Right sol -> return sol -smtGetModel :: MonadIO m => Context -> m T.Text +smtGetModel :: MonadIO m => Context -> m Subst smtGetModel Ctx {..} = do let cmd = "(get-model)" bytestring <- liftIO $ SMTLIB.Backends.command ctxSolver cmd let text = bs2txt bytestring - return text + case A.parseOnly modelP text of + Left err -> Misc.errorstar $ "Parse error on get-value: " ++ err ++ "\n\n" ++ show text + Right sol -> return sol smtSetMbqi :: Context -> IO () smtSetMbqi me = interact' me SetMbqi type SmtParser a = Parser T.Text a +modelP :: SmtParser Subst +modelP = parenP $ do + defs <- A.many' defP + return $ Su (M.fromList defs) + +defP :: SmtParser (Symbol, Expr) +defP = parenP $ do + _ <- A.string "define-fun" + sym <- symbolP + sortP + expr <- exprP + return (sym, expr) + +sortP :: SmtParser () +sortP = do + -- A type is just an S-Expression, we can reuse the parser + let tyP = exprP >> return () + _ <- parenP $ A.many' tyP + tyP + valuesP :: SmtParser Subst valuesP = parenP $ do vs <- A.many' valueP @@ -236,7 +258,7 @@ appP = do return $ foldl' EApp e es litP :: SmtParser Expr -litP = integerP <|> realP <|> boolP <|> (EVar <$> symbolP) +litP = integerP <|> realP <|> boolP <|> bitvecP <|> (EVar <$> symbolP) -- TODO: Parse minus as just a negative integer integerP :: SmtParser Expr @@ -256,6 +278,20 @@ boolP = trueP <|> falseP trueP = A.string "true" >> return PTrue falseP = A.string "false" >> return PFalse +bitvecP :: SmtParser Expr +bitvecP = do + (bv, _) <- A.match (hexP <|> binP) + return $ ECon (L bv $ sizedBitVecSort "x") + where + hexP = do + _ <- A.string "#x" + _ <- A.hexadecimal :: SmtParser Int + return () + binP = do + _ <- A.string "#b" + _ <- A.many1' (A.char '0' <|> A.char '1') + return () + symbolP :: SmtParser Symbol symbolP = {- SCC "symbolP" -} do A.skipSpace diff --git a/tests/neg/ProgTest.fq b/tests/neg/ProgTest.fq new file mode 100644 index 000000000..44f1624d4 --- /dev/null +++ b/tests/neg/ProgTest.fq @@ -0,0 +1,24 @@ +wf: + env [] + reft {vk: int | [$k0]} + +bind 1 x : {v: int | $k0[vk := v]} +bind 2 y : {v: int | $k0[vk := v]} + +constraint: + env [1; 2] + lhs {v: int | v == x + y} + rhs {v: int | v != 7} + id 0 tag [] + +constraint: + env [] + lhs {v: int | v == 3} + rhs {v: int | $k0[vk := v]} + id 1 tag [] + +constraint: + env [] + lhs {v: int | v == 4} + rhs {v: int | $k0[vk := v]} + id 2 tag [] From a2d8feeb381f0d1af1ce440260ea53ed707df7e0 Mon Sep 17 00:00:00 2001 From: Robin Webbers Date: Fri, 7 Jul 2023 11:37:19 +0200 Subject: [PATCH 10/33] Modified to depth first counter example search. Added stack traces to counterexample. --- src/Language/Fixpoint/CounterExample.hs | 222 +++++++++++++-------- src/Language/Fixpoint/Types/Constraints.hs | 2 +- tests/neg/NonLinear.fq | 2 - tests/neg/two-calls.fq | 28 +++ 4 files changed, 164 insertions(+), 90 deletions(-) create mode 100644 tests/neg/two-calls.fq diff --git a/src/Language/Fixpoint/CounterExample.hs b/src/Language/Fixpoint/CounterExample.hs index 80a2c5411..516a9b3e6 100644 --- a/src/Language/Fixpoint/CounterExample.hs +++ b/src/Language/Fixpoint/CounterExample.hs @@ -18,9 +18,12 @@ import qualified Language.Fixpoint.Utils.Files as Ext import qualified Language.Fixpoint.Smt.Interface as SMT import Data.Maybe (fromMaybe) -import Data.List (find) +import Data.List (find, intercalate, foldl') import Data.HashMap.Strict (HashMap) +import Data.String (IsString(..)) +import Data.Bifunctor (first) import qualified Data.HashMap.Strict as Map +import qualified Data.Text as T import Control.Monad.State import Control.Monad.Reader @@ -42,54 +45,41 @@ newtype Prog = Prog (HashMap Name Func) type Name = KVar -- | A function symbol corresponding to a Name. -data Func = Func Signature [Body] +data Func = Func !Signature ![Body] deriving Show -- | A sequence of statements. -data Body = Body SubcId [Statement] +data Body = Body !SubcId ![Statement] deriving Show -- | A statement used to introduce/check constraints, -- together with its location information -data Statement = Statement Location StatementKind - --- | Location information for a statement. Used to map --- a counter example from its trace. -data Location - = BindLoc BindId - -- ^ Location info that came from a binding - | HornLoc SubcId - -- ^ Location info that came from a horn clause - -- (i.e. the main variable of the constraint) - --- | The main part of a statement -data StatementKind - = Let Decl +data Statement + = Let !Decl -- ^ Introduces a new variable. - | Assume Expr + | Assume !Expr -- ^ Constraints a variable. - | Assert Expr + | Assert !Expr -- ^ Checks whether a predicate follows given prior constraints. - | Call Name Subst - -- ^ Call to function. + | Call !Symbol !Name !Subst + -- ^ Call to function. The symbol is the origin, used to trace + -- callstacks. deriving Show -- | A declaration of a Symbol with a Sort. -data Decl = Decl Symbol Sort +data Decl = Decl !Symbol !Sort deriving Show --- | Arguments to a function. -type Args = Subst -- | Signature of a function. type Signature = [Decl] -- | A counter example for a model. -type CounterExample = Subst +type CounterExample = HashMap [Symbol] Subst -- | The enviroment used to build a program. data BuildEnv info = BuildEnv - { info :: SInfo info + { info :: !(SInfo info) -- ^ The horn constraints from which we build the program. - , symbols :: SymEnv + , symbols :: !SymEnv -- ^ Contains the sorts of symbols, which we need for declarations. } @@ -99,18 +89,18 @@ type MonadBuild info m = (MonadReader (BuildEnv info) m, MonadState Prog m, Mona -- | Environment for the counter example generation. data CheckEnv = CheckEnv - { program :: Prog + { program :: !Prog -- ^ The program we are checking - , context :: SMT.Context + , context :: !SMT.Context -- ^ The SMT context we write the constraints from the program to. - , maxDepth :: Int + , maxDepth :: !Int -- ^ The maximum number of functions to traverse (to avoid state blow-up). } -- | State tracked when checking a program. data CheckState = CheckState - { uniqueId :: Int - -- ^ Unique identifier used to avoid clashing names. + { -- uniqueId :: Int +-- -- ^ Unique identifier used to avoid clashing names. -- , depth :: Int -- -- ^ Current depth (i.e. number of functions traversed) } @@ -133,6 +123,8 @@ dbg = liftIO . print . pprint -- TODO: Remove variables from the counter example that got mapped to -- the "wrong" type in smt format (e.g. to an int while not being one). +-- TODO: Reimplement recursion limit. + -- | Try to get a counter example for the given unsafe clauses (if any). tryCounterExample :: (MonadIO m, Fixpoint info) @@ -156,12 +148,22 @@ tryCounterExample _ _ res = return res -- -- In other words, we go from a mapping of Symbol |-> Expr to -- BindId |-> Expr -cexBindIds :: SInfo info -> CounterExample -> BindMap Expr -cexBindIds si (Su cex) = Map.compose cex bindings +cexBindIds :: SInfo info -> CounterExample -> HashMap [BindId] (BindMap Expr) +cexBindIds si cex = Map.mapKeys (map $ (Map.!) symIds) inner where + -- Inner mappings are changed, but the traces aren't yet + inner :: HashMap [Symbol] (BindMap Expr) + inner = (\(Su sub) -> Map.compose sub bindings) <$> cex + + -- Fetch a map of all the available bindings + bindings :: HashMap BindId Symbol bindings = fst' <$> beBinds (bs si) fst' (sym, _, _) = sym + -- Reverse the bindings mapping, so we can map our symbols to bind ids. + symIds :: HashMap Symbol BindId + symIds = Map.fromList $ (\(sym, bid) -> (bid, sym)) <$> Map.toList bindings + -- | Check the given constraints to try and find a counter example. checkProg :: MonadIO m => Config -> SInfo info -> Prog -> [SubcId] -> m CounterExamples checkProg cfg si prog cids = withContext cfg si check @@ -189,7 +191,7 @@ withContext cfg si inner = do runCheck :: MonadIO m => [SubcId] -> CheckEnv -> m CounterExamples runCheck cids env = rd . st . ct $ checkAll cids where - st = flip evalStateT $ CheckState 0 --0 + st = flip evalStateT CheckState --0 --0 rd = flip runReaderT env ct = flip runContT return @@ -219,24 +221,63 @@ type Runner m = m (Maybe CounterExample) smtCheck :: MonadCheck m => Runner m smtCheck = callCC $ \exit -> do ctx <- reader context + valid <- liftIO $ SMT.smtCheckUnsat ctx - when valid $ exit Nothing + -- TODO: Perhaps just get rid of the continuation, as this is + -- the only use of it! + when valid $ exit Nothing -- No model available - cex <- liftIO $ SMT.smtGetModel ctx + Su sub <- liftIO $ SMT.smtGetModel ctx + + -- Filter just the variables for which we have a trace + let renames = first symbolTrace <$> Map.toList sub + let traces = [ (trace, sym, e) | (Just (sym, trace), e) <- renames ] + + -- Insert a mapping per unique layer in the counter example. + let new sym e = Su $ Map.singleton sym e + let insert cex (trace, sym, e) = Map.insertWith (<>) trace (new sym e) cex + let cex = foldl' insert mempty traces - -- -- Counter example (unique safe symbols |-> instance) - -- TODO: Figure out which variables to actually return here! - -- - -- I want to return a stack trace towards the counter example - -- for each binding. return $ Just cex -runFunc :: MonadCheck m => Name -> Args -> Runner m -> Runner m -runFunc name args runner = do +-- | We encode the trace of a symbol in its name. This way, +-- we do not lose it in the SMT solver. This function translates +-- the encoding back. +symbolTrace :: Symbol -> Maybe (Symbol, [Symbol]) +symbolTrace sym = case T.splitOn bindSep' sym' of + (prefix:name:trace) | prefix == progPrefix + -> Just (symbol name, symbol <$> trace) + _ -> Nothing + where + -- symbolSafeText did some weird prepend, + -- so here is just the escaped '@' symbol. + bindSep' = "$64$" + sym' = symbolText sym + +-- | A scope contains the current binders in place +-- as well as the path traversed to reach this scope. +data Scope = Scope + { path :: ![Symbol] + -- ^ The path traversed to reach the scope. + , binders :: !Subst + -- ^ The binders available in the current scope. + } + +instance Semigroup Scope where + scope <> scope' = Scope + { path = path scope <> path scope' + , binders = binders scope <> binders scope' + } + +instance Monoid Scope where + mempty = Scope mempty mempty + +runFunc :: MonadCheck m => Name -> Scope -> Runner m -> Runner m +runFunc name scope runner = do Func _ bodies <- getFunc name -- Generate all execution paths (as runners). - let runner' body = smtScope $ runBody args body runner + let runner' body = smtScope $ runBody scope body runner let paths = map runner' bodies -- Try paths, selecting the first that produces a counter example. @@ -246,29 +287,30 @@ runFunc name args runner = do -- | Run the statements in the body. If there are no more statements -- to run, this will execute the Runner that was passed as argument. -runBody :: MonadCheck m => Args -> Body -> Runner m -> Runner m +runBody :: MonadCheck m => Scope -> Body -> Runner m -> Runner m runBody _ (Body _ []) runner = runner -runBody args (Body cid (stmt:ss)) runner = do +runBody scope (Body cid (stmt:ss)) runner = do -- The remaining statements become a new Runner - let runner' sub = runBody sub (Body cid ss) runner + let runner' scope' = runBody scope' (Body cid ss) runner -- We pass this runner, such that it can be called at a later -- point (possibly multiple times) if we were to encounter a call. - runStatement args stmt runner' + runStatement scope stmt runner' -- | Run the current statement. It might adjust the substitution map -- for a portion of the statements, which is why the runner takes a -- new substitution map as an argument. -runStatement :: MonadCheck m => Subst -> Statement -> (Subst -> Runner m) -> Runner m -runStatement sub stmt runner = do +runStatement :: MonadCheck m => Scope -> Statement -> (Scope -> Runner m) -> Runner m +runStatement scope stmt runner = do -- Runner with the old subst map. - let runner' = runner sub - let stmt' = subst sub stmt + let runner' = runner scope + let stmt' = subst (binders scope) stmt case stmt' of - Call name app -> runFunc name app runner' - Assume e -> smtAssume e >> runner' - Assert e -> smtAssert e >> runner' - -- Run with modified subst map. - Let decl -> smtDeclare sub decl >>= runner + Call origin name app -> do + let scope' = Scope (origin:path scope) app + runFunc name scope' runner' + Assume e -> smtAssume e >> runner' + Assert e -> smtAssert e >> runner' + Let decl -> smtDeclare scope decl >>= runner -- Run with modified scope. -- | Get a function from the program given its name. getFunc :: MonadCheck m => Name -> m Func @@ -277,26 +319,23 @@ getFunc name = do return $ prog Map.! name -- | Returns a unique version of the received symbol. -uniqueSym :: MonadCheck m => Symbol -> m Symbol -uniqueSym sym = do - -- Get unique number - unique <- gets uniqueId - modify $ \s -> s { uniqueId = unique + 1 } - - -- Apply unique number to identifier - let (<.>) = suffixSymbol - let unique' = symbol . show $ unique - return $ sym <.> "@" <.> unique' +uniqueSym :: MonadCheck m => Scope -> Symbol -> m Symbol +uniqueSym scope sym = do + let strs = symbolString <$> progPrefix : sym : path scope + let name = intercalate bindSep strs + return $ symbol name -- | Declare a new symbol, returning an updated substitution -- given with this new symbol in it. The substitution map is -- required to avoid duplicating variable names. -smtDeclare :: MonadCheck m => Subst -> Decl -> m Subst -smtDeclare (Su sub) (Decl sym sort) = do +smtDeclare :: MonadCheck m => Scope -> Decl -> m Scope +smtDeclare scope (Decl sym sort) = do ctx <- reader context - sym' <- uniqueSym sym + sym' <- uniqueSym scope sym liftIO $ SMT.smtDecl ctx sym' sort - return (Su $ Map.insert sym (EVar sym') sub) + let Su sub = binders scope + let binders' = Su $ Map.insert sym (EVar sym') sub + return scope { binders = binders' } -- | Assume the given expression. smtAssert :: MonadCheck m => Expr -> m () @@ -425,10 +464,10 @@ reftToStmts sym RR -- Get constraints from the expression. let constraints = case predKs e of [] -> [Assume e] - ks -> map (uncurry Call) ks + ks -> map (uncurry $ Call sym) ks -- Do proper substitution of v in the constraints - let sub = Su . Map.singleton v $ EVar sym + let sub = Su $ Map.singleton v (EVar sym) return $ decl : subst sub constraints -- | Get the kvars from an expression. @@ -464,9 +503,15 @@ addFunc kvar func = do mainName :: Name mainName = KV "main" +bindSep :: IsString a => a +bindSep = "@" + +progPrefix :: IsString a => a +progPrefix = "prog" + instance PPrint Prog where pprintTidy tidy (Prog funcs) = PP.vcat - . PP.punctuate (PP.text "\n") + . PP.punctuate "\n" . map (uncurry $ ppfunc tidy) . Map.toList $ funcs @@ -479,15 +524,14 @@ instance PPrint Func where ppfunc :: Tidy -> Name -> Func -> PP.Doc ppfunc tidy name (Func sig bodies) = pdecl $+$ pbody $+$ PP.rbrace where - pdecl = fn <+> pname <+> psig <+> PP.lbrace - fn = PP.text "fn" + pdecl = "fn" <+> pname <+> psig <+> PP.lbrace pname = pprintTidy tidy name psig = PP.parens . PP.hsep . PP.punctuate PP.comma . map (pprintTidy tidy) $ sig - pbody = vpunctuate (PP.text "||") + pbody = vpunctuate "||" . map (PP.nest 4 . pprintTidy tidy) $ bodies @@ -504,37 +548,41 @@ instance PPrint Decl where instance PPrint Body where pprintTidy tidy (Body cid stmts) = pcid $+$ pstmts where - pcid = PP.text "// constraint id" <+> pprintTidy tidy cid + pcid = "// constraint id" <+> pprintTidy tidy cid pstmts = PP.vcat . map (pprintTidy tidy) $ stmts instance PPrint Statement where - pprintTidy tidy (Let decl) = PP.text "let" <+> pprintTidy tidy decl - pprintTidy tidy (Assume exprs) = PP.text "assume" <+> pprintTidy tidy exprs - pprintTidy tidy (Assert exprs) = PP.text "assert" <+> pprintTidy tidy exprs - pprintTidy tidy (Call kvar sub) = pprintTidy tidy kvar <+> pprintTidy tidy sub + pprintTidy tidy (Let decl) = "let" <+> pprintTidy tidy decl + pprintTidy tidy (Assume exprs) = "assume" <+> pprintTidy tidy exprs + pprintTidy tidy (Assert exprs) = "assert" <+> pprintTidy tidy exprs + pprintTidy tidy (Call origin name sub) = pname <+> pargs <+> porigin + where + pname = pprintTidy tidy name + pargs = pprintTidy tidy sub + porigin = "// origin" <+> pprintTidy tidy origin instance Subable Statement where syms (Let decl) = syms decl syms (Assume e) = syms e syms (Assert e) = syms e - syms (Call _ (Su sub)) = syms sub + syms (Call _ _ (Su sub)) = syms sub substa f (Let decl) = Let $ substa f decl substa f (Assume e) = Assume $ substa f e substa f (Assert e) = Assert $ substa f e - substa f (Call name (Su sub)) = Call name (Su $ substa f sub) + substa f (Call origin name (Su sub)) = Call origin name (Su $ substa f sub) substf f (Let decl) = Let $ substf f decl substf f (Assume e) = Assume $ substf f e substf f (Assert e) = Assert $ substf f e - substf f (Call name (Su sub)) = Call name (Su $ substf f sub) + substf f (Call origin name (Su sub)) = Call origin name (Su $ substf f sub) subst sub (Let decl) = Let $ subst sub decl subst sub (Assume e) = Assume $ subst sub e subst sub (Assert e) = Assert $ subst sub e - subst sub (Call name (Su sub')) = Call name (Su $ subst sub sub') + subst sub (Call origin name (Su sub')) = Call origin name (Su $ subst sub sub') instance Subable Decl where syms (Decl sym _) = [sym] diff --git a/src/Language/Fixpoint/Types/Constraints.hs b/src/Language/Fixpoint/Types/Constraints.hs index 377f24ae3..2b4bebc97 100644 --- a/src/Language/Fixpoint/Types/Constraints.hs +++ b/src/Language/Fixpoint/Types/Constraints.hs @@ -278,7 +278,7 @@ data Result a = Result , resSolution :: !FixSolution , resNonCutsSolution :: !FixSolution , gresSolution :: !GFixSolution - , resCntExs :: !(M.HashMap SubcId (BindMap Expr)) + , resCntExs :: !(M.HashMap SubcId (M.HashMap [BindId] (BindMap Expr))) } deriving (Generic, Show, Functor) diff --git a/tests/neg/NonLinear.fq b/tests/neg/NonLinear.fq index e341af830..68b95c477 100644 --- a/tests/neg/NonLinear.fq +++ b/tests/neg/NonLinear.fq @@ -1,4 +1,3 @@ - bind 1 pig : {v: int | []} bind 2 pigOut : {v: int | [v = pig + 1]} @@ -25,4 +24,3 @@ constraint: wf: env [10] reft {vk02: int | [$k0]} - diff --git a/tests/neg/two-calls.fq b/tests/neg/two-calls.fq new file mode 100644 index 000000000..bdf079cc3 --- /dev/null +++ b/tests/neg/two-calls.fq @@ -0,0 +1,28 @@ +bind 0 x : {v: int | [$k[vk := v]]} +bind 1 y : {v: int | [$k[vk := v]]} + +constraint: + env [0; 1] + lhs {v0: int | v0 == x + y} + rhs {v0: int | v0 != 7} + id 0 tag [] + +bind 3 three : {v: int | v = 3} + +constraint: + env [3] + lhs {v1: int | [v1 == three]} + rhs {v1: int | $k[vk := v1]} + id 1 tag [] + +bind 4 four : {v: int | v = 4} + +constraint: + env [4] + lhs {v2: int | [v2 == four]} + rhs {v2: int | $k[vk := v2]} + id 2 tag [] + +wf: + env [] + reft {vk: int | [$k]} From 13dabbce2eea4c7b182594ff42af922d9423ce1b Mon Sep 17 00:00:00 2001 From: Robin Webbers Date: Fri, 7 Jul 2023 14:50:27 +0200 Subject: [PATCH 11/33] Split counterexample build and check --- liquid-fixpoint.cabal | 3 + src/Language/Fixpoint/CounterExample.hs | 548 +----------------- src/Language/Fixpoint/CounterExample/Build.hs | 178 ++++++ src/Language/Fixpoint/CounterExample/Check.hs | 250 ++++++++ src/Language/Fixpoint/CounterExample/Types.hs | 151 +++++ 5 files changed, 589 insertions(+), 541 deletions(-) create mode 100644 src/Language/Fixpoint/CounterExample/Build.hs create mode 100644 src/Language/Fixpoint/CounterExample/Check.hs create mode 100644 src/Language/Fixpoint/CounterExample/Types.hs diff --git a/liquid-fixpoint.cabal b/liquid-fixpoint.cabal index 376a7aa93..44f748d41 100644 --- a/liquid-fixpoint.cabal +++ b/liquid-fixpoint.cabal @@ -56,6 +56,9 @@ library exposed-modules: Data.ShareMap Language.Fixpoint.Conditional.Z3 Language.Fixpoint.CounterExample + Language.Fixpoint.CounterExample.Build + Language.Fixpoint.CounterExample.Check + Language.Fixpoint.CounterExample.Types Language.Fixpoint.Defunctionalize Language.Fixpoint.Graph Language.Fixpoint.Graph.Deps diff --git a/src/Language/Fixpoint/CounterExample.hs b/src/Language/Fixpoint/CounterExample.hs index 516a9b3e6..1fd51df78 100644 --- a/src/Language/Fixpoint/CounterExample.hs +++ b/src/Language/Fixpoint/CounterExample.hs @@ -1,130 +1,25 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE BangPatterns #-} module Language.Fixpoint.CounterExample ( tryCounterExample - , dbg ) where -import Language.Fixpoint.Types hiding (exit) -import Language.Fixpoint.Types.Config (Config, srcFile, queryFile, save, counterExample) -import Language.Fixpoint.Solver.Sanitize (symbolEnv) -import Language.Fixpoint.Misc (ensurePath) -import Language.Fixpoint.SortCheck (elaborate) +import Language.Fixpoint.Types +import Language.Fixpoint.CounterExample.Types +import Language.Fixpoint.CounterExample.Build +import Language.Fixpoint.CounterExample.Check +import Language.Fixpoint.Types.Config (Config, counterExample) -import qualified Language.Fixpoint.Utils.Files as Ext -import qualified Language.Fixpoint.Smt.Interface as SMT - -import Data.Maybe (fromMaybe) -import Data.List (find, intercalate, foldl') import Data.HashMap.Strict (HashMap) -import Data.String (IsString(..)) -import Data.Bifunctor (first) import qualified Data.HashMap.Strict as Map -import qualified Data.Text as T - -import Control.Monad.State -import Control.Monad.Reader -import Control.Monad.Cont - -import Text.PrettyPrint.HughesPJ ((<+>), ($+$)) -import qualified Text.PrettyPrint.HughesPJ as PP - --- | Multiple counter examples indexed per constraint id. -type CounterExamples = HashMap SubcId CounterExample - --- | A program, containing multiple function definitions --- mapped by their name. -newtype Prog = Prog (HashMap Name Func) - deriving Show - --- | Identifier of a function. All KVars are translated --- into functions, so it is just an alias. -type Name = KVar - --- | A function symbol corresponding to a Name. -data Func = Func !Signature ![Body] - deriving Show - --- | A sequence of statements. -data Body = Body !SubcId ![Statement] - deriving Show - --- | A statement used to introduce/check constraints, --- together with its location information -data Statement - = Let !Decl - -- ^ Introduces a new variable. - | Assume !Expr - -- ^ Constraints a variable. - | Assert !Expr - -- ^ Checks whether a predicate follows given prior constraints. - | Call !Symbol !Name !Subst - -- ^ Call to function. The symbol is the origin, used to trace - -- callstacks. - deriving Show - --- | A declaration of a Symbol with a Sort. -data Decl = Decl !Symbol !Sort - deriving Show - --- | Signature of a function. -type Signature = [Decl] --- | A counter example for a model. -type CounterExample = HashMap [Symbol] Subst - --- | The enviroment used to build a program. -data BuildEnv info = BuildEnv - { info :: !(SInfo info) - -- ^ The horn constraints from which we build the program. - , symbols :: !SymEnv - -- ^ Contains the sorts of symbols, which we need for declarations. - } --- | The monad used to convert a set of horn constraints to --- the imperative function format. See Prog for the format. -type MonadBuild info m = (MonadReader (BuildEnv info) m, MonadState Prog m, MonadIO m) - --- | Environment for the counter example generation. -data CheckEnv = CheckEnv - { program :: !Prog - -- ^ The program we are checking - , context :: !SMT.Context - -- ^ The SMT context we write the constraints from the program to. - , maxDepth :: !Int - -- ^ The maximum number of functions to traverse (to avoid state blow-up). - } - --- | State tracked when checking a program. -data CheckState = CheckState - { -- uniqueId :: Int --- -- ^ Unique identifier used to avoid clashing names. --- , depth :: Int --- -- ^ Current depth (i.e. number of functions traversed) - } - --- | The monad used to generate counter examples from a Prog. -type MonadCheck m = (MonadReader CheckEnv m, MonadState CheckState m, MonadCont m, MonadIO m) - --- TODO: I don't think we're using all values and constraints on MonadCheck anymore. --- Check what we can remove. - --- TODO: remove this on code cleanup -dbg :: (MonadIO m, PPrint a) => a -> m () -dbg = liftIO . print . pprint - --- TODO: Perhaps split the two parts (building and checking) --- into two separate files, as they share no functions. --- (except for the program types, which I suppose goes into a --- separate file then.) +import Control.Monad.IO.Class -- TODO: Remove variables from the counter example that got mapped to -- the "wrong" type in smt format (e.g. to an int while not being one). --- TODO: Reimplement recursion limit. - -- | Try to get a counter example for the given unsafe clauses (if any). tryCounterExample :: (MonadIO m, Fixpoint info) @@ -162,433 +57,4 @@ cexBindIds si cex = Map.mapKeys (map $ (Map.!) symIds) inner -- Reverse the bindings mapping, so we can map our symbols to bind ids. symIds :: HashMap Symbol BindId - symIds = Map.fromList $ (\(sym, bid) -> (bid, sym)) <$> Map.toList bindings - --- | Check the given constraints to try and find a counter example. -checkProg :: MonadIO m => Config -> SInfo info -> Prog -> [SubcId] -> m CounterExamples -checkProg cfg si prog cids = withContext cfg si check - where - check ctx = runCheck cids CheckEnv - { program = prog - , context = ctx - , maxDepth = 100 -- TODO: Perhaps this should be a parameter for the user? - } - --- | Run the checker with the SMT solver context. -withContext :: MonadIO m => Config -> SInfo info -> (SMT.Context -> m a) -> m a -withContext cfg si inner = do - let file = srcFile cfg <> ".prog" - let env = symbolEnv cfg si - ctx <- liftIO $ SMT.makeContextWithSEnv cfg file env - - !result <- inner ctx - - liftIO $ SMT.cleanupContext ctx - return result - --- | Runs the program checker with the monad stack --- unwrapped. -runCheck :: MonadIO m => [SubcId] -> CheckEnv -> m CounterExamples -runCheck cids env = rd . st . ct $ checkAll cids - where - st = flip evalStateT CheckState --0 --0 - rd = flip runReaderT env - ct = flip runContT return - --- | Try to find a counter example for all the given constraints. -checkAll :: MonadCheck m => [SubcId] -> m CounterExamples -checkAll cids = do - cexs <- forM cids checkConstraint - return $ Map.fromList [(cid, cex) | (cid, Just cex) <- zip cids cexs] - --- | Check a specific constraint id. This will only do actual --- checks for constraints without a KVar on the rhs, as we cannot --- really generate a counter example for these constraints. -checkConstraint :: MonadCheck m => SubcId -> m (Maybe CounterExample) -checkConstraint cid = do - Func _ bodies <- getFunc mainName - let cmp (Body bid _) = bid == cid - case find cmp bodies of - Just body -> runBody mempty body smtCheck - Nothing -> return Nothing - --- | The runner is a computation path in the program. We use this --- as an argument to pass around the remainder of a computation. --- This way, we can pop paths in the SMT due to conditionals. --- Allowing us to retain anything prior to that. -type Runner m = m (Maybe CounterExample) - -smtCheck :: MonadCheck m => Runner m -smtCheck = callCC $ \exit -> do - ctx <- reader context - - valid <- liftIO $ SMT.smtCheckUnsat ctx - -- TODO: Perhaps just get rid of the continuation, as this is - -- the only use of it! - when valid $ exit Nothing -- No model available - - Su sub <- liftIO $ SMT.smtGetModel ctx - - -- Filter just the variables for which we have a trace - let renames = first symbolTrace <$> Map.toList sub - let traces = [ (trace, sym, e) | (Just (sym, trace), e) <- renames ] - - -- Insert a mapping per unique layer in the counter example. - let new sym e = Su $ Map.singleton sym e - let insert cex (trace, sym, e) = Map.insertWith (<>) trace (new sym e) cex - let cex = foldl' insert mempty traces - - return $ Just cex - --- | We encode the trace of a symbol in its name. This way, --- we do not lose it in the SMT solver. This function translates --- the encoding back. -symbolTrace :: Symbol -> Maybe (Symbol, [Symbol]) -symbolTrace sym = case T.splitOn bindSep' sym' of - (prefix:name:trace) | prefix == progPrefix - -> Just (symbol name, symbol <$> trace) - _ -> Nothing - where - -- symbolSafeText did some weird prepend, - -- so here is just the escaped '@' symbol. - bindSep' = "$64$" - sym' = symbolText sym - --- | A scope contains the current binders in place --- as well as the path traversed to reach this scope. -data Scope = Scope - { path :: ![Symbol] - -- ^ The path traversed to reach the scope. - , binders :: !Subst - -- ^ The binders available in the current scope. - } - -instance Semigroup Scope where - scope <> scope' = Scope - { path = path scope <> path scope' - , binders = binders scope <> binders scope' - } - -instance Monoid Scope where - mempty = Scope mempty mempty - -runFunc :: MonadCheck m => Name -> Scope -> Runner m -> Runner m -runFunc name scope runner = do - Func _ bodies <- getFunc name - - -- Generate all execution paths (as runners). - let runner' body = smtScope $ runBody scope body runner - let paths = map runner' bodies - - -- Try paths, selecting the first that produces a counter example. - let select Nothing r = r - select cex _ = return cex - foldM select Nothing paths - --- | Run the statements in the body. If there are no more statements --- to run, this will execute the Runner that was passed as argument. -runBody :: MonadCheck m => Scope -> Body -> Runner m -> Runner m -runBody _ (Body _ []) runner = runner -runBody scope (Body cid (stmt:ss)) runner = do - -- The remaining statements become a new Runner - let runner' scope' = runBody scope' (Body cid ss) runner - -- We pass this runner, such that it can be called at a later - -- point (possibly multiple times) if we were to encounter a call. - runStatement scope stmt runner' - --- | Run the current statement. It might adjust the substitution map --- for a portion of the statements, which is why the runner takes a --- new substitution map as an argument. -runStatement :: MonadCheck m => Scope -> Statement -> (Scope -> Runner m) -> Runner m -runStatement scope stmt runner = do - -- Runner with the old subst map. - let runner' = runner scope - let stmt' = subst (binders scope) stmt - case stmt' of - Call origin name app -> do - let scope' = Scope (origin:path scope) app - runFunc name scope' runner' - Assume e -> smtAssume e >> runner' - Assert e -> smtAssert e >> runner' - Let decl -> smtDeclare scope decl >>= runner -- Run with modified scope. - --- | Get a function from the program given its name. -getFunc :: MonadCheck m => Name -> m Func -getFunc name = do - Prog prog <- reader program - return $ prog Map.! name - --- | Returns a unique version of the received symbol. -uniqueSym :: MonadCheck m => Scope -> Symbol -> m Symbol -uniqueSym scope sym = do - let strs = symbolString <$> progPrefix : sym : path scope - let name = intercalate bindSep strs - return $ symbol name - --- | Declare a new symbol, returning an updated substitution --- given with this new symbol in it. The substitution map is --- required to avoid duplicating variable names. -smtDeclare :: MonadCheck m => Scope -> Decl -> m Scope -smtDeclare scope (Decl sym sort) = do - ctx <- reader context - sym' <- uniqueSym scope sym - liftIO $ SMT.smtDecl ctx sym' sort - let Su sub = binders scope - let binders' = Su $ Map.insert sym (EVar sym') sub - return scope { binders = binders' } - --- | Assume the given expression. -smtAssert :: MonadCheck m => Expr -> m () -smtAssert = smtAssume . PNot - --- | Assert the given expression. -smtAssume :: MonadCheck m => Expr -> m () -smtAssume e = do - ctx <- reader context - liftIO $ SMT.smtAssert ctx e - --- | Run the checker within a scope (i.e. a push/pop pair). -smtScope :: MonadCheck m => m a -> m a -smtScope inner = do - ctx <- reader context - liftIO $ SMT.smtPush ctx - !result <- inner - liftIO $ SMT.smtPop ctx - return result - --- | Make an imperative program from horn clauses. This --- can be used to generate a counter example. -hornToProg :: MonadIO m => Config -> SInfo info -> m Prog -hornToProg cfg si = do - -- Initial program is just an empty main. - let initial = Prog $ Map.singleton mainName (Func [] []) - let env = BuildEnv - { info = si - , symbols = symbolEnv cfg si - } - - -- Run monad that adds all horn clauses - prog <- evalStateT (runReaderT buildProg env) initial - - -- Save the program in a file - liftIO . when (save cfg) $ do - let file = queryFile Ext.Prog cfg - ensurePath file - writeFile file $ PP.render (pprint prog) - - -- Return the generated program - return prog - --- | Build the entire program structure from the constraints --- inside the monad -buildProg :: MonadBuild info m => m Prog -buildProg = do - constraints <- reader $ cm . info - mapM_ addHorn constraints - get - --- | Given a horn clause, generates a body for a function. --- --- The body is generated from the lhs of the horn clause. --- --- This body is added to the function given by the kvar --- on the rhs of the horn clause. If there was no kvar, --- it is added to the main function. -addHorn :: MonadBuild info m => SimpC info -> m () -addHorn horn = do - -- Make the lhs of the clause into statements - lhs <- hornLhsToStmts horn - - -- The rhs has a special case depending on - -- if it is a kvar or not. - (name, decl, rhs) <- case crhs horn of - PKVar name sub -> do - decl <- getSig name - rhs <- substToStmts sub - return (name, decl, rhs) - e -> return (mainName, [], [Assert e]) - - -- Add the horn clause as a function body - let cid = fromMaybe (-1) $ sid horn - let body = Body cid $ lhs <> rhs - addFunc name $ Func decl [body] - --- | Gets a signature of a KVar from its well foundedness constraint -getSig :: MonadBuild info m => Name -> m Signature -getSig kvar = do - -- Get the well foundedness constraint of the kvar - wfcs <- reader $ ws . info - let wfc = wfcs Map.! kvar - - -- Get the bind environment and bindings of the wfc - bindEnv <- reader $ bs . info - let ibinds = elemsIBindEnv . wenv $ wfc - - -- Lookup all Decl from the wfc using the ibinds - let asDecl (sym, sr, _) = Decl sym (sr_sort sr) - let decls = map (asDecl . flip lookupBindEnv bindEnv) ibinds - - -- Get the last Decl from the head of the wfc - let rhs = let (sym, sort, _) = wrft wfc in Decl sym sort - - -- Return the head + bindings as argument map - return $ rhs:decls - --- | Defines some equalities between local variables --- and the passed arguments given some substitution map. -substToStmts :: MonadBuild info m => Subst -> m [Statement] -substToStmts (Su sub) = do - let asEq (ksym, e) = Assume $ PAtom Eq (EVar ksym) e - return $ map asEq (Map.toList sub) - --- | Converts the left hand side of the horn clause to a list --- of assumptions (or calls given by a Name) -hornLhsToStmts :: MonadBuild info m => SimpC info -> m [Statement] -hornLhsToStmts horn = do - bindEnv <- reader $ bs . info - let lhs = clhs bindEnv horn - stmts <- forM lhs $ uncurry reftToStmts - return $ mconcat stmts - --- | Map a refinement to a declaration and constraint pair -reftToStmts :: MonadBuild info m => Symbol -> SortedReft -> m [Statement] -reftToStmts _ RR { sr_sort = FFunc _ _ } = return [] -reftToStmts sym RR - { sr_sort = sort - , sr_reft = Reft (v, e) - } = do - -- Get correct sort for declaration - sort' <- elaborateSort sort - let decl = Let $ Decl sym sort' - - -- Get constraints from the expression. - let constraints = case predKs e of - [] -> [Assume e] - ks -> map (uncurry $ Call sym) ks - - -- Do proper substitution of v in the constraints - let sub = Su $ Map.singleton v (EVar sym) - return $ decl : subst sub constraints - --- | Get the kvars from an expression. --- --- I think this should be the only way in which kvars appear? --- Otherwise, this should be changed! -predKs :: Expr -> [(KVar, Subst)] -predKs (PAnd ps) = mconcat $ map predKs ps -predKs (PKVar k su) = [(k, su)] -predKs _ = [] - --- | The sorts for the apply monomorphization only match if --- we do this elaborate on the sort. Not sure why... --- --- This elaboration also happens inside the declaration --- of the symbol environment, so that's where I got the idea. -elaborateSort :: MonadBuild info m => Sort -> m Sort -elaborateSort sym = do - symbols' <- reader symbols - return $ elaborate "elaborateSort" symbols' sym - --- | Add a function to the function map with index by its name. --- If an entry already exists, it will merge the function --- bodies. -addFunc :: MonadBuild info m => Name -> Func -> m () -addFunc kvar func = do - let merge (Func _ b) (Func d b') = Func d (b <> b') - Prog prog <- get - put . Prog $ Map.insertWith merge kvar func prog - --- | The main function, which any horn clause without a --- KVar on the rhs will be added to. -mainName :: Name -mainName = KV "main" - -bindSep :: IsString a => a -bindSep = "@" - -progPrefix :: IsString a => a -progPrefix = "prog" - -instance PPrint Prog where - pprintTidy tidy (Prog funcs) = PP.vcat - . PP.punctuate "\n" - . map (uncurry $ ppfunc tidy) - . Map.toList - $ funcs - -instance PPrint Func where - pprintTidy tidy = ppfunc tidy anonymous - where - anonymous = KV "_" - -ppfunc :: Tidy -> Name -> Func -> PP.Doc -ppfunc tidy name (Func sig bodies) = pdecl $+$ pbody $+$ PP.rbrace - where - pdecl = "fn" <+> pname <+> psig <+> PP.lbrace - pname = pprintTidy tidy name - psig = PP.parens - . PP.hsep - . PP.punctuate PP.comma - . map (pprintTidy tidy) - $ sig - pbody = vpunctuate "||" - . map (PP.nest 4 . pprintTidy tidy) - $ bodies - - vpunctuate _ [] = mempty - vpunctuate _ [d] = d - vpunctuate p (d:ds) = d $+$ p $+$ vpunctuate p ds - -instance PPrint Decl where - pprintTidy tidy (Decl sym sort) = (psym <> PP.colon) <+> psort - where - psym = pprintTidy tidy sym - psort = pprintTidy tidy sort - -instance PPrint Body where - pprintTidy tidy (Body cid stmts) = pcid $+$ pstmts - where - pcid = "// constraint id" <+> pprintTidy tidy cid - pstmts = PP.vcat - . map (pprintTidy tidy) - $ stmts - -instance PPrint Statement where - pprintTidy tidy (Let decl) = "let" <+> pprintTidy tidy decl - pprintTidy tidy (Assume exprs) = "assume" <+> pprintTidy tidy exprs - pprintTidy tidy (Assert exprs) = "assert" <+> pprintTidy tidy exprs - pprintTidy tidy (Call origin name sub) = pname <+> pargs <+> porigin - where - pname = pprintTidy tidy name - pargs = pprintTidy tidy sub - porigin = "// origin" <+> pprintTidy tidy origin - -instance Subable Statement where - syms (Let decl) = syms decl - syms (Assume e) = syms e - syms (Assert e) = syms e - syms (Call _ _ (Su sub)) = syms sub - - substa f (Let decl) = Let $ substa f decl - substa f (Assume e) = Assume $ substa f e - substa f (Assert e) = Assert $ substa f e - substa f (Call origin name (Su sub)) = Call origin name (Su $ substa f sub) - - substf f (Let decl) = Let $ substf f decl - substf f (Assume e) = Assume $ substf f e - substf f (Assert e) = Assert $ substf f e - substf f (Call origin name (Su sub)) = Call origin name (Su $ substf f sub) - - subst sub (Let decl) = Let $ subst sub decl - subst sub (Assume e) = Assume $ subst sub e - subst sub (Assert e) = Assert $ subst sub e - subst sub (Call origin name (Su sub')) = Call origin name (Su $ subst sub sub') - -instance Subable Decl where - syms (Decl sym _) = [sym] - - substa f (Decl sym sort) = Decl (substa f sym) sort - - substf f (Decl sym sort) = Decl (substf f sym) sort - - subst sub (Decl sym sort) = Decl (subst sub sym) sort + symIds = Map.fromList $ (\(sym, bid) -> (bid, sym)) <$> Map.toList bindings \ No newline at end of file diff --git a/src/Language/Fixpoint/CounterExample/Build.hs b/src/Language/Fixpoint/CounterExample/Build.hs new file mode 100644 index 000000000..da3aa3134 --- /dev/null +++ b/src/Language/Fixpoint/CounterExample/Build.hs @@ -0,0 +1,178 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +module Language.Fixpoint.CounterExample.Build + ( hornToProg + ) where + + +import Language.Fixpoint.Types +import Language.Fixpoint.CounterExample.Types +import Language.Fixpoint.Types.Config (Config, queryFile, save) +import Language.Fixpoint.Solver.Sanitize (symbolEnv) +import Language.Fixpoint.Misc (ensurePath) +import Language.Fixpoint.SortCheck (elaborate) + +import qualified Language.Fixpoint.Utils.Files as Ext +import qualified Text.PrettyPrint.HughesPJ as PP + +import Data.Maybe (fromMaybe) +import qualified Data.HashMap.Strict as Map + +import Control.Monad.State +import Control.Monad.Reader + +-- | The enviroment used to build a program. +data BuildEnv info = BuildEnv + { info :: !(SInfo info) + -- ^ The horn constraints from which we build the program. + , symbols :: !SymEnv + -- ^ Contains the sorts of symbols, which we need for declarations. + } + +-- | The monad used to convert a set of horn constraints to +-- the imperative function format. See Prog for the format. +type MonadBuild info m = (MonadReader (BuildEnv info) m, MonadState Prog m, MonadIO m) + +-- | Make an imperative program from horn clauses. This +-- can be used to generate a counter example. +hornToProg :: MonadIO m => Config -> SInfo info -> m Prog +hornToProg cfg si = do + -- Initial program is just an empty main. + let initial = Prog $ Map.singleton mainName (Func [] []) + let env = BuildEnv + { info = si + , symbols = symbolEnv cfg si + } + + -- Run monad that adds all horn clauses + prog <- evalStateT (runReaderT buildProg env) initial + + -- Save the program in a file + liftIO . when (save cfg) $ do + let file = queryFile Ext.Prog cfg + ensurePath file + writeFile file $ PP.render (pprint prog) + + -- Return the generated program + return prog + +-- | Build the entire program structure from the constraints +-- inside the monad +buildProg :: MonadBuild info m => m Prog +buildProg = do + constraints <- reader $ cm . info + mapM_ addHorn constraints + get + +-- | Given a horn clause, generates a body for a function. +-- +-- The body is generated from the lhs of the horn clause. +-- +-- This body is added to the function given by the kvar +-- on the rhs of the horn clause. If there was no kvar, +-- it is added to the main function. +addHorn :: MonadBuild info m => SimpC info -> m () +addHorn horn = do + -- Make the lhs of the clause into statements + lhs <- hornLhsToStmts horn + + -- The rhs has a special case depending on + -- if it is a kvar or not. + (name, decl, rhs) <- case crhs horn of + PKVar name sub -> do + decl <- getSig name + rhs <- substToStmts sub + return (name, decl, rhs) + e -> return (mainName, [], [Assert e]) + + -- Add the horn clause as a function body + let cid = fromMaybe (-1) $ sid horn + let body = Body cid $ lhs <> rhs + addFunc name $ Func decl [body] + +-- | Gets a signature of a KVar from its well foundedness constraint +getSig :: MonadBuild info m => Name -> m Signature +getSig kvar = do + -- Get the well foundedness constraint of the kvar + wfcs <- reader $ ws . info + let wfc = wfcs Map.! kvar + + -- Get the bind environment and bindings of the wfc + bindEnv <- reader $ bs . info + let ibinds = elemsIBindEnv . wenv $ wfc + + -- Lookup all Decl from the wfc using the ibinds + let asDecl (sym, sr, _) = Decl sym (sr_sort sr) + let decls = map (asDecl . flip lookupBindEnv bindEnv) ibinds + + -- Get the last Decl from the head of the wfc + let rhs = let (sym, sort, _) = wrft wfc in Decl sym sort + + -- Return the head + bindings as argument map + return $ rhs:decls + +-- | Defines some equalities between local variables +-- and the passed arguments given some substitution map. +substToStmts :: MonadBuild info m => Subst -> m [Statement] +substToStmts (Su sub) = do + let asEq (ksym, e) = Assume $ PAtom Eq (EVar ksym) e + return $ map asEq (Map.toList sub) + +-- | Converts the left hand side of the horn clause to a list +-- of assumptions (or calls given by a Name) +hornLhsToStmts :: MonadBuild info m => SimpC info -> m [Statement] +hornLhsToStmts horn = do + bindEnv <- reader $ bs . info + let lhs = clhs bindEnv horn + stmts <- forM lhs $ uncurry reftToStmts + return $ mconcat stmts + +-- | Map a refinement to a declaration and constraint pair +reftToStmts :: MonadBuild info m => Symbol -> SortedReft -> m [Statement] +reftToStmts _ RR { sr_sort = FFunc _ _ } = return [] +reftToStmts sym RR + { sr_sort = sort + , sr_reft = Reft (v, e) + } = do + -- Get correct sort for declaration + sort' <- elaborateSort sort + let decl = Let $ Decl sym sort' + + -- Get constraints from the expression. + let constraints = case predKs e of + [] -> [Assume e] + ks -> map (uncurry $ Call sym) ks + + -- Do proper substitution of v in the constraints + let sub = Su $ Map.singleton v (EVar sym) + return $ decl : subst sub constraints + +-- | Get the kvars from an expression. +-- +-- I think this should be the only way in which kvars appear? +-- Otherwise, this should be changed! +predKs :: Expr -> [(KVar, Subst)] +predKs (PAnd ps) = mconcat $ map predKs ps +predKs (PKVar k su) = [(k, su)] +predKs _ = [] + +-- | The sorts for the apply monomorphization only match if +-- we do this elaborate on the sort. Not sure why... +-- +-- This elaboration also happens inside the declaration +-- of the symbol environment, so that's where I got the idea. +elaborateSort :: MonadBuild info m => Sort -> m Sort +elaborateSort sym = do + symbols' <- reader symbols + return $ elaborate "elaborateSort" symbols' sym + +-- | Add a function to the function map with index by its name. +-- If an entry already exists, it will merge the function +-- bodies. +addFunc :: MonadBuild info m => Name -> Func -> m () +addFunc kvar func = do + let merge (Func _ b) (Func d b') = Func d (b <> b') + Prog prog <- get + put . Prog $ Map.insertWith merge kvar func prog \ No newline at end of file diff --git a/src/Language/Fixpoint/CounterExample/Check.hs b/src/Language/Fixpoint/CounterExample/Check.hs new file mode 100644 index 000000000..8be9c97c0 --- /dev/null +++ b/src/Language/Fixpoint/CounterExample/Check.hs @@ -0,0 +1,250 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +module Language.Fixpoint.CounterExample.Check + ( checkProg + ) where + +import Language.Fixpoint.Types +import Language.Fixpoint.CounterExample.Types +import Language.Fixpoint.Types.Config (Config, srcFile) +import Language.Fixpoint.Solver.Sanitize (symbolEnv) +import qualified Language.Fixpoint.Smt.Interface as SMT + +import Data.List (find, intercalate, foldl') +import Data.Bifunctor (first) +import Data.String (IsString(..)) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as Map +import qualified Data.Text as T + +import Control.Monad.State +import Control.Monad.Reader + +-- | Multiple counter examples indexed per constraint id. +type CounterExamples = HashMap SubcId CounterExample + +-- | Environment for the counter example generation. +data CheckEnv = CheckEnv + { program :: !Prog + -- ^ The program we are checking + , context :: !SMT.Context + -- ^ The SMT context we write the constraints from the program to. + , maxDepth :: !Int + -- ^ The maximum number of functions to traverse (to avoid state blow-up). + } + +-- | State tracked when checking a program. +data CheckState = CheckState +-- { depth :: Int +-- ^ Current depth (i.e. number of functions traversed) +-- } +-- TODO: Reimplement recursion limit. + +-- | The monad used to generate counter examples from a Prog. +type MonadCheck m = (MonadReader CheckEnv m, MonadState CheckState m, MonadIO m) + +-- | Check the given constraints to try and find a counter example. +checkProg :: MonadIO m => Config -> SInfo info -> Prog -> [SubcId] -> m CounterExamples +checkProg cfg si prog cids = withContext cfg si check + where + check ctx = runCheck cids CheckEnv + { program = prog + , context = ctx + , maxDepth = 100 -- TODO: Perhaps this should be a parameter for the user? + } + +-- | Run the checker with the SMT solver context. +withContext :: MonadIO m => Config -> SInfo info -> (SMT.Context -> m a) -> m a +withContext cfg si inner = do + let file = srcFile cfg <> ".prog" + let env = symbolEnv cfg si + ctx <- liftIO $ SMT.makeContextWithSEnv cfg file env + + !result <- inner ctx + + liftIO $ SMT.cleanupContext ctx + return result + +-- | Runs the program checker with the monad stack +-- unwrapped. +runCheck :: MonadIO m => [SubcId] -> CheckEnv -> m CounterExamples +runCheck cids env = rd . st $ checkAll cids + where + st = flip evalStateT CheckState --0 + rd = flip runReaderT env + +-- | Try to find a counter example for all the given constraints. +checkAll :: MonadCheck m => [SubcId] -> m CounterExamples +checkAll cids = do + cexs <- forM cids checkConstraint + return $ Map.fromList [(cid, cex) | (cid, Just cex) <- zip cids cexs] + +-- | Check a specific constraint id. This will only do actual +-- checks for constraints without a KVar on the rhs, as we cannot +-- really generate a counter example for these constraints. +checkConstraint :: MonadCheck m => SubcId -> m (Maybe CounterExample) +checkConstraint cid = do + Func _ bodies <- getFunc mainName + let cmp (Body bid _) = bid == cid + let scope = Scope mempty mempty + case find cmp bodies of + Just body -> runBody scope body smtCheck + Nothing -> return Nothing + +-- | A scope contains the current binders in place +-- as well as the path traversed to reach this scope. +data Scope = Scope + { path :: ![Symbol] + -- ^ The path traversed to reach the scope. + , binders :: !Subst + -- ^ The binders available in the current scope. + } + +-- | The runner is a computation path in the program. We use this +-- as an argument to pass around the remainder of a computation. +-- This way, we can pop paths in the SMT due to conditionals. +-- Allowing us to retain anything prior to that. +type Runner m = m (Maybe CounterExample) + +-- | Run a function. This essentially makes one running branch for +-- each body inside of the function. It will try each branch +-- sequentially, returning early if a counterexample was found. +runFunc :: MonadCheck m => Name -> Scope -> Runner m -> Runner m +runFunc name scope runner = do + Func _ bodies <- getFunc name + + -- Generate all execution paths (as runners). + let runner' body = smtScope $ runBody scope body runner + let paths = map runner' bodies + + -- Try paths, selecting the first that produces a counter example. + let select Nothing r = r + select cex _ = return cex + foldM select Nothing paths + +-- | Run the statements in the body. If there are no more statements +-- to run, this will execute the Runner that was passed as argument. +-- +-- The passed runner here is thus the rest of the computation, when +-- we "return" from this function. +runBody :: MonadCheck m => Scope -> Body -> Runner m -> Runner m +runBody _ (Body _ []) runner = runner +runBody scope (Body cid (stmt:ss)) runner = do + -- The remaining statements become a new Runner + let runner' scope' = runBody scope' (Body cid ss) runner + -- We pass this runner, such that it can be called at a later + -- point (possibly multiple times) if we were to encounter a call. + runStatement scope stmt runner' + +-- | Run the current statement. It might adjust the substitution map +-- for a portion of the statements, which is why the runner takes a +-- new substitution map as an argument. +runStatement :: MonadCheck m => Scope -> Statement -> (Scope -> Runner m) -> Runner m +runStatement scope stmt runner = do + -- Runner with the old subst map. + let runner' = runner scope + let stmt' = subst (binders scope) stmt + case stmt' of + Call origin name app -> do + let scope' = Scope (origin:path scope) app + runFunc name scope' runner' + Assume e -> smtAssume e >> runner' + Assert e -> smtAssert e >> runner' + Let decl -> smtDeclare scope decl >>= runner -- Run with modified scope. + +-- | Get a function from the program given its name. +getFunc :: MonadCheck m => Name -> m Func +getFunc name = do + Prog prog <- reader program + return $ prog Map.! name + +-- | Returns a version of a symbol with the scope encoded into its name. +scopedSym :: MonadCheck m => Scope -> Symbol -> m Symbol +scopedSym scope sym = do + let strs = symbolString <$> progPrefix : sym : path scope + let name = intercalate bindSep strs + return $ symbol name + +-- | Declare a new symbol, returning an updated substitution +-- given with this new symbol in it. The substitution map is +-- required to avoid duplicating variable names. +smtDeclare :: MonadCheck m => Scope -> Decl -> m Scope +smtDeclare scope (Decl sym sort) = do + ctx <- reader context + sym' <- scopedSym scope sym + liftIO $ SMT.smtDecl ctx sym' sort + let Su sub = binders scope + let binders' = Su $ Map.insert sym (EVar sym') sub + return scope { binders = binders' } + +-- | Assume the given expression. +smtAssert :: MonadCheck m => Expr -> m () +smtAssert = smtAssume . PNot + +-- | Assert the given expression. +smtAssume :: MonadCheck m => Expr -> m () +smtAssume e = do + ctx <- reader context + liftIO $ SMT.smtAssert ctx e + +-- | Run the checker within a scope (i.e. a push/pop pair). +smtScope :: MonadCheck m => m a -> m a +smtScope inner = do + ctx <- reader context + liftIO $ SMT.smtPush ctx + !result <- inner + liftIO $ SMT.smtPop ctx + return result + +-- | Check if there is a counterexample, returing one +-- if it is available. +smtCheck :: MonadCheck m => Runner m +smtCheck = do + ctx <- reader context + valid <- liftIO $ SMT.smtCheckUnsat ctx + + if valid then return Nothing else Just <$> smtModel + +-- | Returns a model, with as precondition that the SMT +-- solver had a satisfying assignment prior to this. +smtModel :: MonadCheck m => m CounterExample +smtModel = do + ctx <- reader context + Su sub <- liftIO $ SMT.smtGetModel ctx + + -- Filter just the variables for which we have a trace + let renames = first symbolTrace <$> Map.toList sub + let traces = [ (trace, sym, e) | (Just (sym, trace), e) <- renames ] + + -- Insert a mapping per unique layer in the counter example. + let new sym e = Su $ Map.singleton sym e + let insert cex (trace, sym, e) = Map.insertWith (<>) trace (new sym e) cex + let cex = foldl' insert mempty traces + return cex + +-- | We encode the trace of a symbol in its name. This way, +-- we do not lose it in the SMT solver. This function translates +-- the encoding back. +symbolTrace :: Symbol -> Maybe (Symbol, [Symbol]) +symbolTrace sym = case T.splitOn bindSep' sym' of + (prefix:name:trace) | prefix == progPrefix + -> Just (symbol name, symbol <$> trace) + _ -> Nothing + where + -- symbolSafeText did some weird prepend, + -- so here is just the escaped '@' symbol. + bindSep' = "$64$" + sym' = symbolText sym + +-- | The separator used to encode the stack trace (of binders) +-- inside of smt symbols. +bindSep :: IsString a => a +bindSep = "@" + +-- | Prefix used to show that this smt symbol was generated +-- during a run of the program. +progPrefix :: IsString a => a +progPrefix = "prog" diff --git a/src/Language/Fixpoint/CounterExample/Types.hs b/src/Language/Fixpoint/CounterExample/Types.hs new file mode 100644 index 000000000..8629d09fb --- /dev/null +++ b/src/Language/Fixpoint/CounterExample/Types.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Language.Fixpoint.CounterExample.Types + ( CounterExample + , Prog (..) + , Name + , Func (..) + , Body (..) + , Statement (..) + , Decl (..) + , Signature + + , mainName + ) where + +import Language.Fixpoint.Types +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as Map + +import Text.PrettyPrint.HughesPJ ((<+>), ($+$)) +import qualified Text.PrettyPrint.HughesPJ as PP + +-- | A counter example for a model. +type CounterExample = HashMap [Symbol] Subst + +-- | A program, containing multiple function definitions +-- mapped by their name. +newtype Prog = Prog (HashMap Name Func) + deriving Show + +-- | Identifier of a function. All KVars are translated +-- into functions, so it is just an alias. +type Name = KVar + +-- | A function symbol corresponding to a Name. +data Func = Func !Signature ![Body] + deriving Show + +-- | Signature of a function. +type Signature = [Decl] + +-- | A sequence of statements. +data Body = Body !SubcId ![Statement] + deriving Show + +-- | A statement used to introduce/check constraints, +-- together with its location information +data Statement + = Let !Decl + -- ^ Introduces a new variable. + | Assume !Expr + -- ^ Constraints a variable. + | Assert !Expr + -- ^ Checks whether a predicate follows given prior constraints. + | Call !Symbol !Name !Subst + -- ^ Call to function. The symbol is the origin, used to trace + -- callstacks. + deriving Show + +-- | A declaration of a Symbol with a Sort. +data Decl = Decl !Symbol !Sort + deriving Show + +-- | The main function, which any horn clause without a +-- KVar on the rhs will be added to. +mainName :: Name +mainName = KV "main" + +instance PPrint Prog where + pprintTidy tidy (Prog funcs) = PP.vcat + . PP.punctuate "\n" + . map (uncurry $ ppfunc tidy) + . Map.toList + $ funcs + +instance PPrint Func where + pprintTidy tidy = ppfunc tidy anonymous + where + anonymous = KV "_" + +ppfunc :: Tidy -> Name -> Func -> PP.Doc +ppfunc tidy name (Func sig bodies) = pdecl $+$ pbody $+$ PP.rbrace + where + pdecl = "fn" <+> pname <+> psig <+> PP.lbrace + pname = pprintTidy tidy name + psig = PP.parens + . PP.hsep + . PP.punctuate PP.comma + . map (pprintTidy tidy) + $ sig + pbody = vpunctuate "||" + . map (PP.nest 4 . pprintTidy tidy) + $ bodies + + vpunctuate _ [] = mempty + vpunctuate _ [d] = d + vpunctuate p (d:ds) = d $+$ p $+$ vpunctuate p ds + +instance PPrint Decl where + pprintTidy tidy (Decl sym sort) = (psym <> PP.colon) <+> psort + where + psym = pprintTidy tidy sym + psort = pprintTidy tidy sort + +instance PPrint Body where + pprintTidy tidy (Body cid stmts) = pcid $+$ pstmts + where + pcid = "// constraint id" <+> pprintTidy tidy cid + pstmts = PP.vcat + . map (pprintTidy tidy) + $ stmts + +instance PPrint Statement where + pprintTidy tidy (Let decl) = "let" <+> pprintTidy tidy decl + pprintTidy tidy (Assume exprs) = "assume" <+> pprintTidy tidy exprs + pprintTidy tidy (Assert exprs) = "assert" <+> pprintTidy tidy exprs + pprintTidy tidy (Call origin name sub) = pname <+> pargs <+> porigin + where + pname = pprintTidy tidy name + pargs = pprintTidy tidy sub + porigin = "// origin" <+> pprintTidy tidy origin + +instance Subable Statement where + syms (Let decl) = syms decl + syms (Assume e) = syms e + syms (Assert e) = syms e + syms (Call _ _ (Su sub)) = syms sub + + substa f (Let decl) = Let $ substa f decl + substa f (Assume e) = Assume $ substa f e + substa f (Assert e) = Assert $ substa f e + substa f (Call origin name (Su sub)) = Call origin name (Su $ substa f sub) + + substf f (Let decl) = Let $ substf f decl + substf f (Assume e) = Assume $ substf f e + substf f (Assert e) = Assert $ substf f e + substf f (Call origin name (Su sub)) = Call origin name (Su $ substf f sub) + + subst sub (Let decl) = Let $ subst sub decl + subst sub (Assume e) = Assume $ subst sub e + subst sub (Assert e) = Assert $ subst sub e + subst sub (Call origin name (Su sub')) = Call origin name (Su $ subst sub sub') + +instance Subable Decl where + syms (Decl sym _) = [sym] + + substa f (Decl sym sort) = Decl (substa f sym) sort + + substf f (Decl sym sort) = Decl (substf f sym) sort + + subst sub (Decl sym sort) = Decl (subst sub sym) sort From 705a2ce1f87a583d4c3e332f2cbd9ce19a076999 Mon Sep 17 00:00:00 2001 From: Robin Webbers Date: Thu, 2 Nov 2023 16:16:03 +0100 Subject: [PATCH 12/33] Improved readback from SMT. Added back recursion limit --- src/Language/Fixpoint/CounterExample.hs | 14 ++-- src/Language/Fixpoint/CounterExample/Build.hs | 5 +- src/Language/Fixpoint/CounterExample/Check.hs | 64 +++++++++++++------ src/Language/Fixpoint/CounterExample/Types.hs | 12 +++- 4 files changed, 65 insertions(+), 30 deletions(-) diff --git a/src/Language/Fixpoint/CounterExample.hs b/src/Language/Fixpoint/CounterExample.hs index 1fd51df78..c7d19d0b4 100644 --- a/src/Language/Fixpoint/CounterExample.hs +++ b/src/Language/Fixpoint/CounterExample.hs @@ -31,9 +31,14 @@ tryCounterExample cfg si res@Result { resStatus = Unsafe _ cids' , resCntExs = cexs' } | counterExample cfg = do - let cids = map fst cids' + -- Build program from constraints prog <- hornToProg cfg si + + -- Check the constraints, returning a substitution map + let cids = map fst cids' subs <- checkProg cfg si prog cids + + -- Map the symbols in this substitution to their respective bind id let cexs = cexBindIds si <$> subs return res { resCntExs = cexs <> cexs' } tryCounterExample _ _ res = return res @@ -46,15 +51,14 @@ tryCounterExample _ _ res = return res cexBindIds :: SInfo info -> CounterExample -> HashMap [BindId] (BindMap Expr) cexBindIds si cex = Map.mapKeys (map $ (Map.!) symIds) inner where - -- Inner mappings are changed, but the traces aren't yet + -- Here the inner mappings are changed, but the traces aren't yet inner :: HashMap [Symbol] (BindMap Expr) inner = (\(Su sub) -> Map.compose sub bindings) <$> cex -- Fetch a map of all the available bindings bindings :: HashMap BindId Symbol - bindings = fst' <$> beBinds (bs si) - fst' (sym, _, _) = sym + bindings = (\(bid, _, _) -> bid) <$> beBinds (bs si) -- Reverse the bindings mapping, so we can map our symbols to bind ids. symIds :: HashMap Symbol BindId - symIds = Map.fromList $ (\(sym, bid) -> (bid, sym)) <$> Map.toList bindings \ No newline at end of file + symIds = Map.fromList $ (\(sym, bid) -> (bid, sym)) <$> Map.toList bindings diff --git a/src/Language/Fixpoint/CounterExample/Build.hs b/src/Language/Fixpoint/CounterExample/Build.hs index da3aa3134..84a9b3dd3 100644 --- a/src/Language/Fixpoint/CounterExample/Build.hs +++ b/src/Language/Fixpoint/CounterExample/Build.hs @@ -131,6 +131,7 @@ hornLhsToStmts horn = do -- | Map a refinement to a declaration and constraint pair reftToStmts :: MonadBuild info m => Symbol -> SortedReft -> m [Statement] +reftToStmts _ RR { sr_sort = FAbs _ _ } = return [] reftToStmts _ RR { sr_sort = FFunc _ _ } = return [] reftToStmts sym RR { sr_sort = sort @@ -145,7 +146,7 @@ reftToStmts sym RR [] -> [Assume e] ks -> map (uncurry $ Call sym) ks - -- Do proper substitution of v in the constraints + -- Do substitution of self variable in the constraints let sub = Su $ Map.singleton v (EVar sym) return $ decl : subst sub constraints @@ -175,4 +176,4 @@ addFunc :: MonadBuild info m => Name -> Func -> m () addFunc kvar func = do let merge (Func _ b) (Func d b') = Func d (b <> b') Prog prog <- get - put . Prog $ Map.insertWith merge kvar func prog \ No newline at end of file + put . Prog $ Map.insertWith merge kvar func prog diff --git a/src/Language/Fixpoint/CounterExample/Check.hs b/src/Language/Fixpoint/CounterExample/Check.hs index 8be9c97c0..b33f8f63a 100644 --- a/src/Language/Fixpoint/CounterExample/Check.hs +++ b/src/Language/Fixpoint/CounterExample/Check.hs @@ -13,6 +13,7 @@ import Language.Fixpoint.Types.Config (Config, srcFile) import Language.Fixpoint.Solver.Sanitize (symbolEnv) import qualified Language.Fixpoint.Smt.Interface as SMT +import Data.Char (chr) import Data.List (find, intercalate, foldl') import Data.Bifunctor (first) import Data.String (IsString(..)) @@ -37,11 +38,10 @@ data CheckEnv = CheckEnv } -- | State tracked when checking a program. -data CheckState = CheckState --- { depth :: Int --- ^ Current depth (i.e. number of functions traversed) --- } --- TODO: Reimplement recursion limit. +newtype CheckState = CheckState + { depth :: Int + -- ^ Current depth (i.e. number of functions traversed) + } -- | The monad used to generate counter examples from a Prog. type MonadCheck m = (MonadReader CheckEnv m, MonadState CheckState m, MonadIO m) @@ -73,7 +73,7 @@ withContext cfg si inner = do runCheck :: MonadIO m => [SubcId] -> CheckEnv -> m CounterExamples runCheck cids env = rd . st $ checkAll cids where - st = flip evalStateT CheckState --0 + st = flip evalStateT $ CheckState 0 rd = flip runReaderT env -- | Try to find a counter example for all the given constraints. @@ -102,6 +102,7 @@ data Scope = Scope , binders :: !Subst -- ^ The binders available in the current scope. } + deriving (Eq, Ord, Show) -- | The runner is a computation path in the program. We use this -- as an argument to pass around the remainder of a computation. @@ -114,16 +115,29 @@ type Runner m = m (Maybe CounterExample) -- sequentially, returning early if a counterexample was found. runFunc :: MonadCheck m => Name -> Scope -> Runner m -> Runner m runFunc name scope runner = do + -- Lookup function bodies Func _ bodies <- getFunc name -- Generate all execution paths (as runners). - let runner' body = smtScope $ runBody scope body runner + let runner' body = runBody scope body runner let paths = map runner' bodies -- Try paths, selecting the first that produces a counter example. let select Nothing r = r select cex _ = return cex - foldM select Nothing paths + + -- Check if we've reached the recursion limit. + -- TODO: Perhaps we should make the recursion limit per kvar? + depth' <- gets depth + put $ CheckState $ depth' + 1 + maxDepth' <- reader maxDepth + let recursionLimit = depth' >= maxDepth' + + result <- if recursionLimit then runner else foldM select Nothing paths + + -- Decrement depth after exploring this function + modify $ \s -> s { depth = depth s - 1} + return result -- | Run the statements in the body. If there are no more statements -- to run, this will execute the Runner that was passed as argument. @@ -131,13 +145,15 @@ runFunc name scope runner = do -- The passed runner here is thus the rest of the computation, when -- we "return" from this function. runBody :: MonadCheck m => Scope -> Body -> Runner m -> Runner m -runBody _ (Body _ []) runner = runner -runBody scope (Body cid (stmt:ss)) runner = do - -- The remaining statements become a new Runner - let runner' scope' = runBody scope' (Body cid ss) runner - -- We pass this runner, such that it can be called at a later - -- point (possibly multiple times) if we were to encounter a call. - runStatement scope stmt runner' +runBody scope' body runner = smtScope $ go scope' body + where + go _ (Body _ []) = runner + go scope (Body cid (stmt:ss)) = do + -- The remaining statements become a new Runner + let runner' = flip go (Body cid ss) + -- We pass this runner, such that it can be called at a later + -- point (possibly multiple times) if we were to encounter a call. + runStatement scope stmt runner' -- | Run the current statement. It might adjust the substitution map -- for a portion of the statements, which is why the runner takes a @@ -172,6 +188,8 @@ scopedSym scope sym = do -- given with this new symbol in it. The substitution map is -- required to avoid duplicating variable names. smtDeclare :: MonadCheck m => Scope -> Decl -> m Scope +smtDeclare scope@Scope { binders = Su binds } (Decl sym _) + | Map.member sym binds = return scope smtDeclare scope (Decl sym sort) = do ctx <- reader context sym' <- scopedSym scope sym @@ -229,15 +247,21 @@ smtModel = do -- we do not lose it in the SMT solver. This function translates -- the encoding back. symbolTrace :: Symbol -> Maybe (Symbol, [Symbol]) -symbolTrace sym = case T.splitOn bindSep' sym' of +symbolTrace sym = case T.splitOn bindSep sym' of (prefix:name:trace) | prefix == progPrefix -> Just (symbol name, symbol <$> trace) _ -> Nothing where - -- symbolSafeText did some weird prepend, - -- so here is just the escaped '@' symbol. - bindSep' = "$64$" - sym' = symbolText sym + sym' = escapeSmt . symbolText $ sym + +escapeSmt :: T.Text -> T.Text +escapeSmt = go False . T.split (=='$') + where + go _ [] = "" + go escape (t:ts) = txt t <> go (not escape) ts + where + txt | escape = T.singleton . chr . read . T.unpack + | otherwise = id -- | The separator used to encode the stack trace (of binders) -- inside of smt symbols. diff --git a/src/Language/Fixpoint/CounterExample/Types.hs b/src/Language/Fixpoint/CounterExample/Types.hs index 8629d09fb..0d1081b21 100644 --- a/src/Language/Fixpoint/CounterExample/Types.hs +++ b/src/Language/Fixpoint/CounterExample/Types.hs @@ -11,6 +11,7 @@ module Language.Fixpoint.CounterExample.Types , Signature , mainName + , dbg -- TODO: Remove this on code clean-up! ) where import Language.Fixpoint.Types @@ -20,6 +21,11 @@ import qualified Data.HashMap.Strict as Map import Text.PrettyPrint.HughesPJ ((<+>), ($+$)) import qualified Text.PrettyPrint.HughesPJ as PP +import Control.Monad.IO.Class + +dbg :: (MonadIO m, PPrint a) => a -> m () +dbg = liftIO . print . pprint + -- | A counter example for a model. type CounterExample = HashMap [Symbol] Subst @@ -126,17 +132,17 @@ instance Subable Statement where syms (Assert e) = syms e syms (Call _ _ (Su sub)) = syms sub - substa f (Let decl) = Let $ substa f decl + substa _ (Let decl) = Let decl substa f (Assume e) = Assume $ substa f e substa f (Assert e) = Assert $ substa f e substa f (Call origin name (Su sub)) = Call origin name (Su $ substa f sub) - substf f (Let decl) = Let $ substf f decl + substf _ (Let decl) = Let decl substf f (Assume e) = Assume $ substf f e substf f (Assert e) = Assert $ substf f e substf f (Call origin name (Su sub)) = Call origin name (Su $ substf f sub) - subst sub (Let decl) = Let $ subst sub decl + subst _ (Let decl) = Let decl subst sub (Assume e) = Assume $ subst sub e subst sub (Assert e) = Assert $ subst sub e subst sub (Call origin name (Su sub')) = Call origin name (Su $ subst sub sub') From 8702a1ca6ceeac13cf304f4d17d2b6584dc24bb8 Mon Sep 17 00:00:00 2001 From: Robin Webbers Date: Tue, 14 Nov 2023 12:04:32 +0100 Subject: [PATCH 13/33] Fixed issues with duplicate naming and SMT model parsing --- liquid-fixpoint.cabal | 1 + src/Language/Fixpoint/CounterExample/Build.hs | 20 +++- src/Language/Fixpoint/CounterExample/Check.hs | 100 +++++++++++------- src/Language/Fixpoint/Smt/Interface.hs | 32 +++--- tests/neg/duplicate-names.fq | 24 +++++ tests/neg/duplicate-names2.fq | 29 +++++ tests/neg/parse-types.fq | 17 +++ 7 files changed, 164 insertions(+), 59 deletions(-) create mode 100644 tests/neg/duplicate-names.fq create mode 100644 tests/neg/duplicate-names2.fq create mode 100644 tests/neg/parse-types.fq diff --git a/liquid-fixpoint.cabal b/liquid-fixpoint.cabal index 44f748d41..faa513f72 100644 --- a/liquid-fixpoint.cabal +++ b/liquid-fixpoint.cabal @@ -161,6 +161,7 @@ library , stm , store , vector < 0.13 + , scientific >= 0.3.7 , syb , text , transformers diff --git a/src/Language/Fixpoint/CounterExample/Build.hs b/src/Language/Fixpoint/CounterExample/Build.hs index 84a9b3dd3..a13526ba6 100644 --- a/src/Language/Fixpoint/CounterExample/Build.hs +++ b/src/Language/Fixpoint/CounterExample/Build.hs @@ -19,6 +19,7 @@ import qualified Text.PrettyPrint.HughesPJ as PP import Data.Maybe (fromMaybe) import qualified Data.HashMap.Strict as Map +import Data.List (find) import Control.Monad.State import Control.Monad.Reader @@ -126,9 +127,26 @@ hornLhsToStmts :: MonadBuild info m => SimpC info -> m [Statement] hornLhsToStmts horn = do bindEnv <- reader $ bs . info let lhs = clhs bindEnv horn - stmts <- forM lhs $ uncurry reftToStmts + lhs' <- filterLits . filterDuplicates $ lhs + stmts <- forM lhs' $ uncurry reftToStmts return $ mconcat stmts +filterDuplicates :: [(Symbol, SortedReft)] -> [(Symbol, SortedReft)] +filterDuplicates env = foldr filter' [] env + where + filter' sym acc = case fst sym `member` map fst acc of + Nothing -> sym:acc + Just _ -> acc + + member e = find (e==) + +filterLits :: MonadBuild info m => [(Symbol, SortedReft)] -> m [(Symbol, SortedReft)] +filterLits env = do + con <- reader $ gLits . info + dis <- reader $ dLits . info + let isLit (sym, _) = memberSEnv sym con || memberSEnv sym dis + return $ filter (not . isLit) env + -- | Map a refinement to a declaration and constraint pair reftToStmts :: MonadBuild info m => Symbol -> SortedReft -> m [Statement] reftToStmts _ RR { sr_sort = FAbs _ _ } = return [] diff --git a/src/Language/Fixpoint/CounterExample/Check.hs b/src/Language/Fixpoint/CounterExample/Check.hs index b33f8f63a..be1e69992 100644 --- a/src/Language/Fixpoint/CounterExample/Check.hs +++ b/src/Language/Fixpoint/CounterExample/Check.hs @@ -13,6 +13,7 @@ import Language.Fixpoint.Types.Config (Config, srcFile) import Language.Fixpoint.Solver.Sanitize (symbolEnv) import qualified Language.Fixpoint.Smt.Interface as SMT +import Data.Maybe (fromJust) import Data.Char (chr) import Data.List (find, intercalate, foldl') import Data.Bifunctor (first) @@ -53,7 +54,7 @@ checkProg cfg si prog cids = withContext cfg si check check ctx = runCheck cids CheckEnv { program = prog , context = ctx - , maxDepth = 100 -- TODO: Perhaps this should be a parameter for the user? + , maxDepth = 15 -- TODO: Perhaps this should be a parameter for the user? } -- | Run the checker with the SMT solver context. @@ -87,7 +88,7 @@ checkAll cids = do -- really generate a counter example for these constraints. checkConstraint :: MonadCheck m => SubcId -> m (Maybe CounterExample) checkConstraint cid = do - Func _ bodies <- getFunc mainName + Func _ bodies <- fromJust <$> getFunc mainName let cmp (Body bid _) = bid == cid let scope = Scope mempty mempty case find cmp bodies of @@ -97,7 +98,7 @@ checkConstraint cid = do -- | A scope contains the current binders in place -- as well as the path traversed to reach this scope. data Scope = Scope - { path :: ![Symbol] + { path :: ![(KVar, Symbol)] -- ^ The path traversed to reach the scope. , binders :: !Subst -- ^ The binders available in the current scope. @@ -116,28 +117,31 @@ type Runner m = m (Maybe CounterExample) runFunc :: MonadCheck m => Name -> Scope -> Runner m -> Runner m runFunc name scope runner = do -- Lookup function bodies - Func _ bodies <- getFunc name - - -- Generate all execution paths (as runners). - let runner' body = runBody scope body runner - let paths = map runner' bodies - - -- Try paths, selecting the first that produces a counter example. - let select Nothing r = r - select cex _ = return cex - - -- Check if we've reached the recursion limit. - -- TODO: Perhaps we should make the recursion limit per kvar? - depth' <- gets depth - put $ CheckState $ depth' + 1 - maxDepth' <- reader maxDepth - let recursionLimit = depth' >= maxDepth' - - result <- if recursionLimit then runner else foldM select Nothing paths - - -- Decrement depth after exploring this function - modify $ \s -> s { depth = depth s - 1} - return result + func <- getFunc name + case func of + -- Unconstrained function body. + Nothing -> runner + Just (Func _ bodies) -> do + -- Generate all execution paths (as runners). + let runner' body = runBody scope body runner + let paths = map runner' bodies + + -- Try paths, selecting the first that produces a counter example. + let select Nothing r = r + select cex _ = return cex + + -- Check if we've reached the recursion limit. + -- TODO: Perhaps we should make the recursion limit per kvar? + depth' <- gets depth + put $ CheckState $ depth' + 1 + maxDepth' <- reader maxDepth + let recursionLimit = depth' >= maxDepth' + + result <- if recursionLimit then runner else foldM select Nothing paths + + -- Decrement depth after exploring this function + modify $ \s -> s { depth = depth s - 1} + return result -- | Run the statements in the body. If there are no more statements -- to run, this will execute the Runner that was passed as argument. @@ -165,24 +169,19 @@ runStatement scope stmt runner = do let stmt' = subst (binders scope) stmt case stmt' of Call origin name app -> do - let scope' = Scope (origin:path scope) app + let scope' = Scope ((name, origin):path scope) app runFunc name scope' runner' Assume e -> smtAssume e >> runner' Assert e -> smtAssert e >> runner' - Let decl -> smtDeclare scope decl >>= runner -- Run with modified scope. + Let decl -> do + scope' <- smtDeclare scope decl + runner scope' -- | Get a function from the program given its name. -getFunc :: MonadCheck m => Name -> m Func +getFunc :: MonadCheck m => Name -> m (Maybe Func) getFunc name = do Prog prog <- reader program - return $ prog Map.! name - --- | Returns a version of a symbol with the scope encoded into its name. -scopedSym :: MonadCheck m => Scope -> Symbol -> m Symbol -scopedSym scope sym = do - let strs = symbolString <$> progPrefix : sym : path scope - let name = intercalate bindSep strs - return $ symbol name + return $ Map.lookup name prog -- | Declare a new symbol, returning an updated substitution -- given with this new symbol in it. The substitution map is @@ -192,7 +191,7 @@ smtDeclare scope@Scope { binders = Su binds } (Decl sym _) | Map.member sym binds = return scope smtDeclare scope (Decl sym sort) = do ctx <- reader context - sym' <- scopedSym scope sym + let sym' = scopeSym scope sym liftIO $ SMT.smtDecl ctx sym' sort let Su sub = binders scope let binders' = Su $ Map.insert sym (EVar sym') sub @@ -234,7 +233,7 @@ smtModel = do Su sub <- liftIO $ SMT.smtGetModel ctx -- Filter just the variables for which we have a trace - let renames = first symbolTrace <$> Map.toList sub + let renames = first unscopeSym <$> Map.toList sub let traces = [ (trace, sym, e) | (Just (sym, trace), e) <- renames ] -- Insert a mapping per unique layer in the counter example. @@ -243,15 +242,31 @@ smtModel = do let cex = foldl' insert mempty traces return cex +-- | Returns a version of a symbol with the scope encoded into its name. +scopeSym :: Scope -> Symbol -> Symbol +scopeSym scope sym = symbol name + where + name = intercalate bindSep strs + strs = symbolString <$> progPrefix : sym : paths + paths = uncurry joinCall <$> path scope + joinCall (KV callee) caller = symbol . mconcat $ symbolString <$> [callee, callSep, caller] + -- | We encode the trace of a symbol in its name. This way, -- we do not lose it in the SMT solver. This function translates -- the encoding back. -symbolTrace :: Symbol -> Maybe (Symbol, [Symbol]) -symbolTrace sym = case T.splitOn bindSep sym' of +unscopeSym :: Symbol -> Maybe (Symbol, [Symbol]) +unscopeSym sym = case T.splitOn bindSep sym' of (prefix:name:trace) | prefix == progPrefix - -> Just (symbol name, symbol <$> trace) + -> Just (symbol name, splitCall <$> trace) _ -> Nothing where + splitCall c = symbol . split $ T.splitOn callSep c + + -- We just ignore the callee for now. It was initially here to avoid + -- duplicates in the SMT solver. + split [_callee, caller] = caller + split _ = error "Scoped name should always be in this shape" + sym' = escapeSmt . symbolText $ sym escapeSmt :: T.Text -> T.Text @@ -268,6 +283,9 @@ escapeSmt = go False . T.split (=='$') bindSep :: IsString a => a bindSep = "@" +callSep :: IsString a => a +callSep = "~~" + -- | Prefix used to show that this smt symbol was generated -- during a run of the program. progPrefix :: IsString a => a diff --git a/src/Language/Fixpoint/Smt/Interface.hs b/src/Language/Fixpoint/Smt/Interface.hs index aeb7b885e..c988a5e55 100644 --- a/src/Language/Fixpoint/Smt/Interface.hs +++ b/src/Language/Fixpoint/Smt/Interface.hs @@ -99,6 +99,7 @@ import System.Console.CmdArgs.Verbosity import System.FilePath import System.IO import qualified Data.Attoparsec.Text as A +import qualified Data.Scientific as S -- import qualified Data.HashMap.Strict as M import Data.Attoparsec.Internal.Types (Parser) import Text.PrettyPrint.HughesPJ (text) @@ -210,7 +211,7 @@ smtGetModel Ctx {..} = do bytestring <- liftIO $ SMTLIB.Backends.command ctxSolver cmd let text = bs2txt bytestring case A.parseOnly modelP text of - Left err -> Misc.errorstar $ "Parse error on get-value: " ++ err ++ "\n\n" ++ show text + Left err -> Misc.errorstar $ "Parse error on get-model: " ++ err ++ "\n\n" ++ show text Right sol -> return sol smtSetMbqi :: Context -> IO () @@ -234,7 +235,7 @@ defP = parenP $ do sortP :: SmtParser () sortP = do -- A type is just an S-Expression, we can reuse the parser - let tyP = exprP >> return () + let tyP = void exprP _ <- parenP $ A.many' tyP tyP @@ -258,19 +259,15 @@ appP = do return $ foldl' EApp e es litP :: SmtParser Expr -litP = integerP <|> realP <|> boolP <|> bitvecP <|> (EVar <$> symbolP) - --- TODO: Parse minus as just a negative integer -integerP :: SmtParser Expr -integerP = do - int <- A.signed A.decimal - return $ ECon (I int) +litP = scientificP <|> boolP <|> bitvecP <|> (EVar <$> symbolP) --- TODO: Parse minus as just a negative real -realP :: SmtParser Expr -realP = do - double <- A.signed A.double - return $ ECon (R double) +scientificP :: SmtParser Expr +scientificP = do + val <- A.scientific + let con = case S.floatingOrInteger val of + Left double -> R double + Right int -> I int + return $ ECon con boolP :: SmtParser Expr boolP = trueP <|> falseP @@ -280,15 +277,16 @@ boolP = trueP <|> falseP bitvecP :: SmtParser Expr bitvecP = do + _ <- A.char '#' (bv, _) <- A.match (hexP <|> binP) return $ ECon (L bv $ sizedBitVecSort "x") where hexP = do - _ <- A.string "#x" - _ <- A.hexadecimal :: SmtParser Int + _ <- A.char 'x' + _ <- A.hexadecimal :: SmtParser Integer return () binP = do - _ <- A.string "#b" + _ <- A.char 'b' _ <- A.many1' (A.char '0' <|> A.char '1') return () diff --git a/tests/neg/duplicate-names.fq b/tests/neg/duplicate-names.fq new file mode 100644 index 000000000..91639c137 --- /dev/null +++ b/tests/neg/duplicate-names.fq @@ -0,0 +1,24 @@ +distinct True : (bool) +distinct False : (bool) + +bind 2 True : {v: bool | v} +bind 3 False : {v: bool | ~v} + +bind 0 dup : {v: int | $k} +bind 1 dup : {v: int | $k} + +constraint: + env [] + lhs {v : int | v = 0} + rhs {v : int | $k} + id 0 tag [] + +constraint: + env [0; 1; 2; 3] + lhs {v : int | v = dup} + rhs {v : int | v > 0} + id 1 tag [] + +wf: + env [] + reft {v : int | $k} diff --git a/tests/neg/duplicate-names2.fq b/tests/neg/duplicate-names2.fq new file mode 100644 index 000000000..8de86ce9a --- /dev/null +++ b/tests/neg/duplicate-names2.fq @@ -0,0 +1,29 @@ +bind 0 duplicator : {v: int | $k0 && $k1} + +bind 1 duplicated : {v: int | v == 0} + +constraint: + env [1] + lhs {v : int | v == duplicated} + rhs {v : int | $k0} + id 0 tag [] + +constraint: + env [1] + lhs {v : int | v == duplicated} + rhs {v : int | $k1} + id 1 tag [] + +constraint: + env [0] + lhs {v : int | v = duplicator} + rhs {v : int | v > 0} + id 2 tag [] + +wf: + env [] + reft {v : int | $k0} + +wf: + env [] + reft {v : int | $k1} diff --git a/tests/neg/parse-types.fq b/tests/neg/parse-types.fq new file mode 100644 index 000000000..8a7dcd63f --- /dev/null +++ b/tests/neg/parse-types.fq @@ -0,0 +1,17 @@ +bind 0 x : {v: real | $k} + +constraint: + env [] + lhs {v : real | v = 0.0} + rhs {v : real | $k} + id 0 tag [] + +constraint: + env [0] + lhs {v : real | v = x} + rhs {v : real | v > 0.0} + id 1 tag [] + +wf: + env [] + reft {v : real | $k} From 82ca4271e981fe60772e7b2c2d6d159bb79c1d03 Mon Sep 17 00:00:00 2001 From: Robin Webbers Date: Thu, 15 Feb 2024 15:33:11 +0100 Subject: [PATCH 14/33] Counterexamples now include Result generic, symbol and type. Moved counterexample files with incorrect spelling --- liquid-fixpoint.cabal | 8 +- src/Language/Fixpoint/CounterExample.hs | 64 -------------- src/Language/Fixpoint/Counterexample.hs | 87 +++++++++++++++++++ .../Build.hs | 4 +- .../Check.hs | 23 ++--- .../Types.hs | 13 ++- src/Language/Fixpoint/Solver.hs | 2 +- src/Language/Fixpoint/Types/Constraints.hs | 7 +- src/Language/Fixpoint/Types/Environments.hs | 5 ++ 9 files changed, 125 insertions(+), 88 deletions(-) delete mode 100644 src/Language/Fixpoint/CounterExample.hs create mode 100644 src/Language/Fixpoint/Counterexample.hs rename src/Language/Fixpoint/{CounterExample => Counterexample}/Build.hs (98%) rename src/Language/Fixpoint/{CounterExample => Counterexample}/Check.hs (93%) rename src/Language/Fixpoint/{CounterExample => Counterexample}/Types.hs (90%) diff --git a/liquid-fixpoint.cabal b/liquid-fixpoint.cabal index faa513f72..8f8d09a35 100644 --- a/liquid-fixpoint.cabal +++ b/liquid-fixpoint.cabal @@ -55,10 +55,10 @@ library import: warnings exposed-modules: Data.ShareMap Language.Fixpoint.Conditional.Z3 - Language.Fixpoint.CounterExample - Language.Fixpoint.CounterExample.Build - Language.Fixpoint.CounterExample.Check - Language.Fixpoint.CounterExample.Types + Language.Fixpoint.Counterexample + Language.Fixpoint.Counterexample.Build + Language.Fixpoint.Counterexample.Check + Language.Fixpoint.Counterexample.Types Language.Fixpoint.Defunctionalize Language.Fixpoint.Graph Language.Fixpoint.Graph.Deps diff --git a/src/Language/Fixpoint/CounterExample.hs b/src/Language/Fixpoint/CounterExample.hs deleted file mode 100644 index c7d19d0b4..000000000 --- a/src/Language/Fixpoint/CounterExample.hs +++ /dev/null @@ -1,64 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} - -module Language.Fixpoint.CounterExample - ( tryCounterExample - ) where - -import Language.Fixpoint.Types -import Language.Fixpoint.CounterExample.Types -import Language.Fixpoint.CounterExample.Build -import Language.Fixpoint.CounterExample.Check -import Language.Fixpoint.Types.Config (Config, counterExample) - -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as Map - -import Control.Monad.IO.Class - --- TODO: Remove variables from the counter example that got mapped to --- the "wrong" type in smt format (e.g. to an int while not being one). - --- | Try to get a counter example for the given unsafe clauses (if any). -tryCounterExample - :: (MonadIO m, Fixpoint info) - => Config - -> SInfo info - -> Result (SubcId, info) - -> m (Result (SubcId, info)) -tryCounterExample cfg si res@Result - { resStatus = Unsafe _ cids' - , resCntExs = cexs' - } | counterExample cfg = do - -- Build program from constraints - prog <- hornToProg cfg si - - -- Check the constraints, returning a substitution map - let cids = map fst cids' - subs <- checkProg cfg si prog cids - - -- Map the symbols in this substitution to their respective bind id - let cexs = cexBindIds si <$> subs - return res { resCntExs = cexs <> cexs' } -tryCounterExample _ _ res = return res - --- | Map a counter example to use the BindId instead of the --- variable name as the key. --- --- In other words, we go from a mapping of Symbol |-> Expr to --- BindId |-> Expr -cexBindIds :: SInfo info -> CounterExample -> HashMap [BindId] (BindMap Expr) -cexBindIds si cex = Map.mapKeys (map $ (Map.!) symIds) inner - where - -- Here the inner mappings are changed, but the traces aren't yet - inner :: HashMap [Symbol] (BindMap Expr) - inner = (\(Su sub) -> Map.compose sub bindings) <$> cex - - -- Fetch a map of all the available bindings - bindings :: HashMap BindId Symbol - bindings = (\(bid, _, _) -> bid) <$> beBinds (bs si) - - -- Reverse the bindings mapping, so we can map our symbols to bind ids. - symIds :: HashMap Symbol BindId - symIds = Map.fromList $ (\(sym, bid) -> (bid, sym)) <$> Map.toList bindings diff --git a/src/Language/Fixpoint/Counterexample.hs b/src/Language/Fixpoint/Counterexample.hs new file mode 100644 index 000000000..1d9580ac4 --- /dev/null +++ b/src/Language/Fixpoint/Counterexample.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Language.Fixpoint.Counterexample + ( tryCounterExample + ) where + +import Language.Fixpoint.Types +import Language.Fixpoint.Counterexample.Types +import Language.Fixpoint.Counterexample.Build +import Language.Fixpoint.Counterexample.Check +import Language.Fixpoint.Types.Config (Config, counterExample) + +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as Map + +import Control.Monad.IO.Class + +-- TODO: Remove variables from the counter example that got mapped to +-- the "wrong" type in smt format (e.g. to an int while not being one). + +-- | Try to get a counter example for the given unsafe clauses (if any). +tryCounterExample + :: (MonadIO m, Fixpoint info) + => Config + -> SInfo info + -> Result (SubcId, info) + -> m (Result (SubcId, info)) +tryCounterExample cfg si res@Result + { resStatus = Unsafe _ cids' + , resCounterexamples = cexs' + } | counterExample cfg = do + -- Build program from constraints + prog <- hornToProg cfg si + + -- Check the constraints, returning a substitution map + let cids = map fst cids' + subs <- checkProg cfg si prog cids + + -- Map the symbols in this substitution to their respective bind id + let cexs = toFullCex si <$> subs + return res { resCounterexamples = cexs <> cexs' } +tryCounterExample _ _ res = return res + +-- | Map a counter example to use the BindId instead of the +-- variable name as the key. +-- +-- In other words, we go from a mapping of Symbol |-> Expr to +-- BindId |-> Expr +toFullCex :: forall info. SInfo info -> SMTCounterexample -> Counterexample (SubcId, info) +toFullCex si smtcex = extendSubst <$> pathcex + where + -- Get the bind environment + benv = bs si + + -- Remove all of the map except the bind id. + bindings :: BindMap Symbol + bindings = (\(bid, _, _) -> bid) <$> beBinds benv + + -- Reverses the direction of a hashmap + reverseMap = Map.fromList . fmap (\(a, b) -> (b, a)) . Map.toList + + -- Reverse the bindings mapping, so we can map our symbols to bind ids. + symIds :: HashMap Symbol BindId + symIds = reverseMap bindings + + -- A counterexample where we transformed the path to be [BindId]. + -- I.e. this is a partial translation from SMT Counterexample to a full one. + pathcex :: HashMap [BindId] Subst + pathcex = Map.mapKeys (map $ (Map.!) symIds) smtcex + + -- Maps an smt subst to a full counterexample environment (i.e. the + -- concrete instances for a given scope). + extendSubst :: Subst -> CexEnv (SubcId, info) + extendSubst (Su sub) = benv { beBinds = binds } + where + binds = Map.mapMaybe trans $ beBinds benv + + trans (sym, sreft, info) = extend <$> Map.lookup sym sub + where + -- We fake a SubCId here. It really shouldn't be here, but it is an + -- artifact of this being embedded in the generic of `Result` + -- instead of always being there! + extend ex = (sym, sreft, (ex, (0, info))) + diff --git a/src/Language/Fixpoint/CounterExample/Build.hs b/src/Language/Fixpoint/Counterexample/Build.hs similarity index 98% rename from src/Language/Fixpoint/CounterExample/Build.hs rename to src/Language/Fixpoint/Counterexample/Build.hs index a13526ba6..db21412da 100644 --- a/src/Language/Fixpoint/CounterExample/Build.hs +++ b/src/Language/Fixpoint/Counterexample/Build.hs @@ -2,13 +2,13 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -module Language.Fixpoint.CounterExample.Build +module Language.Fixpoint.Counterexample.Build ( hornToProg ) where import Language.Fixpoint.Types -import Language.Fixpoint.CounterExample.Types +import Language.Fixpoint.Counterexample.Types import Language.Fixpoint.Types.Config (Config, queryFile, save) import Language.Fixpoint.Solver.Sanitize (symbolEnv) import Language.Fixpoint.Misc (ensurePath) diff --git a/src/Language/Fixpoint/CounterExample/Check.hs b/src/Language/Fixpoint/Counterexample/Check.hs similarity index 93% rename from src/Language/Fixpoint/CounterExample/Check.hs rename to src/Language/Fixpoint/Counterexample/Check.hs index be1e69992..e26de973f 100644 --- a/src/Language/Fixpoint/CounterExample/Check.hs +++ b/src/Language/Fixpoint/Counterexample/Check.hs @@ -3,12 +3,12 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -module Language.Fixpoint.CounterExample.Check +module Language.Fixpoint.Counterexample.Check ( checkProg ) where import Language.Fixpoint.Types -import Language.Fixpoint.CounterExample.Types +import Language.Fixpoint.Counterexample.Types import Language.Fixpoint.Types.Config (Config, srcFile) import Language.Fixpoint.Solver.Sanitize (symbolEnv) import qualified Language.Fixpoint.Smt.Interface as SMT @@ -26,7 +26,7 @@ import Control.Monad.State import Control.Monad.Reader -- | Multiple counter examples indexed per constraint id. -type CounterExamples = HashMap SubcId CounterExample +type SMTCounterexamples = HashMap SubcId SMTCounterexample -- | Environment for the counter example generation. data CheckEnv = CheckEnv @@ -48,13 +48,13 @@ newtype CheckState = CheckState type MonadCheck m = (MonadReader CheckEnv m, MonadState CheckState m, MonadIO m) -- | Check the given constraints to try and find a counter example. -checkProg :: MonadIO m => Config -> SInfo info -> Prog -> [SubcId] -> m CounterExamples +checkProg :: MonadIO m => Config -> SInfo info -> Prog -> [SubcId] -> m SMTCounterexamples checkProg cfg si prog cids = withContext cfg si check where check ctx = runCheck cids CheckEnv { program = prog , context = ctx - , maxDepth = 15 -- TODO: Perhaps this should be a parameter for the user? + , maxDepth = 7 -- TODO: Perhaps this should be a parameter for the user? } -- | Run the checker with the SMT solver context. @@ -71,14 +71,14 @@ withContext cfg si inner = do -- | Runs the program checker with the monad stack -- unwrapped. -runCheck :: MonadIO m => [SubcId] -> CheckEnv -> m CounterExamples +runCheck :: MonadIO m => [SubcId] -> CheckEnv -> m SMTCounterexamples runCheck cids env = rd . st $ checkAll cids where st = flip evalStateT $ CheckState 0 rd = flip runReaderT env -- | Try to find a counter example for all the given constraints. -checkAll :: MonadCheck m => [SubcId] -> m CounterExamples +checkAll :: MonadCheck m => [SubcId] -> m SMTCounterexamples checkAll cids = do cexs <- forM cids checkConstraint return $ Map.fromList [(cid, cex) | (cid, Just cex) <- zip cids cexs] @@ -86,7 +86,7 @@ checkAll cids = do -- | Check a specific constraint id. This will only do actual -- checks for constraints without a KVar on the rhs, as we cannot -- really generate a counter example for these constraints. -checkConstraint :: MonadCheck m => SubcId -> m (Maybe CounterExample) +checkConstraint :: MonadCheck m => SubcId -> m (Maybe SMTCounterexample) checkConstraint cid = do Func _ bodies <- fromJust <$> getFunc mainName let cmp (Body bid _) = bid == cid @@ -109,7 +109,7 @@ data Scope = Scope -- as an argument to pass around the remainder of a computation. -- This way, we can pop paths in the SMT due to conditionals. -- Allowing us to retain anything prior to that. -type Runner m = m (Maybe CounterExample) +type Runner m = m (Maybe SMTCounterexample) -- | Run a function. This essentially makes one running branch for -- each body inside of the function. It will try each branch @@ -119,8 +119,9 @@ runFunc name scope runner = do -- Lookup function bodies func <- getFunc name case func of - -- Unconstrained function body. + -- Unconstrained function body, so we just continue with the runner. Nothing -> runner + -- Constrained function body Just (Func _ bodies) -> do -- Generate all execution paths (as runners). let runner' body = runBody scope body runner @@ -227,7 +228,7 @@ smtCheck = do -- | Returns a model, with as precondition that the SMT -- solver had a satisfying assignment prior to this. -smtModel :: MonadCheck m => m CounterExample +smtModel :: MonadCheck m => m SMTCounterexample smtModel = do ctx <- reader context Su sub <- liftIO $ SMT.smtGetModel ctx diff --git a/src/Language/Fixpoint/CounterExample/Types.hs b/src/Language/Fixpoint/Counterexample/Types.hs similarity index 90% rename from src/Language/Fixpoint/CounterExample/Types.hs rename to src/Language/Fixpoint/Counterexample/Types.hs index 0d1081b21..d58e815cb 100644 --- a/src/Language/Fixpoint/CounterExample/Types.hs +++ b/src/Language/Fixpoint/Counterexample/Types.hs @@ -1,7 +1,9 @@ {-# LANGUAGE OverloadedStrings #-} -module Language.Fixpoint.CounterExample.Types - ( CounterExample +module Language.Fixpoint.Counterexample.Types + ( Counterexample + , SMTCounterexample + , CexEnv , Prog (..) , Name , Func (..) @@ -26,8 +28,11 @@ import Control.Monad.IO.Class dbg :: (MonadIO m, PPrint a) => a -> m () dbg = liftIO . print . pprint --- | A counter example for a model. -type CounterExample = HashMap [Symbol] Subst +-- | A counterexample that was read from an SMT model. A full counterexample +-- uses `BindId` to identify symbols and should also contain the refinements +-- and user data corresponding to this counterexample. This is simply an +-- intermediate form, which we translate to a full `Counterexample`. +type SMTCounterexample = HashMap [Symbol] Subst -- | A program, containing multiple function definitions -- mapped by their name. diff --git a/src/Language/Fixpoint/Solver.hs b/src/Language/Fixpoint/Solver.hs index 7be90b3cb..c836cb1cb 100644 --- a/src/Language/Fixpoint/Solver.hs +++ b/src/Language/Fixpoint/Solver.hs @@ -58,11 +58,11 @@ import Language.Fixpoint.Types hiding (GInfo(..), fi) import qualified Language.Fixpoint.Types as Types (GInfo(..)) import Language.Fixpoint.Minimize (minQuery, minQuals, minKvars) import Language.Fixpoint.Solver.Instantiate (instantiate) +import Language.Fixpoint.Counterexample import Control.DeepSeq import qualified Data.ByteString as B import Data.Maybe (catMaybes) -import Language.Fixpoint.CounterExample --------------------------------------------------------------------------- -- | Solve an .fq file ---------------------------------------------------- diff --git a/src/Language/Fixpoint/Types/Constraints.hs b/src/Language/Fixpoint/Types/Constraints.hs index 2b4bebc97..059b02403 100644 --- a/src/Language/Fixpoint/Types/Constraints.hs +++ b/src/Language/Fixpoint/Types/Constraints.hs @@ -63,6 +63,7 @@ module Language.Fixpoint.Types.Constraints ( -- * Results , FixSolution , GFixSolution, toGFixSol + , Counterexample , Result (..) , unsafe, isUnsafe, isSafe ,safe @@ -272,13 +273,15 @@ newtype GFixSol e = GSol (M.HashMap KVar (e, [e])) toGFixSol :: M.HashMap KVar (e, [e]) -> GFixSol e toGFixSol = GSol +-- | A counter example for a model. +type Counterexample a = M.HashMap [BindId] (CexEnv a) data Result a = Result { resStatus :: !(FixResult a) , resSolution :: !FixSolution , resNonCutsSolution :: !FixSolution , gresSolution :: !GFixSolution - , resCntExs :: !(M.HashMap SubcId (M.HashMap [BindId] (BindMap Expr))) + , resCounterexamples :: !(M.HashMap SubcId (Counterexample a)) } deriving (Generic, Show, Functor) @@ -294,7 +297,7 @@ instance Semigroup (Result a) where soln = resSolution r1 <> resSolution r2 nonCutsSoln = resNonCutsSolution r1 <> resNonCutsSolution r2 gsoln = gresSolution r1 <> gresSolution r2 - cntExs = resCntExs r1 <> resCntExs r2 + cntExs = resCounterexamples r1 <> resCounterexamples r2 instance Monoid (Result a) where mempty = Result mempty mempty mempty mempty mempty diff --git a/src/Language/Fixpoint/Types/Environments.hs b/src/Language/Fixpoint/Types/Environments.hs index 8654c0d29..b5db33e47 100644 --- a/src/Language/Fixpoint/Types/Environments.hs +++ b/src/Language/Fixpoint/Types/Environments.hs @@ -48,6 +48,7 @@ module Language.Fixpoint.Types.Environments ( , filterBindEnv, mapBindEnv, mapWithKeyMBindEnv, adjustBindEnv , bindEnvFromList, bindEnvToList, deleteBindEnv, elemsBindEnv , EBindEnv, splitByQuantifiers + , CexEnv -- * Information needed to lookup and update Solutions -- , SolEnv (..) @@ -99,6 +100,10 @@ instance PPrint a => PPrint (SizedEnv a) where type BindEnv a = SizedEnv (Symbol, SortedReft, a) newtype EBindEnv a = EB (BindEnv a) +-- | A counterexample environment. Contains an expression (the concrete +-- instance) aside from the regular symbol and refinement. +type CexEnv a = BindEnv (Expr, a) + splitByQuantifiers :: BindEnv a -> [BindId] -> (BindEnv a, EBindEnv a) splitByQuantifiers (BE i bs) ebs = ( BE i $ M.filterWithKey (\k _ -> notElem k ebs) bs , EB $ BE i $ M.filterWithKey (\k _ -> elem k ebs) bs From 9f91f764a84959cdb98492c8512d508bab9eb7e2 Mon Sep 17 00:00:00 2001 From: Robin Webbers Date: Mon, 19 Feb 2024 10:25:58 +0100 Subject: [PATCH 15/33] Changed name scheme in counterexample to use BindId as a path instead of Symbol --- src/Language/Fixpoint/Counterexample.hs | 81 ++++++++++--------- src/Language/Fixpoint/Counterexample/Build.hs | 38 +++++---- src/Language/Fixpoint/Counterexample/Check.hs | 15 ++-- src/Language/Fixpoint/Counterexample/Types.hs | 32 +++++--- src/Language/Fixpoint/Types/Constraints.hs | 2 +- tests/neg/duplicate-names3.fq | 28 +++++++ 6 files changed, 123 insertions(+), 73 deletions(-) create mode 100644 tests/neg/duplicate-names3.fq diff --git a/src/Language/Fixpoint/Counterexample.hs b/src/Language/Fixpoint/Counterexample.hs index 1d9580ac4..ffc62269f 100644 --- a/src/Language/Fixpoint/Counterexample.hs +++ b/src/Language/Fixpoint/Counterexample.hs @@ -1,7 +1,6 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} module Language.Fixpoint.Counterexample ( tryCounterExample @@ -13,14 +12,19 @@ import Language.Fixpoint.Counterexample.Build import Language.Fixpoint.Counterexample.Check import Language.Fixpoint.Types.Config (Config, counterExample) -import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as Map import Control.Monad.IO.Class +import Control.Monad (void) -- TODO: Remove variables from the counter example that got mapped to -- the "wrong" type in smt format (e.g. to an int while not being one). +-- TODO: Ideally `Result` would not have `SubcId` in its generic. Instead, this +-- should just always be contained in a `Result`. Right now, our counterexample +-- will contain a bunch of meaningless `SubcId` as we need to read it from +-- the result. + -- | Try to get a counter example for the given unsafe clauses (if any). tryCounterExample :: (MonadIO m, Fixpoint info) @@ -37,51 +41,50 @@ tryCounterExample cfg si res@Result -- Check the constraints, returning a substitution map let cids = map fst cids' - subs <- checkProg cfg si prog cids + smtcex <- checkProg cfg si prog cids -- Map the symbols in this substitution to their respective bind id - let cexs = toFullCex si <$> subs + let cexs = toFullCex si <$> smtcex + dbg $ fmap (fmap (fmap (fmap void))) <$> cexs return res { resCounterexamples = cexs <> cexs' } tryCounterExample _ _ res = return res --- | Map a counter example to use the BindId instead of the --- variable name as the key. --- --- In other words, we go from a mapping of Symbol |-> Expr to --- BindId |-> Expr -toFullCex :: forall info. SInfo info -> SMTCounterexample -> Counterexample (SubcId, info) -toFullCex si smtcex = extendSubst <$> pathcex - where - -- Get the bind environment - benv = bs si - - -- Remove all of the map except the bind id. - bindings :: BindMap Symbol - bindings = (\(bid, _, _) -> bid) <$> beBinds benv +-- | Extend an SMT counterexample to a full counterexample. - -- Reverses the direction of a hashmap - reverseMap = Map.fromList . fmap (\(a, b) -> (b, a)) . Map.toList +-- With this, the variables are indexed by +-- `BindId` and they contain also their refinement type and user info. +toFullCex :: SInfo info -> SMTCounterexample -> Counterexample (SubcId, info) +toFullCex si = fmap $ substToCexEnv si - -- Reverse the bindings mapping, so we can map our symbols to bind ids. - symIds :: HashMap Symbol BindId - symIds = reverseMap bindings +-- | Extend an SMT counterexample environment (i.e. the substitution map) to a +-- full counterexample environment. With this, the variables are indexed by +-- `BindId` and they contain also their refinement type and user info. +substToCexEnv :: SInfo info -> Subst -> CexEnv (SubcId, info) +substToCexEnv si (Su sub) = benv { beBinds = binds } + where + benv = bs si - -- A counterexample where we transformed the path to be [BindId]. - -- I.e. this is a partial translation from SMT Counterexample to a full one. - pathcex :: HashMap [BindId] Subst - pathcex = Map.mapKeys (map $ (Map.!) symIds) smtcex + binds = Map.mapMaybe trans $ beBinds benv - -- Maps an smt subst to a full counterexample environment (i.e. the - -- concrete instances for a given scope). - extendSubst :: Subst -> CexEnv (SubcId, info) - extendSubst (Su sub) = benv { beBinds = binds } + trans (sym, sreft, info) = extend <$> Map.lookup sym sub where - binds = Map.mapMaybe trans $ beBinds benv - - trans (sym, sreft, info) = extend <$> Map.lookup sym sub - where - -- We fake a SubCId here. It really shouldn't be here, but it is an - -- artifact of this being embedded in the generic of `Result` - -- instead of always being there! - extend ex = (sym, sreft, (ex, (0, info))) + -- We fake a SubCId here. It really shouldn't be here, but it is + -- an artifact of a SubcId needing to be embedded in the generic of + -- `Result`! Ideally, we would have the CexEnv contain just the same + -- generic as SInfo. This would require us to change the structure of + -- `Result` to contain the SubcId always. + extend ex = (sym, sreft, (ex, (0, info))) + +-- TODO: The bindings don't completely match yet. Try out +-- tests/neg/duplicate-names3.fq +-- +-- There you can see that we get 2 bindings for z, while both k instances only +-- should get 1! +-- +-- We should use the IBindEnv of every separate horn clause (look at Build.hs +-- on how to get the IBindEnv). With this local bind set, we can get a correct +-- environment! + +-- TODO: Make the `Counterexample` structure a tree instead of a hashmap with +-- lists. diff --git a/src/Language/Fixpoint/Counterexample/Build.hs b/src/Language/Fixpoint/Counterexample/Build.hs index db21412da..f1fecf47c 100644 --- a/src/Language/Fixpoint/Counterexample/Build.hs +++ b/src/Language/Fixpoint/Counterexample/Build.hs @@ -36,6 +36,8 @@ data BuildEnv info = BuildEnv -- the imperative function format. See Prog for the format. type MonadBuild info m = (MonadReader (BuildEnv info) m, MonadState Prog m, MonadIO m) +type Binding = (BindId, Symbol, SortedReft) + -- | Make an imperative program from horn clauses. This -- can be used to generate a counter example. hornToProg :: MonadIO m => Config -> SInfo info -> m Prog @@ -126,35 +128,41 @@ substToStmts (Su sub) = do hornLhsToStmts :: MonadBuild info m => SimpC info -> m [Statement] hornLhsToStmts horn = do bindEnv <- reader $ bs . info - let lhs = clhs bindEnv horn + let lhs = relevantLhs bindEnv horn lhs' <- filterLits . filterDuplicates $ lhs - stmts <- forM lhs' $ uncurry reftToStmts + stmts <- forM lhs' reftToStmts return $ mconcat stmts -filterDuplicates :: [(Symbol, SortedReft)] -> [(Symbol, SortedReft)] -filterDuplicates env = foldr filter' [] env +relevantLhs :: BindEnv info -> SimpC info -> [Binding] +relevantLhs benv horn = [(bid, sym, ref) | bid <- elemsIBindEnv ibenv, let (sym, ref, _) = lookupBindEnv bid benv] + where + ibenv = senv horn + +filterDuplicates :: [Binding] -> [Binding] +filterDuplicates = foldr filter' [] where - filter' sym acc = case fst sym `member` map fst acc of - Nothing -> sym:acc + filter' e acc = case e `member` acc of + Nothing -> e:acc Just _ -> acc - member e = find (e==) + snd' (_, x, _) = x + member e es = find (snd' e==) $ map snd' es -filterLits :: MonadBuild info m => [(Symbol, SortedReft)] -> m [(Symbol, SortedReft)] +filterLits :: MonadBuild info m => [Binding] -> m [Binding] filterLits env = do con <- reader $ gLits . info dis <- reader $ dLits . info - let isLit (sym, _) = memberSEnv sym con || memberSEnv sym dis + let isLit (_, sym, _) = memberSEnv sym con || memberSEnv sym dis return $ filter (not . isLit) env -- | Map a refinement to a declaration and constraint pair -reftToStmts :: MonadBuild info m => Symbol -> SortedReft -> m [Statement] -reftToStmts _ RR { sr_sort = FAbs _ _ } = return [] -reftToStmts _ RR { sr_sort = FFunc _ _ } = return [] -reftToStmts sym RR +reftToStmts :: MonadBuild info m => Binding -> m [Statement] +reftToStmts (_, _, RR { sr_sort = FAbs _ _ }) = return [] +reftToStmts (_, _, RR { sr_sort = FFunc _ _ }) = return [] +reftToStmts (bid, sym, RR { sr_sort = sort , sr_reft = Reft (v, e) - } = do + }) = do -- Get correct sort for declaration sort' <- elaborateSort sort let decl = Let $ Decl sym sort' @@ -162,7 +170,7 @@ reftToStmts sym RR -- Get constraints from the expression. let constraints = case predKs e of [] -> [Assume e] - ks -> map (uncurry $ Call sym) ks + ks -> fmap (uncurry $ Call bid) ks -- Do substitution of self variable in the constraints let sub = Su $ Map.singleton v (EVar sym) diff --git a/src/Language/Fixpoint/Counterexample/Check.hs b/src/Language/Fixpoint/Counterexample/Check.hs index e26de973f..e6acfef76 100644 --- a/src/Language/Fixpoint/Counterexample/Check.hs +++ b/src/Language/Fixpoint/Counterexample/Check.hs @@ -98,7 +98,7 @@ checkConstraint cid = do -- | A scope contains the current binders in place -- as well as the path traversed to reach this scope. data Scope = Scope - { path :: ![(KVar, Symbol)] + { path :: ![(BindId, Name)] -- ^ The path traversed to reach the scope. , binders :: !Subst -- ^ The binders available in the current scope. @@ -133,6 +133,8 @@ runFunc name scope runner = do -- Check if we've reached the recursion limit. -- TODO: Perhaps we should make the recursion limit per kvar? + -- TODO: We should really explore shallow trees first. Right now, + -- we explore max depth trees only... depth' <- gets depth put $ CheckState $ depth' + 1 maxDepth' <- reader maxDepth @@ -170,7 +172,7 @@ runStatement scope stmt runner = do let stmt' = subst (binders scope) stmt case stmt' of Call origin name app -> do - let scope' = Scope ((name, origin):path scope) app + let scope' = Scope ((origin, name):path scope) app runFunc name scope' runner' Assume e -> smtAssume e >> runner' Assert e -> smtAssert e >> runner' @@ -250,22 +252,23 @@ scopeSym scope sym = symbol name name = intercalate bindSep strs strs = symbolString <$> progPrefix : sym : paths paths = uncurry joinCall <$> path scope - joinCall (KV callee) caller = symbol . mconcat $ symbolString <$> [callee, callSep, caller] + joinCall caller (KV callee) = symbol . mconcat $ symbolString <$> [symbol $ show caller, callSep, callee] -- | We encode the trace of a symbol in its name. This way, -- we do not lose it in the SMT solver. This function translates -- the encoding back. -unscopeSym :: Symbol -> Maybe (Symbol, [Symbol]) +unscopeSym :: Symbol -> Maybe (Symbol, [(BindId, Name)]) unscopeSym sym = case T.splitOn bindSep sym' of (prefix:name:trace) | prefix == progPrefix -> Just (symbol name, splitCall <$> trace) _ -> Nothing where - splitCall c = symbol . split $ T.splitOn callSep c + splitCall :: T.Text -> (BindId, Name) + splitCall = split . T.splitOn callSep -- We just ignore the callee for now. It was initially here to avoid -- duplicates in the SMT solver. - split [_callee, caller] = caller + split [caller, callee] = (read $ T.unpack caller, KV $ symbol callee) split _ = error "Scoped name should always be in this shape" sym' = escapeSmt . symbolText $ sym diff --git a/src/Language/Fixpoint/Counterexample/Types.hs b/src/Language/Fixpoint/Counterexample/Types.hs index d58e815cb..d8ac71605 100644 --- a/src/Language/Fixpoint/Counterexample/Types.hs +++ b/src/Language/Fixpoint/Counterexample/Types.hs @@ -4,6 +4,7 @@ module Language.Fixpoint.Counterexample.Types ( Counterexample , SMTCounterexample , CexEnv +-- , Counterexample (..) , Prog (..) , Name , Func (..) @@ -19,6 +20,7 @@ module Language.Fixpoint.Counterexample.Types import Language.Fixpoint.Types import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as Map +-- import Data.Tree (Tree) import Text.PrettyPrint.HughesPJ ((<+>), ($+$)) import qualified Text.PrettyPrint.HughesPJ as PP @@ -28,19 +30,26 @@ import Control.Monad.IO.Class dbg :: (MonadIO m, PPrint a) => a -> m () dbg = liftIO . print . pprint +-- -- | A full counterexample in a tree like representation. +-- data Counterexample a = Counterexample +-- { cexEnv :: !(CexEnv a) +-- -- ^ Current scope of counterexample +-- , cexKvars :: !(BindMap (Counterexample a)) +-- -- ^ The kvars that may be expanded from the current scope +-- } + -- | A counterexample that was read from an SMT model. A full counterexample -- uses `BindId` to identify symbols and should also contain the refinements -- and user data corresponding to this counterexample. This is simply an -- intermediate form, which we translate to a full `Counterexample`. -type SMTCounterexample = HashMap [Symbol] Subst +type SMTCounterexample = HashMap [(BindId, Name)] Subst --- | A program, containing multiple function definitions --- mapped by their name. +-- | A program, containing multiple function definitions mapped by their name. newtype Prog = Prog (HashMap Name Func) deriving Show --- | Identifier of a function. All KVars are translated --- into functions, so it is just an alias. +-- | Identifier of a function. All KVars are translated into functions, so it is +-- just an alias. type Name = KVar -- | A function symbol corresponding to a Name. @@ -54,8 +63,8 @@ type Signature = [Decl] data Body = Body !SubcId ![Statement] deriving Show --- | A statement used to introduce/check constraints, --- together with its location information +-- | A statement used to introduce/check constraints, together with its location +-- information. data Statement = Let !Decl -- ^ Introduces a new variable. @@ -63,17 +72,16 @@ data Statement -- ^ Constraints a variable. | Assert !Expr -- ^ Checks whether a predicate follows given prior constraints. - | Call !Symbol !Name !Subst - -- ^ Call to function. The symbol is the origin, used to trace - -- callstacks. + | Call !BindId !Name !Subst + -- ^ Call to function. The bind id is the origin, used to trace callstacks. deriving Show -- | A declaration of a Symbol with a Sort. data Decl = Decl !Symbol !Sort deriving Show --- | The main function, which any horn clause without a --- KVar on the rhs will be added to. +-- | The main function, which any horn clause without a KVar on the rhs will be +-- added to. mainName :: Name mainName = KV "main" diff --git a/src/Language/Fixpoint/Types/Constraints.hs b/src/Language/Fixpoint/Types/Constraints.hs index 059b02403..1aaa44ce9 100644 --- a/src/Language/Fixpoint/Types/Constraints.hs +++ b/src/Language/Fixpoint/Types/Constraints.hs @@ -274,7 +274,7 @@ toGFixSol :: M.HashMap KVar (e, [e]) -> GFixSol e toGFixSol = GSol -- | A counter example for a model. -type Counterexample a = M.HashMap [BindId] (CexEnv a) +type Counterexample a = M.HashMap [(BindId, KVar)] (CexEnv a) data Result a = Result { resStatus :: !(FixResult a) diff --git a/tests/neg/duplicate-names3.fq b/tests/neg/duplicate-names3.fq new file mode 100644 index 000000000..55d1bc53b --- /dev/null +++ b/tests/neg/duplicate-names3.fq @@ -0,0 +1,28 @@ +bind 0 x : {v: int | [$k[vk := v]]} +bind 1 y : {v: int | [$k[vk := v]]} + +constraint: + env [0; 1] + lhs {v0: int | v0 == x + y} + rhs {v0: int | v0 != 7} + id 0 tag [] + +bind 3 z : {v: int | v = 3} + +constraint: + env [3] + lhs {v1: int | [v1 == z]} + rhs {v1: int | $k[vk := v1]} + id 1 tag [] + +bind 4 z : {v: int | v = 4} + +constraint: + env [4] + lhs {v2: int | [v2 == z]} + rhs {v2: int | $k[vk := v2]} + id 2 tag [] + +wf: + env [] + reft {vk: int | [$k]} From 876804d894e83d467003b20303ec585764e3e8ff Mon Sep 17 00:00:00 2001 From: Robin Webbers Date: Mon, 19 Feb 2024 16:36:27 +0100 Subject: [PATCH 16/33] Changed the format of counterexamles. The extension to full counterexample now uses the local bind environment to get accurate types. --- src/Language/Fixpoint/Counterexample.hs | 54 +++++++---------- src/Language/Fixpoint/Counterexample/Check.hs | 52 ++++++++++------- src/Language/Fixpoint/Counterexample/Types.hs | 39 ++++++------- src/Language/Fixpoint/Types/Constraints.hs | 58 +++++++++++++++++-- 4 files changed, 122 insertions(+), 81 deletions(-) diff --git a/src/Language/Fixpoint/Counterexample.hs b/src/Language/Fixpoint/Counterexample.hs index ffc62269f..f065329e9 100644 --- a/src/Language/Fixpoint/Counterexample.hs +++ b/src/Language/Fixpoint/Counterexample.hs @@ -6,7 +6,7 @@ module Language.Fixpoint.Counterexample ( tryCounterExample ) where -import Language.Fixpoint.Types +import Language.Fixpoint.Types hiding (Counterexample) import Language.Fixpoint.Counterexample.Types import Language.Fixpoint.Counterexample.Build import Language.Fixpoint.Counterexample.Check @@ -15,7 +15,6 @@ import Language.Fixpoint.Types.Config (Config, counterExample) import qualified Data.HashMap.Strict as Map import Control.Monad.IO.Class -import Control.Monad (void) -- TODO: Remove variables from the counter example that got mapped to -- the "wrong" type in smt format (e.g. to an int while not being one). @@ -40,51 +39,40 @@ tryCounterExample cfg si res@Result prog <- hornToProg cfg si -- Check the constraints, returning a substitution map - let cids = map fst cids' + let cids = fst <$> cids' smtcex <- checkProg cfg si prog cids -- Map the symbols in this substitution to their respective bind id - let cexs = toFullCex si <$> smtcex - dbg $ fmap (fmap (fmap (fmap void))) <$> cexs + let cexs = Map.mapWithKey (toFullCex si) smtcex return res { resCounterexamples = cexs <> cexs' } tryCounterExample _ _ res = return res -- | Extend an SMT counterexample to a full counterexample. - --- With this, the variables are indexed by --- `BindId` and they contain also their refinement type and user info. -toFullCex :: SInfo info -> SMTCounterexample -> Counterexample (SubcId, info) -toFullCex si = fmap $ substToCexEnv si +toFullCex :: SInfo info -> SubcId -> SMTCounterexample -> FullCounterexample (SubcId, info) +toFullCex si = go + where + go subcid (Counterexample env trace) = Counterexample + { cexEnv = substToCexEnv si subcid env + , cexFrames = Map.mapWithKey (toFullCex si . snd) trace + } -- | Extend an SMT counterexample environment (i.e. the substitution map) to a -- full counterexample environment. With this, the variables are indexed by -- `BindId` and they contain also their refinement type and user info. -substToCexEnv :: SInfo info -> Subst -> CexEnv (SubcId, info) -substToCexEnv si (Su sub) = benv { beBinds = binds } +substToCexEnv :: SInfo info -> SubcId -> Subst -> CexEnv (SubcId, info) +substToCexEnv si subcid (Su sub) = benv { beBinds = binds } where benv = bs si + ibenv = senv $ cm si Map.! subcid - binds = Map.mapMaybe trans $ beBinds benv + -- Filter out all bind ids that are not in the constraint. Then map the + -- symbols back to the bind ids. + binds = Map.mapMaybe trans + . Map.filterWithKey (\bid _ -> memberIBindEnv bid ibenv) + . beBinds + $ benv + -- Extend the symbol with a its type and user info if possible. trans (sym, sreft, info) = extend <$> Map.lookup sym sub where - -- We fake a SubCId here. It really shouldn't be here, but it is - -- an artifact of a SubcId needing to be embedded in the generic of - -- `Result`! Ideally, we would have the CexEnv contain just the same - -- generic as SInfo. This would require us to change the structure of - -- `Result` to contain the SubcId always. - extend ex = (sym, sreft, (ex, (0, info))) - --- TODO: The bindings don't completely match yet. Try out --- tests/neg/duplicate-names3.fq --- --- There you can see that we get 2 bindings for z, while both k instances only --- should get 1! --- --- We should use the IBindEnv of every separate horn clause (look at Build.hs --- on how to get the IBindEnv). With this local bind set, we can get a correct --- environment! - --- TODO: Make the `Counterexample` structure a tree instead of a hashmap with --- lists. - + extend ex = (sym, sreft, (ex, (subcid, info))) diff --git a/src/Language/Fixpoint/Counterexample/Check.hs b/src/Language/Fixpoint/Counterexample/Check.hs index e6acfef76..bf169fa71 100644 --- a/src/Language/Fixpoint/Counterexample/Check.hs +++ b/src/Language/Fixpoint/Counterexample/Check.hs @@ -98,7 +98,7 @@ checkConstraint cid = do -- | A scope contains the current binders in place -- as well as the path traversed to reach this scope. data Scope = Scope - { path :: ![(BindId, Name)] + { path :: ![FrameId] -- ^ The path traversed to reach the scope. , binders :: !Subst -- ^ The binders available in the current scope. @@ -124,8 +124,8 @@ runFunc name scope runner = do -- Constrained function body Just (Func _ bodies) -> do -- Generate all execution paths (as runners). - let runner' body = runBody scope body runner - let paths = map runner' bodies + let runner' body = runBody (extendScope scope body) body runner + let paths = runner' <$> bodies -- Try paths, selecting the first that produces a counter example. let select Nothing r = r @@ -146,11 +146,18 @@ runFunc name scope runner = do modify $ \s -> s { depth = depth s - 1} return result --- | Run the statements in the body. If there are no more statements --- to run, this will execute the Runner that was passed as argument. +-- | Extend the scope to include the id of the body, i.e. the `SubcId`. +extendScope :: Scope -> Body -> Scope +extendScope scope (Body bodyId _) = withSubcId scope + where + withSubcId scope'@Scope { path = (bindId,_):ps } = scope' { path = (bindId, bodyId):ps } + withSubcId _ = error "No scope to extend." + +-- | Run the statements in the body. If there are no more statements to run, +-- this will execute the Runner that was passed as argument. -- --- The passed runner here is thus the rest of the computation, when --- we "return" from this function. +-- The passed runner here is thus the rest of the computation, when we "return" +-- from this function. runBody :: MonadCheck m => Scope -> Body -> Runner m -> Runner m runBody scope' body runner = smtScope $ go scope' body where @@ -172,7 +179,9 @@ runStatement scope stmt runner = do let stmt' = subst (binders scope) stmt case stmt' of Call origin name app -> do - let scope' = Scope ((origin, name):path scope) app + -- We fake a SubcId here, it will later get mapped into the scope when we + -- decide which body to run. + let scope' = Scope ((origin, 0):path scope) app runFunc name scope' runner' Assume e -> smtAssume e >> runner' Assert e -> smtAssert e >> runner' @@ -239,10 +248,11 @@ smtModel = do let renames = first unscopeSym <$> Map.toList sub let traces = [ (trace, sym, e) | (Just (sym, trace), e) <- renames ] - -- Insert a mapping per unique layer in the counter example. - let new sym e = Su $ Map.singleton sym e - let insert cex (trace, sym, e) = Map.insertWith (<>) trace (new sym e) cex - let cex = foldl' insert mempty traces + -- Insert per singleton. Entries are monoidically merged when inserted. + let insert (trace, sym, e) = cexInsert trace $ Su (Map.singleton sym e) + + -- Insert all elements + let cex = foldl' (flip insert) mempty traces return cex -- | Returns a version of a symbol with the scope encoded into its name. @@ -252,24 +262,24 @@ scopeSym scope sym = symbol name name = intercalate bindSep strs strs = symbolString <$> progPrefix : sym : paths paths = uncurry joinCall <$> path scope - joinCall caller (KV callee) = symbol . mconcat $ symbolString <$> [symbol $ show caller, callSep, callee] + joinCall caller callee = symbol . mconcat $ [show caller, callSep, show callee] -- | We encode the trace of a symbol in its name. This way, -- we do not lose it in the SMT solver. This function translates -- the encoding back. -unscopeSym :: Symbol -> Maybe (Symbol, [(BindId, Name)]) +unscopeSym :: Symbol -> Maybe (Symbol, [FrameId]) unscopeSym sym = case T.splitOn bindSep sym' of (prefix:name:trace) | prefix == progPrefix - -> Just (symbol name, splitCall <$> trace) + -> Just (symbol name, toFrameId <$> trace) _ -> Nothing where - splitCall :: T.Text -> (BindId, Name) - splitCall = split . T.splitOn callSep + toFrameId = split . T.splitOn callSep + + split [caller, callee] = (read' caller, read' callee) + split _ = error "Scoped name was not correctly shaped" - -- We just ignore the callee for now. It was initially here to avoid - -- duplicates in the SMT solver. - split [caller, callee] = (read $ T.unpack caller, KV $ symbol callee) - split _ = error "Scoped name should always be in this shape" + read' :: Read a => T.Text -> a + read' = read . T.unpack sym' = escapeSmt . symbolText $ sym diff --git a/src/Language/Fixpoint/Counterexample/Types.hs b/src/Language/Fixpoint/Counterexample/Types.hs index d8ac71605..609c77eba 100644 --- a/src/Language/Fixpoint/Counterexample/Types.hs +++ b/src/Language/Fixpoint/Counterexample/Types.hs @@ -1,10 +1,15 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveFunctor #-} module Language.Fixpoint.Counterexample.Types - ( Counterexample + ( Counterexample (..) , SMTCounterexample + , FullCounterexample , CexEnv --- , Counterexample (..) + , cexInsert + , FrameId + , Trace + , Prog (..) , Name , Func (..) @@ -20,7 +25,6 @@ module Language.Fixpoint.Counterexample.Types import Language.Fixpoint.Types import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as Map --- import Data.Tree (Tree) import Text.PrettyPrint.HughesPJ ((<+>), ($+$)) import qualified Text.PrettyPrint.HughesPJ as PP @@ -30,19 +34,9 @@ import Control.Monad.IO.Class dbg :: (MonadIO m, PPrint a) => a -> m () dbg = liftIO . print . pprint --- -- | A full counterexample in a tree like representation. --- data Counterexample a = Counterexample --- { cexEnv :: !(CexEnv a) --- -- ^ Current scope of counterexample --- , cexKvars :: !(BindMap (Counterexample a)) --- -- ^ The kvars that may be expanded from the current scope --- } - --- | A counterexample that was read from an SMT model. A full counterexample --- uses `BindId` to identify symbols and should also contain the refinements --- and user data corresponding to this counterexample. This is simply an --- intermediate form, which we translate to a full `Counterexample`. -type SMTCounterexample = HashMap [(BindId, Name)] Subst +-- | A counterexample that was mapped from an SMT result. It is a simple mapping +-- from symbol to concrete instance. +type SMTCounterexample = Counterexample Subst -- | A program, containing multiple function definitions mapped by their name. newtype Prog = Prog (HashMap Name Func) @@ -73,7 +67,8 @@ data Statement | Assert !Expr -- ^ Checks whether a predicate follows given prior constraints. | Call !BindId !Name !Subst - -- ^ Call to function. The bind id is the origin, used to trace callstacks. + -- ^ Call to function. The bind id is used to trace callstacks. I.e. it is the + -- caller of the function. deriving Show -- | A declaration of a Symbol with a Sort. @@ -133,11 +128,11 @@ instance PPrint Statement where pprintTidy tidy (Let decl) = "let" <+> pprintTidy tidy decl pprintTidy tidy (Assume exprs) = "assume" <+> pprintTidy tidy exprs pprintTidy tidy (Assert exprs) = "assert" <+> pprintTidy tidy exprs - pprintTidy tidy (Call origin name sub) = pname <+> pargs <+> porigin + pprintTidy tidy (Call bid name sub) = pname <+> pargs <+> porigin where pname = pprintTidy tidy name pargs = pprintTidy tidy sub - porigin = "// origin" <+> pprintTidy tidy origin + porigin = "// bind id" <+> pprintTidy tidy bid instance Subable Statement where syms (Let decl) = syms decl @@ -148,17 +143,17 @@ instance Subable Statement where substa _ (Let decl) = Let decl substa f (Assume e) = Assume $ substa f e substa f (Assert e) = Assert $ substa f e - substa f (Call origin name (Su sub)) = Call origin name (Su $ substa f sub) + substa f (Call bid name (Su sub)) = Call bid name (Su $ substa f sub) substf _ (Let decl) = Let decl substf f (Assume e) = Assume $ substf f e substf f (Assert e) = Assert $ substf f e - substf f (Call origin name (Su sub)) = Call origin name (Su $ substf f sub) + substf f (Call bid name (Su sub)) = Call bid name (Su $ substf f sub) subst _ (Let decl) = Let decl subst sub (Assume e) = Assume $ subst sub e subst sub (Assert e) = Assert $ subst sub e - subst sub (Call origin name (Su sub')) = Call origin name (Su $ subst sub sub') + subst sub (Call bid name (Su sub')) = Call bid name (Su $ subst sub sub') instance Subable Decl where syms (Decl sym _) = [sym] diff --git a/src/Language/Fixpoint/Types/Constraints.hs b/src/Language/Fixpoint/Types/Constraints.hs index 1aaa44ce9..cbaf1d698 100644 --- a/src/Language/Fixpoint/Types/Constraints.hs +++ b/src/Language/Fixpoint/Types/Constraints.hs @@ -61,9 +61,14 @@ module Language.Fixpoint.Types.Constraints ( , qualBinds -- * Results + , Counterexample (..) + , FullCounterexample + , Trace + , FrameId + , cexInsert + , FixSolution , GFixSolution, toGFixSol - , Counterexample , Result (..) , unsafe, isUnsafe, isSafe ,safe @@ -263,6 +268,51 @@ subcId = mfromJust "subCId" . sid -- | Solutions and Results --------------------------------------------------------------------------- +-- | A counterexample in a tree like representation. +data Counterexample a = Counterexample + { cexEnv :: !a + -- ^ The environment in the current stack frame. + , cexFrames :: !(M.HashMap FrameId (Counterexample a)) + -- ^ The counterexamples stack frames that can be explored from the current + -- environment. + } + deriving (Generic, Show, Functor) + +instance PPrint a => PPrint (Counterexample a) where + pprintTidy tidy (Counterexample env trace) = penv $+$ ptrace + where + penv = pprintTidy tidy env + ptrace = pprintTidy tidy trace + +instance Semigroup a => Semigroup (Counterexample a) where + lhs <> rhs = Counterexample + { cexEnv = cexEnv lhs <> cexEnv rhs + , cexFrames = M.unionWith (<>) (cexFrames lhs) (cexFrames rhs) + } + +instance Monoid a => Monoid (Counterexample a) where + mempty = Counterexample mempty mempty + +-- | Monoidically add an element to a counterexample. +cexInsert :: Monoid a => Trace -> a -> Counterexample a -> Counterexample a +cexInsert trace v cex = cex <> go trace + where + go (f:fs) = Counterexample mempty $ M.singleton f (go fs) + go [] = Counterexample v mempty + +-- | A stack trace is built from multiple frame ids. This is mostly used for +-- SMT encodings. These traces are made into a tree like representation in the +-- actual counterexample object. +type Trace = [FrameId] + +-- | An identfier for a "stack frame" in a counterexample. +type FrameId = (BindId, SubcId) + +-- | A counterexample that was extended with additional information from the +-- environment. It additionally includes types, bind ids and user info, aside +-- from what is already provided from an `SMTCounterexample`. +type FullCounterexample a = Counterexample (CexEnv a) + type GFixSolution = GFixSol Expr type FixSolution = M.HashMap KVar Expr @@ -273,15 +323,12 @@ newtype GFixSol e = GSol (M.HashMap KVar (e, [e])) toGFixSol :: M.HashMap KVar (e, [e]) -> GFixSol e toGFixSol = GSol --- | A counter example for a model. -type Counterexample a = M.HashMap [(BindId, KVar)] (CexEnv a) - data Result a = Result { resStatus :: !(FixResult a) , resSolution :: !FixSolution , resNonCutsSolution :: !FixSolution , gresSolution :: !GFixSolution - , resCounterexamples :: !(M.HashMap SubcId (Counterexample a)) + , resCounterexamples :: !(M.HashMap SubcId (FullCounterexample a)) } deriving (Generic, Show, Functor) @@ -418,6 +465,7 @@ instance (NFData a) => NFData (WfC a) instance (NFData a) => NFData (SimpC a) instance (NFData (c a), NFData a) => NFData (GInfo c a) instance (NFData a) => NFData (Result a) +instance (NFData a) => NFData (Counterexample a) instance Hashable Qualifier instance Hashable QualPattern From 3b84915be678f082d05da023c13ffe129b24fe20 Mon Sep 17 00:00:00 2001 From: Robin Webbers Date: Mon, 19 Feb 2024 16:40:47 +0100 Subject: [PATCH 17/33] Removed obsolete where binding from `toFullCex` --- src/Language/Fixpoint/Counterexample.hs | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) diff --git a/src/Language/Fixpoint/Counterexample.hs b/src/Language/Fixpoint/Counterexample.hs index f065329e9..a58ac05ae 100644 --- a/src/Language/Fixpoint/Counterexample.hs +++ b/src/Language/Fixpoint/Counterexample.hs @@ -49,12 +49,10 @@ tryCounterExample _ _ res = return res -- | Extend an SMT counterexample to a full counterexample. toFullCex :: SInfo info -> SubcId -> SMTCounterexample -> FullCounterexample (SubcId, info) -toFullCex si = go - where - go subcid (Counterexample env trace) = Counterexample - { cexEnv = substToCexEnv si subcid env - , cexFrames = Map.mapWithKey (toFullCex si . snd) trace - } +toFullCex si subcid (Counterexample env trace) = Counterexample + { cexEnv = substToCexEnv si subcid env + , cexFrames = Map.mapWithKey (toFullCex si . snd) trace + } -- | Extend an SMT counterexample environment (i.e. the substitution map) to a -- full counterexample environment. With this, the variables are indexed by From 558306f3717f375b96824535e508902ace21592b Mon Sep 17 00:00:00 2001 From: Robin Webbers Date: Wed, 28 Feb 2024 11:56:13 +0100 Subject: [PATCH 18/33] Obsolete environments are now deleted from the counterexample --- src/Language/Fixpoint/Counterexample.hs | 25 +++++++++++++++---- src/Language/Fixpoint/Counterexample/Build.hs | 8 +++--- tests/neg/obsolete-env.fq | 12 +++++++++ 3 files changed, 37 insertions(+), 8 deletions(-) create mode 100644 tests/neg/obsolete-env.fq diff --git a/src/Language/Fixpoint/Counterexample.hs b/src/Language/Fixpoint/Counterexample.hs index a58ac05ae..9b5003c2f 100644 --- a/src/Language/Fixpoint/Counterexample.hs +++ b/src/Language/Fixpoint/Counterexample.hs @@ -6,11 +6,13 @@ module Language.Fixpoint.Counterexample ( tryCounterExample ) where -import Language.Fixpoint.Types hiding (Counterexample) +import Language.Fixpoint.Types +import Language.Fixpoint.Types.Config (Config, counterExample) +import Language.Fixpoint.Solver.EnvironmentReduction (dropLikelyIrrelevantBindings) + import Language.Fixpoint.Counterexample.Types import Language.Fixpoint.Counterexample.Build import Language.Fixpoint.Counterexample.Check -import Language.Fixpoint.Types.Config (Config, counterExample) import qualified Data.HashMap.Strict as Map @@ -44,6 +46,8 @@ tryCounterExample cfg si res@Result -- Map the symbols in this substitution to their respective bind id let cexs = Map.mapWithKey (toFullCex si) smtcex + + dbg $ (fmap . fmap . fmap . fmap $ toFix) <$> cexs return res { resCounterexamples = cexs <> cexs' } tryCounterExample _ _ res = return res @@ -61,7 +65,16 @@ substToCexEnv :: SInfo info -> SubcId -> Subst -> CexEnv (SubcId, info) substToCexEnv si subcid (Su sub) = benv { beBinds = binds } where benv = bs si - ibenv = senv $ cm si Map.! subcid + horn = cm si Map.! subcid + ibenv = senv horn + + -- Get the relevant bindings i.e. those that affect the outcome of the rhs. + symbols = exprSymbolsSet $ crhs horn + symRefts = Map.fromList $ clhs benv horn + relevant = dropLikelyIrrelevantBindings symbols symRefts + + -- This new substitution map contains only the relevant bindings. + sub' = Map.intersectionWith const sub relevant -- Filter out all bind ids that are not in the constraint. Then map the -- symbols back to the bind ids. @@ -70,7 +83,9 @@ substToCexEnv si subcid (Su sub) = benv { beBinds = binds } . beBinds $ benv - -- Extend the symbol with a its type and user info if possible. - trans (sym, sreft, info) = extend <$> Map.lookup sym sub + -- Extends a symbol from the bind environment with a concrete instance (and + -- the subcid, but this just there to match the type signature of `Result` + -- later down the line). + trans (sym, sreft, info) = extend <$> Map.lookup sym sub' where extend ex = (sym, sreft, (ex, (subcid, info))) diff --git a/src/Language/Fixpoint/Counterexample/Build.hs b/src/Language/Fixpoint/Counterexample/Build.hs index f1fecf47c..d6607c08d 100644 --- a/src/Language/Fixpoint/Counterexample/Build.hs +++ b/src/Language/Fixpoint/Counterexample/Build.hs @@ -134,9 +134,11 @@ hornLhsToStmts horn = do return $ mconcat stmts relevantLhs :: BindEnv info -> SimpC info -> [Binding] -relevantLhs benv horn = [(bid, sym, ref) | bid <- elemsIBindEnv ibenv, let (sym, ref, _) = lookupBindEnv bid benv] - where - ibenv = senv horn +relevantLhs benv horn = + [ (bid, sym, ref) + | bid <- elemsIBindEnv $ senv horn + , let (sym, ref, _) = lookupBindEnv bid benv + ] filterDuplicates :: [Binding] -> [Binding] filterDuplicates = foldr filter' [] diff --git a/tests/neg/obsolete-env.fq b/tests/neg/obsolete-env.fq new file mode 100644 index 000000000..3dcc4b19d --- /dev/null +++ b/tests/neg/obsolete-env.fq @@ -0,0 +1,12 @@ + +bind 0 x : {v: int | true} +bind 1 y : {v: int | v >= 0} +bind 2 unused0 : {v:int | v = 2} +bind 3 unused1 : {v:int | v = 3} +bind 4 unused2 : {v:int | v = 4} + +constraint: + env [0; 1; 2; 3; 4] + lhs {v: int | v == x + y} + rhs {v: int | v >= 0} + id 0 tag [] From 3a656bcffaa1cca568098cfbe75d374b575ea226 Mon Sep 17 00:00:00 2001 From: Robin Webbers Date: Wed, 28 Feb 2024 12:52:45 +0100 Subject: [PATCH 19/33] Split SMT interface of counterexamples from checker --- liquid-fixpoint.cabal | 1 + src/Language/Fixpoint/Counterexample/Check.hs | 136 +---------------- src/Language/Fixpoint/Counterexample/SMT.hs | 142 ++++++++++++++++++ src/Language/Fixpoint/Counterexample/Types.hs | 17 +++ tests/neg/duplicate-names2.fq | 3 +- 5 files changed, 167 insertions(+), 132 deletions(-) create mode 100644 src/Language/Fixpoint/Counterexample/SMT.hs diff --git a/liquid-fixpoint.cabal b/liquid-fixpoint.cabal index 8f8d09a35..d2b0dabed 100644 --- a/liquid-fixpoint.cabal +++ b/liquid-fixpoint.cabal @@ -58,6 +58,7 @@ library Language.Fixpoint.Counterexample Language.Fixpoint.Counterexample.Build Language.Fixpoint.Counterexample.Check + Language.Fixpoint.Counterexample.SMT Language.Fixpoint.Counterexample.Types Language.Fixpoint.Defunctionalize Language.Fixpoint.Graph diff --git a/src/Language/Fixpoint/Counterexample/Check.hs b/src/Language/Fixpoint/Counterexample/Check.hs index bf169fa71..eb288b986 100644 --- a/src/Language/Fixpoint/Counterexample/Check.hs +++ b/src/Language/Fixpoint/Counterexample/Check.hs @@ -9,18 +9,15 @@ module Language.Fixpoint.Counterexample.Check import Language.Fixpoint.Types import Language.Fixpoint.Counterexample.Types +import Language.Fixpoint.Counterexample.SMT import Language.Fixpoint.Types.Config (Config, srcFile) import Language.Fixpoint.Solver.Sanitize (symbolEnv) import qualified Language.Fixpoint.Smt.Interface as SMT import Data.Maybe (fromJust) -import Data.Char (chr) -import Data.List (find, intercalate, foldl') -import Data.Bifunctor (first) -import Data.String (IsString(..)) +import Data.List (find) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as Map -import qualified Data.Text as T import Control.Monad.State import Control.Monad.Reader @@ -38,6 +35,9 @@ data CheckEnv = CheckEnv -- ^ The maximum number of functions to traverse (to avoid state blow-up). } +instance SMTContext CheckEnv where + smtContext = context + -- | State tracked when checking a program. newtype CheckState = CheckState { depth :: Int @@ -95,22 +95,6 @@ checkConstraint cid = do Just body -> runBody scope body smtCheck Nothing -> return Nothing --- | A scope contains the current binders in place --- as well as the path traversed to reach this scope. -data Scope = Scope - { path :: ![FrameId] - -- ^ The path traversed to reach the scope. - , binders :: !Subst - -- ^ The binders available in the current scope. - } - deriving (Eq, Ord, Show) - --- | The runner is a computation path in the program. We use this --- as an argument to pass around the remainder of a computation. --- This way, we can pop paths in the SMT due to conditionals. --- Allowing us to retain anything prior to that. -type Runner m = m (Maybe SMTCounterexample) - -- | Run a function. This essentially makes one running branch for -- each body inside of the function. It will try each branch -- sequentially, returning early if a counterexample was found. @@ -194,113 +178,3 @@ getFunc :: MonadCheck m => Name -> m (Maybe Func) getFunc name = do Prog prog <- reader program return $ Map.lookup name prog - --- | Declare a new symbol, returning an updated substitution --- given with this new symbol in it. The substitution map is --- required to avoid duplicating variable names. -smtDeclare :: MonadCheck m => Scope -> Decl -> m Scope -smtDeclare scope@Scope { binders = Su binds } (Decl sym _) - | Map.member sym binds = return scope -smtDeclare scope (Decl sym sort) = do - ctx <- reader context - let sym' = scopeSym scope sym - liftIO $ SMT.smtDecl ctx sym' sort - let Su sub = binders scope - let binders' = Su $ Map.insert sym (EVar sym') sub - return scope { binders = binders' } - --- | Assume the given expression. -smtAssert :: MonadCheck m => Expr -> m () -smtAssert = smtAssume . PNot - --- | Assert the given expression. -smtAssume :: MonadCheck m => Expr -> m () -smtAssume e = do - ctx <- reader context - liftIO $ SMT.smtAssert ctx e - --- | Run the checker within a scope (i.e. a push/pop pair). -smtScope :: MonadCheck m => m a -> m a -smtScope inner = do - ctx <- reader context - liftIO $ SMT.smtPush ctx - !result <- inner - liftIO $ SMT.smtPop ctx - return result - --- | Check if there is a counterexample, returing one --- if it is available. -smtCheck :: MonadCheck m => Runner m -smtCheck = do - ctx <- reader context - valid <- liftIO $ SMT.smtCheckUnsat ctx - - if valid then return Nothing else Just <$> smtModel - --- | Returns a model, with as precondition that the SMT --- solver had a satisfying assignment prior to this. -smtModel :: MonadCheck m => m SMTCounterexample -smtModel = do - ctx <- reader context - Su sub <- liftIO $ SMT.smtGetModel ctx - - -- Filter just the variables for which we have a trace - let renames = first unscopeSym <$> Map.toList sub - let traces = [ (trace, sym, e) | (Just (sym, trace), e) <- renames ] - - -- Insert per singleton. Entries are monoidically merged when inserted. - let insert (trace, sym, e) = cexInsert trace $ Su (Map.singleton sym e) - - -- Insert all elements - let cex = foldl' (flip insert) mempty traces - return cex - --- | Returns a version of a symbol with the scope encoded into its name. -scopeSym :: Scope -> Symbol -> Symbol -scopeSym scope sym = symbol name - where - name = intercalate bindSep strs - strs = symbolString <$> progPrefix : sym : paths - paths = uncurry joinCall <$> path scope - joinCall caller callee = symbol . mconcat $ [show caller, callSep, show callee] - --- | We encode the trace of a symbol in its name. This way, --- we do not lose it in the SMT solver. This function translates --- the encoding back. -unscopeSym :: Symbol -> Maybe (Symbol, [FrameId]) -unscopeSym sym = case T.splitOn bindSep sym' of - (prefix:name:trace) | prefix == progPrefix - -> Just (symbol name, toFrameId <$> trace) - _ -> Nothing - where - toFrameId = split . T.splitOn callSep - - split [caller, callee] = (read' caller, read' callee) - split _ = error "Scoped name was not correctly shaped" - - read' :: Read a => T.Text -> a - read' = read . T.unpack - - sym' = escapeSmt . symbolText $ sym - -escapeSmt :: T.Text -> T.Text -escapeSmt = go False . T.split (=='$') - where - go _ [] = "" - go escape (t:ts) = txt t <> go (not escape) ts - where - txt | escape = T.singleton . chr . read . T.unpack - | otherwise = id - --- | The separator used to encode the stack trace (of binders) --- inside of smt symbols. -bindSep :: IsString a => a -bindSep = "@" - -callSep :: IsString a => a -callSep = "~~" - --- | Prefix used to show that this smt symbol was generated --- during a run of the program. -progPrefix :: IsString a => a -progPrefix = "prog" diff --git a/src/Language/Fixpoint/Counterexample/SMT.hs b/src/Language/Fixpoint/Counterexample/SMT.hs new file mode 100644 index 000000000..a91b5c6e7 --- /dev/null +++ b/src/Language/Fixpoint/Counterexample/SMT.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE OverloadedStrings #-} + +module Language.Fixpoint.Counterexample.SMT + ( SMTContext (..) + , smtDeclare + , smtAssert + , smtAssume + , smtScope + , smtCheck + , smtModel + ) where + +import Language.Fixpoint.Types +import Language.Fixpoint.Counterexample.Types +import qualified Language.Fixpoint.Smt.Interface as SMT + +import Control.Monad.Reader + +import qualified Data.HashMap.Strict as Map +import qualified Data.Text as T +import Data.String (IsString(..)) +import Data.Bifunctor (first) +import Data.Char (chr) +import Data.List (intercalate, foldl') + +class SMTContext a where + smtContext :: a -> SMT.Context + +type MonadSMT r m = (SMTContext r, MonadReader r m, MonadIO m) + +-- | Declare a new symbol, returning an updated substitution +-- given with this new symbol in it. The substitution map is +-- required to avoid duplicating variable names. +smtDeclare :: MonadSMT s m => Scope -> Decl -> m Scope +smtDeclare scope@Scope { binders = Su binds } (Decl sym _) + | Map.member sym binds = return scope +smtDeclare scope (Decl sym sort) = do + ctx <- reader smtContext + let sym' = scopeSym scope sym + liftIO $ SMT.smtDecl ctx sym' sort + let Su sub = binders scope + let binders' = Su $ Map.insert sym (EVar sym') sub + return scope { binders = binders' } + +-- | Assume the given expression. +smtAssert :: MonadSMT s m => Expr -> m () +smtAssert = smtAssume . PNot + +-- | Assert the given expression. +smtAssume :: MonadSMT s m => Expr -> m () +smtAssume e = do + ctx <- reader smtContext + liftIO $ SMT.smtAssert ctx e + +-- | Run the checker within a scope (i.e. a push/pop pair). +smtScope :: MonadSMT s m => m a -> m a +smtScope inner = do + ctx <- reader smtContext + liftIO $ SMT.smtPush ctx + !result <- inner + liftIO $ SMT.smtPop ctx + return result + +-- | Check if there is a counterexample, returing one +-- if it is available. +smtCheck :: MonadSMT s m => Runner m +smtCheck = do + ctx <- reader smtContext + valid <- liftIO $ SMT.smtCheckUnsat ctx + + if valid then return Nothing else Just <$> smtModel + +-- | Returns a model, with as precondition that the SMT +-- solver had a satisfying assignment prior to this. +smtModel :: MonadSMT s m => m SMTCounterexample +smtModel = do + ctx <- reader smtContext + Su sub <- liftIO $ SMT.smtGetModel ctx + + -- Filter just the variables for which we have a trace + let renames = first unscopeSym <$> Map.toList sub + let traces = [ (trace, sym, e) | (Just (sym, trace), e) <- renames ] + + -- Insert per singleton. Entries are monoidically merged when inserted. + let insert (trace, sym, e) = cexInsert trace $ Su (Map.singleton sym e) + + -- Insert all elements + let cex = foldl' (flip insert) mempty traces + return cex + +-- | Returns a version of a symbol with the scope encoded into its name. +scopeSym :: Scope -> Symbol -> Symbol +scopeSym scope sym = symbol name + where + name = intercalate bindSep strs + strs = symbolString <$> progPrefix : sym : paths + paths = uncurry joinCall <$> path scope + joinCall caller callee = symbol . mconcat $ [show caller, callSep, show callee] + +-- | We encode the trace of a symbol in its name. This way, +-- we do not lose it in the SMT solver. This function translates +-- the encoding back. +unscopeSym :: Symbol -> Maybe (Symbol, [FrameId]) +unscopeSym sym = case T.splitOn bindSep sym' of + (prefix:name:trace) | prefix == progPrefix + -> Just (symbol name, toFrameId <$> trace) + _ -> Nothing + where + toFrameId = split . T.splitOn callSep + + split [caller, callee] = (read' caller, read' callee) + split _ = error "Scoped name was not correctly shaped" + + read' :: Read a => T.Text -> a + read' = read . T.unpack + + sym' = escapeSmt . symbolText $ sym + +escapeSmt :: T.Text -> T.Text +escapeSmt = go False . T.split (=='$') + where + go _ [] = "" + go escape (t:ts) = txt t <> go (not escape) ts + where + txt | escape = T.singleton . chr . read . T.unpack + | otherwise = id + +-- | The separator used to encode the stack trace (of binders) +-- inside of smt symbols. +bindSep :: IsString a => a +bindSep = "@" + +callSep :: IsString a => a +callSep = "~~" + +-- | Prefix used to show that this smt symbol was generated +-- during a run of the program. +progPrefix :: IsString a => a +progPrefix = "prog" + diff --git a/src/Language/Fixpoint/Counterexample/Types.hs b/src/Language/Fixpoint/Counterexample/Types.hs index 609c77eba..f9ac023d6 100644 --- a/src/Language/Fixpoint/Counterexample/Types.hs +++ b/src/Language/Fixpoint/Counterexample/Types.hs @@ -9,6 +9,8 @@ module Language.Fixpoint.Counterexample.Types , cexInsert , FrameId , Trace + , Runner + , Scope (..) , Prog (..) , Name @@ -38,6 +40,21 @@ dbg = liftIO . print . pprint -- from symbol to concrete instance. type SMTCounterexample = Counterexample Subst +-- | The runner is a computation path in the program. We use this as an argument +-- to pass around the remainder of a computation. This way, we can pop paths in +-- the SMT due to conditionals. Allowing us to retain anything prior to that. +type Runner m = m (Maybe SMTCounterexample) + +-- | A scope contains the current binders in place as well as the path traversed +-- to reach this scope. +data Scope = Scope + { path :: ![FrameId] + -- ^ The path traversed to reach the scope. + , binders :: !Subst + -- ^ The binders available in the current scope. + } + deriving (Eq, Ord, Show) + -- | A program, containing multiple function definitions mapped by their name. newtype Prog = Prog (HashMap Name Func) deriving Show diff --git a/tests/neg/duplicate-names2.fq b/tests/neg/duplicate-names2.fq index 8de86ce9a..9e8f9d428 100644 --- a/tests/neg/duplicate-names2.fq +++ b/tests/neg/duplicate-names2.fq @@ -1,6 +1,7 @@ bind 0 duplicator : {v: int | $k0 && $k1} bind 1 duplicated : {v: int | v == 0} +bind 2 duplicated : {v: int | v == 1} constraint: env [1] @@ -9,7 +10,7 @@ constraint: id 0 tag [] constraint: - env [1] + env [2] lhs {v : int | v == duplicated} rhs {v : int | $k1} id 1 tag [] From f0f0967dd6e0822184f7a3b2a05ce643afcceffa Mon Sep 17 00:00:00 2001 From: Robin Webbers Date: Wed, 28 Feb 2024 13:56:12 +0100 Subject: [PATCH 20/33] Squashed calls to not incorrectly unfold multiple kvars if they were conjuncted in Counterexample checker --- src/Language/Fixpoint/Counterexample/Build.hs | 8 +++---- src/Language/Fixpoint/Counterexample/Check.hs | 19 ++++++++++------- src/Language/Fixpoint/Counterexample/SMT.hs | 10 +++++---- src/Language/Fixpoint/Counterexample/Types.hs | 21 +++++++++++-------- 4 files changed, 33 insertions(+), 25 deletions(-) diff --git a/src/Language/Fixpoint/Counterexample/Build.hs b/src/Language/Fixpoint/Counterexample/Build.hs index d6607c08d..68f0bdb0e 100644 --- a/src/Language/Fixpoint/Counterexample/Build.hs +++ b/src/Language/Fixpoint/Counterexample/Build.hs @@ -49,7 +49,7 @@ hornToProg cfg si = do , symbols = symbolEnv cfg si } - -- Run monad that adds all horn clauses + -- Run monad that adds all horn clauses to the program prog <- evalStateT (runReaderT buildProg env) initial -- Save the program in a file @@ -171,12 +171,12 @@ reftToStmts (bid, sym, RR -- Get constraints from the expression. let constraints = case predKs e of - [] -> [Assume e] - ks -> fmap (uncurry $ Call bid) ks + [] -> Assume e + ks -> Call bid ks -- Do substitution of self variable in the constraints let sub = Su $ Map.singleton v (EVar sym) - return $ decl : subst sub constraints + return [decl, subst sub constraints] -- | Get the kvars from an expression. -- diff --git a/src/Language/Fixpoint/Counterexample/Check.hs b/src/Language/Fixpoint/Counterexample/Check.hs index eb288b986..b1426ac69 100644 --- a/src/Language/Fixpoint/Counterexample/Check.hs +++ b/src/Language/Fixpoint/Counterexample/Check.hs @@ -111,10 +111,6 @@ runFunc name scope runner = do let runner' body = runBody (extendScope scope body) body runner let paths = runner' <$> bodies - -- Try paths, selecting the first that produces a counter example. - let select Nothing r = r - select cex _ = return cex - -- Check if we've reached the recursion limit. -- TODO: Perhaps we should make the recursion limit per kvar? -- TODO: We should really explore shallow trees first. Right now, @@ -124,7 +120,7 @@ runFunc name scope runner = do maxDepth' <- reader maxDepth let recursionLimit = depth' >= maxDepth' - result <- if recursionLimit then runner else foldM select Nothing paths + result <- if recursionLimit then runner else foldRunners paths -- Decrement depth after exploring this function modify $ \s -> s { depth = depth s - 1} @@ -162,11 +158,12 @@ runStatement scope stmt runner = do let runner' = runner scope let stmt' = subst (binders scope) stmt case stmt' of - Call origin name app -> do + Call origin calls -> do -- We fake a SubcId here, it will later get mapped into the scope when we -- decide which body to run. - let scope' = Scope ((origin, 0):path scope) app - runFunc name scope' runner' + let scope' app = Scope ((origin, 0):path scope) app + let runCall (name, app) = runFunc name (scope' app) runner' + foldRunners $ runCall <$> calls Assume e -> smtAssume e >> runner' Assert e -> smtAssert e >> runner' Let decl -> do @@ -178,3 +175,9 @@ getFunc :: MonadCheck m => Name -> m (Maybe Func) getFunc name = do Prog prog <- reader program return $ Map.lookup name prog + +foldRunners :: Monad m => [Runner m] -> Runner m +foldRunners = foldM select Nothing + where + select Nothing r = r + select cex _ = return cex diff --git a/src/Language/Fixpoint/Counterexample/SMT.hs b/src/Language/Fixpoint/Counterexample/SMT.hs index a91b5c6e7..9cf7d43a8 100644 --- a/src/Language/Fixpoint/Counterexample/SMT.hs +++ b/src/Language/Fixpoint/Counterexample/SMT.hs @@ -127,16 +127,18 @@ escapeSmt = go False . T.split (=='$') txt | escape = T.singleton . chr . read . T.unpack | otherwise = id --- | The separator used to encode the stack trace (of binders) --- inside of smt symbols. +-- | The separator used to encode the stack trace (of binders) inside of smt +-- symbols. bindSep :: IsString a => a bindSep = "@" +-- | The separator used to separate the caller from the callee inside of a +-- single stack frame of the stack trace. callSep :: IsString a => a callSep = "~~" --- | Prefix used to show that this smt symbol was generated --- during a run of the program. +-- | Prefix used to show that this smt symbol was generated during a run of +-- the program. progPrefix :: IsString a => a progPrefix = "prog" diff --git a/src/Language/Fixpoint/Counterexample/Types.hs b/src/Language/Fixpoint/Counterexample/Types.hs index f9ac023d6..b0cd3c5fd 100644 --- a/src/Language/Fixpoint/Counterexample/Types.hs +++ b/src/Language/Fixpoint/Counterexample/Types.hs @@ -1,5 +1,4 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE DeriveFunctor #-} module Language.Fixpoint.Counterexample.Types ( Counterexample (..) @@ -27,6 +26,7 @@ module Language.Fixpoint.Counterexample.Types import Language.Fixpoint.Types import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as Map +import Data.Bifunctor (second) import Text.PrettyPrint.HughesPJ ((<+>), ($+$)) import qualified Text.PrettyPrint.HughesPJ as PP @@ -83,7 +83,7 @@ data Statement -- ^ Constraints a variable. | Assert !Expr -- ^ Checks whether a predicate follows given prior constraints. - | Call !BindId !Name !Subst + | Call !BindId ![(Name, Subst)] -- ^ Call to function. The bind id is used to trace callstacks. I.e. it is the -- caller of the function. deriving Show @@ -145,32 +145,35 @@ instance PPrint Statement where pprintTidy tidy (Let decl) = "let" <+> pprintTidy tidy decl pprintTidy tidy (Assume exprs) = "assume" <+> pprintTidy tidy exprs pprintTidy tidy (Assert exprs) = "assert" <+> pprintTidy tidy exprs - pprintTidy tidy (Call bid name sub) = pname <+> pargs <+> porigin + pprintTidy tidy (Call bid calls) = "call" <+> porigin $+$ pcalls where - pname = pprintTidy tidy name - pargs = pprintTidy tidy sub porigin = "// bind id" <+> pprintTidy tidy bid + pcalls = PP.vcat $ PP.nest 4 . pcall <$> calls + pcall (name, sub) = pprintTidy tidy name <+> pprintTidy tidy sub instance Subable Statement where syms (Let decl) = syms decl syms (Assume e) = syms e syms (Assert e) = syms e - syms (Call _ _ (Su sub)) = syms sub + syms (Call _ calls) = mconcat $ syms . (\(Su sub) -> sub) . snd <$> calls substa _ (Let decl) = Let decl substa f (Assume e) = Assume $ substa f e substa f (Assert e) = Assert $ substa f e - substa f (Call bid name (Su sub)) = Call bid name (Su $ substa f sub) + substa f (Call bid calls) = Call bid $ mapsub (substa f) <$> calls substf _ (Let decl) = Let decl substf f (Assume e) = Assume $ substf f e substf f (Assert e) = Assert $ substf f e - substf f (Call bid name (Su sub)) = Call bid name (Su $ substf f sub) + substf f (Call bid calls) = Call bid (mapsub (substf f) <$> calls) subst _ (Let decl) = Let decl subst sub (Assume e) = Assume $ subst sub e subst sub (Assert e) = Assert $ subst sub e - subst sub (Call bid name (Su sub')) = Call bid name (Su $ subst sub sub') + subst sub (Call bid calls) = Call bid (mapsub (subst sub) <$> calls) + +mapsub :: (HashMap Symbol Expr -> HashMap Symbol Expr) -> (a, Subst) -> (a, Subst) +mapsub f = second (\(Su sub) -> Su $ f sub) instance Subable Decl where syms (Decl sym _) = [sym] From bca82083d1ea7a6257252a47622387bd56cafdbf Mon Sep 17 00:00:00 2001 From: Robin Webbers Date: Thu, 7 Mar 2024 14:20:53 +0100 Subject: [PATCH 21/33] Changed counterexample SMT scope to just include top level subcid. Added JSON output for Counterexample --- liquid-fixpoint.cabal | 1 + src/Language/Fixpoint/Counterexample.hs | 16 +- src/Language/Fixpoint/Counterexample/Build.hs | 3 +- src/Language/Fixpoint/Counterexample/Check.hs | 23 +-- src/Language/Fixpoint/Counterexample/JSON.hs | 141 ++++++++++++++++++ src/Language/Fixpoint/Counterexample/SMT.hs | 66 ++++---- src/Language/Fixpoint/Counterexample/Types.hs | 5 +- src/Language/Fixpoint/Types/Constraints.hs | 26 ++-- src/Language/Fixpoint/Utils/Files.hs | 2 + 9 files changed, 214 insertions(+), 69 deletions(-) create mode 100644 src/Language/Fixpoint/Counterexample/JSON.hs diff --git a/liquid-fixpoint.cabal b/liquid-fixpoint.cabal index d2b0dabed..b137e1a5d 100644 --- a/liquid-fixpoint.cabal +++ b/liquid-fixpoint.cabal @@ -58,6 +58,7 @@ library Language.Fixpoint.Counterexample Language.Fixpoint.Counterexample.Build Language.Fixpoint.Counterexample.Check + Language.Fixpoint.Counterexample.JSON Language.Fixpoint.Counterexample.SMT Language.Fixpoint.Counterexample.Types Language.Fixpoint.Defunctionalize diff --git a/src/Language/Fixpoint/Counterexample.hs b/src/Language/Fixpoint/Counterexample.hs index 9b5003c2f..a6854e80c 100644 --- a/src/Language/Fixpoint/Counterexample.hs +++ b/src/Language/Fixpoint/Counterexample.hs @@ -7,6 +7,7 @@ module Language.Fixpoint.Counterexample ) where import Language.Fixpoint.Types +import Language.Fixpoint.Counterexample.JSON (jsonCex) import Language.Fixpoint.Types.Config (Config, counterExample) import Language.Fixpoint.Solver.EnvironmentReduction (dropLikelyIrrelevantBindings) @@ -17,6 +18,7 @@ import Language.Fixpoint.Counterexample.Check import qualified Data.HashMap.Strict as Map import Control.Monad.IO.Class +import Control.Monad (forM_) -- TODO: Remove variables from the counter example that got mapped to -- the "wrong" type in smt format (e.g. to an int while not being one). @@ -44,18 +46,22 @@ tryCounterExample cfg si res@Result let cids = fst <$> cids' smtcex <- checkProg cfg si prog cids - -- Map the symbols in this substitution to their respective bind id - let cexs = Map.mapWithKey (toFullCex si) smtcex + -- Extend the smt counterexample to include additional bind info + let cexs = toFullCex si <$> smtcex + + -- Store the counterexamples as JSON + forM_ cexs $ jsonCex cfg si dbg $ (fmap . fmap . fmap . fmap $ toFix) <$> cexs return res { resCounterexamples = cexs <> cexs' } tryCounterExample _ _ res = return res -- | Extend an SMT counterexample to a full counterexample. -toFullCex :: SInfo info -> SubcId -> SMTCounterexample -> FullCounterexample (SubcId, info) -toFullCex si subcid (Counterexample env trace) = Counterexample +toFullCex :: SInfo info -> SMTCounterexample -> FullCounterexample (SubcId, info) +toFullCex si (Counterexample env subcid trace) = Counterexample { cexEnv = substToCexEnv si subcid env - , cexFrames = Map.mapWithKey (toFullCex si . snd) trace + , cexConstraint = subcid + , cexFrames = toFullCex si <$> trace } -- | Extend an SMT counterexample environment (i.e. the substitution map) to a diff --git a/src/Language/Fixpoint/Counterexample/Build.hs b/src/Language/Fixpoint/Counterexample/Build.hs index 68f0bdb0e..8392ab49f 100644 --- a/src/Language/Fixpoint/Counterexample/Build.hs +++ b/src/Language/Fixpoint/Counterexample/Build.hs @@ -15,7 +15,6 @@ import Language.Fixpoint.Misc (ensurePath) import Language.Fixpoint.SortCheck (elaborate) import qualified Language.Fixpoint.Utils.Files as Ext -import qualified Text.PrettyPrint.HughesPJ as PP import Data.Maybe (fromMaybe) import qualified Data.HashMap.Strict as Map @@ -56,7 +55,7 @@ hornToProg cfg si = do liftIO . when (save cfg) $ do let file = queryFile Ext.Prog cfg ensurePath file - writeFile file $ PP.render (pprint prog) + writeFile file . show . pprint $ prog -- Return the generated program return prog diff --git a/src/Language/Fixpoint/Counterexample/Check.hs b/src/Language/Fixpoint/Counterexample/Check.hs index b1426ac69..f77278be9 100644 --- a/src/Language/Fixpoint/Counterexample/Check.hs +++ b/src/Language/Fixpoint/Counterexample/Check.hs @@ -14,17 +14,13 @@ import Language.Fixpoint.Types.Config (Config, srcFile) import Language.Fixpoint.Solver.Sanitize (symbolEnv) import qualified Language.Fixpoint.Smt.Interface as SMT -import Data.Maybe (fromJust) +import Data.Maybe (fromJust, catMaybes) import Data.List (find) -import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as Map import Control.Monad.State import Control.Monad.Reader --- | Multiple counter examples indexed per constraint id. -type SMTCounterexamples = HashMap SubcId SMTCounterexample - -- | Environment for the counter example generation. data CheckEnv = CheckEnv { program :: !Prog @@ -48,7 +44,7 @@ newtype CheckState = CheckState type MonadCheck m = (MonadReader CheckEnv m, MonadState CheckState m, MonadIO m) -- | Check the given constraints to try and find a counter example. -checkProg :: MonadIO m => Config -> SInfo info -> Prog -> [SubcId] -> m SMTCounterexamples +checkProg :: MonadIO m => Config -> SInfo info -> Prog -> [SubcId] -> m [SMTCounterexample] checkProg cfg si prog cids = withContext cfg si check where check ctx = runCheck cids CheckEnv @@ -71,17 +67,17 @@ withContext cfg si inner = do -- | Runs the program checker with the monad stack -- unwrapped. -runCheck :: MonadIO m => [SubcId] -> CheckEnv -> m SMTCounterexamples +runCheck :: MonadIO m => [SubcId] -> CheckEnv -> m [SMTCounterexample] runCheck cids env = rd . st $ checkAll cids where st = flip evalStateT $ CheckState 0 rd = flip runReaderT env -- | Try to find a counter example for all the given constraints. -checkAll :: MonadCheck m => [SubcId] -> m SMTCounterexamples +checkAll :: MonadCheck m => [SubcId] -> m [SMTCounterexample] checkAll cids = do cexs <- forM cids checkConstraint - return $ Map.fromList [(cid, cex) | (cid, Just cex) <- zip cids cexs] + return $ catMaybes cexs -- | Check a specific constraint id. This will only do actual -- checks for constraints without a KVar on the rhs, as we cannot @@ -90,7 +86,7 @@ checkConstraint :: MonadCheck m => SubcId -> m (Maybe SMTCounterexample) checkConstraint cid = do Func _ bodies <- fromJust <$> getFunc mainName let cmp (Body bid _) = bid == cid - let scope = Scope mempty mempty + let scope = Scope mempty cid mempty case find cmp bodies of Just body -> runBody scope body smtCheck Nothing -> return Nothing @@ -128,10 +124,7 @@ runFunc name scope runner = do -- | Extend the scope to include the id of the body, i.e. the `SubcId`. extendScope :: Scope -> Body -> Scope -extendScope scope (Body bodyId _) = withSubcId scope - where - withSubcId scope'@Scope { path = (bindId,_):ps } = scope' { path = (bindId, bodyId):ps } - withSubcId _ = error "No scope to extend." +extendScope scope (Body cid _) = scope { constraint = cid } -- | Run the statements in the body. If there are no more statements to run, -- this will execute the Runner that was passed as argument. @@ -161,7 +154,7 @@ runStatement scope stmt runner = do Call origin calls -> do -- We fake a SubcId here, it will later get mapped into the scope when we -- decide which body to run. - let scope' app = Scope ((origin, 0):path scope) app + let scope' app = Scope (origin:path scope) 0 app let runCall (name, app) = runFunc name (scope' app) runner' foldRunners $ runCall <$> calls Assume e -> smtAssume e >> runner' diff --git a/src/Language/Fixpoint/Counterexample/JSON.hs b/src/Language/Fixpoint/Counterexample/JSON.hs new file mode 100644 index 000000000..b916d9ad4 --- /dev/null +++ b/src/Language/Fixpoint/Counterexample/JSON.hs @@ -0,0 +1,141 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +module Language.Fixpoint.Counterexample.JSON + ( Symbol + , Refinement + , Expr + , Path + , Span (..) + , Location (..) + , Variable (..) + , Constraint (..) + , Counterexample (..) + , formatCex + , jsonCex + ) where + +import qualified Language.Fixpoint.Utils.Files as Ext +import qualified Language.Fixpoint.Types as F +import qualified Language.Fixpoint.Misc as F +import qualified Language.Fixpoint.Types.Config as F +import GHC.Generics (Generic) +import Data.Aeson (FromJSON, ToJSON, encodeFile) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.HashMap.Strict as Map + +import Control.Monad.IO.Class + +data Counterexample = Counterexample + { environment :: ![Variable] + , constraint :: !Constraint + } deriving (Generic, Show) + +instance FromJSON Counterexample +instance ToJSON Counterexample + +data Variable = Variable + { symbol :: !Symbol + , expression :: !Expr + , refinement :: !Refinement + , must_instance :: !(Maybe Counterexample) + , location :: !(Maybe Location) + } deriving (Generic, Show) + +instance FromJSON Variable +instance ToJSON Variable + +data Constraint = Constraint + { concrete :: !Expr + , synthesized :: !Refinement + , required :: !Refinement + , location :: !(Maybe Location) + } deriving (Generic, Show) + +instance FromJSON Constraint +instance ToJSON Constraint + +data Location = Location + { span :: !Span + , path :: !Path + } deriving (Generic, Show) + +instance FromJSON Location +instance ToJSON Location + +data Span = Span + { start :: !Int + , length :: !Int + } deriving (Generic, Show) + +instance FromJSON Span +instance ToJSON Span + +type Symbol = Text +type Refinement = Text +type Expr = Text +type Path = Text + +jsonCex :: MonadIO m => F.Config -> F.SInfo info -> F.FullCounterexample a -> m () +jsonCex cfg si cex | F.save cfg = liftIO $ do + let cex' = formatCex si cex + let ext = Ext.Cex . fromIntegral . F.cexConstraint $ cex + let file = F.queryFile ext cfg + F.ensurePath file + encodeFile file cex' +jsonCex _ _ _ = return () + +formatCex :: F.SInfo info -> F.FullCounterexample a -> Counterexample +formatCex si cex = Counterexample + { environment = formatEnv si cex + , constraint = formatConstraint si cex + } + +formatEnv :: F.SInfo info -> F.FullCounterexample a -> [Variable] +formatEnv si cex = formatVar <$> vars + where + vars = Map.toList . F.beBinds . F.cexEnv $ cex + + formatVar (bid, (sym, synth, (conc, _a))) = Variable + { symbol = ppFormat sym + , expression = formatConcrete synth conc + , refinement = ppFormat synth + , must_instance = must + , location = Nothing + } + where + must = formatCex si <$> F.cexFrames cex Map.!? bid + +formatConstraint :: F.SInfo info -> F.FullCounterexample a -> Constraint +formatConstraint si cex = Constraint + { concrete = formatConcrete csynth cconcrete + , synthesized = ppFormat csynth + , required = ppFormat ccheck + , location = Nothing + } + where + cheadId = F.cbind horn + horn = F.cm si Map.! F.cexConstraint cex + binds = F.beBinds . F.cexEnv $ cex + + -- Get the head of the constraint. + (_csym, csynth, (cconcrete, _a)) = binds Map.! cheadId + + -- Get checked expr + cexpr = F.crhs horn + ccheck = withExpr csynth cexpr + +formatConcrete :: F.SortedReft -> F.Expr -> Text +formatConcrete sr e = ppFormat sort <> "[" <> ppFormat e <> "]" + where + sort = F.sr_sort sr + +withExpr :: F.SortedReft -> F.Expr -> F.SortedReft +withExpr sr e = sr { F.sr_reft = F.Reft (sort, e) } + where + F.Reft (sort, _) = F.sr_reft sr + +ppFormat :: F.PPrint a => a -> Text +ppFormat = T.pack . show . F.pprint diff --git a/src/Language/Fixpoint/Counterexample/SMT.hs b/src/Language/Fixpoint/Counterexample/SMT.hs index 9cf7d43a8..314dd12b7 100644 --- a/src/Language/Fixpoint/Counterexample/SMT.hs +++ b/src/Language/Fixpoint/Counterexample/SMT.hs @@ -20,6 +20,7 @@ import Control.Monad.Reader import qualified Data.HashMap.Strict as Map import qualified Data.Text as T +import Text.Read (readMaybe) import Data.String (IsString(..)) import Data.Bifunctor (first) import Data.Char (chr) @@ -44,11 +45,11 @@ smtDeclare scope (Decl sym sort) = do let binders' = Su $ Map.insert sym (EVar sym') sub return scope { binders = binders' } --- | Assume the given expression. +-- | Assert the given expression. smtAssert :: MonadSMT s m => Expr -> m () smtAssert = smtAssume . PNot --- | Assert the given expression. +-- | Assume the given expression. smtAssume :: MonadSMT s m => Expr -> m () smtAssume e = do ctx <- reader smtContext @@ -81,10 +82,10 @@ smtModel = do -- Filter just the variables for which we have a trace let renames = first unscopeSym <$> Map.toList sub - let traces = [ (trace, sym, e) | (Just (sym, trace), e) <- renames ] + let traces = [ (trace, (cid, sym, e)) | (Just (sym, cid, trace), e) <- renames ] -- Insert per singleton. Entries are monoidically merged when inserted. - let insert (trace, sym, e) = cexInsert trace $ Su (Map.singleton sym e) + let insert (trace, (cid, sym, e)) = cexInsert trace (cid, Su (Map.singleton sym e)) -- Insert all elements let cex = foldl' (flip insert) mempty traces @@ -95,48 +96,49 @@ scopeSym :: Scope -> Symbol -> Symbol scopeSym scope sym = symbol name where name = intercalate bindSep strs - strs = symbolString <$> progPrefix : sym : paths - paths = uncurry joinCall <$> path scope - joinCall caller callee = symbol . mconcat $ [show caller, callSep, show callee] + strs = symbolString <$> progPrefix : sym : cid : paths + cid = symbol . show . constraint $ scope + paths = symbol . show <$> path scope -- | We encode the trace of a symbol in its name. This way, -- we do not lose it in the SMT solver. This function translates -- the encoding back. -unscopeSym :: Symbol -> Maybe (Symbol, [FrameId]) -unscopeSym sym = case T.splitOn bindSep sym' of - (prefix:name:trace) | prefix == progPrefix - -> Just (symbol name, toFrameId <$> trace) - _ -> Nothing - where - toFrameId = split . T.splitOn callSep - - split [caller, callee] = (read' caller, read' callee) - split _ = error "Scoped name was not correctly shaped" - - read' :: Read a => T.Text -> a - read' = read . T.unpack - - sym' = escapeSmt . symbolText $ sym - -escapeSmt :: T.Text -> T.Text +unscopeSym :: Symbol -> Maybe (Symbol, SubcId, [BindId]) +unscopeSym sym = do + -- Remove the escape tokens from the SMT formatted symbol + sym' <- escapeSmt . symbolText $ sym + + -- Check if it is in the program form + (name, cid, trace) <- case T.splitOn bindSep sym' of + (prefix:name:cid:trace) -> do + guard $ prefix == progPrefix + return (name, cid, trace) + _ -> Nothing + + let read' :: Read a => T.Text -> Maybe a + read' = readMaybe . T.unpack + + -- Try to parse the trace and constraint id + trace' <- sequence $ read' <$> trace + cid' <- read' cid + return (symbol name, cid', trace') + +-- | Remove escape tokens applied to the input string when it was formatted to +-- SMT string. +escapeSmt :: T.Text -> Maybe T.Text escapeSmt = go False . T.split (=='$') where - go _ [] = "" + go _ [] = return "" go escape (t:ts) = txt t <> go (not escape) ts where - txt | escape = T.singleton . chr . read . T.unpack - | otherwise = id + txt | escape = readMaybe . T.unpack >=> return . T.singleton . chr + | otherwise = return -- | The separator used to encode the stack trace (of binders) inside of smt -- symbols. bindSep :: IsString a => a bindSep = "@" --- | The separator used to separate the caller from the callee inside of a --- single stack frame of the stack trace. -callSep :: IsString a => a -callSep = "~~" - -- | Prefix used to show that this smt symbol was generated during a run of -- the program. progPrefix :: IsString a => a diff --git a/src/Language/Fixpoint/Counterexample/Types.hs b/src/Language/Fixpoint/Counterexample/Types.hs index b0cd3c5fd..0e452e0e9 100644 --- a/src/Language/Fixpoint/Counterexample/Types.hs +++ b/src/Language/Fixpoint/Counterexample/Types.hs @@ -6,7 +6,6 @@ module Language.Fixpoint.Counterexample.Types , FullCounterexample , CexEnv , cexInsert - , FrameId , Trace , Runner , Scope (..) @@ -48,8 +47,10 @@ type Runner m = m (Maybe SMTCounterexample) -- | A scope contains the current binders in place as well as the path traversed -- to reach this scope. data Scope = Scope - { path :: ![FrameId] + { path :: ![BindId] -- ^ The path traversed to reach the scope. + , constraint :: !SubcId + -- ^ The current constraint, which dictates the binders. , binders :: !Subst -- ^ The binders available in the current scope. } diff --git a/src/Language/Fixpoint/Types/Constraints.hs b/src/Language/Fixpoint/Types/Constraints.hs index cbaf1d698..abb965872 100644 --- a/src/Language/Fixpoint/Types/Constraints.hs +++ b/src/Language/Fixpoint/Types/Constraints.hs @@ -64,7 +64,6 @@ module Language.Fixpoint.Types.Constraints ( , Counterexample (..) , FullCounterexample , Trace - , FrameId , cexInsert , FixSolution @@ -272,41 +271,42 @@ subcId = mfromJust "subCId" . sid data Counterexample a = Counterexample { cexEnv :: !a -- ^ The environment in the current stack frame. - , cexFrames :: !(M.HashMap FrameId (Counterexample a)) + , cexConstraint :: !SubcId + -- ^ The constraint which the environment belongs to. + , cexFrames :: !(M.HashMap BindId (Counterexample a)) -- ^ The counterexamples stack frames that can be explored from the current -- environment. } deriving (Generic, Show, Functor) instance PPrint a => PPrint (Counterexample a) where - pprintTidy tidy (Counterexample env trace) = penv $+$ ptrace + pprintTidy tidy (Counterexample env cid trace) = pcid $+$ penv $+$ ptrace where + pcid = "in constraint" <+> pprintTidy tidy cid penv = pprintTidy tidy env ptrace = pprintTidy tidy trace instance Semigroup a => Semigroup (Counterexample a) where lhs <> rhs = Counterexample { cexEnv = cexEnv lhs <> cexEnv rhs + , cexConstraint = cexConstraint rhs , cexFrames = M.unionWith (<>) (cexFrames lhs) (cexFrames rhs) } instance Monoid a => Monoid (Counterexample a) where - mempty = Counterexample mempty mempty + mempty = Counterexample mempty 0 mempty -- | Monoidically add an element to a counterexample. -cexInsert :: Monoid a => Trace -> a -> Counterexample a -> Counterexample a -cexInsert trace v cex = cex <> go trace +cexInsert :: Monoid a => Trace -> (SubcId, a) -> Counterexample a -> Counterexample a +cexInsert trace (cid, v) cex = cex <> go trace where - go (f:fs) = Counterexample mempty $ M.singleton f (go fs) - go [] = Counterexample v mempty + go (f:fs) = Counterexample mempty cid $ M.singleton f (go fs) + go [] = Counterexample v cid mempty -- | A stack trace is built from multiple frame ids. This is mostly used for -- SMT encodings. These traces are made into a tree like representation in the -- actual counterexample object. -type Trace = [FrameId] - --- | An identfier for a "stack frame" in a counterexample. -type FrameId = (BindId, SubcId) +type Trace = [BindId] -- | A counterexample that was extended with additional information from the -- environment. It additionally includes types, bind ids and user info, aside @@ -328,7 +328,7 @@ data Result a = Result , resSolution :: !FixSolution , resNonCutsSolution :: !FixSolution , gresSolution :: !GFixSolution - , resCounterexamples :: !(M.HashMap SubcId (FullCounterexample a)) + , resCounterexamples :: ![FullCounterexample a] } deriving (Generic, Show, Functor) diff --git a/src/Language/Fixpoint/Utils/Files.hs b/src/Language/Fixpoint/Utils/Files.hs index b4c751249..8622665a5 100644 --- a/src/Language/Fixpoint/Utils/Files.hs +++ b/src/Language/Fixpoint/Utils/Files.hs @@ -90,6 +90,7 @@ data Ext = Cgi -- ^ Constraint Generation Information | Dat | BinFq -- ^ Binary representation of .fq / FInfo | Prog -- ^ Program file (counter example generation) + | Cex !Int -- ^ Counterexample JSON file (for external explorer) | Smt2 -- ^ SMTLIB2 query file | HSmt2 -- ^ Horn query file | Min -- ^ filter constraints with delta debug @@ -123,6 +124,7 @@ extMap = go go Result = ".out" go Saved = ".bak" go Cache = ".err" + go (Cex n) = ".cex." <> show n <> ".json" go Prog = ".prog" go Smt2 = ".smt2" go HSmt2 = ".horn.smt2" From 2852c278974c6bb421a8977ca6a3d265d765cb3d Mon Sep 17 00:00:00 2001 From: Robin Webbers Date: Fri, 8 Mar 2024 12:20:50 +0100 Subject: [PATCH 22/33] Solved issue where counterexamples were not correctly inserted. Solved issue where head constraint was removed from the environment. --- src/Language/Fixpoint/Counterexample.hs | 11 +++-- src/Language/Fixpoint/Counterexample/JSON.hs | 16 +++---- src/Language/Fixpoint/Counterexample/SMT.hs | 44 +++++++++++++------ src/Language/Fixpoint/Counterexample/Types.hs | 8 +++- src/Language/Fixpoint/Types/Constraints.hs | 24 ---------- tests/neg/false.fq | 5 +++ 6 files changed, 53 insertions(+), 55 deletions(-) create mode 100644 tests/neg/false.fq diff --git a/src/Language/Fixpoint/Counterexample.hs b/src/Language/Fixpoint/Counterexample.hs index a6854e80c..8c830bb1a 100644 --- a/src/Language/Fixpoint/Counterexample.hs +++ b/src/Language/Fixpoint/Counterexample.hs @@ -51,8 +51,6 @@ tryCounterExample cfg si res@Result -- Store the counterexamples as JSON forM_ cexs $ jsonCex cfg si - - dbg $ (fmap . fmap . fmap . fmap $ toFix) <$> cexs return res { resCounterexamples = cexs <> cexs' } tryCounterExample _ _ res = return res @@ -74,10 +72,15 @@ substToCexEnv si subcid (Su sub) = benv { beBinds = binds } horn = cm si Map.! subcid ibenv = senv horn - -- Get the relevant bindings i.e. those that affect the outcome of the rhs. + -- The constraint head symbol and refinement + (csym, creft, _) = beBinds benv Map.! cbind horn + symbols = exprSymbolsSet $ crhs horn symRefts = Map.fromList $ clhs benv horn - relevant = dropLikelyIrrelevantBindings symbols symRefts + -- Make sure the rhs is always in the relevant set! + relevant = Map.insert csym creft + -- Get the relevant bindings i.e. those that affect the outcome of the rhs. + $ dropLikelyIrrelevantBindings symbols symRefts -- This new substitution map contains only the relevant bindings. sub' = Map.intersectionWith const sub relevant diff --git a/src/Language/Fixpoint/Counterexample/JSON.hs b/src/Language/Fixpoint/Counterexample/JSON.hs index b916d9ad4..acb0ef0cd 100644 --- a/src/Language/Fixpoint/Counterexample/JSON.hs +++ b/src/Language/Fixpoint/Counterexample/JSON.hs @@ -100,7 +100,7 @@ formatEnv si cex = formatVar <$> vars formatVar (bid, (sym, synth, (conc, _a))) = Variable { symbol = ppFormat sym - , expression = formatConcrete synth conc + , expression = ppFormat conc , refinement = ppFormat synth , must_instance = must , location = Nothing @@ -110,7 +110,7 @@ formatEnv si cex = formatVar <$> vars formatConstraint :: F.SInfo info -> F.FullCounterexample a -> Constraint formatConstraint si cex = Constraint - { concrete = formatConcrete csynth cconcrete + { concrete = ppFormat cconcrete , synthesized = ppFormat csynth , required = ppFormat ccheck , location = Nothing @@ -127,15 +127,9 @@ formatConstraint si cex = Constraint cexpr = F.crhs horn ccheck = withExpr csynth cexpr -formatConcrete :: F.SortedReft -> F.Expr -> Text -formatConcrete sr e = ppFormat sort <> "[" <> ppFormat e <> "]" - where - sort = F.sr_sort sr - -withExpr :: F.SortedReft -> F.Expr -> F.SortedReft -withExpr sr e = sr { F.sr_reft = F.Reft (sort, e) } - where - F.Reft (sort, _) = F.sr_reft sr + withExpr sr e = sr { F.sr_reft = F.Reft (sort, e) } + where + F.Reft (sort, _) = F.sr_reft sr ppFormat :: F.PPrint a => a -> Text ppFormat = T.pack . show . F.pprint diff --git a/src/Language/Fixpoint/Counterexample/SMT.hs b/src/Language/Fixpoint/Counterexample/SMT.hs index 314dd12b7..e0178ea7a 100644 --- a/src/Language/Fixpoint/Counterexample/SMT.hs +++ b/src/Language/Fixpoint/Counterexample/SMT.hs @@ -35,8 +35,6 @@ type MonadSMT r m = (SMTContext r, MonadReader r m, MonadIO m) -- given with this new symbol in it. The substitution map is -- required to avoid duplicating variable names. smtDeclare :: MonadSMT s m => Scope -> Decl -> m Scope -smtDeclare scope@Scope { binders = Su binds } (Decl sym _) - | Map.member sym binds = return scope smtDeclare scope (Decl sym sort) = do ctx <- reader smtContext let sym' = scopeSym scope sym @@ -78,18 +76,36 @@ smtCheck = do smtModel :: MonadSMT s m => m SMTCounterexample smtModel = do ctx <- reader smtContext - Su sub <- liftIO $ SMT.smtGetModel ctx + sub <- liftIO $ SMT.smtGetModel ctx + return $ smtSubstToCex sub - -- Filter just the variables for which we have a trace - let renames = first unscopeSym <$> Map.toList sub - let traces = [ (trace, (cid, sym, e)) | (Just (sym, cid, trace), e) <- renames ] - - -- Insert per singleton. Entries are monoidically merged when inserted. - let insert (trace, (cid, sym, e)) = cexInsert trace (cid, Su (Map.singleton sym e)) - - -- Insert all elements - let cex = foldl' (flip insert) mempty traces - return cex +-- | Transform an SMT substitution, which contains SMT scoped symbols, into +-- a layered, tree-like counterexample. +smtSubstToCex :: Subst -> SMTCounterexample +smtSubstToCex (Su sub) = foldl' (flip $ uncurry insertCex) dummyCex traces + where + -- | Unwind SMT names. + renames = first unscopeSym <$> Map.toList sub + + -- | Keep just the ones that were introduced by the counterexample checker. + traces = [ (k, e) | (Just k, e) <- renames ] + + -- | A dummy counterexample to fill empty entries on insertion + dummyCex = Counterexample mempty 0 mempty + + -- | Insert a scoped name with its expression into the SMT counterexample + insertCex (sym, cid, trace) e = go $ reverse trace + where + go :: Trace -> SMTCounterexample -> SMTCounterexample + go (t:ts) cex = cex + { cexFrames = Map.insertWith (const $ go ts) t dummyCex $ cexFrames cex + } + go _ cex@Counterexample + { cexEnv = Su su + } = cex + { cexConstraint = cid + , cexEnv = Su . Map.insert sym e $ su + } -- | Returns a version of a symbol with the scope encoded into its name. scopeSym :: Scope -> Symbol -> Symbol @@ -103,7 +119,7 @@ scopeSym scope sym = symbol name -- | We encode the trace of a symbol in its name. This way, -- we do not lose it in the SMT solver. This function translates -- the encoding back. -unscopeSym :: Symbol -> Maybe (Symbol, SubcId, [BindId]) +unscopeSym :: Symbol -> Maybe (Symbol, SubcId, Trace) unscopeSym sym = do -- Remove the escape tokens from the SMT formatted symbol sym' <- escapeSmt . symbolText $ sym diff --git a/src/Language/Fixpoint/Counterexample/Types.hs b/src/Language/Fixpoint/Counterexample/Types.hs index 0e452e0e9..81ac6f694 100644 --- a/src/Language/Fixpoint/Counterexample/Types.hs +++ b/src/Language/Fixpoint/Counterexample/Types.hs @@ -5,7 +5,6 @@ module Language.Fixpoint.Counterexample.Types , SMTCounterexample , FullCounterexample , CexEnv - , cexInsert , Trace , Runner , Scope (..) @@ -47,7 +46,7 @@ type Runner m = m (Maybe SMTCounterexample) -- | A scope contains the current binders in place as well as the path traversed -- to reach this scope. data Scope = Scope - { path :: ![BindId] + { path :: !Trace -- ^ The path traversed to reach the scope. , constraint :: !SubcId -- ^ The current constraint, which dictates the binders. @@ -56,6 +55,11 @@ data Scope = Scope } deriving (Eq, Ord, Show) +-- | A stack trace is built from multiple frame ids. This is mostly used for +-- SMT encodings. These traces are made into a tree like representation in the +-- actual counterexample object. +type Trace = [BindId] + -- | A program, containing multiple function definitions mapped by their name. newtype Prog = Prog (HashMap Name Func) deriving Show diff --git a/src/Language/Fixpoint/Types/Constraints.hs b/src/Language/Fixpoint/Types/Constraints.hs index abb965872..70c5c5dcc 100644 --- a/src/Language/Fixpoint/Types/Constraints.hs +++ b/src/Language/Fixpoint/Types/Constraints.hs @@ -63,8 +63,6 @@ module Language.Fixpoint.Types.Constraints ( -- * Results , Counterexample (..) , FullCounterexample - , Trace - , cexInsert , FixSolution , GFixSolution, toGFixSol @@ -286,28 +284,6 @@ instance PPrint a => PPrint (Counterexample a) where penv = pprintTidy tidy env ptrace = pprintTidy tidy trace -instance Semigroup a => Semigroup (Counterexample a) where - lhs <> rhs = Counterexample - { cexEnv = cexEnv lhs <> cexEnv rhs - , cexConstraint = cexConstraint rhs - , cexFrames = M.unionWith (<>) (cexFrames lhs) (cexFrames rhs) - } - -instance Monoid a => Monoid (Counterexample a) where - mempty = Counterexample mempty 0 mempty - --- | Monoidically add an element to a counterexample. -cexInsert :: Monoid a => Trace -> (SubcId, a) -> Counterexample a -> Counterexample a -cexInsert trace (cid, v) cex = cex <> go trace - where - go (f:fs) = Counterexample mempty cid $ M.singleton f (go fs) - go [] = Counterexample v cid mempty - --- | A stack trace is built from multiple frame ids. This is mostly used for --- SMT encodings. These traces are made into a tree like representation in the --- actual counterexample object. -type Trace = [BindId] - -- | A counterexample that was extended with additional information from the -- environment. It additionally includes types, bind ids and user info, aside -- from what is already provided from an `SMTCounterexample`. diff --git a/tests/neg/false.fq b/tests/neg/false.fq new file mode 100644 index 000000000..3b9ecb2e6 --- /dev/null +++ b/tests/neg/false.fq @@ -0,0 +1,5 @@ +constraint: + env [] + lhs {v : int | true} + rhs {v : int | false} + id 0 tag [] From 3b43016057ff538a6d6731a46a281f86fe58de98 Mon Sep 17 00:00:00 2001 From: Robin Webbers Date: Thu, 14 Mar 2024 14:30:20 +0100 Subject: [PATCH 23/33] Used internal location information for producing spans in a counterexample --- src/Language/Fixpoint/Counterexample.hs | 2 +- src/Language/Fixpoint/Counterexample/JSON.hs | 186 ++++++++++++++----- 2 files changed, 136 insertions(+), 52 deletions(-) diff --git a/src/Language/Fixpoint/Counterexample.hs b/src/Language/Fixpoint/Counterexample.hs index 8c830bb1a..485a08ed9 100644 --- a/src/Language/Fixpoint/Counterexample.hs +++ b/src/Language/Fixpoint/Counterexample.hs @@ -30,7 +30,7 @@ import Control.Monad (forM_) -- | Try to get a counter example for the given unsafe clauses (if any). tryCounterExample - :: (MonadIO m, Fixpoint info) + :: (MonadIO m, Fixpoint info, Loc info) => Config -> SInfo info -> Result (SubcId, info) diff --git a/src/Language/Fixpoint/Counterexample/JSON.hs b/src/Language/Fixpoint/Counterexample/JSON.hs index acb0ef0cd..f87e9bd03 100644 --- a/src/Language/Fixpoint/Counterexample/JSON.hs +++ b/src/Language/Fixpoint/Counterexample/JSON.hs @@ -1,14 +1,12 @@ -{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NamedFieldPuns #-} module Language.Fixpoint.Counterexample.JSON ( Symbol , Refinement , Expr - , Path - , Span (..) - , Location (..) , Variable (..) , Constraint (..) , Counterexample (..) @@ -26,6 +24,7 @@ import Data.Text (Text) import qualified Data.Text as T import qualified Data.HashMap.Strict as Map +import Control.Exception import Control.Monad.IO.Class data Counterexample = Counterexample @@ -57,13 +56,19 @@ data Constraint = Constraint instance FromJSON Constraint instance ToJSON Constraint -data Location = Location - { span :: !Span - , path :: !Path - } deriving (Generic, Show) - -instance FromJSON Location -instance ToJSON Location +-- data RowColumn = RowColumn +-- { row :: !Int +-- , col :: !Int +-- } deriving (Generic, Show) +-- +-- instance FromJSON RowColumn +-- instance ToJSON RowColumn +-- +-- data Location = Location +-- { start :: !RowColumn +-- , end :: !RowColumn +-- , path :: !Path +-- } deriving (Generic, Show) data Span = Span { start :: !Int @@ -73,63 +78,142 @@ data Span = Span instance FromJSON Span instance ToJSON Span +data Location = Location + { span :: !Span + , path :: !Path + } deriving (Generic, Show) + +instance FromJSON Location +instance ToJSON Location + +type Path = Text type Symbol = Text type Refinement = Text type Expr = Text -type Path = Text -jsonCex :: MonadIO m => F.Config -> F.SInfo info -> F.FullCounterexample a -> m () -jsonCex cfg si cex | F.save cfg = liftIO $ do - let cex' = formatCex si cex +-- TODO: Check liquidhaskell-boot/src/Language/Haskell/Liquid/UX/Tidy.hs +-- from LH to copy how they make the environment "tidy". +jsonCex :: (F.Loc info, MonadIO m) => F.Config -> F.SInfo info -> F.FullCounterexample (F.SubcId, info) -> m () +jsonCex cfg si cex | F.save cfg = do + cex' <- formatCex si cex let ext = Ext.Cex . fromIntegral . F.cexConstraint $ cex let file = F.queryFile ext cfg - F.ensurePath file - encodeFile file cex' + liftIO $ F.ensurePath file + liftIO $ encodeFile file cex' jsonCex _ _ _ = return () -formatCex :: F.SInfo info -> F.FullCounterexample a -> Counterexample -formatCex si cex = Counterexample - { environment = formatEnv si cex - , constraint = formatConstraint si cex - } - -formatEnv :: F.SInfo info -> F.FullCounterexample a -> [Variable] -formatEnv si cex = formatVar <$> vars +formatCex :: (F.Loc info, MonadIO m) => F.SInfo info -> F.FullCounterexample (F.SubcId, info) -> m Counterexample +formatCex si cex = do + env <- formatEnv si cex + cst <- formatConstraint si cex + return Counterexample + { environment = env + , constraint = cst + } + +formatEnv :: (F.Loc info, MonadIO m) => F.SInfo info -> F.FullCounterexample (F.SubcId, info) -> m [Variable] +formatEnv si cex = do + mapM formatVar vars where vars = Map.toList . F.beBinds . F.cexEnv $ cex - formatVar (bid, (sym, synth, (conc, _a))) = Variable - { symbol = ppFormat sym - , expression = ppFormat conc - , refinement = ppFormat synth - , must_instance = must - , location = Nothing - } - where - must = formatCex si <$> F.cexFrames cex Map.!? bid - -formatConstraint :: F.SInfo info -> F.FullCounterexample a -> Constraint -formatConstraint si cex = Constraint - { concrete = ppFormat cconcrete - , synthesized = ppFormat csynth - , required = ppFormat ccheck - , location = Nothing - } - where - cheadId = F.cbind horn - horn = F.cm si Map.! F.cexConstraint cex - binds = F.beBinds . F.cexEnv $ cex + formatVar (bid, (sym, synth, (conc, (_, info)))) = do + must <- mapM (formatCex si) $ F.cexFrames cex Map.!? bid + loc <- getLocation info + return Variable + { symbol = ppFormat sym + , expression = ppFormat conc + , refinement = ppFormat synth + , must_instance = must + , location = loc + } + +formatConstraint :: (F.Loc info, MonadIO m) => F.SInfo info -> F.FullCounterexample (F.SubcId, info) -> m Constraint +formatConstraint si cex = do + let horn = F.cm si Map.! F.cexConstraint cex + let cheadId = F.cbind horn + let binds = F.beBinds . F.cexEnv $ cex -- Get the head of the constraint. - (_csym, csynth, (cconcrete, _a)) = binds Map.! cheadId + let (_csym, csynth, (cconcrete, (_, info))) = binds Map.! cheadId + + -- Get checked expr + let cexpr = F.crhs horn + let ccheck = withExpr csynth cexpr - -- Get checked expr - cexpr = F.crhs horn - ccheck = withExpr csynth cexpr + loc <- getLocation info + return Constraint + { concrete = ppFormat cconcrete + , synthesized = ppFormat csynth + , required = ppFormat ccheck + , location = loc + } + where withExpr sr e = sr { F.sr_reft = F.Reft (sort, e) } where F.Reft (sort, _) = F.sr_reft sr ppFormat :: F.PPrint a => a -> Text -ppFormat = T.pack . show . F.pprint +ppFormat = T.pack . show . F.pprintTidy F.Lossy + +-- | Storing spans with columns and rows doesn't really make sense when +-- printing. The JSON format instead just stores a range. This function does +-- the conversion, though it might be a bit slow, as we are quite literally +-- counting the number of characters to reach the span. +getLocation :: MonadIO m => F.Loc info => info -> m (Maybe Location) +getLocation i = liftIO $ handle ignore $ do + -- Helpers + let getRow = F.unPos . F.sourceLine + let getCol = F.unPos . F.sourceColumn + + -- The initial SourceSpan + let F.SS { sp_start, sp_stop } = F.srcSpan i + let path = F.sourceName sp_start + let startRow = getRow sp_start - 1 + let endRow = getRow sp_stop + let startCol = getCol sp_start - 1 + let endCol = getCol sp_stop + + -- Split between what comes before and the rows that actually contain the + -- content. + content <- lines <$> readFile path + let (before, rest) = splitAt startRow content + let (content', _) = splitAt (endRow - startRow) rest + + -- This part remove the start and end of the rows in which the final span + -- lies. The start and end is dictated by the columns. + (hs, l) <- case unsnoc content' of + Just v -> return v + _ -> throwIO $ userError "incorrect range" + let content'' = hs <> [take endCol l] + (h, ls) <- case uncons content'' of + Just v -> return v + _ -> throwIO $ userError "incorrect range" + let content''' = drop startCol h : ls + + -- Calculate the final start and length, including the number of newline + -- characters. + let start = sum (Prelude.length <$> before) + Prelude.length before + startCol + let len = sum (Prelude.length <$> content''') + Prelude.length content''' - 1 + + return . Just $ Location + { span = Span + { start = start + , length = len + } + , path = T.pack path + } + +ignore :: MonadIO m => IOException -> m (Maybe a) +ignore = const $ return Nothing + +-- TODO: Remove these definitions of unsnoc and uncons once the GHC version is +-- high enough such that they're in Data.List. Don't forget to add them to the +-- import in this case! +unsnoc :: [a] -> Maybe ([a], a) +unsnoc = foldr (\x -> Just . maybe ([], x) (\(~(a, b)) -> (x : a, b))) Nothing + +uncons :: [a] -> Maybe (a, [a]) +uncons [] = Nothing +uncons (x:xs) = Just (x, xs) From bb2715141a49a8c123961c8bdef11355e40dda2b Mon Sep 17 00:00:00 2001 From: Robin Webbers Date: Tue, 19 Mar 2024 14:54:51 +0100 Subject: [PATCH 24/33] Removed spurous counterexamples from declarations after assume/call/assert and underconstraint kvars when recursion depth was reached --- src/Language/Fixpoint/Counterexample.hs | 6 ++-- src/Language/Fixpoint/Counterexample/Build.hs | 18 ++++++++++-- src/Language/Fixpoint/Counterexample/Check.hs | 4 +-- src/Language/Fixpoint/Counterexample/JSON.hs | 1 + src/Language/Fixpoint/Counterexample/SMT.hs | 2 +- src/Language/Fixpoint/Types/Config.hs | 4 +-- tests/neg/decl-order.fq | 28 +++++++++++++++++++ 7 files changed, 53 insertions(+), 10 deletions(-) create mode 100644 tests/neg/decl-order.fq diff --git a/src/Language/Fixpoint/Counterexample.hs b/src/Language/Fixpoint/Counterexample.hs index 485a08ed9..0049db233 100644 --- a/src/Language/Fixpoint/Counterexample.hs +++ b/src/Language/Fixpoint/Counterexample.hs @@ -8,7 +8,7 @@ module Language.Fixpoint.Counterexample import Language.Fixpoint.Types import Language.Fixpoint.Counterexample.JSON (jsonCex) -import Language.Fixpoint.Types.Config (Config, counterExample) +import Language.Fixpoint.Types.Config (Config, counterexample) import Language.Fixpoint.Solver.EnvironmentReduction (dropLikelyIrrelevantBindings) import Language.Fixpoint.Counterexample.Types @@ -30,7 +30,7 @@ import Control.Monad (forM_) -- | Try to get a counter example for the given unsafe clauses (if any). tryCounterExample - :: (MonadIO m, Fixpoint info, Loc info) + :: (MonadIO m, Fixpoint info, Loc info, PPrint info) => Config -> SInfo info -> Result (SubcId, info) @@ -38,7 +38,7 @@ tryCounterExample tryCounterExample cfg si res@Result { resStatus = Unsafe _ cids' , resCounterexamples = cexs' - } | counterExample cfg = do + } | counterexample cfg = do -- Build program from constraints prog <- hornToProg cfg si diff --git a/src/Language/Fixpoint/Counterexample/Build.hs b/src/Language/Fixpoint/Counterexample/Build.hs index 69062e460..3d07dede8 100644 --- a/src/Language/Fixpoint/Counterexample/Build.hs +++ b/src/Language/Fixpoint/Counterexample/Build.hs @@ -18,7 +18,7 @@ import qualified Language.Fixpoint.Utils.Files as Ext import Data.Maybe (fromMaybe) import qualified Data.HashMap.Strict as Map -import Data.List (find) +import Data.List (find, sortBy) import Control.Monad.State import Control.Monad.Reader @@ -55,6 +55,7 @@ hornToProg cfg si = do -- Save the program in a file liftIO . when (save cfg) $ do let file = queryFile Ext.Prog cfg + liftIO . putStrLn $ "Saving counterexample program: " ++ file ++ "\n" ensurePath file writeFile file . show . pprint $ prog @@ -92,9 +93,22 @@ addHorn horn = do -- Add the horn clause as a function body let cid = fromMaybe (-1) $ sid horn - let body = Body cid $ lhs <> rhs + let statements = sortStatements $ lhs <> rhs + let body = Body cid $ statements addFunc name $ Func decl [body] +-- | Sort the statements so we do all declarations first. +-- TODO: Change the `Body` type so it contains a substitution map. Remove the +-- Let statement from the types of statements we have! +sortStatements :: [Statement] -> [Statement] +sortStatements = sortBy cmp + where + cmp (Let _) (Let _) = EQ + cmp (Let _) _ = LT + cmp _ (Let _) = GT + cmp _ _ = EQ + + -- | Gets a signature of a KVar from its well foundedness constraint getSig :: MonadBuild info m => Name -> m Signature getSig kvar = do diff --git a/src/Language/Fixpoint/Counterexample/Check.hs b/src/Language/Fixpoint/Counterexample/Check.hs index 4e68f8764..50b402395 100644 --- a/src/Language/Fixpoint/Counterexample/Check.hs +++ b/src/Language/Fixpoint/Counterexample/Check.hs @@ -117,7 +117,7 @@ runFunc name scope runner = do maxDepth' <- reader maxDepth let recursionLimit = depth' >= maxDepth' - result <- if recursionLimit then runner else foldRunners paths + result <- if recursionLimit then return Nothing else foldRunners paths -- Decrement depth after exploring this function modify $ \s -> s { depth = depth s - 1} @@ -137,7 +137,7 @@ runBody scope' body runner = smtScope $ go scope' body where go _ (Body _ []) = runner go scope (Body cid (stmt:ss)) = do - -- The remaining statements become a new Runner + -- The remaining statements becomes a new Runner let runner' = flip go (Body cid ss) -- We pass this runner, such that it can be called at a later -- point (possibly multiple times) if we were to encounter a call. diff --git a/src/Language/Fixpoint/Counterexample/JSON.hs b/src/Language/Fixpoint/Counterexample/JSON.hs index f87e9bd03..a78f8761e 100644 --- a/src/Language/Fixpoint/Counterexample/JSON.hs +++ b/src/Language/Fixpoint/Counterexample/JSON.hs @@ -98,6 +98,7 @@ jsonCex cfg si cex | F.save cfg = do cex' <- formatCex si cex let ext = Ext.Cex . fromIntegral . F.cexConstraint $ cex let file = F.queryFile ext cfg + liftIO . putStrLn $ "Saving counterexample json: " ++ file ++ "\n" liftIO $ F.ensurePath file liftIO $ encodeFile file cex' jsonCex _ _ _ = return () diff --git a/src/Language/Fixpoint/Counterexample/SMT.hs b/src/Language/Fixpoint/Counterexample/SMT.hs index 1e6580e37..a16ba89bd 100644 --- a/src/Language/Fixpoint/Counterexample/SMT.hs +++ b/src/Language/Fixpoint/Counterexample/SMT.hs @@ -99,7 +99,7 @@ smtSubstToCex (Su sub) = foldl' (flip $ uncurry insertCex) dummyCex traces where go :: Trace -> SMTCounterexample -> SMTCounterexample go (t:ts) cex = cex - { cexFrames = Map.insertWith (const $ go ts) t dummyCex $ cexFrames cex + { cexFrames = Map.insertWith (const $ go ts) t (go ts dummyCex) $ cexFrames cex } go _ cex@Counterexample { cexEnv = Su su diff --git a/src/Language/Fixpoint/Types/Config.hs b/src/Language/Fixpoint/Types/Config.hs index a221fb5bb..ca48f443f 100644 --- a/src/Language/Fixpoint/Types/Config.hs +++ b/src/Language/Fixpoint/Types/Config.hs @@ -94,7 +94,7 @@ data Config = Config , etaElim :: Bool -- ^ eta eliminate function definitions , gradual :: Bool -- ^ solve "gradual" constraints , ginteractive :: Bool -- ^ interactive gradual solving - , counterExample :: Bool -- ^ Tries to produce a counter example if unsafe + , counterexample :: Bool -- ^ Tries to produce a counter example if unsafe , autoKuts :: Bool -- ^ ignore given kut variables , nonLinCuts :: Bool -- ^ Treat non-linear vars as cuts , noslice :: Bool -- ^ Disable non-concrete KVar slicing @@ -246,7 +246,7 @@ defConfig = Config { , minimalSol = False &= help "Shrink fixpoint by removing implied qualifiers" , gradual = False &= help "Solve gradual-refinement typing constraints" , ginteractive = False &= help "Interactive Gradual Solving" - , counterExample = False &= name "counter-example" &= help "Tries to produce a counter example for unsafe clauses" + , counterexample = False &= name "counterexample" &= help "Tries to produce a counter example for unsafe clauses" , autoKuts = False &= help "Ignore given Kut vars, compute from scratch" , nonLinCuts = False &= help "Treat non-linear kvars as cuts" , noslice = False &= help "Disable non-concrete KVar slicing" diff --git a/tests/neg/decl-order.fq b/tests/neg/decl-order.fq new file mode 100644 index 000000000..175dc22f7 --- /dev/null +++ b/tests/neg/decl-order.fq @@ -0,0 +1,28 @@ +bind 0 x : {v: int | v > y} +bind 1 y : {v: int | y == 0} + +constraint: + env [0; 1] + lhs {v0: int | v0 == x} + rhs {v0: int | v0 > 1} + id 0 tag [] + +// bind 3 three : {v: int | v = 3} + +// constraint: +// env [3] +// lhs {v1: int | [v1 == three]} +// rhs {v1: int | $k[vk := v1]} +// id 1 tag [] + +// bind 4 four : {v: int | v = 4} + +// constraint: +// env [4] +// lhs {v2: int | [v2 == four]} +// rhs {v2: int | $k[vk := v2]} +// id 2 tag [] + +// wf: +// env [] +// reft {vk: int | [$k]} From f50e50ce4ef029fd13413fe0162ad033d73f295e Mon Sep 17 00:00:00 2001 From: Robin Webbers Date: Wed, 20 Mar 2024 15:37:13 +0100 Subject: [PATCH 25/33] Fixed wrong naming on 'fix$' names. Fixed wrong recursion limit, that caused the checker to do nothing --- src/Language/Fixpoint/Counterexample/Build.hs | 21 ++++++-- src/Language/Fixpoint/Counterexample/Check.hs | 53 ++++++++----------- src/Language/Fixpoint/Counterexample/JSON.hs | 12 +++-- src/Language/Fixpoint/Types/Names.hs | 1 + tests/neg/decl-order.fq | 28 ++++------ 5 files changed, 59 insertions(+), 56 deletions(-) diff --git a/src/Language/Fixpoint/Counterexample/Build.hs b/src/Language/Fixpoint/Counterexample/Build.hs index 3d07dede8..8a9a520e4 100644 --- a/src/Language/Fixpoint/Counterexample/Build.hs +++ b/src/Language/Fixpoint/Counterexample/Build.hs @@ -50,7 +50,7 @@ hornToProg cfg si = do } -- Run monad that adds all horn clauses to the program - prog <- evalStateT (runReaderT buildProg env) initial + prog <- sortBodies <$> evalStateT (runReaderT buildProg env) initial -- Save the program in a file liftIO . when (save cfg) $ do @@ -108,7 +108,6 @@ sortStatements = sortBy cmp cmp _ (Let _) = GT cmp _ _ = EQ - -- | Gets a signature of a KVar from its well foundedness constraint getSig :: MonadBuild info m => Name -> m Signature getSig kvar = do @@ -179,9 +178,13 @@ reftToStmts (bid, sym, RR { sr_sort = sort , sr_reft = Reft (v, e) }) = do + -- Prefix the symbol if required. Otherwise, some symbols won't match their + -- fix$36$ version when substituting. + let sym' = symbol . prefixAlpha . symbolText $ sym + -- Get correct sort for declaration sort' <- elaborateSort sort - let decl = Let $ Decl sym sort' + let decl = Let $ Decl sym' sort' -- Get constraints from the expression. let constraints = case predKs e of @@ -219,3 +222,15 @@ addFunc kvar func = do let merge (Func _ b) (Func d b') = Func d (b <> b') Prog prog <- get put . Prog $ Map.insertWith merge kvar func prog + +-- | We try to place functions with as little kvars as possible first, as these +-- most likely find us a counterexample. Ideally, we do something less primitive +-- than just a sort though... +sortBodies :: Prog -> Prog +sortBodies (Prog prog) = Prog $ sortFunc <$> prog + where + sortFunc (Func sig bodies) = Func sig $ sortBy cmp bodies + cmp a b = count a `compare` count b + count (Body _ stmts) = length . filter isCall $ stmts + isCall (Call _ _) = True + isCall _ = False diff --git a/src/Language/Fixpoint/Counterexample/Check.hs b/src/Language/Fixpoint/Counterexample/Check.hs index 50b402395..dd5f3d604 100644 --- a/src/Language/Fixpoint/Counterexample/Check.hs +++ b/src/Language/Fixpoint/Counterexample/Check.hs @@ -18,7 +18,7 @@ import Data.Maybe (fromJust, catMaybes) import Data.List (find) import qualified Data.HashMap.Strict as Map -import Control.Monad.State +import Control.Monad.State.Strict import Control.Monad.Reader import Control.Monad (forM, foldM) @@ -35,14 +35,8 @@ data CheckEnv = CheckEnv instance SMTContext CheckEnv where smtContext = context --- | State tracked when checking a program. -newtype CheckState = CheckState - { depth :: Int - -- ^ Current depth (i.e. number of functions traversed) - } - -- | The monad used to generate counter examples from a Prog. -type MonadCheck m = (MonadReader CheckEnv m, MonadState CheckState m, MonadIO m) +type MonadCheck m = (MonadReader CheckEnv m, MonadIO m) -- | Check the given constraints to try and find a counter example. checkProg :: MonadIO m => Config -> SInfo info -> Prog -> [SubcId] -> m [SMTCounterexample] @@ -51,7 +45,8 @@ checkProg cfg si prog cids = withContext cfg si check check ctx = runCheck cids CheckEnv { program = prog , context = ctx - , maxDepth = 7 -- TODO: Perhaps this should be a parameter for the user? + -- TODO: Perhaps the max depth should be a parameter for the user? + , maxDepth = 7 } -- | Run the checker with the SMT solver context. @@ -69,9 +64,8 @@ withContext cfg si inner = do -- | Runs the program checker with the monad stack -- unwrapped. runCheck :: MonadIO m => [SubcId] -> CheckEnv -> m [SMTCounterexample] -runCheck cids env = rd . st $ checkAll cids +runCheck cids env = rd $ checkAll cids where - st = flip evalStateT $ CheckState 0 rd = flip runReaderT env -- | Try to find a counter example for all the given constraints. @@ -99,41 +93,32 @@ runFunc :: MonadCheck m => Name -> Scope -> Runner m -> Runner m runFunc name scope runner = do -- Lookup function bodies func <- getFunc name + maxDepth' <- reader maxDepth case func of - -- Unconstrained function body, so we just continue with the runner. - Nothing -> runner + -- Recursion limit reached, so no counterexample. + _ | length (path scope) >= maxDepth' -> return Nothing + -- Unconstrained function body, so there is no counterexample here. This + -- would be equivalent to trying to create an inhabitant of {v:a | false}, + -- which doesn't exist. + Nothing -> return Nothing -- Constrained function body Just (Func _ bodies) -> do -- Generate all execution paths (as runners). let runner' body = runBody (extendScope scope body) body runner let paths = runner' <$> bodies - -- Check if we've reached the recursion limit. - -- TODO: Perhaps we should make the recursion limit per kvar? -- TODO: We should really explore shallow trees first. Right now, - -- we explore max depth trees only... - depth' <- gets depth - put $ CheckState $ depth' + 1 - maxDepth' <- reader maxDepth - let recursionLimit = depth' >= maxDepth' - - result <- if recursionLimit then return Nothing else foldRunners paths - - -- Decrement depth after exploring this function - modify $ \s -> s { depth = depth s - 1} + -- we might get a large tree, while a much smaller counterexample existed. + result <- foldRunners paths return result --- | Extend the scope to include the id of the body, i.e. the `SubcId`. -extendScope :: Scope -> Body -> Scope -extendScope scope (Body cid _) = scope { constraint = cid } - -- | Run the statements in the body. If there are no more statements to run, -- this will execute the Runner that was passed as argument. -- -- The passed runner here is thus the rest of the computation, when we "return" -- from this function. runBody :: MonadCheck m => Scope -> Body -> Runner m -> Runner m -runBody scope' body runner = smtScope $ go scope' body +runBody scope' body@(Body _ _) runner = smtScope $ go scope' body where go _ (Body _ []) = runner go scope (Body cid (stmt:ss)) = do @@ -170,8 +155,14 @@ getFunc name = do Prog prog <- reader program return $ Map.lookup name prog -foldRunners :: Monad m => [Runner m] -> Runner m +-- | Fold the runners, selecting the first one that produced a counterexample, +-- if any. +foldRunners :: MonadCheck m => [Runner m] -> Runner m foldRunners = foldM select Nothing where select Nothing r = r select cex _ = return cex + +-- | Extend the scope to include the id of the body, i.e. the `SubcId`. +extendScope :: Scope -> Body -> Scope +extendScope scope (Body cid _) = scope { constraint = cid } diff --git a/src/Language/Fixpoint/Counterexample/JSON.hs b/src/Language/Fixpoint/Counterexample/JSON.hs index a78f8761e..0cc229a3b 100644 --- a/src/Language/Fixpoint/Counterexample/JSON.hs +++ b/src/Language/Fixpoint/Counterexample/JSON.hs @@ -23,6 +23,8 @@ import Data.Aeson (FromJSON, ToJSON, encodeFile) import Data.Text (Text) import qualified Data.Text as T import qualified Data.HashMap.Strict as Map +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as B (lines) import Control.Exception import Control.Monad.IO.Class @@ -178,7 +180,7 @@ getLocation i = liftIO $ handle ignore $ do -- Split between what comes before and the rows that actually contain the -- content. - content <- lines <$> readFile path + content <- B.lines <$> B.readFile path let (before, rest) = splitAt startRow content let (content', _) = splitAt (endRow - startRow) rest @@ -187,16 +189,16 @@ getLocation i = liftIO $ handle ignore $ do (hs, l) <- case unsnoc content' of Just v -> return v _ -> throwIO $ userError "incorrect range" - let content'' = hs <> [take endCol l] + let content'' = hs <> [B.take endCol l] (h, ls) <- case uncons content'' of Just v -> return v _ -> throwIO $ userError "incorrect range" - let content''' = drop startCol h : ls + let content''' = B.drop startCol h : ls -- Calculate the final start and length, including the number of newline -- characters. - let start = sum (Prelude.length <$> before) + Prelude.length before + startCol - let len = sum (Prelude.length <$> content''') + Prelude.length content''' - 1 + let start = sum (B.length <$> before) + Prelude.length before + startCol + let len = sum (B.length <$> content''') + Prelude.length content''' - 1 return . Just $ Location { span = Span diff --git a/src/Language/Fixpoint/Types/Names.hs b/src/Language/Fixpoint/Types/Names.hs index 5e9ffbf32..9d56ffb21 100644 --- a/src/Language/Fixpoint/Types/Names.hs +++ b/src/Language/Fixpoint/Types/Names.hs @@ -61,6 +61,7 @@ module Language.Fixpoint.Types.Names ( , vvCon , tidySymbol , unKArgSymbol + , prefixAlpha -- * Widely used prefixes , anfPrefix diff --git a/tests/neg/decl-order.fq b/tests/neg/decl-order.fq index 175dc22f7..dcb5fdb50 100644 --- a/tests/neg/decl-order.fq +++ b/tests/neg/decl-order.fq @@ -1,4 +1,4 @@ -bind 0 x : {v: int | v > y} +bind 0 x : {v: int | $k[v2:=v][karg:=y]} bind 1 y : {v: int | y == 0} constraint: @@ -7,22 +7,16 @@ constraint: rhs {v0: int | v0 > 1} id 0 tag [] -// bind 3 three : {v: int | v = 3} +bind 2 z : {v: int | true} -// constraint: -// env [3] -// lhs {v1: int | [v1 == three]} -// rhs {v1: int | $k[vk := v1]} -// id 1 tag [] - -// bind 4 four : {v: int | v = 4} +constraint: + env [2] + lhs {v1: int | v1 > z} + rhs {v1: int | $k[v2:=v1][karg:=z]} + id 1 tag [] -// constraint: -// env [4] -// lhs {v2: int | [v2 == four]} -// rhs {v2: int | $k[vk := v2]} -// id 2 tag [] +bind 10 karg : {v:int | true} -// wf: -// env [] -// reft {vk: int | [$k]} +wf: + env [10] + reft {v2 : int | $k} From 72ac0fab3804c89c5776fe85dc129034c769a50b Mon Sep 17 00:00:00 2001 From: Robin Webbers Date: Sun, 24 Mar 2024 17:52:11 +0100 Subject: [PATCH 26/33] Added define axioms to counterexample constraints, such that we generate lists of the correct length. Renamed counterexample SMT functions. --- src/Language/Fixpoint/Counterexample.hs | 6 +- src/Language/Fixpoint/Counterexample/Build.hs | 60 ++++++++++++----- src/Language/Fixpoint/Counterexample/Check.hs | 47 ++++++------- src/Language/Fixpoint/Counterexample/SMT.hs | 66 +++++++++++-------- src/Language/Fixpoint/Counterexample/Types.hs | 27 ++++++-- tests/neg/duplicate-names.fq | 2 + tests/neg/duplicate-names2.fq | 2 + tests/neg/duplicate-names3.fq | 2 + tests/neg/false.fq | 2 + tests/neg/linear.fq | 2 + tests/neg/list-len-define.fq | 20 ++++++ tests/neg/two-calls.fq | 2 + 12 files changed, 163 insertions(+), 75 deletions(-) create mode 100644 tests/neg/list-len-define.fq diff --git a/src/Language/Fixpoint/Counterexample.hs b/src/Language/Fixpoint/Counterexample.hs index 0049db233..c62c16c20 100644 --- a/src/Language/Fixpoint/Counterexample.hs +++ b/src/Language/Fixpoint/Counterexample.hs @@ -30,7 +30,11 @@ import Control.Monad (forM_) -- | Try to get a counter example for the given unsafe clauses (if any). tryCounterExample - :: (MonadIO m, Fixpoint info, Loc info, PPrint info) + :: MonadIO m + => Show info + => Fixpoint info + => Loc info + => PPrint info => Config -> SInfo info -> Result (SubcId, info) diff --git a/src/Language/Fixpoint/Counterexample/Build.hs b/src/Language/Fixpoint/Counterexample/Build.hs index 8a9a520e4..f73c6ae61 100644 --- a/src/Language/Fixpoint/Counterexample/Build.hs +++ b/src/Language/Fixpoint/Counterexample/Build.hs @@ -12,13 +12,13 @@ import Language.Fixpoint.Counterexample.Types import Language.Fixpoint.Types.Config (Config, queryFile, save) import Language.Fixpoint.Solver.Sanitize (symbolEnv) import Language.Fixpoint.Misc (ensurePath) -import Language.Fixpoint.SortCheck (elaborate) +import Language.Fixpoint.SortCheck (Elaborate (..)) import qualified Language.Fixpoint.Utils.Files as Ext import Data.Maybe (fromMaybe) import qualified Data.HashMap.Strict as Map -import Data.List (find, sortBy) +import Data.List (find, sortBy, foldl') import Control.Monad.State import Control.Monad.Reader @@ -40,15 +40,26 @@ type Binding = (BindId, Symbol, SortedReft) -- | Make an imperative program from horn clauses. This -- can be used to generate a counter example. -hornToProg :: MonadIO m => Config -> SInfo info -> m Prog +hornToProg + :: MonadIO m + => Fixpoint info + => Show info + => Config + -> SInfo info + -> m Prog hornToProg cfg si = do -- Initial program is just an empty main. - let initial = Prog $ Map.singleton mainName (Func [] []) + let initial = Prog + { functions = Map.singleton mainName (Func [] []) + , definitions = mempty + } let env = BuildEnv { info = si , symbols = symbolEnv cfg si } + liftIO . print . ae $ si + -- Run monad that adds all horn clauses to the program prog <- sortBodies <$> evalStateT (runReaderT buildProg env) initial @@ -66,10 +77,25 @@ hornToProg cfg si = do -- inside the monad buildProg :: MonadBuild info m => m Prog buildProg = do + addDefinitions constraints <- reader $ cm . info mapM_ addHorn constraints get +addDefinitions :: MonadBuild info m => m () +addDefinitions = do + eqs <- reader $ aenvEqs . ae . info + mapM_ addEquation eqs + +addEquation :: MonadBuild info m => Equation -> m () +addEquation equ = do + -- Build a constraint from the equation + let call = foldl' EApp (EVar $ eqName equ) (EVar . fst <$> eqArgs equ) + let eq = PAtom Eq call $ eqBody equ + constraint' <- elaborate' $ PAll (eqArgs equ) eq + + modify (\s -> s { definitions = constraint' : definitions s }) + -- | Given a horn clause, generates a body for a function. -- -- The body is generated from the lhs of the horn clause. @@ -172,6 +198,7 @@ filterLits env = do -- | Map a refinement to a declaration and constraint pair reftToStmts :: MonadBuild info m => Binding -> m [Statement] +-- Ignore abstractions and functions, as they don't have refinements. reftToStmts (_, _, RR { sr_sort = FAbs _ _ }) = return [] reftToStmts (_, _, RR { sr_sort = FFunc _ _ }) = return [] reftToStmts (bid, sym, RR @@ -183,7 +210,7 @@ reftToStmts (bid, sym, RR let sym' = symbol . prefixAlpha . symbolText $ sym -- Get correct sort for declaration - sort' <- elaborateSort sort + sort' <- elaborate' sort let decl = Let $ Decl sym' sort' -- Get constraints from the expression. @@ -204,15 +231,15 @@ predKs (PAnd ps) = mconcat $ map predKs ps predKs (PKVar k su) = [(k, su)] predKs _ = [] --- | The sorts for the apply monomorphization only match if --- we do this elaborate on the sort. Not sure why... +-- | The sorts for the apply monomorphization only match if we do this elaborate +-- on the sort. Not sure why... -- --- This elaboration also happens inside the declaration --- of the symbol environment, so that's where I got the idea. -elaborateSort :: MonadBuild info m => Sort -> m Sort -elaborateSort sym = do +-- This elaboration also happens inside the declaration of the symbol +-- environment, so that's where I got the idea. +elaborate' :: MonadBuild info m => Elaborate a => a -> m a +elaborate' x = do symbols' <- reader symbols - return $ elaborate "elaborateSort" symbols' sym + return $ elaborate "elaborateSort" symbols' x -- | Add a function to the function map with index by its name. -- If an entry already exists, it will merge the function @@ -220,15 +247,18 @@ elaborateSort sym = do addFunc :: MonadBuild info m => Name -> Func -> m () addFunc kvar func = do let merge (Func _ b) (Func d b') = Func d (b <> b') - Prog prog <- get - put . Prog $ Map.insertWith merge kvar func prog + prog <- get + let functions' = Map.insertWith merge kvar func $ functions prog + put $ prog { functions = functions' } -- | We try to place functions with as little kvars as possible first, as these -- most likely find us a counterexample. Ideally, we do something less primitive -- than just a sort though... sortBodies :: Prog -> Prog -sortBodies (Prog prog) = Prog $ sortFunc <$> prog +sortBodies prog = prog { functions = functions' } where + functions' = sortFunc <$> functions prog + sortFunc (Func sig bodies) = Func sig $ sortBy cmp bodies cmp a b = count a `compare` count b count (Body _ stmts) = length . filter isCall $ stmts diff --git a/src/Language/Fixpoint/Counterexample/Check.hs b/src/Language/Fixpoint/Counterexample/Check.hs index dd5f3d604..f8157cef6 100644 --- a/src/Language/Fixpoint/Counterexample/Check.hs +++ b/src/Language/Fixpoint/Counterexample/Check.hs @@ -9,10 +9,8 @@ module Language.Fixpoint.Counterexample.Check import Language.Fixpoint.Types import Language.Fixpoint.Counterexample.Types -import Language.Fixpoint.Counterexample.SMT -import Language.Fixpoint.Types.Config (Config, srcFile) -import Language.Fixpoint.Solver.Sanitize (symbolEnv) -import qualified Language.Fixpoint.Smt.Interface as SMT +import Language.Fixpoint.Counterexample.SMT as SMT +import Language.Fixpoint.Types.Config (Config) import Data.Maybe (fromJust, catMaybes) import Data.List (find) @@ -40,27 +38,15 @@ type MonadCheck m = (MonadReader CheckEnv m, MonadIO m) -- | Check the given constraints to try and find a counter example. checkProg :: MonadIO m => Config -> SInfo info -> Prog -> [SubcId] -> m [SMTCounterexample] -checkProg cfg si prog cids = withContext cfg si check +checkProg cfg si prog cids = SMT.withContext cfg si check where check ctx = runCheck cids CheckEnv { program = prog , context = ctx -- TODO: Perhaps the max depth should be a parameter for the user? - , maxDepth = 7 + , maxDepth = 10 } --- | Run the checker with the SMT solver context. -withContext :: MonadIO m => Config -> SInfo info -> (SMT.Context -> m a) -> m a -withContext cfg si inner = do - let file = srcFile cfg <> ".prog" - let env = symbolEnv cfg si - ctx <- liftIO $ SMT.makeContextWithSEnv cfg file env - - !result <- inner ctx - - liftIO $ SMT.cleanupContext ctx - return result - -- | Runs the program checker with the monad stack -- unwrapped. runCheck :: MonadIO m => [SubcId] -> CheckEnv -> m [SMTCounterexample] @@ -71,9 +57,15 @@ runCheck cids env = rd $ checkAll cids -- | Try to find a counter example for all the given constraints. checkAll :: MonadCheck m => [SubcId] -> m [SMTCounterexample] checkAll cids = do + setDefinitions cexs <- forM cids checkConstraint return $ catMaybes cexs +setDefinitions :: MonadCheck m => m () +setDefinitions = do + defs <- reader $ definitions . program + mapM_ SMT.assume defs + -- | Check a specific constraint id. This will only do actual -- checks for constraints without a KVar on the rhs, as we cannot -- really generate a counter example for these constraints. @@ -83,7 +75,7 @@ checkConstraint cid = do let cmp (Body bid _) = bid == cid let scope = Scope mempty cid mempty case find cmp bodies of - Just body -> runBody scope body smtCheck + Just body -> runBody scope body SMT.checkSat Nothing -> return Nothing -- | Run a function. This essentially makes one running branch for @@ -107,8 +99,9 @@ runFunc name scope runner = do let runner' body = runBody (extendScope scope body) body runner let paths = runner' <$> bodies - -- TODO: We should really explore shallow trees first. Right now, - -- we might get a large tree, while a much smaller counterexample existed. + -- TODO: We should really explore shallow trees first. The current thing + -- can search for a really long time if there are a large number of paths + -- before the actual counterexample... result <- foldRunners paths return result @@ -118,7 +111,7 @@ runFunc name scope runner = do -- The passed runner here is thus the rest of the computation, when we "return" -- from this function. runBody :: MonadCheck m => Scope -> Body -> Runner m -> Runner m -runBody scope' body@(Body _ _) runner = smtScope $ go scope' body +runBody scope' body@(Body _ _) runner = SMT.inScope $ go scope' body where go _ (Body _ []) = runner go scope (Body cid (stmt:ss)) = do @@ -143,17 +136,17 @@ runStatement scope stmt runner = do let scope' app = Scope (origin:path scope) 0 app let runCall (name, app) = runFunc name (scope' app) runner' foldRunners $ runCall <$> calls - Assume e -> smtAssume e >> runner' - Assert e -> smtAssert e >> runner' + Assume e -> SMT.assume e >> runner' + Assert e -> SMT.assert e >> runner' Let decl -> do - scope' <- smtDeclare scope decl + scope' <- SMT.declare scope decl runner scope' -- | Get a function from the program given its name. getFunc :: MonadCheck m => Name -> m (Maybe Func) getFunc name = do - Prog prog <- reader program - return $ Map.lookup name prog + funcs <- reader $ functions . program + return $ Map.lookup name funcs -- | Fold the runners, selecting the first one that produced a counterexample, -- if any. diff --git a/src/Language/Fixpoint/Counterexample/SMT.hs b/src/Language/Fixpoint/Counterexample/SMT.hs index a16ba89bd..0bfbbab0d 100644 --- a/src/Language/Fixpoint/Counterexample/SMT.hs +++ b/src/Language/Fixpoint/Counterexample/SMT.hs @@ -3,16 +3,19 @@ {-# LANGUAGE OverloadedStrings #-} module Language.Fixpoint.Counterexample.SMT - ( SMTContext (..) - , smtDeclare - , smtAssert - , smtAssume - , smtScope - , smtCheck - , smtModel + ( SMT.Context + , SMTContext (..) + , withContext + , declare + , assert + , assume + , inScope + , checkSat ) where import Language.Fixpoint.Types +import Language.Fixpoint.Types.Config (Config, srcFile) +import Language.Fixpoint.Solver.Sanitize (symbolEnv) import Language.Fixpoint.Counterexample.Types import qualified Language.Fixpoint.Smt.Interface as SMT @@ -32,11 +35,23 @@ class SMTContext a where type MonadSMT r m = (SMTContext r, MonadReader r m, MonadIO m) +-- | Run the checker with the SMT solver context. +withContext :: MonadIO m => Config -> SInfo info -> (SMT.Context -> m a) -> m a +withContext cfg si inner = do + let file = srcFile cfg <> ".prog" + let env = symbolEnv cfg si + ctx <- liftIO $ SMT.makeContextWithSEnv cfg file env + + !result <- inner ctx + + liftIO $ SMT.cleanupContext ctx + return result + -- | Declare a new symbol, returning an updated substitution -- given with this new symbol in it. The substitution map is -- required to avoid duplicating variable names. -smtDeclare :: MonadSMT s m => Scope -> Decl -> m Scope -smtDeclare scope (Decl sym sort) = do +declare :: MonadSMT s m => Scope -> Decl -> m Scope +declare scope (Decl sym sort) = do ctx <- reader smtContext let sym' = scopeSym scope sym liftIO $ SMT.smtDecl ctx sym' sort @@ -45,43 +60,42 @@ smtDeclare scope (Decl sym sort) = do return scope { binders = binders' } -- | Assert the given expression. -smtAssert :: MonadSMT s m => Expr -> m () -smtAssert = smtAssume . PNot +assert :: MonadSMT s m => Expr -> m () +assert = assume . PNot -- | Assume the given expression. -smtAssume :: MonadSMT s m => Expr -> m () -smtAssume e = do +assume :: MonadSMT s m => Expr -> m () +assume e = do ctx <- reader smtContext liftIO $ SMT.smtAssert ctx e -- | Run the checker within a scope (i.e. a push/pop pair). -smtScope :: MonadSMT s m => m a -> m a -smtScope inner = do +inScope :: MonadSMT s m => m a -> m a +inScope inner = do ctx <- reader smtContext liftIO $ SMT.smtPush ctx !result <- inner liftIO $ SMT.smtPop ctx return result --- | Check if there is a counterexample, returing one --- if it is available. -smtCheck :: MonadSMT s m => Runner m -smtCheck = do +-- | Check if there is a counterexample, returing one if it is available. +checkSat :: MonadSMT s m => Runner m +checkSat = do ctx <- reader smtContext valid <- liftIO $ SMT.smtCheckUnsat ctx - if valid then return Nothing else Just <$> smtModel + if valid then return Nothing else Just <$> getModel --- | Returns a model, with as precondition that the SMT --- solver had a satisfying assignment prior to this. -smtModel :: MonadSMT s m => m SMTCounterexample -smtModel = do +-- | Returns a model, with as precondition that the SMT solver had a satisfying +-- assignment prior to this. +getModel :: MonadSMT s m => m SMTCounterexample +getModel = do ctx <- reader smtContext sub <- liftIO $ SMT.smtGetModel ctx return $ smtSubstToCex sub --- | Transform an SMT substitution, which contains SMT scoped symbols, into --- a layered, tree-like counterexample. +-- | Transform an SMT substitution, which contains SMT scoped symbols, into a +-- layered, tree-like counterexample. smtSubstToCex :: Subst -> SMTCounterexample smtSubstToCex (Su sub) = foldl' (flip $ uncurry insertCex) dummyCex traces where diff --git a/src/Language/Fixpoint/Counterexample/Types.hs b/src/Language/Fixpoint/Counterexample/Types.hs index 81ac6f694..45e672f29 100644 --- a/src/Language/Fixpoint/Counterexample/Types.hs +++ b/src/Language/Fixpoint/Counterexample/Types.hs @@ -61,7 +61,12 @@ data Scope = Scope type Trace = [BindId] -- | A program, containing multiple function definitions mapped by their name. -newtype Prog = Prog (HashMap Name Func) +data Prog = Prog + { functions :: (HashMap Name Func) + -- ^ The functions of this program. + , definitions :: [Expr] + -- ^ Constraints that need to hold originating from define statements. + } deriving Show -- | Identifier of a function. All KVars are translated into functions, so it is @@ -103,11 +108,21 @@ mainName :: Name mainName = KV "main" instance PPrint Prog where - pprintTidy tidy (Prog funcs) = PP.vcat - . PP.punctuate "\n" - . map (uncurry $ ppfunc tidy) - . Map.toList - $ funcs + pprintTidy tidy prog = pcstr $+$ pfuncs + where + pcstr = PP.vcat + . PP.punctuate "\n" + . map (pprintTidy tidy) + . definitions + $ prog + + pfuncs = PP.vcat + . PP.punctuate "\n" + . map (uncurry $ ppfunc tidy) + . Map.toList + . functions + $ prog + instance PPrint Func where pprintTidy tidy = ppfunc tidy anonymous diff --git a/tests/neg/duplicate-names.fq b/tests/neg/duplicate-names.fq index 91639c137..ffd037211 100644 --- a/tests/neg/duplicate-names.fq +++ b/tests/neg/duplicate-names.fq @@ -1,3 +1,5 @@ +fixpoint "--counterexample" + distinct True : (bool) distinct False : (bool) diff --git a/tests/neg/duplicate-names2.fq b/tests/neg/duplicate-names2.fq index 9e8f9d428..99bb9a450 100644 --- a/tests/neg/duplicate-names2.fq +++ b/tests/neg/duplicate-names2.fq @@ -1,3 +1,5 @@ +fixpoint "--counterexample" + bind 0 duplicator : {v: int | $k0 && $k1} bind 1 duplicated : {v: int | v == 0} diff --git a/tests/neg/duplicate-names3.fq b/tests/neg/duplicate-names3.fq index 55d1bc53b..51fead988 100644 --- a/tests/neg/duplicate-names3.fq +++ b/tests/neg/duplicate-names3.fq @@ -1,3 +1,5 @@ +fixpoint "--counterexample" + bind 0 x : {v: int | [$k[vk := v]]} bind 1 y : {v: int | [$k[vk := v]]} diff --git a/tests/neg/false.fq b/tests/neg/false.fq index 3b9ecb2e6..73306826b 100644 --- a/tests/neg/false.fq +++ b/tests/neg/false.fq @@ -1,3 +1,5 @@ +fixpoint "--counterexample" + constraint: env [] lhs {v : int | true} diff --git a/tests/neg/linear.fq b/tests/neg/linear.fq index 5af4085da..7c3ab53bf 100644 --- a/tests/neg/linear.fq +++ b/tests/neg/linear.fq @@ -1,3 +1,5 @@ +fixpoint "--counterexample" + bind 0 x : {v : int | true} bind 1 y : {v : int | true} bind 2 y : {v : int | true} diff --git a/tests/neg/list-len-define.fq b/tests/neg/list-len-define.fq new file mode 100644 index 000000000..1f6b56b9c --- /dev/null +++ b/tests/neg/list-len-define.fq @@ -0,0 +1,20 @@ +fixpoint "--counterexample" + +data Vec 1 = [ + | VNil { } + | VCons { head : @(0), tail : Vec @(0)} +] + +constant len: (func(1, [(Vec @(0)); int])) + +define len(l: Vec a) : int = { + if (is$VNil l) then 0 else (1 + len(tail l)) +} + +bind 0 xs : {v: Vec int | v = (VCons 2 VNil)} + +constraint: + env [0] + lhs {v : Vec int | len v == 3} + rhs {v : Vec int | v = xs} + id 1 tag [] diff --git a/tests/neg/two-calls.fq b/tests/neg/two-calls.fq index bdf079cc3..2ba1e23d9 100644 --- a/tests/neg/two-calls.fq +++ b/tests/neg/two-calls.fq @@ -1,3 +1,5 @@ +fixpoint "--counterexample" + bind 0 x : {v: int | [$k[vk := v]]} bind 1 y : {v: int | [$k[vk := v]]} From d308c7e19dee4653f4325c6ae65f8a82c8df9a04 Mon Sep 17 00:00:00 2001 From: Robin Webbers Date: Sun, 24 Mar 2024 18:01:52 +0100 Subject: [PATCH 27/33] Removed debug print --- src/Language/Fixpoint/Counterexample/Build.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/Language/Fixpoint/Counterexample/Build.hs b/src/Language/Fixpoint/Counterexample/Build.hs index f73c6ae61..7c9e2ec13 100644 --- a/src/Language/Fixpoint/Counterexample/Build.hs +++ b/src/Language/Fixpoint/Counterexample/Build.hs @@ -58,8 +58,6 @@ hornToProg cfg si = do , symbols = symbolEnv cfg si } - liftIO . print . ae $ si - -- Run monad that adds all horn clauses to the program prog <- sortBodies <$> evalStateT (runReaderT buildProg env) initial From d8049fbcb77029711d12277bcab71818a71569c7 Mon Sep 17 00:00:00 2001 From: Robin Webbers Date: Mon, 25 Mar 2024 12:40:24 +0100 Subject: [PATCH 28/33] Added support for SMT Sequence theory --- src/Language/Fixpoint/Smt/Theories.hs | 211 +++++++++++++++++++++++- src/Language/Fixpoint/Types/Names.hs | 4 +- src/Language/Fixpoint/Types/Sorts.hs | 6 +- src/Language/Fixpoint/Types/Theories.hs | 4 + tests/neg/sequence.fq | 10 ++ tests/pos/sequence.fq | 7 + 6 files changed, 238 insertions(+), 4 deletions(-) create mode 100644 tests/neg/sequence.fq create mode 100644 tests/pos/sequence.fq diff --git a/src/Language/Fixpoint/Smt/Theories.hs b/src/Language/Fixpoint/Smt/Theories.hs index 83ad4114c..4447e4055 100644 --- a/src/Language/Fixpoint/Smt/Theories.hs +++ b/src/Language/Fixpoint/Smt/Theories.hs @@ -171,6 +171,191 @@ mapPrj = "Map_project" mapShift = "Map_shift" -- See [Map key shift] mapToSet = "Map_to_set" +-- | (seq.unit elem) +-- Sequence with a single element `elem`. +seqUnit :: TheorySymbol +seqUnit = Thy + { tsSym = "Seq$unit" + , tsRaw = "seq.unit" + -- forall a. a -> Seq a + , tsSort = FAbs 0 $ FFunc (FVar 0) $ seqSort 0 + , tsInterp = Theory + } + +-- | (as seq.empty (Seq Int)) +-- The empty sequence of integers. +seqEmpty :: TheorySymbol +seqEmpty = Thy + { tsSym = "Seq$empty" + , tsRaw = "seq.empty" + -- forall a. Seq a + , tsSort = FAbs 0 $ seqSort 0 + , tsInterp = Theory + } + +-- | (seq.++ a b c) +-- Concatenation of one or more sequences. +-- +-- We define the concat in fixpoint as just joining two sequences. +seqConcat :: TheorySymbol +seqConcat = Thy + { tsSym = "Seq$concat" + , tsRaw = "seq.++" + -- forall a. Seq a -> Seq a -> Seq a + , tsSort = FAbs 0 $ FFunc (seqSort 0) $ FFunc (seqSort 0) $ seqSort 0 + , tsInterp = Theory + } + +-- | (seq.len s) +-- Sequence length. Returns an integer. +seqLen :: TheorySymbol +seqLen = Thy + { tsSym = "Seq$len" + , tsRaw = "seq.len" + -- forall a. Seq a -> Int + , tsSort = FAbs 0 $ FFunc (seqSort 0) intSort + , tsInterp = Theory + } + +-- | (seq.extract s offset length) +-- Retrieves sub-sequence of `s` at `offset`. +seqExtract :: TheorySymbol +seqExtract = Thy + { tsSym = "Seq$extract" + , tsRaw = "seq.extract" + -- forall a. Seq a -> Int -> Int -> Seq a + , tsSort = FAbs 0 $ FFunc (seqSort 0) $ FFunc intSort $ FFunc intSort $ seqSort 0 + , tsInterp = Theory + } + +-- | (seq.indexof s sub [offset]) +-- Retrieves first position of `sub` in `s`, -1 if there are no occurrences. +-- +-- We don't take the optional `offset` argument in fixpoint. +seqIndexOf :: TheorySymbol +seqIndexOf = Thy + { tsSym = "Seq$indexof" + , tsRaw = "seq.indexof" + -- forall a. Seq a -> a -> Int + , tsSort = FAbs 0 $ FFunc (seqSort 0) $ FFunc (FVar 0) $ intSort + , tsInterp = Theory + } + +-- | (seq.at s offset) +-- Sub-sequence of length 1 at offset in s. +seqAt :: TheorySymbol +seqAt = Thy + { tsSym = "Seq$at" + , tsRaw = "seq.at" + -- forall a. Seq a -> Int -> Seq a + , tsSort = FAbs 0 $ FFunc (seqSort 0) $ FFunc intSort $ seqSort 0 + , tsInterp = Theory + } + +-- | (seq.nth s offset) +-- Element at offset in s. If offset is out of bounds the result is +-- under-specified. In other words, it is treated as a fresh variable. +seqNth :: TheorySymbol +seqNth = Thy + { tsSym = "Seq$nth" + , tsRaw = "seq.nth" + -- forall a. Seq a -> Int -> a + , tsSort = FAbs 0 $ FFunc (seqSort 0) $ FFunc intSort $ FVar 0 + , tsInterp = Theory + } + +-- | (seq.contains s sub) +-- Does s contain the sub-sequence sub? +seqContains :: TheorySymbol +seqContains = Thy + { tsSym = "Seq$contains" + , tsRaw = "seq.contains" + -- forall a. Seq a -> Seq a -> Bool + , tsSort = FAbs 0 $ FFunc (seqSort 0) $ FFunc (seqSort 0) $ boolSort + , tsInterp = Theory + } + +-- | (seq.prefixof pre s) +-- Is pre a prefix of s? +seqPrefixOf :: TheorySymbol +seqPrefixOf = Thy + { tsSym = "Seq$prefixof" + , tsRaw = "seq.prefixof" + -- forall a. Seq a -> Seq a -> Bool + , tsSort = FAbs 0 $ FFunc (seqSort 0) $ FFunc (seqSort 0) $ boolSort + , tsInterp = Theory + } + +-- | (seq.suffixof suf s) +-- Is suf a suffix of s? +seqSuffixOf :: TheorySymbol +seqSuffixOf = Thy + { tsSym = "Seq$suffixof" + , tsRaw = "seq.suffixof" + -- forall a. Seq a -> Seq a -> Bool + , tsSort = FAbs 0 $ FFunc (seqSort 0) $ FFunc (seqSort 0) $ boolSort + , tsInterp = Theory + } + +-- | (seq.replace s src dst) +-- Replace the first occurrence of src by dst in s. +seqReplace :: TheorySymbol +seqReplace = Thy + { tsSym = "Seq$replace" + , tsRaw = "seq.replace" + -- forall a. Seq a -> a -> a -> Seq a + , tsSort = FAbs 0 $ FFunc (seqSort 0) $ FFunc (FVar 0) $ FFunc (FVar 0) $ seqSort 0 + , tsInterp = Theory + } + +-- | (seq.map fn s) +-- Map function `fn` (an expression of sort (Array S T)) on sequence `s` of sort +-- (Seq S). +seqMap :: TheorySymbol +seqMap = Thy + { tsSym = "Seq$map" + , tsRaw = "seq.map" + -- TODO: Define correct type (this requires array type) + , tsSort = intSort + , tsInterp = Theory + } + +-- (seq.mapi fn o s) +-- Map function `fn` (an expression of sort (Array Int S T)) on offset `o` and +-- sequence `s` of sort (Seq S). +seqMapi :: TheorySymbol +seqMapi = Thy + { tsSym = "Seq$mapi" + , tsRaw = "seq.mapi" + -- TODO: Define correct type (this requires array type) + , tsSort = intSort + , tsInterp = Theory + } + +-- | (seq.fold_left fn b s) +-- Fold function `fn` (an expression of sort (Array T S T)) on initial value `b` +-- of sort `T` and sequence `s` of sort (Seq S). +seqFoldLeft :: TheorySymbol +seqFoldLeft = Thy + { tsSym = "Seq$fold_left" + , tsRaw = "seq.fold_left" + -- TODO: Define correct type (this requires array type) + , tsSort = intSort + , tsInterp = Theory + } + +-- | (seq.fold_lefti fn o b s) +-- Fold function `fn` (an expression of sort (Array Int T S T)) on offset `o`, +-- initial value `b` of sort `T` and sequence `s` of sort (Seq S). +seqFoldLefti :: TheorySymbol +seqFoldLefti = Thy + { tsSym = "Seq$fold_lefti" + , tsRaw = "seq.fold_lefti" + -- TODO: Define correct type (this requires array type) + , tsSort = intSort + , tsInterp = Theory + } + -- [Interaction between Map and Set] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- Function mapToSet: Convert a map to a set. The map's key may be of @@ -423,6 +608,7 @@ smt2SmtSort SBool = "Bool" smt2SmtSort SString = fromText string smt2SmtSort SSet = fromText set smt2SmtSort SMap = fromText map +smt2SmtSort (SSeq a) = parens $ "Seq" <+> smt2SmtSort a smt2SmtSort (SBitVec n) = key "_ BitVec" (bShow n) smt2SmtSort (SVar n) = "T" <> bShow n smt2SmtSort (SData c []) = symbolBuilder c @@ -506,7 +692,7 @@ theorySymbols ds = fromListSEnv $ -- SHIFTLAM uninterpSymbols -------------------------------------------------------------------------------- interpSymbols :: [(Symbol, TheorySymbol)] -------------------------------------------------------------------------------- -interpSymbols = +interpSymbols = interpSeq <> [ interpSym setEmp emp (FAbs 0 $ FFunc (setSort $ FVar 0) boolSort) , interpSym setEmpty emp (FAbs 0 $ FFunc intSort (setSort $ FVar 0)) , interpSym setSng sng (FAbs 0 $ FFunc (FVar 0) (setSort $ FVar 0)) @@ -586,7 +772,6 @@ interpSymbols = , interpSym intbv64Name "(_ int2bv 64)" (FFunc intSort bv64) , interpSym bv32intName "(_ bv2int 32)" (FFunc bv32 intSort) , interpSym bv64intName "(_ bv2int 64)" (FFunc bv64 intSort) - ] where -- (sizedBitVecSort "Size1") @@ -621,6 +806,28 @@ interpSymbols = mapDefSort = FAbs 0 $ FAbs 1 $ FFunc (FVar 1) (mapSort (FVar 0) (FVar 1)) +interpSeq :: [(Symbol, TheorySymbol)] +interpSeq = interpTheorySymbol <$> + [ seqUnit + , seqEmpty + , seqConcat + , seqLen + , seqExtract + , seqIndexOf + , seqAt + , seqNth + , seqContains + , seqPrefixOf + , seqSuffixOf + , seqReplace + , seqMap + , seqMapi + , seqFoldLeft + , seqFoldLefti + ] + +interpTheorySymbol :: TheorySymbol -> (Symbol, TheorySymbol) +interpTheorySymbol ts = (tsSym ts, ts) interpBvUop :: Symbol -> (Symbol, TheorySymbol) interpBvUop name = interpSym' name bvUopSort diff --git a/src/Language/Fixpoint/Types/Names.hs b/src/Language/Fixpoint/Types/Names.hs index 9d56ffb21..3b9c6328b 100644 --- a/src/Language/Fixpoint/Types/Names.hs +++ b/src/Language/Fixpoint/Types/Names.hs @@ -107,6 +107,7 @@ module Language.Fixpoint.Types.Names ( , vvName , sizeName , bitVecName + , seqName -- , bvAndName, bvOrName, bvSubName, bvAddName , intbv32Name, intbv64Name, bv32intName, bv64intName , propConName @@ -684,11 +685,12 @@ intbv64Name = "int_to_bv64" bv32intName = "bv32_to_int" bv64intName = "bv64_to_int" -nilName, consName, sizeName, bitVecName :: Symbol +nilName, consName, sizeName, bitVecName, seqName :: Symbol nilName = "nil" consName = "cons" sizeName = "Size" bitVecName = "BitVec" +seqName = "Seq" mulFuncName, divFuncName :: Symbol diff --git a/src/Language/Fixpoint/Types/Sorts.hs b/src/Language/Fixpoint/Types/Sorts.hs index 3b1e64217..e3556bf8c 100644 --- a/src/Language/Fixpoint/Types/Sorts.hs +++ b/src/Language/Fixpoint/Types/Sorts.hs @@ -37,7 +37,7 @@ module Language.Fixpoint.Types.Sorts ( , mapFVar , basicSorts, intSort, realSort, boolSort, strSort, funcSort -- , bitVec32Sort, bitVec64Sort - , setSort, bitVecSort + , setSort, bitVecSort, seqSort , sizedBitVecSort , mapSort, charSort , listFTyCon @@ -494,6 +494,10 @@ setSort = FApp (FTC setFTyCon) -- bitVec64Sort :: Sort -- bitVec64Sort = bitVecSort (FTC (symbolFTycon' size64Name)) +-- | Produces a `Seq a` from a given polymorphic identifier. +seqSort :: Int -> Sort +seqSort i = FApp (FTC $ symbolFTycon' seqName) (FVar i) + bitVecSort :: Int -> Sort bitVecSort i = FApp (FTC $ symbolFTycon' bitVecName) (FVar i) diff --git a/src/Language/Fixpoint/Types/Theories.hs b/src/Language/Fixpoint/Types/Theories.hs index 8d1b83f48..37820694c 100644 --- a/src/Language/Fixpoint/Types/Theories.hs +++ b/src/Language/Fixpoint/Types/Theories.hs @@ -230,6 +230,7 @@ data SmtSort | SString | SSet | SMap + | SSeq SmtSort | SBitVec !Int | SVar !Int | SData !FTycon ![SmtSort] @@ -274,6 +275,8 @@ fappSmtSort poly m env = go -- HKT go t@(FVar _) ts = SApp (sortSmtSort poly env <$> (t:ts)) go (FTC c) _ | setConName == symbol c = SSet + go (FTC c) [s] + | seqName == symbol c = SSeq $ sortSmtSort poly env s go (FTC c) _ | mapConName == symbol c = SMap go (FTC bv) [FTC s] @@ -299,6 +302,7 @@ instance PPrint SmtSort where pprintTidy _ SString = text "Str" pprintTidy _ SSet = text "Set" pprintTidy _ SMap = text "Map" + pprintTidy k (SSeq a) = text "Seq" <+> pprintTidy k a pprintTidy _ (SBitVec n) = text "BitVec" <+> int n pprintTidy _ (SVar i) = text "@" <-> int i -- HKT pprintTidy k (SApp ts) = ppParens k (pprintTidy k tyAppName) ts diff --git a/tests/neg/sequence.fq b/tests/neg/sequence.fq new file mode 100644 index 000000000..2e2a4d115 --- /dev/null +++ b/tests/neg/sequence.fq @@ -0,0 +1,10 @@ +fixpoint "--counterexample" + +bind 0 xs : {v: Seq int | Seq$len v == 2} +bind 1 ys : {v: Seq int | Seq$len v == 2} + +constraint: + env [0;1] + lhs {v : Seq int | v == xs} + rhs {v : Seq int | v == ys} + id 0 tag [] diff --git a/tests/pos/sequence.fq b/tests/pos/sequence.fq new file mode 100644 index 000000000..5e54bebb6 --- /dev/null +++ b/tests/pos/sequence.fq @@ -0,0 +1,7 @@ +bind 0 xs : {v: Seq int | xs == Seq$concat (Seq$unit 0) (Seq$unit 1)} + +constraint: + env [0] + lhs {v : Seq int | v == xs} + rhs {v : Seq int | Seq$len v == 2} + id 0 tag [] From d1cec55b7325a2ae35a5bf158ffce3d76d3048e6 Mon Sep 17 00:00:00 2001 From: Robin Webbers Date: Mon, 25 Mar 2024 14:52:26 +0100 Subject: [PATCH 29/33] Definitions as quantified axioms proved too slow, so for now I removed it from the counterexample generation. --- src/Language/Fixpoint/Counterexample/Check.hs | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/src/Language/Fixpoint/Counterexample/Check.hs b/src/Language/Fixpoint/Counterexample/Check.hs index f8157cef6..f4d7a213e 100644 --- a/src/Language/Fixpoint/Counterexample/Check.hs +++ b/src/Language/Fixpoint/Counterexample/Check.hs @@ -18,7 +18,7 @@ import qualified Data.HashMap.Strict as Map import Control.Monad.State.Strict import Control.Monad.Reader -import Control.Monad (forM, foldM) +import Control.Monad (forM, foldM, when) -- | Environment for the counter example generation. data CheckEnv = CheckEnv @@ -57,7 +57,10 @@ runCheck cids env = rd $ checkAll cids -- | Try to find a counter example for all the given constraints. checkAll :: MonadCheck m => [SubcId] -> m [SMTCounterexample] checkAll cids = do - setDefinitions + -- Using definitions as quantified axioms is really slow! Perhaps this should + -- be feature gated, or we should just never do this as there are most likely + -- faster alternatives. I'll leave it like this for now. + when False setDefinitions cexs <- forM cids checkConstraint return $ catMaybes cexs From b504b4781c2c59ff5fada062a9b92f746fffa336 Mon Sep 17 00:00:00 2001 From: Robin Webbers Date: Mon, 1 Apr 2024 11:55:44 +0200 Subject: [PATCH 30/33] Resolved issue where the counterexample build would ignore other refinements if it included kvars --- src/Language/Fixpoint/Counterexample/Build.hs | 27 ++++++++++--------- 1 file changed, 15 insertions(+), 12 deletions(-) diff --git a/src/Language/Fixpoint/Counterexample/Build.hs b/src/Language/Fixpoint/Counterexample/Build.hs index 7c9e2ec13..4b5b6e88e 100644 --- a/src/Language/Fixpoint/Counterexample/Build.hs +++ b/src/Language/Fixpoint/Counterexample/Build.hs @@ -211,23 +211,26 @@ reftToStmts (bid, sym, RR sort' <- elaborate' sort let decl = Let $ Decl sym' sort' - -- Get constraints from the expression. - let constraints = case predKs e of - [] -> Assume e - ks -> Call bid ks + -- TODO: Could we perhaps remove duplicate calls here? There seem to be a + -- lot, so this could eliminate a lot of overhead potentially! + -- Get constraints from the expression. + let constraints = exprStmts bid e -- Do substitution of self variable in the constraints let sub = Su $ Map.singleton v (EVar sym) - return [decl, subst sub constraints] + return $ decl : subst sub constraints --- | Get the kvars from an expression. +-- | Split the expression into a number of statements -- --- I think this should be the only way in which kvars appear? --- Otherwise, this should be changed! -predKs :: Expr -> [(KVar, Subst)] -predKs (PAnd ps) = mconcat $ map predKs ps -predKs (PKVar k su) = [(k, su)] -predKs _ = [] +-- Note that kvars should only appear as conjuncted from the root expression, +-- or as the root itself. This function does not catch nested kvars. +exprStmts :: BindId -> Expr -> [Statement] +exprStmts bid = go + where + go (PAnd ps) = ps >>= go + -- TODO: Change call so it doesn't take a list of locations. + go (PKVar k su) = [Call bid [(k, su)]] + go e = [Assume e] -- | The sorts for the apply monomorphization only match if we do this elaborate -- on the sort. Not sure why... From b5bbb840d647c21f1385b3f204cb2bff1c572bd4 Mon Sep 17 00:00:00 2001 From: Robin Webbers Date: Tue, 2 Apr 2024 17:27:31 +0200 Subject: [PATCH 31/33] Added early pruning of paths and removal of duplicate kvars (i.e. identical module transitively equivalent variables) --- src/Language/Fixpoint/Counterexample/Build.hs | 97 ++++++++++++++++--- src/Language/Fixpoint/Counterexample/Check.hs | 14 ++- src/Language/Fixpoint/Counterexample/SMT.hs | 24 +++-- src/Language/Fixpoint/Counterexample/Types.hs | 16 +-- 4 files changed, 119 insertions(+), 32 deletions(-) diff --git a/src/Language/Fixpoint/Counterexample/Build.hs b/src/Language/Fixpoint/Counterexample/Build.hs index 4b5b6e88e..b52bf8158 100644 --- a/src/Language/Fixpoint/Counterexample/Build.hs +++ b/src/Language/Fixpoint/Counterexample/Build.hs @@ -1,6 +1,7 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternGuards #-} module Language.Fixpoint.Counterexample.Build ( hornToProg @@ -17,9 +18,13 @@ import Language.Fixpoint.SortCheck (Elaborate (..)) import qualified Language.Fixpoint.Utils.Files as Ext import Data.Maybe (fromMaybe) +import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as Map +import qualified Data.Set as Set import Data.List (find, sortBy, foldl') +import qualified Data.List as List +import Control.Monad (foldM) import Control.Monad.State import Control.Monad.Reader import Control.Monad (when, forM) @@ -117,21 +122,15 @@ addHorn horn = do -- Add the horn clause as a function body let cid = fromMaybe (-1) $ sid horn - let statements = sortStatements $ lhs <> rhs + -- TODO: The exploration ideally doesn't need the ordering on the calls for + -- the pruning of branches. + -- TODO: It might be better to replace Let statements by a substitution map. + -- Sort the statements, let bindings should go first. Calls last. We want + -- to have all available variables at the start. + let statements = dedupCalls decl . List.sort $ lhs <> rhs let body = Body cid $ statements addFunc name $ Func decl [body] --- | Sort the statements so we do all declarations first. --- TODO: Change the `Body` type so it contains a substitution map. Remove the --- Let statement from the types of statements we have! -sortStatements :: [Statement] -> [Statement] -sortStatements = sortBy cmp - where - cmp (Let _) (Let _) = EQ - cmp (Let _) _ = LT - cmp _ (Let _) = GT - cmp _ _ = EQ - -- | Gets a signature of a KVar from its well foundedness constraint getSig :: MonadBuild info m => Name -> m Signature getSig kvar = do @@ -211,9 +210,6 @@ reftToStmts (bid, sym, RR sort' <- elaborate' sort let decl = Let $ Decl sym' sort' - -- TODO: Could we perhaps remove duplicate calls here? There seem to be a - -- lot, so this could eliminate a lot of overhead potentially! - -- Get constraints from the expression. let constraints = exprStmts bid e -- Do substitution of self variable in the constraints @@ -265,3 +261,74 @@ sortBodies prog = prog { functions = functions' } count (Body _ stmts) = length . filter isCall $ stmts isCall (Call _ _) = True isCall _ = False + +type Equivalents = HashMap Symbol ID +type ID = Int + +-- | Check if two symbols are equivalent. +symEq :: Equivalents -> Symbol -> Symbol -> Bool +symEq alias lhs rhs = Map.lookup lhs alias == Map.lookup rhs alias + +-- | Get a map of all equivalent symbols. I.e. symbols which were literally +-- defined to be by a statement of the form; assume x == y +getEqs :: Signature -> [Statement] -> Equivalents +getEqs sig statements = evalState getAliases' 0 + where + statements' = (Let <$> sig) <> statements + getAliases' = foldM go mempty statements' + + go acc (Let (Decl sym _)) = do + identifier <- fresh + return $ acc <> Map.singleton sym identifier + go acc (Assume (PAtom Eq lhs rhs)) + | EVar lhs' <- uncst lhs + , EVar rhs' <- uncst rhs = do + let identifier = Map.lookup lhs' acc + let old = Map.lookup rhs' acc + case (identifier, old) of + -- Add to aliases if both names are defined in the environment. + (Just identifier', Just old') -> do + let rename current = if current == old' then identifier' else current + return $ rename <$> acc + + -- Otherwise, just return the accumulator as is + _ -> return acc + go acc _ = return acc + + fresh = state $ \s -> (s, s + 1) + + uncst (ECst e _) = uncst e + uncst e = e + +-- | Deduplicate calls by building an equivalence map and checking whether +-- substitution maps are submaps of each other. +dedupCalls :: Signature -> [Statement] -> [Statement] +dedupCalls signature statements = dedup $ replace <$> statements + where + dedup = Set.toList . Set.fromList + + -- FIXME: I don't think this captures all cases! (has to do with ordering of + -- statements) + -- Replaces a submap subst with the bigger version. + replace (Call _ [(_, sub)]) + | Just v <- find (isSubmap' sub) statements = v + replace s = s + + isSubmap' sub (Call _ [(_, sub')]) = isSubmap eqs sub sub' + isSubmap' _ _ = False + + eqs = getEqs signature statements + +-- | Returns whether the first substitution map is a sub-assignment of the +-- second. In other words, if the first subst can be ignored if both as it +-- places the same (but less) constraints as the second subst. +isSubmap :: Equivalents -> Subst -> Subst -> Bool +isSubmap eqs (Su sub0) (Su sub1) = null remaining + where + remaining = Map.differenceWith diff sub0 sub1 + + diff (EVar sym0) (EVar sym1) + | not $ eq' sym0 sym1 = Just $ EVar sym0 + diff _ _ = Nothing + + eq' = symEq eqs diff --git a/src/Language/Fixpoint/Counterexample/Check.hs b/src/Language/Fixpoint/Counterexample/Check.hs index f4d7a213e..828ed702d 100644 --- a/src/Language/Fixpoint/Counterexample/Check.hs +++ b/src/Language/Fixpoint/Counterexample/Check.hs @@ -36,6 +36,11 @@ instance SMTContext CheckEnv where -- | The monad used to generate counter examples from a Prog. type MonadCheck m = (MonadReader CheckEnv m, MonadIO m) +-- | The runner is a computation path in the program. We use this as an argument +-- to pass around the remainder of a computation. This way, we can pop paths in +-- the SMT due to conditionals. Allowing us to retain anything prior to that. +type Runner m = m (Maybe SMTCounterexample) + -- | Check the given constraints to try and find a counter example. checkProg :: MonadIO m => Config -> SInfo info -> Prog -> [SubcId] -> m [SMTCounterexample] checkProg cfg si prog cids = SMT.withContext cfg si check @@ -78,7 +83,7 @@ checkConstraint cid = do let cmp (Body bid _) = bid == cid let scope = Scope mempty cid mempty case find cmp bodies of - Just body -> runBody scope body SMT.checkSat + Just body -> runBody scope body SMT.getModel Nothing -> return Nothing -- | Run a function. This essentially makes one running branch for @@ -89,13 +94,20 @@ runFunc name scope runner = do -- Lookup function bodies func <- getFunc name maxDepth' <- reader maxDepth + sat <- SMT.checkSat case func of + -- This sub tree is already unsatisfiable. Adding more constraints never + -- makes it satisfiable and, as such, we prune this subtree. + _ | not sat -> return Nothing + -- Recursion limit reached, so no counterexample. _ | length (path scope) >= maxDepth' -> return Nothing + -- Unconstrained function body, so there is no counterexample here. This -- would be equivalent to trying to create an inhabitant of {v:a | false}, -- which doesn't exist. Nothing -> return Nothing + -- Constrained function body Just (Func _ bodies) -> do -- Generate all execution paths (as runners). diff --git a/src/Language/Fixpoint/Counterexample/SMT.hs b/src/Language/Fixpoint/Counterexample/SMT.hs index 0bfbbab0d..b002b2543 100644 --- a/src/Language/Fixpoint/Counterexample/SMT.hs +++ b/src/Language/Fixpoint/Counterexample/SMT.hs @@ -11,6 +11,8 @@ module Language.Fixpoint.Counterexample.SMT , assume , inScope , checkSat + , getModel + , getModelUnsafe ) where import Language.Fixpoint.Types @@ -79,21 +81,27 @@ inScope inner = do return result -- | Check if there is a counterexample, returing one if it is available. -checkSat :: MonadSMT s m => Runner m +checkSat :: MonadSMT s m => m Bool checkSat = do ctx <- reader smtContext - valid <- liftIO $ SMT.smtCheckUnsat ctx + liftIO $ not <$> SMT.smtCheckUnsat ctx - if valid then return Nothing else Just <$> getModel - --- | Returns a model, with as precondition that the SMT solver had a satisfying --- assignment prior to this. -getModel :: MonadSMT s m => m SMTCounterexample -getModel = do +-- | Returns a model, with as precondition that the SMT solver had a satisfying +-- assignment prior to this. Hence, this is "unsafe", as calling it without +-- this precondition will crash the program. +getModelUnsafe :: MonadSMT s m => m SMTCounterexample +getModelUnsafe = do ctx <- reader smtContext sub <- liftIO $ SMT.smtGetModel ctx return $ smtSubstToCex sub +-- | Checks satisfiability, returning a model if available. +getModel :: MonadSMT s m => m (Maybe SMTCounterexample) +getModel = do + sat <- checkSat + if sat then Just <$> getModelUnsafe else return Nothing + + -- | Transform an SMT substitution, which contains SMT scoped symbols, into a -- layered, tree-like counterexample. smtSubstToCex :: Subst -> SMTCounterexample diff --git a/src/Language/Fixpoint/Counterexample/Types.hs b/src/Language/Fixpoint/Counterexample/Types.hs index 45e672f29..59273f580 100644 --- a/src/Language/Fixpoint/Counterexample/Types.hs +++ b/src/Language/Fixpoint/Counterexample/Types.hs @@ -6,7 +6,6 @@ module Language.Fixpoint.Counterexample.Types , FullCounterexample , CexEnv , Trace - , Runner , Scope (..) , Prog (..) @@ -38,11 +37,6 @@ dbg = liftIO . print . pprint -- from symbol to concrete instance. type SMTCounterexample = Counterexample Subst --- | The runner is a computation path in the program. We use this as an argument --- to pass around the remainder of a computation. This way, we can pop paths in --- the SMT due to conditionals. Allowing us to retain anything prior to that. -type Runner m = m (Maybe SMTCounterexample) - -- | A scope contains the current binders in place as well as the path traversed -- to reach this scope. data Scope = Scope @@ -86,6 +80,12 @@ data Body = Body !SubcId ![Statement] -- | A statement used to introduce/check constraints, together with its location -- information. +-- +-- WARNING: We rely on the order of these declarations for the derive of Ord. +-- Specifically, to sort the statements in this same order for the builder. +-- Let bindings should appear first so everything is in scope and correctly +-- named. Calls should be last: this allows us to prune branches when executing +-- them. Do not change these unless you know what you are doing! data Statement = Let !Decl -- ^ Introduces a new variable. @@ -96,11 +96,11 @@ data Statement | Call !BindId ![(Name, Subst)] -- ^ Call to function. The bind id is used to trace callstacks. I.e. it is the -- caller of the function. - deriving Show + deriving (Show, Eq, Ord) -- | A declaration of a Symbol with a Sort. data Decl = Decl !Symbol !Sort - deriving Show + deriving (Show, Eq, Ord) -- | The main function, which any horn clause without a KVar on the rhs will be -- added to. From 2e88e2cd888d69bc59146c075cf397daa10ad9ed Mon Sep 17 00:00:00 2001 From: Robin Webbers Date: Tue, 2 Apr 2024 23:42:21 +0200 Subject: [PATCH 32/33] Changed search strategy from DFS to iterative deepening DFS --- src/Language/Fixpoint/Counterexample/Check.hs | 104 +++++++++++++----- src/Language/Fixpoint/Counterexample/Types.hs | 4 + 2 files changed, 83 insertions(+), 25 deletions(-) diff --git a/src/Language/Fixpoint/Counterexample/Check.hs b/src/Language/Fixpoint/Counterexample/Check.hs index 828ed702d..559da8052 100644 --- a/src/Language/Fixpoint/Counterexample/Check.hs +++ b/src/Language/Fixpoint/Counterexample/Check.hs @@ -12,9 +12,10 @@ import Language.Fixpoint.Counterexample.Types import Language.Fixpoint.Counterexample.SMT as SMT import Language.Fixpoint.Types.Config (Config) -import Data.Maybe (fromJust, catMaybes) +import Data.Maybe (fromJust, catMaybes, isJust) import Data.List (find) import qualified Data.HashMap.Strict as Map +import qualified Data.HashSet as Set import Control.Monad.State.Strict import Control.Monad.Reader @@ -26,15 +27,24 @@ data CheckEnv = CheckEnv -- ^ The program we are checking , context :: !SMT.Context -- ^ The SMT context we write the constraints from the program to. - , maxDepth :: !Int - -- ^ The maximum number of functions to traverse (to avoid state blow-up). + , maxIterations :: !Int + -- ^ The checker is an iterative deepening DFS. This is the maximum number of + -- iterations before we give up entirely. + } + +data CheckState = CheckState + { curRec :: !Int + -- ^ The number of recursive unfoldings currently in the path. + , maxRec :: !Int + -- ^ The maximum number of recursive unfoldings we allow in any path for this + -- iteration. } instance SMTContext CheckEnv where smtContext = context -- | The monad used to generate counter examples from a Prog. -type MonadCheck m = (MonadReader CheckEnv m, MonadIO m) +type MonadCheck m = (MonadReader CheckEnv m, MonadIO m, MonadState CheckState m) -- | The runner is a computation path in the program. We use this as an argument -- to pass around the remainder of a computation. This way, we can pop paths in @@ -48,16 +58,20 @@ checkProg cfg si prog cids = SMT.withContext cfg si check check ctx = runCheck cids CheckEnv { program = prog , context = ctx - -- TODO: Perhaps the max depth should be a parameter for the user? - , maxDepth = 10 + -- TODO: Perhaps the max iterative depth should be a user parameter? + , maxIterations = 3 } -- | Runs the program checker with the monad stack -- unwrapped. runCheck :: MonadIO m => [SubcId] -> CheckEnv -> m [SMTCounterexample] -runCheck cids env = rd $ checkAll cids +runCheck cids env = rd . st $ checkAll cids where rd = flip runReaderT env + st = flip evalStateT CheckState + { curRec = 0 + , maxRec = 0 + } -- | Try to find a counter example for all the given constraints. checkAll :: MonadCheck m => [SubcId] -> m [SMTCounterexample] @@ -81,28 +95,47 @@ checkConstraint :: MonadCheck m => SubcId -> m (Maybe SMTCounterexample) checkConstraint cid = do Func _ bodies <- fromJust <$> getFunc mainName let cmp (Body bid _) = bid == cid - let scope = Scope mempty cid mempty + let scope = Scope + { path = mempty + , constraint = cid + , binders = mempty + , visited = mempty + } case find cmp bodies of - Just body -> runBody scope body SMT.getModel + Just body -> iterateDepth $ runBody scope body SMT.getModel Nothing -> return Nothing +-- | Does iterative deepening of search; it checks if the current runner +-- produces a counterexample. If not, it increments the allowed recursion limit. +-- It will continue doing so until either a counterexample is found or the +-- iteration limit is reached. +iterateDepth :: MonadCheck m => Runner m -> Runner m +iterateDepth runner = do + cex <- runner + curLimit <- gets maxRec + limit <- reader maxIterations + case cex of + Just _ -> return cex + _ | curLimit > limit -> return Nothing + _ -> do + modify $ \s -> s { maxRec = maxRec s + 1 } + cex' <- iterateDepth runner + modify $ \s -> s { maxRec = maxRec s - 1 } + return cex' + -- | Run a function. This essentially makes one running branch for -- each body inside of the function. It will try each branch -- sequentially, returning early if a counterexample was found. runFunc :: MonadCheck m => Name -> Scope -> Runner m -> Runner m -runFunc name scope runner = do +runFunc name scope' runner = withRec name scope' $ \scope -> do -- Lookup function bodies func <- getFunc name - maxDepth' <- reader maxDepth sat <- SMT.checkSat case func of -- This sub tree is already unsatisfiable. Adding more constraints never -- makes it satisfiable and, as such, we prune this subtree. _ | not sat -> return Nothing - -- Recursion limit reached, so no counterexample. - _ | length (path scope) >= maxDepth' -> return Nothing - -- Unconstrained function body, so there is no counterexample here. This -- would be equivalent to trying to create an inhabitant of {v:a | false}, -- which doesn't exist. @@ -113,12 +146,28 @@ runFunc name scope runner = do -- Generate all execution paths (as runners). let runner' body = runBody (extendScope scope body) body runner let paths = runner' <$> bodies + foldRunners paths + +-- | Increments the recursive call counter for the entire remaining runner. We +-- only allow `maxRec` recursive calls over an entire path, not of the subtree. +withRec :: MonadCheck m => Name -> Scope -> (Scope -> Runner m) -> Runner m +withRec name scope runner + | name `Set.member` visited scope = do + modify $ \s -> s { curRec = curRec s + 1 } + limit <- recursionLimit + result <- if limit then return Nothing else runner' + modify $ \s -> s { curRec = curRec s - 1 } + return result + | otherwise = runner' + where + runner' = runner scope { visited = Set.insert name (visited scope)} - -- TODO: We should really explore shallow trees first. The current thing - -- can search for a really long time if there are a large number of paths - -- before the actual counterexample... - result <- foldRunners paths - return result +-- | Returns whether the recursion limit has been hit. +recursionLimit :: MonadCheck m => m Bool +recursionLimit = do + nrec <- gets curRec + limit <- gets maxRec + return $ nrec > limit -- | Run the statements in the body. If there are no more statements to run, -- this will execute the Runner that was passed as argument. @@ -145,17 +194,22 @@ runStatement scope stmt runner = do let runner' = runner scope let stmt' = subst (binders scope) stmt case stmt' of - Call origin calls -> do - -- We fake a SubcId here, it will later get mapped into the scope when we - -- decide which body to run. - let scope' app = Scope (origin:path scope) 0 app - let runCall (name, app) = runFunc name (scope' app) runner' - foldRunners $ runCall <$> calls Assume e -> SMT.assume e >> runner' Assert e -> SMT.assert e >> runner' Let decl -> do scope' <- SMT.declare scope decl runner scope' + Call origin calls -> do + let scope' app = Scope + { path = origin : path scope + -- We fake a SubcId here, it will later get mapped into the scope + -- when we decide which body to run. + , constraint = 0 + , binders = app + , visited = visited scope + } + let runCall (name, app) = runFunc name (scope' app) runner' + foldRunners $ runCall <$> calls -- | Get a function from the program given its name. getFunc :: MonadCheck m => Name -> m (Maybe Func) diff --git a/src/Language/Fixpoint/Counterexample/Types.hs b/src/Language/Fixpoint/Counterexample/Types.hs index 59273f580..3d8f6c3fc 100644 --- a/src/Language/Fixpoint/Counterexample/Types.hs +++ b/src/Language/Fixpoint/Counterexample/Types.hs @@ -23,6 +23,7 @@ module Language.Fixpoint.Counterexample.Types import Language.Fixpoint.Types import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as Map +import Data.HashSet (HashSet) import Data.Bifunctor (second) import Text.PrettyPrint.HughesPJ ((<+>), ($+$)) @@ -46,6 +47,9 @@ data Scope = Scope -- ^ The current constraint, which dictates the binders. , binders :: !Subst -- ^ The binders available in the current scope. + , visited :: HashSet Name + -- ^ The functions that have already been visited. This is to track whether we + -- want to expand a function or if we have already hit the recursion limit. } deriving (Eq, Ord, Show) From 677d322829c2d9bb95cc6623f480b40ada377872 Mon Sep 17 00:00:00 2001 From: Robin Webbers Date: Tue, 2 Apr 2024 23:45:06 +0200 Subject: [PATCH 33/33] Removed obsolete import --- src/Language/Fixpoint/Counterexample/Check.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language/Fixpoint/Counterexample/Check.hs b/src/Language/Fixpoint/Counterexample/Check.hs index 559da8052..820cea2f7 100644 --- a/src/Language/Fixpoint/Counterexample/Check.hs +++ b/src/Language/Fixpoint/Counterexample/Check.hs @@ -12,7 +12,7 @@ import Language.Fixpoint.Counterexample.Types import Language.Fixpoint.Counterexample.SMT as SMT import Language.Fixpoint.Types.Config (Config) -import Data.Maybe (fromJust, catMaybes, isJust) +import Data.Maybe (fromJust, catMaybes) import Data.List (find) import qualified Data.HashMap.Strict as Map import qualified Data.HashSet as Set