From 2a50244b0c05875675a4736a1587b26af395210c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dan=20Ros=C3=A9n?= Date: Fri, 28 Aug 2015 17:28:37 +0200 Subject: [PATCH 1/3] Working on adding a min-translation --- tip-lib/executable/Main.hs | 17 ++++++---- tip-lib/src/Tip/Core.hs | 2 ++ tip-lib/src/Tip/Pass/AxiomatizeDatadecls.hs | 23 +++++++------ tip-lib/src/Tip/Pass/AxiomatizeFuncdefs.hs | 37 +++++++++++++-------- tip-lib/src/Tip/Passes.hs | 9 +++-- tip-lib/tip-lib.cabal | 1 + 6 files changed, 58 insertions(+), 31 deletions(-) diff --git a/tip-lib/executable/Main.hs b/tip-lib/executable/Main.hs index ec58bbdd..0f98f366 100644 --- a/tip-lib/executable/Main.hs +++ b/tip-lib/executable/Main.hs @@ -20,7 +20,9 @@ import System.FilePath import Options.Applicative import Control.Monad -data OutputMode = Haskell | Why3 | CVC4 | Isabelle | TIP | TFF +data MinOpt = MinEnabled | MinDisabled + +data OutputMode = Haskell | Why3 | CVC4 | Isabelle | TIP | TFF MinOpt parseOutputMode :: Parser OutputMode parseOutputMode = @@ -28,7 +30,8 @@ parseOutputMode = <|> flag' Why3 (long "why" <> help "WhyML output") <|> flag' CVC4 (long "smtlib" <> help "SMTLIB output (CVC4-compatible)") <|> flag' Isabelle (long "isabelle" <> help "Isabelle output") - <|> flag' TFF (long "tff" <> help "TPTP TFF output") + <|> flag' (TFF MinDisabled) (long "tff" <> help "TPTP TFF output") + <|> flag' (TFF MinEnabled) (long "tff-min" <> help "TPTP TFF output with Min") <|> flag TIP TIP (long "tip" <> help "TIP output (default)") optionParser :: Parser ([StandardPass], Maybe String, OutputMode, Maybe FilePath) @@ -74,16 +77,18 @@ handle passes mode multipath s = , SimplifyGently, NegateConjecture ] , "smt2") - TFF -> + TFF min_mode -> ( TFF.ppTheory , passes ++ [ TypeSkolemConjecture, Monomorphise False , LambdaLift, AxiomatizeLambdas , SimplifyGently, CollapseEqual, RemoveAliases , SimplifyGently, Monomorphise False, IfToBoolOp, CommuteMatch - , SimplifyGently, LetLift, SimplifyGently, AxiomatizeFuncdefs2 - , SimplifyGently, AxiomatizeDatadecls - ] + , SimplifyGently, LetLift, SimplifyGently + ] ++ + case min_mode of + MinEnabled -> [Min] + MinDisabled -> [AxiomatizeFuncdefs2, SimplifyGently, AxiomatizeDatadecls] , "p") Haskell -> (HS.ppTheory, passes, "hs") Why3 -> (Why3.ppTheory, passes ++ [CSEMatchWhy3], "mlw") diff --git a/tip-lib/src/Tip/Core.hs b/tip-lib/src/Tip/Core.hs index f16697c4..c1b92d93 100644 --- a/tip-lib/src/Tip/Core.hs +++ b/tip-lib/src/Tip/Core.hs @@ -23,6 +23,8 @@ import Control.Monad import qualified Data.Map as Map import Control.Applicative ((<|>)) +import Data.Maybe + infix 4 === -- infixr 3 /\ infixr 2 \/ diff --git a/tip-lib/src/Tip/Pass/AxiomatizeDatadecls.hs b/tip-lib/src/Tip/Pass/AxiomatizeDatadecls.hs index eebc0404..81d11b67 100644 --- a/tip-lib/src/Tip/Pass/AxiomatizeDatadecls.hs +++ b/tip-lib/src/Tip/Pass/AxiomatizeDatadecls.hs @@ -10,15 +10,17 @@ import Tip.Scope import Data.List (tails) import Data.Monoid +import Data.Maybe + import qualified Data.Map as M -axiomatizeDatadecls :: Name a => Theory a -> Fresh (Theory a) -axiomatizeDatadecls thy@Theory{..} = - do thys <- mapM trDatatype thy_datatypes +axiomatizeDatadecls :: Name a => (Expr a -> Maybe (Expr a)) -> Theory a -> Fresh (Theory a) +axiomatizeDatadecls min_pred thy@Theory{..} = + do thys <- mapM (trDatatype min_pred) thy_datatypes return (mconcat (thys ++ [thy { thy_datatypes = [] }])) -trDatatype :: Name a => Datatype a -> Fresh (Theory a) -trDatatype dt@Datatype{..} = +trDatatype :: Name a => (Expr a -> Maybe (Expr a)) -> Datatype a -> Fresh (Theory a) +trDatatype min_pred dt@Datatype{..} = do let ty_args = map TyVar data_tvs -- X = nil | X = cons(head(X), tail(X)) @@ -39,13 +41,13 @@ trDatatype dt@Datatype{..} = inj <- sequence [ do qs <- mapM freshLocal (map snd args) + let con = Gbl (constructor dt c ty_args) :@: map Lcl qs return $ Formula Assert data_tvs $ mkQuant Forall qs $ - Gbl (projector dt c i ty_args) :@: - [Gbl (constructor dt c ty_args) :@: map Lcl qs] - === - Lcl (case drop i qs of q:_ -> q; [] -> __) + maybeToList (min_pred con) + ===> (Gbl (projector dt c i ty_args) :@: [con] + === Lcl (case drop i qs of q:_ -> q; [] -> __)) | c@(Constructor _ _ args) <- data_cons , i <- [0..length args-1] ] @@ -60,7 +62,8 @@ trDatatype dt@Datatype{..} = return $ Formula Assert data_tvs $ mkQuant Forall (qs_k ++ qs_j) $ - tm_k =/= tm_j + (maybeToList (min_pred tm_k) ++ maybeToList (min_pred tm_j)) + ===> (tm_k =/= tm_j) | (k@(Constructor _ _ args_k),j@(Constructor _ _ args_j)) <- diag data_cons ] diff --git a/tip-lib/src/Tip/Pass/AxiomatizeFuncdefs.hs b/tip-lib/src/Tip/Pass/AxiomatizeFuncdefs.hs index ac0b6b51..282e565e 100644 --- a/tip-lib/src/Tip/Pass/AxiomatizeFuncdefs.hs +++ b/tip-lib/src/Tip/Pass/AxiomatizeFuncdefs.hs @@ -8,6 +8,7 @@ import Tip.Core import Tip.Fresh import Tip.Scope +import Data.Maybe import Data.List (delete) import Data.Generics.Geniplate import Control.Applicative @@ -35,8 +36,8 @@ axiomatize fn@Function{..} = -- | Makes function definitions into case by converting case to -- left hand side pattern matching. -axiomatizeFuncdefs2 :: Name a => Theory a -> Theory a -axiomatizeFuncdefs2 thy@Theory{..} = +axiomatizeFuncdefs2 :: Name a => (Expr a -> Maybe (Expr a)) -> Theory a -> Theory a +axiomatizeFuncdefs2 min_pred thy@Theory{..} = thy{ thy_funcs = [], thy_sigs = thy_sigs ++ abs, @@ -44,29 +45,35 @@ axiomatizeFuncdefs2 thy@Theory{..} = } where scp = scope thy - (abs,fms) = unzip (map (axiomatize2 scp) thy_funcs) + (abs,fms) = unzip (map (axiomatize2 min_pred scp) thy_funcs) -axiomatize2 :: forall a . Ord a => Scope a -> Function a -> (Signature a, [Formula a]) -axiomatize2 scp fn@Function{..} = +axiomatize2 :: forall a . Ord a => (Expr a -> Maybe (Expr a)) -> Scope a -> Function a -> (Signature a, [Formula a]) +axiomatize2 min_pred scp fn@Function{..} = ( Signature func_name (funcType fn) , map (Formula Assert func_tvs) - (ax func_args [] (map Lcl func_args) func_body) + (ax func_args + (maybeToList (min_pred (func_app (map Lcl func_args)))) + (map Lcl func_args) + func_body) ) where + func_app = applyFunction fn (map TyVar func_tvs) -- ax vars pre args body -- ~= -- forall vars . pre => f(args) = body ax :: [Local a] -> [Expr a] -> [Expr a] -> Expr a -> [Expr a] ax vars pre args e0 = case e0 of - Match s (Case Default def_rhs:alts) -> ax vars (pre ++ map (invert_pat s . case_pat) alts) args def_rhs ++ ax_alts s alts + Match s (Case Default def_rhs:alts) -> + ax vars (pre ++ map (invert_pat s . case_pat) alts) args def_rhs + ++ ax_alts s alts Match s alts -> ax_alts s alts Let x b e -> ax (vars ++ [x]) (pre ++ [Lcl x === b]) args e Lam{} -> __ Quant{} -> __ _ -> -- e0 should now only be (:@:) and Lcl - [mkQuant Forall vars (pre ===> applyFunction fn (map TyVar func_tvs) args === e0)] + [mkQuant Forall vars (pre ===> func_app args === e0)] where invert_pat :: Expr a -> Pattern a -> Expr a invert_pat _ Default = __ @@ -84,9 +91,13 @@ axiomatize2 scp fn@Function{..} = ax_pat s (ConPat k bs) rhs = rec bs rhs s (Gbl k :@: map Lcl bs) rec :: [Local a] -> Expr a -> Expr a -> Expr a -> [Expr a] - rec new e (Lcl x) pat_expr = - let su = unsafeSubst pat_expr x - in ax (delete x vars ++ new) (map su pre) (map su args) (su e) - - rec new e scrut pat_expr = ax (vars ++ new) (pre ++ [scrut === pat_expr]) args e + rec new e scrut pat_expr = + maybeToList + (fmap (\ min_scrut -> mkQuant Forall vars (pre ===> min_scrut)) + (min_pred scrut)) + ++ case scrut of + Lcl x -> + let su = unsafeSubst pat_expr x + in ax (delete x vars ++ new) (map su pre) (map su args) (su e) + _ -> ax (vars ++ new) (pre ++ [scrut === pat_expr]) args e diff --git a/tip-lib/src/Tip/Passes.hs b/tip-lib/src/Tip/Passes.hs index cca909a3..24a9a40a 100644 --- a/tip-lib/src/Tip/Passes.hs +++ b/tip-lib/src/Tip/Passes.hs @@ -79,6 +79,7 @@ import Tip.Pass.EliminateDeadCode import Tip.Pass.FillInCases import Tip.Pass.AxiomatizeFuncdefs import Tip.Pass.AxiomatizeDatadecls +import Tip.Pass.Min import Tip.Pass.SelectConjecture import Tip.Pass.DropSuffix import Tip.Pass.Induction @@ -112,6 +113,7 @@ data StandardPass | AxiomatizeFuncdefs | AxiomatizeFuncdefs2 | AxiomatizeDatadecls + | Min | Monomorphise Bool | CSEMatch | CSEMatchWhy3 @@ -146,8 +148,9 @@ instance Pass StandardPass where LetLift -> single $ letLift AxiomatizeLambdas -> single $ axiomatizeLambdas AxiomatizeFuncdefs -> single $ return . axiomatizeFuncdefs - AxiomatizeFuncdefs2 -> single $ return . axiomatizeFuncdefs2 - AxiomatizeDatadecls -> single $ axiomatizeDatadecls + AxiomatizeFuncdefs2 -> single $ return . axiomatizeFuncdefs2 (const Nothing) + AxiomatizeDatadecls -> single $ axiomatizeDatadecls (const Nothing) + Min -> single $ minPass Monomorphise b -> single $ monomorphise b CSEMatch -> single $ return . cseMatch cseMatchNormal CSEMatchWhy3 -> single $ return . cseMatch cseMatchWhy3 @@ -203,6 +206,8 @@ instance Pass StandardPass where help "Transform function definitions to axioms with left hand side pattern matching instead of match", unitPass AxiomatizeDatadecls $ help "Transform data declarations to axioms", + unitPass Min $ + help "Transform function and data declarations to axioms, using a ``min'' heuristic", flag' () (long ("monomorphise") <> help "Try to monomorphise the problem") *> pure (Monomorphise False), flag' () (long ("monomorphise-verbose") <> help "Try to monomorphise the problem verbosely") *> pure (Monomorphise True), unitPass CSEMatch $ diff --git a/tip-lib/tip-lib.cabal b/tip-lib/tip-lib.cabal index 051eabf0..8fb57d7a 100644 --- a/tip-lib/tip-lib.cabal +++ b/tip-lib/tip-lib.cabal @@ -62,6 +62,7 @@ library Tip.Pass.FillInCases Tip.Pass.Induction Tip.Pass.Lift + Tip.Pass.Min Tip.Pass.Monomorphise Tip.Pass.Pipeline Tip.Pass.RemoveMatch From 46159b5c69b9623157a444967f69e8659dd049a0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dan=20Ros=C3=A9n?= Date: Fri, 28 Aug 2015 17:29:20 +0200 Subject: [PATCH 2/3] Add Tip.Pass.Min too --- tip-lib/src/Tip/Pass/Min.hs | 57 +++++++++++++++++++++++++++++++++++++ 1 file changed, 57 insertions(+) create mode 100644 tip-lib/src/Tip/Pass/Min.hs diff --git a/tip-lib/src/Tip/Pass/Min.hs b/tip-lib/src/Tip/Pass/Min.hs new file mode 100644 index 00000000..69670aa6 --- /dev/null +++ b/tip-lib/src/Tip/Pass/Min.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE CPP #-} +module Tip.Pass.Min where + +#include "errors.h" +import Tip.Pass.AxiomatizeFuncdefs +import Tip.Pass.AxiomatizeDatadecls + +import Tip.Types +import Tip.Core +import Tip.Fresh +import Tip.Utils + +import Tip.Pretty +import Tip.Pretty.SMT + +import qualified Data.Map as M + +-- assumes a monomorphic theory +minPass :: Name a => Theory a -> Fresh (Theory a) +minPass thy = + do minsigs <- + fmap M.fromList $ sequence + [ do min_ <- freshNamed "min" + return $ (t,Signature min_ (PolyType [] [t] boolType)) + | t <- theoryTypes thy + ] + let min_pred e = let ty = exprType e + msig = FROMJUST("Lost type " ++ ppRender ty ++ " on expression " ++ ppRender e)(M.lookup ty minsigs) + in applySignature msig [] [e] + thy' <- axiomatizeDatadecls (Just . min_pred) + (axiomatizeFuncdefs2 (Just . min_pred) + (minAsserts min_pred thy)) + return thy'{ + thy_sigs = M.elems minsigs ++ thy_sigs thy' + } + +minAsserts :: Ord a => (Expr a -> Expr a) -> Theory a -> Theory a +minAsserts min_pred thy = thy{ + thy_asserts = concatMap (minAssert min_pred) (thy_asserts thy) + } + +-- Only works with forall quantifiers on the top level +minAssert :: Ord a => (Expr a -> Expr a) -> Formula a -> [Formula a] +minAssert min_pred fm0@(Formula role tvs (forallView -> (vs,e))) = + case role of + Assert -> [ Formula Assert tvs (mkQuant Forall vs (min_pred t ==> e)) | t <- tms ] + Prove -> [ Formula Assert tvs (mkQuant Forall vs (min_pred t)) | t <- tms ] + ++ [ fm0 ] + where tms = usort (terms e) + +terms :: Expr a -> [Expr a] +terms (Builtin b :@: es) + | logicalBuiltin b = concatMap terms es +terms Lcl{} = [] +terms t = [t] + From d561973d132ecd5378eaf09cf8d81272ba4e2ffc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dan=20Ros=C3=A9n?= Date: Wed, 9 Sep 2015 18:11:55 +0200 Subject: [PATCH 3/3] Use fmap instead of <$> --- tip-lib/src/Tip/Pass/AxiomatizeDatadecls.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tip-lib/src/Tip/Pass/AxiomatizeDatadecls.hs b/tip-lib/src/Tip/Pass/AxiomatizeDatadecls.hs index 15f08430..779ec638 100644 --- a/tip-lib/src/Tip/Pass/AxiomatizeDatadecls.hs +++ b/tip-lib/src/Tip/Pass/AxiomatizeDatadecls.hs @@ -54,7 +54,7 @@ trDatatype min_pred dt@Datatype{..} = -- nil /= cons(X,Y) distinct <- - concat <$> sequence + concat `fmap` sequence [ do qs_k <- mapM freshLocal (map snd args_k) qs_j <- mapM freshLocal (map snd args_j) let tm_k = Gbl (constructor dt k ty_args) :@: map Lcl qs_k